ADDED Makefile.in Index: Makefile.in ================================================================== --- Makefile.in +++ Makefile.in @@ -0,0 +1,328 @@ +# +# This file is a Makefile for CTk. 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. +# +# @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + +# Current CTk version; used in various names. + +VERSION = 8.0 + +#---------------------------------------------------------------- +# 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 CTK_LIBRARY environment variable at +# run-time to override the compiled-in location): +CTK_LIBRARY = $(prefix)/lib/ctk$(VERSION) + +# Path name to use when installing library scripts: +SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(CTK_LIBRARY) + +# Directory in which to install the archive libctk.a: +LIB_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/lib + +# Directory in which to install the program cwish: +BIN_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/bin + +# Directory from which the program cwish should be referenced by scripts: +BIN_DIR = $(exec_prefix)/bin + +# Directory in which to install the include file ctk.h: +INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/include + +# Top-level directory for manual entries: +MAN_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/man + +# Directory in which to install manual entry for cwish: +MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 + +# Libraries to use when linking: must include at least the +# appropriate version of Tcl for this version of CTk, curses, +# and the math library (in that order). It is (hopefully) filled +# in properly by the configure script. +LIBS = @LIBS@ + +# To change the compiler switches, for example to change from -O +# to -g, change the following line: +CFLAGS = -O + +# Linker options (-L/.../lib) necessary to find the TCL +# and curses libraries (if any). It is (hopefully) filled in +# properly by the configure script. +LDFLAGS = @LDFLAGS@ + +# Preprocessor options (-I/.../include) necessary to find the TCL +# and curses header files (if any). It is (hopefully) filled in +# properly by the configure script. +CPPFLAGS = @CPPFLAGS@ + +# Preprocessor definitions. It should be filled in properly by the +# configure script, but if configure did not find the curses library +# then you may have to add some definitions by hand. The curses +# definitions are: +# +# -DUSE_NCURSES_H=1 Curses include file is called "ncurses.h" +# -DHAVE_CURS_SET=1 Curses package supports the curs_set() function +# -DHAVE_SET_TERM=1 Curses package supports the set_term() function +# -DHAVE_BEEP=1 Curses package supports the beep() function +# -DHAVE_KEYPAD=1 Curses package supports the keypad() function +AC_FLAGS = @DEFS@ + +# 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 + +# CTk 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 + +#---------------------------------------------------------------- +# 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. +#---------------------------------------------------------------- + +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} ${CPPFLAGS} -I${SRC_DIR} \ +${AC_FLAGS} ${PROTO_FLAGS} ${SECURITY_FLAGS} ${MEM_DEBUG_FLAGS} \ +-DCTK_LIBRARY=\"${CTK_LIBRARY}\" + +WIDGOBJS = tkButton.o tkEntry.o tkFrame.o tkListbox.o \ + tkMenu.o tkMenubutton.o tkScrollbar.o + +TEXTOBJS = tkText.o tkTextBTree.o tkTextDisp.o tkTextIndex.o \ + tkTextMark.o tkTextTag.o + +OBJS = ctkDisplay.o ctkRegion.o tkAppInit.o tkArgv.o tkBind.o tkCmds.o \ + tkConfig.o tkFocus.o tkFont.o tkGeometry.o tkGet.o \ + tkMain.o tkOption.o tkPack.o tkPlace.o tkPreserve.o tkUtil.o \ + tkWindow.o tkXEvent.o \ + $(WIDGOBJS) $(TEXTOBJS) + +SRCS = ctkDisplay.c ctkRegion.c tkAppInit.c tkArgv.c tkBind.c tkButton.c \ + tkCmds.c tkConfig.c tkEntry.c tkFocus.c tkFont.c tkFrame.c \ + tkGeometry.c tkGet.c tkListbox.c tkMain.c tkMenu.c tkMenubutton.c \ + tkOption.c tkPack.c tkPlace.c tkPreserve.c tkScrollbar.c tkText.c \ + tkTextBTree.c tkTextDisp.c tkTextIndex.c tkTextMark.c tkTextTag.c \ + tkUtil.c tkWindow.c tkXEvent.c + +HDRS = default.h keyCodes.h ks_names.h patchlevel.h tk.h tkInt.h \ + tkPort.h tkText.h + +DEMOPROGS = widget + +all: libctk.a cwish$(VERSION) + +libctk.a: $(OBJS) + rm -f libctk.a + ar cr libctk.a $(OBJS) + $(RANLIB) libctk.a + +cwish$(VERSION): tkAppInit.o libctk.a + $(CC) $(CC_SWITCHES) tkAppInit.o libctk.a $(LDFLAGS) $(LIBS) -o cwish$(VERSION) + +configInfo: Makefile + @rm -f configInfo + @echo "# Definitions and libraries needed to build Tk applications" >> configInfo + @echo "# (generated by the configure script):" >> configInfo + @echo "TK_CC_SWITCHES = ${AC_FLAGS} ${MEM_DEBUG_FLAGS}" >> configInfo + @echo "TK_LIBS = @LIBS@" >> configInfo + +install: install-binaries install-libraries install-demos install-man + +install-binaries: libctk.a cwish$(VERSION) + @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 libctk.a" + @$(INSTALL_DATA) libctk.a $(LIB_INSTALL_DIR) + @$(RANLIB) $(LIB_INSTALL_DIR)/libctk.a + @echo "Installing cwish$(VERSION)" + @$(INSTALL_PROGRAM) cwish$(VERSION) $(BIN_INSTALL_DIR) + +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 ctk.h" + @$(INSTALL_DATA) $(SRC_DIR)/tk.h $(INCLUDE_INSTALL_DIR)/ctk.h + for i in $(SRC_DIR)/library/*.tcl $(SRC_DIR)/library/tclIndex; \ + do \ + echo "Installing $$i"; \ + $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ + done; + +install-demos: + @for i in $(INSTALL_ROOT)$(prefix)/lib $(SCRIPT_INSTALL_DIR) \ + $(SCRIPT_INSTALL_DIR)/demos; \ + 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/cwish|$(BIN_DIR)/cwish$(VERSION)|' \ + $$i > $(SCRIPT_INSTALL_DIR)/demos/$$i; \ + fi; \ + done; + @for i in $(DEMOPROGS); \ + do \ + chmod 755 $(SCRIPT_INSTALL_DIR)/demos/$$i; \ + done; + +install-man: + @for i in $(MAN_INSTALL_DIR) $(MAN1_INSTALL_DIR); \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @for i in *.1; \ + do \ + echo "Installing doc/$$i"; \ + $(INSTALL_DATA) $$i $(MAN1_INSTALL_DIR); \ + done; + +Makefile: $(SRC_DIR)/Makefile.in + $(SHELL) config.status + +clean: + rm -f *.a *.o core errs *~ \#* TAGS *.E a.out errors tktest cwish$(VERSION) \ + config.info + +distclean: clean + rm -f Makefile config.status + +depend: + makedepend -- $(CC_SWITCHES) -- $(SRCS) + +.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 $(SRCS) | grep -v UCHAR + +# +# Target to make sure that only symbols with "Tk" or "Ctk" prefixes are +# exported. +# + +checkexports: libctk.a + -nm -p libctk.a | awk '$$2 ~ /[TDB]/ { print $$3 }' | sort -n | grep -v '^[Cc]?[Tt]k' + +# +# Target to create a proper Tk distribution from information in the +# master source directory. DISTDIR must be defined to indicate where +# to put the distribution. +# + +configure: configure.in + autoconf +dist: configure + rm -rf $(DISTDIR) + mkdir $(DISTDIR) + cp license.terms Makefile.in $(DISTDIR) + chmod 664 $(DISTDIR)/Makefile.in + cp -p $(SRCS) $(HDRS) $(DISTDIR) + mkdir $(DISTDIR)/compat + cp -p license.terms compat/unistd.h compat/stdlib.h $(DISTDIR)/compat + cp -p README README.TERM ToDo changes porting.notes *.1 $(DISTDIR) + cp -p configure configure.in install-sh $(DISTDIR) + chmod 775 $(DISTDIR)/configure $(DISTDIR)/configure.in + chmod +x $(DISTDIR)/install-sh + mkdir $(DISTDIR)/library + cp -p license.terms library/*.tcl library/tclIndex $(DISTDIR)/library + mkdir $(DISTDIR)/library/demos + cp -pr library/demos/widget library/demos/README \ + license.terms $(DISTDIR)/library/demos + +mci_args: + @echo ctk README README.TERM ToDo changes porting.notes license.terms \ + Makefile.in configure.in install-sh \ + $(SRCS) $(HDRS) compat library + +# DO NOT DELETE THIS LINE -- make depend depends on it. ADDED README Index: README ================================================================== --- README +++ README @@ -0,0 +1,244 @@ +The CTk Toolkit + +by Martin Andrews +andrewm@ccfadm.eeg.ccf.org + +@(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + +1. Introduction +---------------- + +This directory contains the sources for CTk, a curses port of John +Ousterhout's Tk toolkit for X11. The information here corresponds to +CTk 4.0. CTk 4.0 is based on Tk 4.0p3. Like Tk 4.0p3, it is designed +to work with Tcl 7.4p3 and may not work with other releases of Tcl. + +Using CTk, applications with a modern GUI-ish interface can be created +for character terminals. These same applications, without modification, +can provide a real GUI interface by using Tk. Thus, sites with an +embedded base of character terminals (and a small capital budget) can +smoothly migrate to GUI applications. + +2. Documentation +---------------- + +There is a man page for cwish (cwish(1)) explaining execution options +for the CTk shell. For script writing, the Tk Documentation, along with the +list of differences in section 5 of this document should be enough to get +started. + +3. Compiling and installing CTk +------------------------------- + +CTk requires TCL and a System V curses package (CTk will build +with BSD curses but has at least one display glitch and many +missing features - see porting.notes for more information). +Unlike Tk, you do not need the source for Tcl to build CTk. +Only the Tcl 7.4 library and include file (tcl.h) are necessary. +If your system does not have a System V compatible curses, +there is a free version, ncurses, available in GNU archives +(for instance ftp://prep.ai.mit.edu/pub/gnu). + +CTk builds cleanly on the three systems I have easy access to: + + 486 PC running Linux 1.1.54 using gcc 2.58 and ncurses 1.8.5 + + HP 9000/835 running HP-UX 9.04 using optional ANSI C compiler and + ncurses 1.8.6 or using K&R C compiler and hp curses (old system V, + not very pretty) + + Sun 4c running Sun OS 4.13 using System V compiler (/usr/5bin/cc) + and System V curses + +Perform the following steps to compile and install CTk: + + (a) Type "./configure" in this directory. This runs a configuration + script created by GNU autoconf, which configures CTk for your + system and creates a Makefile. If you are using ncurses, and + the library is named "libncurses" instead of "libcurses" give + the "-with-ncurses" option to configure. Also, if Tcl or curses + are not installed in the standard search path, you can use + "-with-libdirs=" and "-with-incdirs=" to add directories to + the library and header search path, respectively (use the + directives once, the argument can be a list of space separated + directories). For more details on using configure, check out + the autoconf documentation (not included here). + + (b) Type "make". This will create a library archive called "libctk.a" + and an interpreter application called "cwish" 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 CTk'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. If you'd like to use a default installation + directory, you can change the "exec_prefix" and "prefix" definitions + in the Makefile. + + (e) At this point you can play with Tcl by invoking the "cwish" + program and typing Tcl commands. However, if you haven't installed + CTk then you'll first need to set your CTK_LIBRARY environment + variable to hold the full path name of the "library" subdirectory. + +I am interested in receiving information on changes required to +build CTk on your platform. + +4. Test suite +------------- + +Next release. (Really.) + +5. Getting started +------------------ + +It is now easy to run cwish interactively. If you have not +installed cwish set the CTK_LIBRARY environment variable to +the path of the library directory, then try: + + cwish + +This will start cwish, and then pop-up a command dialog window where +you can enter TCL commands. You can bring up this dialog at any time +by pressing . + +You can also try out a simple demo of the cwish widgets with: + + cwish library/demos/stuff + +There are other demos in the library/demos directory including a +crude port of the Tk widget demo (warning it is easy for the focus +to get lost - if so press Ctrl+C to get the command dialog and +type "exit" there). + +Key bindings are very nearly the same as for Tk (which is very nearly +the same as Motif). This may be unfamiliar to people used to common +Unix curses applications (elm, lynx, ..). I decided to stick with the +Tk binding for two reasons: + +1) Less confusion for users that switch between Tk and CTk + versions of an application. + +2) Easier to incorporate updates from Tk. + +Here is a quick summary of the key bindings for those unfamiliar +with Motif (or Microsoft Windows): + + activates/selects a widget + moves focus to next the widget + moves focus to the prior widget + activates the default button in a dialog + Arrow keys move the cursor within a widget + moves focus to the first menu + closes a menu without making a selection + +Your terminal or terminfo entry may not support all the keys (like +). See README.TERM for tips on configuring terminfo +entries for CTk. + +6. Summary of differences between CTk 4.0b1 and Tk 4.0 +-------------------------------------------------------- + +The following commands are not available in CTk: + + canvas + clipboard + message + image + scale + selection + send + +The wm command is severely crippled. + +None of the widgets support the scan method. + +The text widget does not support tag bindings: "text tag bind". + +The text widget does not support embedded windows "text window". + +The -tearoff option for menu widgets can create a tearoff entry, +but the entry doesn't work (and I don't know if there is any point +in making it work). + +Many configuration options (like -background and -foreground) cannot +be modified. Attempts to set the unsupported options will silently +be ignored. Querying the options with cget will return a fixed +?reasonable? value. The unsupported options are: + + -activebackground + -activeborderwidth + -activerelief + -background + -bg + -bitmap + -borderwidth (supported by widgets, not by text tags) + -colormap + -cursor + -disabledforeground + -exportselection + -fg + -font + -foreground + -highlightcolor + -highlightbackground + -highlightthickness + -image + -insertbackground + -insertborderwidth + -insertofftime + -insertontime + -insertwidth + -indicatoron + -jump + -relief + -repeatdelay + -repeatinterval + -screen + -selectbackground + -selectborderwidth + -selectcolor + -selectforeground + -selectimage + -setgrid + -tearoff + -troughcolor + -visual + +And a lot more I forgot to mention. + +7. Support and bug fixes +------------------------ + +Send bug reports and suggestions for improvements to: + + Martin Andrews + andrewm@ccfadm.eeg.ccf.org + +When reporting bugs, please provide a short cwish script that I can +use to reproduce the bug. Make sure that the script runs with a +bare-bones cwish and doesn't depend on any extensions. Also, please +include three additional pieces of information with the script: + + (a) how do I use the script to make the problem happen (e.g. + what keys do you press, in what order)? + (b) what happens when you do these things (presumably this is + undesirable)? + (c) what did you expect to happen instead? + +For general problems with using Tk or Tcl, try posting to the +comp.lang.tcl Usenet newsgroup. + +8. Release organization +--------------------------- + +Each CTk release is identified by two numbers separated by a dot, e.g. +3.2 or 3.3. These numbers match the release number of the corresponding +Tk release. Suffixes for alpha, beta, and patch releases (aX, bX, and pX +respectively) are numbered independent of Tk. ADDED README.TERM Index: README.TERM ================================================================== --- README.TERM +++ README.TERM @@ -0,0 +1,98 @@ +README.TERM + Terminfo Notes for the CTk Toolkit + +This file contains hints for setting up terminfo entries for use with CTk. +It assumes the reader already understands how to write terminfo entries +(as much as anyone really understands this black art). See the manual +page, terminfo(4), for general information on terminfo. + +@(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + +Special Keys +------------ + +CTk tries to map the curses key codes to X-11 keycodes and hence to +Tk key names. This mapping (in reverse) is shown below: + + Tk Name Capname + ------- ------- + BackSpace kbs + Begin kbeg + Cancel kcan + Clear kclr + Delete kdch1 + Shift-Delete kdl1 + Down kcud1 + End kend + End kfnd + Control-End kll + Execute kcmd + F1 kf1 + F10 kf10 + F2 kf2 + F3 kf3 + F4 kf4 + F5 kf5 + F6 kf6 + F7 kf7 + F8 kf8 + F9 kf9 + Help khlp + Home khome + Insert kich1 + Insert kmir + Shift-Insert kil1 + Left kcub1 + Menu kopt + Next knp + Pause kspd + Print kprt + Prior kpp + Redo krdo + Return kent + Right kcuf1 + Select kslt + Tab knxt + Shift-Tab kcbt + Shift-Tab kprv + Undo kund + Up kcuu1 + +In addition the following special keys can be generated by control +keys (therefore, you cannot receive a event): + + Tk Name Control Key + ------- ----------- + Backspace + Tab + Return + +Other control keys are passed as the appropriate key press with the +Control Modifier set. + + +Display Attributes +------------------ + +CTk uses the following terminfo display attributes: standout (the focus), +reverse (selected), underline (entry widgets), bold (button widgets), +and dim (inactive widgets). CTk does not try to use combinations of +attributes (for example: bold-underline) so you do not need to +define the "sgr" capability. If an attribute is not defined the item +is displayed as plain text. + +If possible, each of the attributes should have a unique appearance +(standout = bold is very bad, because a button will not change appearance +when it has the focus). Following the ncurses recommendation that +standout should "represent a good, high contrast, easy-on-the-eyes, +format" I define standout as reverse-dim. + + +Custom CTk Terminfo Entries +--------------------------- + +If you find that the terminal definition you want for CTk conflicts with +what you want normally. You can create the CTk entry with an alternate +name (like vt100-tk) and then set the environment variable CTK_TERM +to this alternate entry. CTK_TERM is by CTk in preference to the TERM +environment variable. ADDED ToDo Index: ToDo ================================================================== --- ToDo +++ ToDo @@ -0,0 +1,46 @@ +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. + +@(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + +1. Add option to turn off background fill on window visibility +changes (only frame and toplevel widgets need it). + +2. Implement embedded windows for text widget. + +3. Fix cursor display in text widgets (occasionally off the right edge +of the screen). + +5. Implement remaining methods of wm command. + +7. Add bindings for entry and text selection (ones that can be +generated from a character terminal). + +8. Support color? Handy for PC consoles with too little oomph for X. +(And for people with VT320 terminals - but does anyone really have +them?) + +9. Add message and scale widgets. + +10. Add do-nothing variants of all remaining unsupported Tk commands? + +11. Implement remaining text display attributes (only underline works) - +would some way of mapping the attributes to available terminal attributes. + +18. Extend command dialog to include menu of complete window management +operations. + +23. Modify tkFont.c so that display of ISO-??? characters is reasonable +(map characters with diacritics to characters without). + +24. Can't use -geometry option because "wm" is defined in time - either +move forward Tk_AppInit, or make "wm" a C command. + +25. Add "ctk exec" command to execute an interactive command on win's +display. (e.g. "ctk exec . vi myfile") + +26. Call delscreen() after endwin() on systems that define delscreen(). +(SysVR4 curses seem to need it to free up resources - but HP curses +doesn't define delscreen()) ADDED changes Index: changes ================================================================== --- changes +++ changes @@ -0,0 +1,317 @@ +Changes made since ctk8.0 was initially released are summarized below: + +Changed the 'configure' command to recognize tcl8.0 +Changed the Makefile.in to build cwish$(VERSION) instead of cwish + +This file summarizes all changes made to CTk since version 4.0a1 was +released on March 12, 1995. Changes that aren't backward compatible +are marked specially. + +@(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + +$Log: ctk.shar,v $ +# Revision 1.50 1996/01/15 14:47:16 andrewm +# More portability glitches (needed to reset interpreter result +# in TkEntryInsert routines). +# +# Revision 1.49 1996/01/13 18:31:51 andrewm +# Dumb typos in tkCmds.c - found when build under SunOS. +# +# Revision 1.48 1995/12/21 19:31:05 andrewm +# Added "ctk redraw" command. +# +# Revision 1.47 1995/12/20 22:22:00 andrewm +# (bug fix) made ctkDisplay.c 8-bit clean (wasn't casting char +# to unsigned char) - thanks Jan Vlcek. +# +# Revision 1.46 1995/12/20 21:13:04 andrewm +# Incorporate changes from Tk4.0 patch 3 (tk4.0p3). +# +# Revision 1.45 1995/12/20 16:28:09 andrewm +# Incorporate changes from tk4.0 patch 2. +# +# Revision 1.44 1995/12/04 19:57:27 andrewm +# (bug fix) tkListbox.c - display cursor even when active row is not +# visible (put it in the top left corner). +# +# (feature change) tkListbox.c - no longer display "*" next to selected +# items - rely on display attribute instead. +# +# (feature change) listbox.tcl - Left and Right now scroll by pages +# instead of characters. +# +# Revision 1.43 1995/12/04 19:19:52 andrewm +# bug fix - forgot to change var name when pasting code into tk_popup. +# +# Revision 1.42 1995/11/19 17:07:16 andrewm +# Incorporate changes from Tk4.0 patch 1. +# +# Revision 1.41 1995/11/17 15:35:49 andrewm +# Drop use of A_INVIS in ctkDisplay.c - those styles should never be +# drawn anyway - and most terms don't support it (and it screws up +# out terminal session manager). +# +# Revision 1.40 1995/11/06 13:31:19 andrewm +# Change TK_PATCH_LEVEL to CTK_PATCH_LEVEL and tcl variable tk_patchLevel +# with ctk_patchLevel. Only version numbers track between Tk and CTk - +# and this make for an easy way to tell when you are using CTk. +# +# Add Tk_RestackWindow() and pull stacking arguments out of Tk_Map() - +# now raise and lower commands use Tk_RestackWindow instead of Ctk_Map +# (because they should not map unmapped windows). +# +# The CTk menu now underlines the X in Exit (not the E). +# +# Revision 1.39 1995/08/31 19:48:54 andrewm +# Make sure that all uses of ckalloc/ckfree are with (char *) pointers +# (cast when necessary). +# +# Install as version 4.0 - don't need a different library for each patch. +# +# Revision 1.38 1995/08/25 20:38:47 andrewm +# bug fix - finally track down glitch that caused some slaves to not +# be mapped - backwards logic in tkGeometry.c. +# +# aesthetics - tk_dialog now uses a simpler appearance for the default +# button (add [] to label instead of an enclosing frame). +# +# Revision 1.37 1995/08/25 18:41:19 andrewm +# Change tkFindMenu to that it only finds menubuttons that do not +# have an indicator (otherwise the F10 key will fire menus of +# options buttons). +# +# Add exit to Ctk menu. +# +# Revision 1.36 1995/08/24 17:50:35 andrewm +# Add compatibilty info to tk.h to simplify porting of Tk extensions +# to ctk (BLT table was easy!). +# +# Revision 1.35 1995/08/22 19:48:01 andrewm +# Fix bug when destroying all windows from within a command from +# an event binding (could core dump). +# +# Revision 1.34 1995/08/22 17:31:37 andrewm +# Add ability for multi-column (wrapped) menus. +# +# Change menu button indicator to "^" (was "="). +# +# Revision 1.33 1995/08/21 21:39:57 andrewm +# More logical key fixes - no longer bind directly to "space" - instead +# bind to Select, and remap space to Select. +# +# Make Return a do-what-I-want key instead of the dialog closure key +# (which is now Execute). +# +# Curses Enter/Send key now maps to KP_Enter, not Return. +# +# Revision 1.32 1995/08/21 20:47:50 andrewm +# Remove root window from name table after creating "." window - +# otherwise user can reference the root, which can cause core dumps. +# +# Change bindings to use logical key names only - then central +# ctk.tcl binds other keys to generate logical key events. +# +# Add ctk_event command (ala testevent). +# +# Revision 1.31 1995/08/21 14:52:49 andrewm +# Fix foolish change to text/entry insertion - back to Insert procefdure +# returning a boolean. +# +# Revision 1.30 1995/08/21 13:30:49 andrewm +# Pull out the menu traversal by matching first label character - decide +# it better belongs in a library. +# +# Revision 1.29 1995/08/18 21:58:02 andrewm +# Modify bindings within menu to activate entries by pressing the first +# letter of their label. +# +# Revision 1.28 1995/08/18 19:56:34 andrewm +# Rewite the tkEntryInsert and tkEntrySeeInsert procedures in C. +# Not sure if the payoff is worth it this time. +# +# Revision 1.27 1995/08/18 14:15:35 andrewm +# Rewrite the tk_focusNext and tk_focusPrev procedures in C, because +# their overhead was annoying on loaded server machines - particularly +# if you overshoot a widget and have not Shift-Tab on your terminal! + +--- ctk4.0b1 Released --- + +# Revision 1.26 1995/07/25 14:07:28 andrewm +# (new feature) Add some of the Tk demos - begin fixing them for CTk. +# +# Clean up documentation for CTk 4.0b1 release. +# +# Revision 1.25 1995/07/21 21:19:00 andrewm +# (bug fix) fixes for non-ANSI compiler (SunOs). +# +# Revision 1.24 1995/07/20 21:26:44 andrewm +# (new feature) add -with-libdirs and -with-incdirs directives for +# configure. +# +# (new feature) unsupported Tk commands are now passed to a "ctk_unsupported" +# command - if this command is not defined then the command is ignored. +# +# Revision 1.23 1995/07/20 18:05:00 andrewm +# (bug fix) tkListbox.c - don't let cursor scroll horizontally with contents +# of listbox. +# +# Revision 1.22 1995/07/20 16:20:50 andrewm +# Fill in cwish man page. +# Include configuration changes from Tk4.0 +# +# Revision 1.21 1995/07/19 21:24:09 andrewm +# (feature change, bug fix) Include Tk4.0 changes to the (C)Tk library files. +# +# Revision 1.20 1995/07/18 21:38:55 andrewm +# (bug fix, new feature, changed feature) Incorporate changes from Tk4.0b4 +# and Tk4.0 (final release). +# +# (feature change) tkListbox.c - selected items in listbox are now +# highlighted for the entire width of the listbox. +# +# Revision 1.19 1995/07/17 12:38:47 andrewm +# (feature change) ctk.tcl - go back to activating menubar buttons +# with unshifted alpha characters. +# +# Revision 1.18 1995/07/14 15:45:38 andrewm +# (new feature) updgrade tkMain.c and tkAppInit.c to work with tcl7.4 (final) +# +# Revision 1.17 1995/07/11 22:08:19 andrewm +# (new feature) tkFocus.c - now try to pass focus to the topmost visible +# toplevel when focus is lost (focus window destroyed). +# +# Revision 1.16 1995/07/11 20:54:02 andrewm +# (bug fix) wm.tcl - fix several references to "winfo" that should be "info". +# +# Revision 1.15 1995/07/11 20:33:19 andrewm +# (new feature) tkFocus.c - added local focus maintenance, so that +# each top-level remembers the last child to have the focus. +# +# Revision 1.14 1995/07/11 19:25:12 andrewm +# (new feature) added binding for F2 to pass focus to next top level - +# really just a stop gap till I write a real window manager for CTk. +# +# Revision 1.13 1995/07/11 18:13:53 andrewm +# (bug fix) tkCmds.c - "winfo children" no longer reports "." as +# a child of itself. +# +# Revision 1.12 1995/07/10 13:29:17 andrewm +# add -borderwidth to list of unsupported options (its not supported +# for text tags). +# +# Revision 1.11 1995/06/24 23:45:13 andrewm +# (new feature) add list of values for unsupported options - return this +# value when "cget" is attempted on the option. +# +# Revision 1.10 1995/06/24 17:04:58 andrewm +# (bug fix) tkWindow.c: change initialization in Tk_CreateMainWindow() +# so that .ctkdefaults can be processed (used to cause a crash). +# Also set default geometry for "." to 20x10. +# +# Revision 1.9 1995/06/24 15:58:50 andrewm +# (new feature) ctkDisplay.c: display open fails if device is not a tty. +# +# Revision 1.8 1995/06/23 20:57:00 andrewm +# (bug fix) tkTextDisp.c - Fix a prior fix in TkTextSetYView() when +# adjusting just a little below the current window (could cause a +# core dump). +# +# Revision 1.7 1995/06/23 13:26:46 andrewm +# (feature change) frames/toplevels no longer highlight when they +# have the focus (it was a waste). +# +# (feature change) menus default to "-tearoff 0" (should remove support +# for -tearoff, it has no practical use in ctk - the torn off menu +# would be less convenient than the original). +# +# Revision 1.6 1995/06/11 22:44:11 andrewm +# (bug fix) fix bug where bottom of text widget would not be cleared +# when lines were removed (also remove some superfluous code) tkTextDisp.c +# +# Revision 1.5 1995/06/11 22:08:24 andrewm +# use curses KEY_ constants in keyCodes.h (used to be hard-coded). +# +# Revision 1.4 1995/06/11 21:29:42 andrewm +# (bug fix) wm procedure now sets -relx/-rely so that geometry can be +# changed without withdrawing the window. +# +# (feature change) Traversal to menubutton via shortcut now only happens +# with shifted alpha characters. +# +# Revision 1.3 1995/06/11 14:36:39 andrewm +# Display focus/insertion point using terminal cursor (instead of inverted +# text) - faster and better appearance. +# +# Revision 1.2 1995/05/28 14:55:30 andrewm +# (new feature) sweeping changes, add tkOption.c, to support +# "option" command. + +5/5/95 (bug fix) Modify command.tcl so that commands are evaluated +in a global context. + +--- ctk4.0a2 Released --- + +5/4/95 (bug fix) Modify configure.in to check for gettimeofday() - +if it doesn't exist add the socket library (for SCO). + +5/4/95 (new feature) Modify ctkDisplay.c so that the environment +variable CTK_TERM can override the TERM environment variable (to +allow terminal definitions customized for CTk). + +5/3/95 (new feature) Add ctkDialog for interactive cwish sessions. Modify +tkMain.c so that it calls ctkDialog instead of reading commands from +stdin when the user doesn't redirect the display. + +5/3/95 (feature change) Modify tkCmds.c so that widget bindings come before +class bindings. (Patch from Dr. Ousterhout.) +*** POTENTIAL INCOMPATIBILITY *** + +4/22/95 (bug fix) Modify tkFont.c and and tkTextDisp.c so that cursor +is drawn in entry and text widgets when the insertion point is in front +of a tab character. + +4/22/95 (new feature) Add scrollbar.tcl for scrollbar keyboard bindings and +modify tkScrollbar.c to highlight when the scrollbar has the focus. +(But scrollbars default to "-takefocus 0".) + +4/22/95 (feature change) Modify tkMain.c and tkWindow.c to change +the environment variable that specifies display terminal to CTK_DISPLAY +(CWISH_DISPLAY will still work but it is deprecated and support for it +will eventually be removed). +*** POTENTIAL INCOMPATIBILITY *** + +4/22/95 (feature change) Modify listbox.tcl so that PageUp and PageDown +key bindings change the active element. + +4/6/95 (many fixes & features) Incorporate tk4.0b3 changes. +*** POTENTIAL INCOMPATIBILITY *** + +3/23/95 (bug fix) Modified tkWindow so that Tk_CreateMainWindow() +will not pass a null argument (screen) to the "frame" command - +this was the real cause of the NULL dereference I tried to fix on +3/20/95 - undo that first fix. + +3/21/95 (new feature) Modify tkFrame.c, tkListbox.c, tkText.c, and +tkTextDisp.c to highlight the border of frame, listbox, and text +widgets when they have the focus. + +3/20/95 (bug fix) Modified tkConfig.c so that DoConfig() wouldn't +dereference a NULL value (thanks Peter da Silva). + +3/20/95 (bug fix) Modified tkWindow.c to destroy top-level children of +main window (missed them before, and therefore wouldn't close display). + +3/15/95 (new feature) Modify ctkDisplay.c to put terminals in raw mode +so that interrupt, quit, etc are passed as keys instead of generating +signals. + +3/13/95 (bug fix) Modified tkTextMark.c to no longer dump core when the +insert mark wraps across lines (put back InsertUndisplayProc() - why +I removed it in the first place I have no idea). + +9/20/96 (port) Port ctk to tcl7.6: event handling (remove from ctk, call +tcl's), channel handling. Should be better to reorganize code and +merge in tk4.2 as another platform (Curses) -- Juanjo + +7/16/97 (port) Port ctk to tcl8.0: change ctk.tcl to expect a higher version of tcl/tk. +Still needs "grid" and a number of other enhancements. Michael (mschwart@nyx.net) ADDED compat/license.terms Index: compat/license.terms ================================================================== --- compat/license.terms +++ compat/license.terms @@ -0,0 +1,32 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., Cleveland Clinic Foundation, 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. + +RESTRICTED RIGHTS: Use, duplication or disclosure by the government +is subject to the restrictions as set forth in subparagraph (c) (1) (ii) +of the Rights in Technical Data and Computer Software Clause as DFARS +252.227-7013 and FAR 52.227-19. ADDED compat/stdlib.h Index: compat/stdlib.h ================================================================== --- compat/stdlib.h +++ 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. + * + * @(#) stdlib.h 1.9 94/12/17 16:26:20 + */ + +#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 */ ADDED compat/unistd.h Index: compat/unistd.h ================================================================== --- compat/unistd.h +++ compat/unistd.h @@ -0,0 +1,83 @@ +/* + * unistd.h -- + * + * Macros, CONSTants and prototypes for Posix conformance. + * + * Copyright 1989 Regents of the University of California + * Permission to use, copy, modify, and distribute this + * software and its documentation for any purpose and without + * fee is hereby granted, provided that the above copyright + * notice appear in all copies. The University of California + * makes no representations about the suitability of this + * software for any purpose. It is provided "as is" without + * express or implied warranty. + * + * @(#) unistd.h 1.5 94/12/17 16:26:27 + */ + +#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 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 */ + ADDED config.cache Index: config.cache ================================================================== --- config.cache +++ config.cache @@ -0,0 +1,37 @@ +# 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. +# +ac_cv_c_cross=${ac_cv_c_cross='no'} +ac_cv_func_BSDgettimeofday=${ac_cv_func_BSDgettimeofday='no'} +ac_cv_func_beep=${ac_cv_func_beep='yes'} +ac_cv_func_curs_set=${ac_cv_func_curs_set='yes'} +ac_cv_func_gettimeofday=${ac_cv_func_gettimeofday='yes'} +ac_cv_func_keypad=${ac_cv_func_keypad='yes'} +ac_cv_func_memmove=${ac_cv_func_memmove='yes'} +ac_cv_func_set_term=${ac_cv_func_set_term='yes'} +ac_cv_func_sin=${ac_cv_func_sin='no'} +ac_cv_func_strtod=${ac_cv_func_strtod='yes'} +ac_cv_header_limits_h=${ac_cv_header_limits_h='yes'} +ac_cv_header_stdc=${ac_cv_header_stdc='yes'} +ac_cv_header_unistd_h=${ac_cv_header_unistd_h='yes'} +ac_cv_lib_curses=${ac_cv_lib_curses='yes'} +ac_cv_lib_ieee=${ac_cv_lib_ieee='yes'} +ac_cv_lib_tcl8_2=${ac_cv_lib_tcl8_2='no'} +ac_cv_path_install=${ac_cv_path_install=''/usr/bin/ginstall -c''} +ac_cv_prog_CPP=${ac_cv_prog_CPP=''cc -E''} +ac_cv_prog_RANLIB=${ac_cv_prog_RANLIB='ranlib'} +ac_cv_type_mode_t=${ac_cv_type_mode_t='yes'} +ac_cv_type_pid_t=${ac_cv_type_pid_t='yes'} +ac_cv_type_size_t=${ac_cv_type_size_t='yes'} +ac_cv_type_uid_t=${ac_cv_type_uid_t='yes'} ADDED config.log Index: config.log ================================================================== --- config.log +++ config.log @@ -0,0 +1,72 @@ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +cc -E +cc -E +cc -E +cc -c conftest.c +cc -E +cc -E +cc -E +cc -o conftest conftest.c +cc -E +cc -E +cc -E +cc -o conftest conftest.c +configure: In function 'main': +configure:1009: warning: incompatible implicit declaration of built-in function 'exit' +cc -E +cc -E +cc -E +cc -E +cc -o conftest conftest.c -lcurses +cc -E +cc -o conftest conftest.c -lcurses +cc -o conftest conftest.c -lcurses +cc -o conftest conftest.c -lcurses +cc -o conftest conftest.c -lcurses +cc -c conftest.c +cc -c conftest.c +configure: In function 't': +configure:1428: error: 'FILE' has no member named '_cnt' +cc -c conftest.c +configure: In function 't': +configure:1444: error: 'FILE' has no member named '__cnt' +cc -c conftest.c +configure: In function 't': +configure:1461: error: 'FILE' has no member named '_r' +cc -c conftest.c +configure: In function 't': +configure:1478: error: 'FILE' has no member named 'readCount' +cc -c conftest.c +configure: In function 't': +configure:1501: error: 'FILE' has no member named '_gptr' +configure:1501: error: 'FILE' has no member named '_egptr' +cc -c conftest.c +cc -o conftest conftest.c -lcurses +configure:1572: warning: conflicting types for built-in function 'sin' +/tmp/ccYH09hj.o: In function `t': +conftest.c:(.text+0x20): undefined reference to `sin' +collect2: ld returned 1 exit status +cc -o conftest conftest.c -lieee -lm -lcurses +cc -o conftest conftest.c -lieee -lm -lcurses +cc -o conftest conftest.c -lieee -lm -lcurses +configure:1708: warning: conflicting types for built-in function 'memmove' +cc -o conftest conftest.c -lieee -lm -lcurses +configure: In function 'main': +configure:1766: warning: incompatible implicit declaration of built-in function 'exit' +configure:1768: warning: incompatible implicit declaration of built-in function 'exit' +cc -o conftest conftest.c -lieee -lm -lcurses +/tmp/cc6XWPiP.o: In function `t': +conftest.c:(.text+0x20): undefined reference to `BSDgettimeofday' +collect2: ld returned 1 exit status +cc -E +cc -o conftest conftest.c -lieee -lm -lcurses +cc -o conftest conftest.c -lieee -lm -lcurses +configure: In function 'main': +configure:1935: warning: incompatible implicit declaration of built-in function 'exit' +configure:1937: warning: incompatible implicit declaration of built-in function 'exit' +cc -o conftest conftest.c -ltcl8.2 -lieee -lm -lcurses +/usr/lib/gcc/i486-slackware-linux/4.3.3/../../../../i486-slackware-linux/bin/ld: cannot find -ltcl8.2 +collect2: ld returned 1 exit status +cc -E ADDED configure Index: configure ================================================================== --- configure +++ configure @@ -0,0 +1,2215 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.7 +# 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 + --with-ncurses use ncurses library instead of curses" +ac_help="$ac_help + --with-libdirs directories to add to library search path" +ac_help="$ac_help + --with-incdirs directories to add to include search path" + +# 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 +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +# Initialize some other variables. +subdirs= +MFLAGS= MAKEFLAGS= + +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 + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir="$ac_optarg" ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + 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" ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir="$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=EPREFIX install architecture-dependent files in EPREFIX + [same as prefix] + --bindir=DIR user executables in DIR [EPREFIX/bin] + --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] + --libexecdir=DIR program executables in DIR [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data in DIR + [PREFIX/share] + --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data in DIR + [PREFIX/com] + --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] + --libdir=DIR object code libraries in DIR [EPREFIX/lib] + --includedir=DIR C header files in DIR [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] + --infodir=DIR info documentation in DIR [PREFIX/info] + --mandir=DIR man documentation in DIR [PREFIX/man] + --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 +EOF + cat << EOF +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 +EOF + if test -n "$ac_help"; then + echo "--enable and --with options recognized:$ac_help" + fi + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir="$ac_optarg" ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir="$ac_optarg" ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir="$ac_optarg" ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir="$ac_optarg" ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir="$ac_optarg" ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir="$ac_optarg" ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir="$ac_optarg" ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir="$ac_optarg" ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -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.7" + 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=tk.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='echo $CPP $CPPFLAGS 1>&5; +$CPP $CPPFLAGS' +ac_compile='echo ${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5; +${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5 2>&5' +ac_link='echo ${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5; +${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 + + + +# @(#) $Id: ctk.shar,v 1.48 1995/12/21 19:31:05 andrewm Exp andrewm $ + +# Check whether --with-ncurses or --without-ncurses was given. +if test "${with_ncurses+set}" = set; then + withval="$with_ncurses" + : +else + with_ncurses=no +fi + +# Check whether --with-libdirs or --without-libdirs was given. +if test "${with_libdirs+set}" = set; then + withval="$with_libdirs" + : +fi + +# Check whether --with-incdirs or --without-incdirs was given. +if test "${with_incdirs+set}" = set; then + withval="$with_incdirs" + : +fi + + +for ldir in $with_libdirs ;do + LDFLAGS="$LDFLAGS -L$ldir" +done +for idir in $with_incdirs ;do + CPPFLAGS="$CPPFLAGS -I$idir" +done + +ac_aux_dir= +for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } +fi +ac_config_guess=$ac_aux_dir/config.guess +ac_config_sub=$ac_aux_dir/config.sub +ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. + +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# ./install, which can be erroneously created by make from ./install.sh. +echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 +if test -z "$INSTALL"; then +if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + # Account for people who put trailing slashes in PATH elements. + case "$ac_dir/" in + /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + for ac_prog in ginstall installbsd scoinst install; do + if test -f $ac_dir/$ac_prog; then + if test $ac_prog = install && + grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + # OSF/1 installbsd also uses dspmsg, but is usable. + : + else + ac_cv_path_install="$ac_dir/$ac_prog -c" + break 2 + fi + fi + done + ;; + esac + done + IFS="$ac_save_ifs" + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL="$ac_cv_path_install" + else + # As a last resort, use the slow shell script. We don't cache a + # path for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the path is relative. + INSTALL="$ac_install_sh" + fi +fi +echo "$ac_t""$INSTALL" 1>&6 + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + +# 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 + +if test "x$prefix" = xNONE; then +echo $ac_n "checking for prefix by ""... $ac_c" 1>&6 +# Extract the first word of "cwish", so it can be a program name with args. +set dummy cwish; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_path_CWISH'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + case "$CWISH" in + /*) + ac_cv_path_CWISH="$CWISH" # Let the user override the test with a path. + ;; + *) + 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_path_CWISH="$ac_dir/$ac_word" + break + fi + done + IFS="$ac_save_ifs" + ;; +esac +fi +CWISH="$ac_cv_path_CWISH" +if test -n "$CWISH"; then + echo "$ac_t""$CWISH" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + if test -n "$ac_cv_path_CWISH"; then + prefix=`echo $ac_cv_path_CWISH|sed 's%/[^/][^/]*//*[^/][^/]*$%%'` + fi +fi + +CC=${CC-cc} + +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 + +for ac_hdr in unistd.h limits.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 + +#-------------------------------------------------------------------- +# 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 $ac_n "checking stdlib.h""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strtol" >/dev/null 2>&1; then + rm -rf conftest* + tk_ok=yes +else + rm -rf conftest* + tk_ok=no +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* + tk_ok=no +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* + tk_ok=no +fi +rm -f conftest* + +if test $tk_ok = no; then + cat >> confdefs.h <<\EOF +#define NO_STDLIB_H 1 +EOF + +fi +echo "$ac_t""$tk_ok" 1>&6 + +#-------------------------------------------------------------------- +# Check for various typedefs and provide substitutes if +# they don't exist. +#-------------------------------------------------------------------- + +# 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 + +echo "$ac_t""$ac_cv_c_cross" 1>&6 +cross_compiling=$ac_cv_c_cross + +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 + : +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 + + +#-------------------------------------------------------------------- +# Locate the curses header files and the curses library +# archive. +#-------------------------------------------------------------------- + +got_it=no +if test $with_ncurses = yes; then + echo $ac_n "checking for -lncurses""... $ac_c" 1>&6 +ac_lib_var=`echo ncurses | tr '.-/+' '___p'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lncurses $LIBS" +cat > conftest.$ac_ext <&6 + LIBS="$LIBS -lncurses"; got_it=yes +else + echo "$ac_t""no" 1>&6 +fi + +else + echo $ac_n "checking for -lcurses""... $ac_c" 1>&6 +ac_lib_var=`echo curses | tr '.-/+' '___p'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lcurses $LIBS" +cat > conftest.$ac_ext <&6 + LIBS="$LIBS -lcurses"; got_it=yes +else + echo "$ac_t""no" 1>&6 +unset ac_cv_lib_curses + echo $ac_n "checking for -lcurses""... $ac_c" 1>&6 +ac_lib_var=`echo curses | tr '.-/+' '___p'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lcurses -ltermcap $LIBS" +cat > conftest.$ac_ext <&6 + LIBS="$LIBS -lcurses -ltermcap"; got_it=yes +else + echo "$ac_t""no" 1>&6 +fi + +fi + +fi +if test $got_it = no; then + echo "configure: warning: couldn't find curses library archive" 1>&2 + echo "configure: warning: will not be able to properly determine curses capabilities" 1>&2 +fi + +echo $ac_n "checking curses header file""... $ac_c" 1>&6 +got_it=no +if test $with_ncurses = yes; then + 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* + got_it=ncurses.h; cat >> confdefs.h <<\EOF +#define USE_NCURSES_H 1 +EOF + +else + echo "$ac_err" >&5 +fi +rm -f conftest* +fi +if test $got_it = no; then + 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* + got_it=curses.h +else + echo "$ac_err" >&5 +fi +rm -f conftest* +fi +if test $got_it = no; then + echo "configure: warning: couldn't find curses include file" 1>&2 +fi +echo "$ac_t""$got_it" 1>&6 + +#-------------------------------------------------------------------- +# Check the curses library features. +#-------------------------------------------------------------------- + +for ac_func in curs_set set_term beep keypad +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 + ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` + cat >> confdefs.h <&6 +fi +done + + +#-------------------------------------------------------------------- +# 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* + tk_ok=yes +else + rm -rf conftest* + tk_ok=no +fi +rm -f conftest* + +echo "$ac_t""$tk_ok" 1>&6 +if test $tk_ok = yes; then + cat >> confdefs.h <<\EOF +#define NEED_MATHERR 1 +EOF + +fi + +#-------------------------------------------------------------------- +# Figure out how to find out whether a FILE structure contains +# buffered readable data. Some known names for the count field: +# _cnt: Most UNIX systems +# __cnt: HPUX +# _r: BSD +# readCount: Sprite +# Or, in GNU libc there are two fields, _gptr and _egptr, which +# have to be compared. +#-------------------------------------------------------------------- + +echo $ac_n "checking count field in FILE structures""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +FILE *f = stdin; f->_cnt = 0; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + fcnt="_cnt" +fi +rm -f conftest* + +if test "$fcnt" = ""; then + cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +FILE *f = stdin; f->__cnt = 0; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + fcnt="__cnt" +fi +rm -f conftest* + +fi +if test "$fcnt" = ""; then + cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +FILE *f = stdin; f->_r = 0; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + fcnt="_r" +fi +rm -f conftest* + +fi +if test "$fcnt" = ""; then + cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +FILE *f = stdin; f->readCount = 0; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + fcnt="readCount" +fi +rm -f conftest* + +fi +if test "$fcnt" != ""; then + cat >> confdefs.h < conftest.$ac_ext < +int main() { return 0; } +int t() { +FILE *f = stdin; f->_gptr = f->_egptr; +; 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 = yes; then + cat >> confdefs.h <<\EOF +#define TK_FILE_GPTR 1 +EOF + + fcnt="_gptr/_egptr" + fi +fi +if test "$fcnt" = ""; then + cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end; +; 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 = yes; then + cat >> confdefs.h <<\EOF +#define TK_FILE_READ_PTR 1 +EOF + + fcnt="_IO_read_ptr/_IO_read_end" + fi +fi +if test "$fcnt" = ""; then + echo "$ac_t""not found; must supply TkReadDataPending procedure" 1>&6 +else + echo "$ac_t"""$fcnt"" 1>&6 +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 + : +else + echo "$ac_t""no" 1>&6 +LIBS="-lm $LIBS" +fi + +echo $ac_n "checking for -lieee""... $ac_c" 1>&6 +ac_lib_var=`echo ieee | tr '.-/+' '___p'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lieee $LIBS" +cat > conftest.$ac_ext <&6 + LIBS="-lieee $LIBS" +else + echo "$ac_t""no" 1>&6 +fi + + +#-------------------------------------------------------------------- +# Apparently SCO requires -lsocket for the gettimeofday() +# function. +#-------------------------------------------------------------------- + +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 +LIBS="-lsocket $LIBS" +fi + + +#-------------------------------------------------------------------- +# If this system doesn't have a memmove procedure, use memcpy +# instead. +#-------------------------------------------------------------------- + +echo $ac_n "checking for memmove""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_memmove'+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 memmove(); + +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_memmove) || defined (__stub___memmove) +choke me +#else +memmove(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_memmove=yes" +else + rm -rf conftest* + eval "ac_cv_func_memmove=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'memmove`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define memmove memcpy +EOF + +fi + + +#-------------------------------------------------------------------- +# Figure out whether "char" is unsigned. If so, set a +# #define. +#-------------------------------------------------------------------- + +echo $ac_n "checking type of "char"""... $ac_c" 1>&6 +if test "$cross_compiling" = yes; then + { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; } +else +cat > conftest.$ac_ext </dev/null; then + tk_signed=1 +else + tk_signed=0 +fi +fi +rm -fr conftest* +if test $tk_signed = 0; then + cat >> confdefs.h <<\EOF +#define CHAR_UNSIGNED 1 +EOF + + echo "$ac_t""unsigned" 1>&6 +else + echo "$ac_t""signed" 1>&6 +fi + +#-------------------------------------------------------------------- +# SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# +# Also, check for the existence of a gettimeofday declaration, +# to tkPort.h can declare it if it isn't already declared. +#-------------------------------------------------------------------- + +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 +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* + + +#-------------------------------------------------------------------- +# Under Solaris 2.4, strtod returns the wrong value for the +# terminating character under some conditions. Check for this +# and if the problem exists use a substitute procedure +# "fixstrtod" (provided by Tcl) that corrects the error. +#-------------------------------------------------------------------- + +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 + tk_strtod=1 +else + echo "$ac_t""no" 1>&6 +tk_strtod=0 +fi + +if test "$tk_strtod" = 1; then + echo $ac_n "checking for Solaris 2.4 strtod bug""... $ac_c" 1>&6 + if test "$cross_compiling" = yes; then + { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; } +else +cat > conftest.$ac_ext </dev/null; then + echo "$ac_t""ok" 1>&6 +else + + echo "$ac_t""buggy" 1>&6 + cat >> confdefs.h <<\EOF +#define strtod fixstrtod +EOF + + +fi +fi +rm -fr conftest* +fi + +#-------------------------------------------------------------------- +# Locate the Tcl header files and the Tcl library +# archive. +#-------------------------------------------------------------------- + +echo $ac_n "checking for -ltcl8.2""... $ac_c" 1>&6 +ac_lib_var=`echo tcl8.2 | tr '.-/+' '___p'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-ltcl8.2 $LIBS" +cat > conftest.$ac_ext <&6 + LIBS="-ltcl8.2 $LIBS"; got_it=yes +else + echo "$ac_t""no" 1>&6 +echo "configure: warning: couldn't find tcl8.2 library archive" 1>&2 +fi + +cat > 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* + echo "configure: warning: couldn't find tcl include file" 1>&2 +fi +rm -f conftest* + +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.7" + 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 +ac_given_INSTALL="$INSTALL" + +trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +EOF +cat >> $CONFIG_STATUS < 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%@bindir@%$bindir%g +s%@sbindir@%$sbindir%g +s%@libexecdir@%$libexecdir%g +s%@datadir@%$datadir%g +s%@sysconfdir@%$sysconfdir%g +s%@sharedstatedir@%$sharedstatedir%g +s%@localstatedir@%$localstatedir%g +s%@libdir@%$libdir%g +s%@includedir@%$includedir%g +s%@oldincludedir@%$oldincludedir%g +s%@infodir@%$infodir%g +s%@mandir@%$mandir%g +s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g +s%@INSTALL_DATA@%$INSTALL_DATA%g +s%@RANLIB@%$RANLIB%g +s%@CWISH@%$CWISH%g +s%@CC@%$CC%g +s%@CPP@%$CPP%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 + + case "$ac_given_INSTALL" in + [/$]*) INSTALL="$ac_given_INSTALL" ;; + *) INSTALL="$ac_dots$ac_given_INSTALL" ;; + 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 +s%@INSTALL@%$INSTALL%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 + ADDED configure.in Index: configure.in ================================================================== --- configure.in +++ configure.in @@ -0,0 +1,291 @@ +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) + +# @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + +AC_ARG_WITH(ncurses, + [ --with-ncurses use ncurses library instead of curses], + , [with_ncurses=no]) +AC_ARG_WITH(libdirs, + [ --with-libdirs directories to add to library search path]) +AC_ARG_WITH(incdirs, + [ --with-incdirs directories to add to include search path]) + +for ldir in $with_libdirs ;do + LDFLAGS="$LDFLAGS -L$ldir" +done +for idir in $with_incdirs ;do + CPPFLAGS="$CPPFLAGS -I$idir" +done + +AC_PROG_INSTALL +AC_PROG_RANLIB +AC_PREFIX(cwish) +CC=${CC-cc} +AC_SUBST(CC) +AC_HAVE_HEADERS(unistd.h limits.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 + +#-------------------------------------------------------------------- +# Supply a substitute for stdlib.h if it doesn't define strtol, +# strtoul, or strtod (which it doesn't in some versions of SunOS). +#-------------------------------------------------------------------- + +AC_MSG_CHECKING(stdlib.h) +AC_HEADER_EGREP(strtol, stdlib.h, tk_ok=yes, tk_ok=no) +AC_HEADER_EGREP(strtoul, stdlib.h, , tk_ok=no) +AC_HEADER_EGREP(strtod, stdlib.h, , tk_ok=no) +if test $tk_ok = no; then + AC_DEFINE(NO_STDLIB_H) +fi +AC_MSG_RESULT($tk_ok) + +#-------------------------------------------------------------------- +# 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 curses header files and the curses library +# archive. +#-------------------------------------------------------------------- + +got_it=no +if test $with_ncurses = yes; then + AC_CHECK_LIB(ncurses, initscr, + [LIBS="$LIBS -lncurses"; got_it=yes]) +else + AC_CHECK_LIB(curses, initscr, + [LIBS="$LIBS -lcurses"; got_it=yes], + [unset ac_cv_lib_curses + AC_CHECK_LIB(curses, initscr, + [LIBS="$LIBS -lcurses -ltermcap"; got_it=yes], + , + [-ltermcap])] ) +fi +if test $got_it = no; then + AC_MSG_WARN(couldn't find curses library archive) + AC_MSG_WARN(will not be able to properly determine curses capabilities) +fi + +AC_MSG_CHECKING([curses header file]) +got_it=no +if test $with_ncurses = yes; then + AC_TRY_CPP([#include ], + [got_it=ncurses.h; AC_DEFINE(USE_NCURSES_H)]) +fi +if test $got_it = no; then + AC_TRY_CPP([#include ], got_it=curses.h) +fi +if test $got_it = no; then + AC_MSG_WARN(couldn't find curses include file) +fi +AC_MSG_RESULT($got_it) + +#-------------------------------------------------------------------- +# Check the curses library features. +#-------------------------------------------------------------------- + +AC_HAVE_FUNCS(curs_set set_term beep keypad) + +#-------------------------------------------------------------------- +# 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; +], tk_ok=yes, tk_ok=no) +AC_MSG_RESULT($tk_ok) +if test $tk_ok = yes; then + AC_DEFINE(NEED_MATHERR) +fi + +#-------------------------------------------------------------------- +# Figure out how to find out whether a FILE structure contains +# buffered readable data. Some known names for the count field: +# _cnt: Most UNIX systems +# __cnt: HPUX +# _r: BSD +# readCount: Sprite +# Or, in GNU libc there are two fields, _gptr and _egptr, which +# have to be compared. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([count field in FILE structures]) +AC_TRY_COMPILE([#include ], + [FILE *f = stdin; f->_cnt = 0;], fcnt="_cnt", ) +if test "$fcnt" = ""; then + AC_TRY_COMPILE([#include ], + [FILE *f = stdin; f->__cnt = 0;], fcnt="__cnt", ) +fi +if test "$fcnt" = ""; then + AC_TRY_COMPILE([#include ], + [FILE *f = stdin; f->_r = 0;], fcnt="_r", ) +fi +if test "$fcnt" = ""; then + AC_TRY_COMPILE([#include ], + [FILE *f = stdin; f->readCount = 0;], fcnt="readCount", ) +fi +if test "$fcnt" != ""; then + AC_DEFINE_UNQUOTED(TK_FILE_COUNT, $fcnt) +fi +if test "$fcnt" = ""; then + AC_TRY_COMPILE([#include ], + [FILE *f = stdin; f->_gptr = f->_egptr;], + tk_ok=yes, tk_ok=no) + if test $tk_ok = yes; then + AC_DEFINE(TK_FILE_GPTR) + fcnt="_gptr/_egptr" + fi +fi +if test "$fcnt" = ""; then + AC_TRY_COMPILE([#include ], + [FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end;], + tk_ok=yes, tk_ok=no) + if test $tk_ok = yes; then + AC_DEFINE(TK_FILE_READ_PTR) + fcnt="_IO_read_ptr/_IO_read_end" + fi +fi +if test "$fcnt" = ""; then + AC_MSG_RESULT([not found; must supply TkReadDataPending procedure]) +else + AC_MSG_RESULT("$fcnt") +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"). +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(sin, , [LIBS="-lm $LIBS"]) +AC_CHECK_LIB(ieee, main, [LIBS="-lieee $LIBS"]) + +#-------------------------------------------------------------------- +# Apparently SCO requires -lsocket for the gettimeofday() +# function. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(gettimeofday, , [LIBS="-lsocket $LIBS"]) + +#-------------------------------------------------------------------- +# If this system doesn't have a memmove procedure, use memcpy +# instead. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(memmove, , [AC_DEFINE(memmove, memcpy)]) + +#-------------------------------------------------------------------- +# Figure out whether "char" is unsigned. If so, set a +# #define. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING(type of "char") +AC_TRY_RUN([ +int main() +{ + char c; + int i; + c = 0377; + i = c; + if (i == -1) { + exit(0); + } + exit(1); +}], tk_signed=1, tk_signed=0) +if test $tk_signed = 0; then + AC_DEFINE(CHAR_UNSIGNED) + AC_MSG_RESULT(unsigned) +else + AC_MSG_RESULT(signed) +fi + +#-------------------------------------------------------------------- +# SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# +# Also, check for the existence of a gettimeofday declaration, +# to tkPort.h can declare it if it isn't already declared. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(BSDgettimeofday, AC_DEFINE(HAVE_BSDGETTIMEOFDAY)) +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) +]) + +#-------------------------------------------------------------------- +# Under Solaris 2.4, strtod returns the wrong value for the +# terminating character under some conditions. Check for this +# and if the problem exists use a substitute procedure +# "fixstrtod" (provided by Tcl) that corrects the error. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtod, tk_strtod=1, tk_strtod=0) +if test "$tk_strtod" = 1; then + AC_MSG_CHECKING([for Solaris 2.4 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); + }], AC_MSG_RESULT(ok), [ + AC_MSG_RESULT(buggy) + AC_DEFINE(strtod, fixstrtod) + ]) +fi + +#-------------------------------------------------------------------- +# Locate the Tcl header files and the Tcl library +# archive. +#-------------------------------------------------------------------- + +AC_CHECK_LIB(tcl, Tcl_Init, [LIBS="-ltcl8.0 $LIBS"; got_it=yes], + [AC_MSG_WARN(couldn't find tcl8.0 library archive)] ) +AC_TRY_CPP([#include "tcl.h"], , + [AC_MSG_WARN(couldn't find tcl include file)] ) + +AC_OUTPUT(Makefile) ADDED ctk.tcl Index: ctk.tcl ================================================================== --- ctk.tcl +++ ctk.tcl @@ -0,0 +1,31 @@ +#! /usr/bin/env tclsh + +load ./libctk.so Tk + +namespace eval ::pkcs11_getfile {} +unset -nocomplain ::pkcs11_getfile::pkcs11file + +# Curses Tk lacks a "tk_getOpenFile" dialog, we create a simple input dialog +toplevel .pkcs11_getfile +label .pkcs11_getfile.lblInput -text "Please enter the pathname to a working PKCS#11 Module" +entry .pkcs11_getfile.entInput +button .pkcs11_getfile.btnOK -text "OK" -command { + set ::pkcs11_getfile::pkcs11file [.pkcs11_getfile.entInput get] + + destroy .pkcs11_getfile +} +button .pkcs11_getfile.btnCancel -text "Cancel" -command { + destroy .pkcs11_getfile + + set ::pkcs11_getfile::pkcs11file "" +} + +pack .pkcs11_getfile.lblInput +pack .pkcs11_getfile.entInput +pack .pkcs11_getfile.btnOK .pkcs11_getfile.btnCancel + +focus .pkcs11_getfile.entInput + +tkwait variable ::pkcs11_getfile::pkcs11file +set pkcs11file $::pkcs11_getfile::pkcs11file + ADDED ctkDisplay.c Index: ctkDisplay.c ================================================================== --- ctkDisplay.c +++ ctkDisplay.c @@ -0,0 +1,919 @@ +/* + * ctkDisplay.c (CTk) -- + * + * CTK display functions (hides all curses functions). + * + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "tkInt.h" +#include +#ifdef USE_NCURSES_H +# include +#else +# include +#endif + +#ifdef CLK_TCK +# define MS_PER_CLOCK (1000.0/CLK_TCK) +#elif defined HZ +# define MS_PER_CLOCK (1000.0/HZ) +#else + /* + * If all else fails, assume 60 clock ticks per second - + * hope that is okay! + */ +# define MS_PER_CLOCK (1000.0/60) +#endif + +/* + * Definitions for weak curses implementations. + */ + +#ifndef ACS_ULCORNER +/* + * This curses does not define the alternate character set constants. + * Define them locally. + */ +# define ACS_ULCORNER '+' +# define ACS_LLCORNER '+' +# define ACS_URCORNER '+' +# define ACS_LRCORNER '+' +# define ACS_HLINE '-' +# define ACS_VLINE '|' +# define ACS_PLUS '+' +#endif /* ACS_ULCORNER */ + +#ifndef HAVE_CURS_SET +/* + * Don't have curs_set() function - ignore it. + * + * The cursor gets pretty annoying, but haven't found any other + * way to turn it off. + */ +# define curs_set(mode) ((void) 0) +#endif + +#ifndef A_STANDOUT + typedef int chtype; +# define attrset(attr) ((attr) ? standout() : standend()) +# define A_STANDOUT 1 +# define A_INVIS 0 +# define A_NORMAL 0 +# define A_UNDERLINE 0 +# define A_REVERSE 0 +# define A_DIM 0 +# define A_BOLD 0 +# define A_DIM 0 +# define A_BOLD 0 +# define A_REVERSE 0 +#endif + +#ifdef HAVE_SET_TERM +# define SetDisplay(dispPtr) \ + if (curDispPtr != (dispPtr)) \ + set_term((SCREEN *) (curDispPtr = (dispPtr))->display) +#else +# define SetDisplay(dispPtr) ((void) 0) +# define newterm(type, outPtr, inPtr) initscr() +#endif + +#ifndef HAVE_KEYPAD +# define keypad(win, flag) ((void) 0) +#endif + +#ifndef HAVE_BEEP +# define beep() ((void) 0) +#endif + +/* + * Macros for the most often used curses operations. This + * will hopefully help if someone wants to convert to a different + * terminal I/O library (like DOS BIOS?). + */ +#define Move(x,y) move(y,x) +#define PutChar(ch) addch(ch) +#define SetStyle(style) attrset(styleAttributes[style]) + + +/* + * TextInfo - client data passed to DrawTextSpan() when drawing text. + */ +typedef struct { + char *str; /* String being drawn. */ + int left; /* Absolute X coordinate to draw first character + * of string at. */ +} TextInfo; + +/* + * Curses attributes that correspond to CTk styles. + * This definition must be modified in concert with + * the Ctk_Style definition in tk.h + */ +chtype styleAttributes[] = { + A_NORMAL, A_NORMAL, A_UNDERLINE, A_REVERSE, A_DIM, A_BOLD, + A_DIM, A_BOLD, A_STANDOUT, A_REVERSE +}; + +/* + * Current display for input/output. Changed by SetDisplay(). + */ + +TkDisplay *curDispPtr = NULL; + +/* + * The data structure and hash table below are used to map from + * raw keycodes (curses) to keysyms and modifier masks. + */ + +typedef struct { + int code; /* Curses key code. */ + KeySym sym; /* Key sym. */ + int modMask; /* Modifiers. */ +} KeyCodeInfo; + +static KeyCodeInfo keyCodeArray[] = { +#include "keyCodes.h" + {0, 0, 0} +}; +static Tcl_HashTable keyCodeTable; /* Hashed form of above structure. */ + +/* + * Forward declarations of static functions. + */ + +static void TermFileProc _ANSI_ARGS_((ClientData clientData, + int mask)); +static void RefreshDisplay _ANSI_ARGS_((TkDisplay *dispPtr)); +static void DrawTextSpan _ANSI_ARGS_((int left, int right, int y, + ClientData data)); +static void FillSpan _ANSI_ARGS_((int left, int right, int y, + ClientData data)); + + + +/* + *-------------------------------------------------------------- + * + * CtkDisplayInit -- + * + * Opens a connection to terminal with specified name, + * and stores terminal information in the display + * structure pointed to by `dispPtr'. + * + * Results: + * Standard TCL result. + * + * Side effects: + * The screen is cleared, and all sorts of I/O options + * are set appropriately for a full-screen application. + * + *-------------------------------------------------------------- + */ + +int +CtkDisplayInit(interp, dispPtr, termName) + Tcl_Interp *interp; + TkDisplay *dispPtr; + char *termName; +{ + char *type; + int length; + FILE *outPtr; + + int fd; /* For the return value of Tcl_GetChannelHandle */ + /* The Tcl_File is no longer needed, since Channels now subsume their work */ + + static int initialized = 0; + + if (!initialized) { + register KeyCodeInfo *codePtr; + register Tcl_HashEntry *hPtr; + int dummy; + + initialized = 1; + Tcl_InitHashTable(&keyCodeTable, TCL_ONE_WORD_KEYS); + for (codePtr = keyCodeArray; codePtr->code != 0; codePtr++) { + hPtr = Tcl_CreateHashEntry(&keyCodeTable, + (char *) codePtr->code, &dummy); + Tcl_SetHashValue(hPtr, (ClientData) codePtr); + } + } + + type = strchr(termName, ':'); + if (type == NULL) { + length = strlen(termName); + type = getenv("CTK_TERM"); + if (!type) type = getenv("TERM"); + } else { + length = type - termName; + type++; + } + dispPtr->type = (char *) ckalloc((unsigned) strlen(type) + 1); + strcpy(dispPtr->type, type); + + dispPtr->name = (char *) ckalloc((unsigned) (length+1)); + strncpy(dispPtr->name, termName, length); + dispPtr->name[length] = '\0'; + + if (strcmp(dispPtr->name, "tty") == 0) { + dispPtr->chan = Tcl_GetStdChannel(TCL_STDIN); + } else { +#ifdef HAVE_SET_TERM + dispPtr->chan = HAVE_SET_TERM ? Tcl_OpenFileChannel(interp, dispPtr->name, + "r+", 0) : NULL; +#else + dispPtr->chan = NULL; +#endif + if (dispPtr->chan == NULL) { + Tcl_AppendResult(interp, "couldn't connect to device \"", + dispPtr->name, "\"", (char *) NULL); + goto error; + } + } + if ( Tcl_GetChannelHandle(dispPtr->chan, TCL_READABLE, &(dispPtr->fd) ) != TCL_OK ) + { + Tcl_AppendResult(interp, "couldn't get device handle for device \"", + dispPtr->name, "\"", (char *) NULL); + goto error; + } + + if (!isatty(dispPtr->fd)) { + Tcl_AppendResult(interp, "display device \"", dispPtr->name, + "\" is not a tty", (char *) NULL); + goto error; + } + if (dispPtr->fd == 0) { + dispPtr->inPtr = stdin; + outPtr = stdout; + } else { + dispPtr->inPtr = fdopen(dispPtr->fd, "r+"); + outPtr = dispPtr->inPtr; + } + + dispPtr->display = + (ClientData) newterm(dispPtr->type, outPtr, dispPtr->inPtr); + SetDisplay(dispPtr); + raw(); + nonl(); + noecho(); + keypad(stdscr, TRUE); + + Tcl_CreateChannelHandler(dispPtr->chan, TCL_READABLE, + TermFileProc, (ClientData) dispPtr); + return TCL_OK; + +error: + ckfree(dispPtr->name); + dispPtr->name = NULL; + ckfree(dispPtr->type); + dispPtr->type = NULL; + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * CtkDisplayEnd -- + * + * Ends CTk's use of terminal. + * + * Results: + * None. + * + * Side effects: + * The terminal is restored to line mode. + * + *-------------------------------------------------------------- + */ + +void +CtkDisplayEnd(dispPtr) + TkDisplay *dispPtr; +{ + SetDisplay(dispPtr); + curs_set(1); + endwin(); + + Tcl_DeleteChannelHandler(dispPtr->chan, + TermFileProc, (ClientData) dispPtr); + if (dispPtr->inPtr != stdin) { + fclose(dispPtr->inPtr); + } + ckfree(dispPtr->name); + ckfree(dispPtr->type); +} + +/* + *-------------------------------------------------------------- + * + * Ctk_DisplayFlush -- + * + * Flushes all output to the specified display. If dispPtr + * is NULL then output to all connected displays is flushed. + * + * Results: + * None. + * + * Side effects: + * The terminal display is updated. + * + *-------------------------------------------------------------- + */ + +void +Ctk_DisplayFlush(dispPtr) + TkDisplay *dispPtr; +{ + if (dispPtr) { + RefreshDisplay(dispPtr); + } else { + for (dispPtr = tkDisplayList; + dispPtr != (TkDisplay*) NULL; + dispPtr = dispPtr->nextPtr) { + RefreshDisplay(dispPtr); + } + } +} + +/* + *-------------------------------------------------------------- + * + * Ctk_DisplayRedraw -- + * + * Force a complete redraw of the specified display. + * + * Results: + * None. + * + * Side effects: + * The entire terminal display is redrawn. + * + *-------------------------------------------------------------- + */ + +void +Ctk_DisplayRedraw(dispPtr) + TkDisplay *dispPtr; +{ + SetDisplay(dispPtr); + clearok(stdscr, 1); +} + +/* + *-------------------------------------------------------------- + * + * Ctk_SetCursor -- + * + * Postions display cursor in window at specified (local) + * coordinates. + * + * Results: + * None. + * + * Side effects: + * Modifies window's display structure. + *-------------------------------------------------------------- + */ + +void +Ctk_SetCursor(winPtr, x, y) + TkWindow *winPtr; + int x, y; +{ + TkDisplay *dispPtr = Tk_Display(winPtr); + dispPtr->cursorPtr = winPtr; + dispPtr->cursorX = x; + dispPtr->cursorY = y; +} + +static void +RefreshDisplay(dispPtr) + TkDisplay *dispPtr; +{ + TkWindow *winPtr = dispPtr->cursorPtr; + int x, y; + int visible = 0; + + SetDisplay(dispPtr); + if (CtkIsDisplayed(winPtr)) { + /* + * Convert to absolute screen coordinates + */ + x = dispPtr->cursorX + winPtr->absLeft; + y = dispPtr->cursorY + winPtr->absTop; + if (y >= winPtr->maskRect.top + && y < winPtr->maskRect.bottom + && x >= winPtr->maskRect.left + && x < winPtr->maskRect.right + && CtkPointInRegion(x, y, winPtr->clipRgn) ) { + Move(x, y); + visible = 1; + } + } + curs_set(visible); + refresh(); +} + +/* + *-------------------------------------------------------------- + * + * CtkDisplayBell -- + * + * Flushes all output to the terminal (otherwise drawing + * may be buffered). + * + * Results: + * None. + * + * Side effects: + * The terminal display is updated. + * + *-------------------------------------------------------------- + */ + +void +CtkDisplayBell(dispPtr) + TkDisplay *dispPtr; +{ + SetDisplay(dispPtr); + beep(); +} + +/* + *-------------------------------------------------------------- + * + * Ctk_DisplayWidth -- + * Ctk_DisplayHeight -- + * + * Get geometry of terminal. + * + * Results: + * Size (width/height respectively) of terminal. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Ctk_DisplayWidth(dispPtr) + TkDisplay *dispPtr; +{ + SetDisplay(dispPtr); + return COLS; +} + +int +Ctk_DisplayHeight(dispPtr) + TkDisplay *dispPtr; +{ + SetDisplay(dispPtr); + return LINES; +} + +/* + *-------------------------------------------------------------- + * + * TermFileProc -- + * + * File handler for a terminal. + * + * Results: + * Returns TK_FILE_HANDLED if any events were processed. + * Otherwise returns TCL_READABLE. + * + * Side effects: + * Dispatches events (invoking event handlers). + * + *-------------------------------------------------------------- + */ + +static void +TermFileProc(clientData, mask) + ClientData clientData; + int mask; +{ + TkDisplay *dispPtr = (TkDisplay *) clientData; + Ctk_Event event; + struct tms timesBuf; + Tcl_HashEntry *hPtr; + KeyCodeInfo *codePtr; + int key; + + if ((mask & TCL_READABLE) == TCL_READABLE) { + SetDisplay(dispPtr); + + key = getch(); + hPtr = Tcl_FindHashEntry(&keyCodeTable, (char *) key); + if (hPtr) { + codePtr = (KeyCodeInfo *) Tcl_GetHashValue(hPtr); + event.u.key.sym = codePtr->sym; + event.u.key.state = codePtr->modMask; + } else { + event.u.key.sym = key; + event.u.key.state = 0; + } + event.type = CTK_KEY_EVENT; + event.window = dispPtr->focusPtr; + event.u.key.time = (unsigned long) (times(×Buf)*MS_PER_CLOCK); + Tk_HandleEvent(&event); + } +} + +/* + *-------------------------------------------------------------- + * + * Ctk_DrawCharacter -- + * + * Display a single character in a view. + * + * Results: + * None. + * + * Side effects: + * Character is output to the terminal. + * + *-------------------------------------------------------------- + */ + +void +Ctk_DrawCharacter(winPtr, x, y, style, character) + TkWindow *winPtr; /* Window to draw into. */ + int x,y; /* Position, relative to view, to + * start draw at. */ + Ctk_Style style; /* Style to draw character in. */ + int character; /* Character to draw. */ +{ + if (!CtkIsDisplayed(winPtr)) { + return; + } + + /* + * Convert to absolute screen coordinates + */ + y += winPtr->absTop; + x += winPtr->absLeft; + + if (y >= winPtr->clipRect.top + && y < winPtr->clipRect.bottom + && x >= winPtr->clipRect.left + && x < winPtr->clipRect.right + && CtkPointInRegion(x, y, winPtr->clipRgn) ) { + SetDisplay(winPtr->dispPtr); + SetStyle(style); + Move(x, y); + PutChar(character); + } +} + +/* + *-------------------------------------------------------------- + * + * Ctk_DrawString -- + * + * Display `length' characters from `str' into `winPtr' + * at position (`x',`y') in specified `style'. If `length' + * is -1 then draw till a null character is reached. + * + * Results: + * None. + * + * Side effects: + * Characters are output to the terminal. + * + *-------------------------------------------------------------- + */ + +void +Ctk_DrawString(winPtr, x, y, style, str, length) + TkWindow *winPtr; /* Window to draw into. */ + int x,y; /* Position, relative to view, to + * start drawing. */ + Ctk_Style style; /* Style to draw characters in. */ + char *str; /* Points to characters to be drawn. */ + int length; /* Number of characters from str + * to draw, or -1 to draw till NULL + * termination. */ +{ + int strLeft, strRight; + TextInfo text_info; + + if (!CtkIsDisplayed(winPtr)) { + return; + } + + /* + * Convert to absolute screen coordinates + */ + y += winPtr->absTop; + if (y < winPtr->clipRect.top || y > winPtr->clipRect.bottom) { + return; + } + x += winPtr->absLeft; + + if (length == -1) { + length = strlen(str); + } + strLeft = x; + strRight = x+length; + CtkIntersectSpans(&strLeft, &strRight, + winPtr->clipRect.left, winPtr->clipRect.right); + if (CtkSpanIsEmpty(strLeft, strRight)) return; + + SetDisplay(winPtr->dispPtr); + SetStyle(style); + text_info.str = str; + text_info.left = x; + CtkForEachIntersectingSpan(DrawTextSpan, (ClientData) &text_info, + strLeft, strRight, y, winPtr->clipRgn); +} + +/* + *-------------------------------------------------------------- + * + * DrawTextSpan -- + * + * Called by ForEachSpan() or ForEachIntersectingSpan() + * to draw a segment of a string. + * + * Results: + * None. + * + * Side effects: + * Characters are output to the terminal. + * + *-------------------------------------------------------------- + */ + +static void +DrawTextSpan(left, right, y, data) + int left; /* X coordinate to start drawing. */ + int right; /* X coordinate to stop drawing (this + * position is not drawn into). */ + int y; /* Y coordinate to draw at. */ + ClientData data; /* Points at TextInfo structure. */ +{ + char *charPtr = ((TextInfo*) data)->str + left - ((TextInfo*) data)->left; + int x; + + Move(left, y); + for (x=left; x < right; x++) { + PutChar(UCHAR(*charPtr++)); + } +} + +/* + *-------------------------------------------------------------- + * + * Ctk_ClearWindow -- + * + * Fill view with its background (as defined by + * winPtr->fillStyle and winPtr->fillChar). + * + * Results: + * None. + * + * Side effects: + * Characters are output to the terminal. + * + *-------------------------------------------------------------- + */ + +void +Ctk_ClearWindow(winPtr) + TkWindow * winPtr; /* Window to clear. */ +{ + int left = winPtr->clipRect.left; + int right = winPtr->clipRect.right; + int y; + + if (winPtr->fillStyle == CTK_INVISIBLE_STYLE || (!CtkIsDisplayed(winPtr)) + || CtkSpanIsEmpty(left, right)) { + return; + } + + SetDisplay(winPtr->dispPtr); + SetStyle(winPtr->fillStyle); + for (y=winPtr->clipRect.top; y < winPtr->clipRect.bottom; y++) { + CtkForEachIntersectingSpan( + FillSpan, (ClientData) winPtr->fillChar, + left, right, y, + winPtr->clipRgn); + } +} + +/* + *-------------------------------------------------------------- + * + * CtkFillRegion -- + * + * Fills in a region with the specified character and style. + * Region is in absolute screen coordinates. No clipping is + * performed. + * + * Results: + * None. + * + * Side effects: + * Characters are output to the terminal. + * + *-------------------------------------------------------------- + */ + +void +CtkFillRegion(dispPtr, rgnPtr, fillStyle, fillChar) + TkDisplay *dispPtr; + CtkRegion *rgnPtr; + Ctk_Style fillStyle; + int fillChar; +{ + SetDisplay(dispPtr); + SetStyle(fillStyle); + CtkForEachSpan(FillSpan, (ClientData) fillChar, rgnPtr); +} + +/* + *-------------------------------------------------------------- + * + * Ctk_FillRect -- + * + * Draw a rectangle filled with the specified character + * and style in `winPtr' at relative coordinates (x1,y1) + * to (x2-1,y2-1). + * + * Results: + * None. + * + * Side effects: + * Characters are output to the terminal. + * + *-------------------------------------------------------------- + */ + +void +Ctk_FillRect(winPtr, x1, y1, x2, y2, fillStyle, fillChar) + TkWindow *winPtr; + int x1; + int y1; + int x2; + int y2; + Ctk_Style fillStyle; + int fillChar; +{ + Ctk_Rect rect; + int y; + + if (!CtkIsDisplayed(winPtr)) { + return; + } + CtkSetRect(&rect, x1, y1, x2, y2); + CtkMoveRect(&rect, winPtr->absLeft, winPtr->absTop); + CtkIntersectRects(&rect, &winPtr->clipRect); + if ( CtkSpanIsEmpty(rect.left, rect.right) ) { + return; + } + SetDisplay(winPtr->dispPtr); + SetStyle(fillStyle); + for (y=rect.top; y < rect.bottom; y++) + { + CtkForEachIntersectingSpan( FillSpan, (ClientData) fillChar, + rect.left, rect.right, y, winPtr->clipRgn); + } +} + +/* + *-------------------------------------------------------------- + * + * FillSpan -- + * + * Called by ForEachSpan() or ForEachIntersectingSpan() + * to fill a span with the same character. + * + * Results: + * None. + * + * Side effects: + * Characters are output to the terminal. + * + *-------------------------------------------------------------- + */ + +static void +FillSpan(left, right, y, data) + int left; /* X coordinate to start filling. */ + int right; /* X coordinate to stop filling (this + * position is not draw into). */ + int y; /* Y coordinate to draw at. */ + ClientData data; /* Character to draw. */ +{ + int x; + + Move(left, y); + for (x=left; x < right; x++) { + PutChar((int) data); + } +} + +/* + *-------------------------------------------------------------- + * + * Ctk_DrawRect -- + * + * Draw outline of rectangle with line drawing characters + * and the specified style in `winPtr' at relative + * coordinates (x1,y1) to (x2,y2). + * + * Results: + * None. + * + * Side effects: + * Characters are output to the terminal. + * + *-------------------------------------------------------------- + */ + +void +Ctk_DrawRect(winPtr, x1, y1, x2, y2, lineStyle) + TkWindow *winPtr; + int x1; + int y1; + int x2; + int y2; + Ctk_Style lineStyle; +{ + Ctk_Rect *clipRectPtr = &winPtr->clipRect; + int left; + int right; + int top; + int bottom; + int y; + + if (!CtkIsDisplayed(winPtr) || x1 > x2 || y1 > y2) { + return; + } + SetDisplay(winPtr->dispPtr); + SetStyle(lineStyle); + + Ctk_DrawCharacter(winPtr, x1, y1, lineStyle, ACS_ULCORNER); + Ctk_DrawCharacter(winPtr, x2, y1, lineStyle, ACS_URCORNER); + Ctk_DrawCharacter(winPtr, x1, y2, lineStyle, ACS_LLCORNER); + Ctk_DrawCharacter(winPtr, x2, y2, lineStyle, ACS_LRCORNER); + + /* Convert to screen coordinates */ + x1 += winPtr->absLeft; + x2 += winPtr->absLeft; + y1 += winPtr->absTop; + y2 += winPtr->absTop; + + /* + * Draw horizontal lines. + */ + left = x1+1; + right = x2; + CtkIntersectSpans(&left, &right, clipRectPtr->left, clipRectPtr->right); + if (!CtkSpanIsEmpty(left, right)) { + if ((clipRectPtr->top <= y1) && (clipRectPtr->bottom > y1)) { + CtkForEachIntersectingSpan( + FillSpan, (ClientData) ACS_HLINE, + left, right, y1, + winPtr->clipRgn); + } + if ((clipRectPtr->top <= y2) && (clipRectPtr->bottom > y2)) { + CtkForEachIntersectingSpan( + FillSpan, (ClientData) ACS_HLINE, + left, right, y2, + winPtr->clipRgn); + } + } + + /* + * Draw vertical lines. + */ + top = y1 + 1; + bottom = y2; + CtkIntersectSpans(&top, &bottom, clipRectPtr->top, clipRectPtr->bottom); + if ((clipRectPtr->left <= x1) && (clipRectPtr->right > x1)) { + for (y=top; y < bottom; y++) { + if (CtkPointInRegion(x1, y, winPtr->clipRgn)) { + Move(x1, y); + PutChar(ACS_VLINE); + } + } + } + if ((clipRectPtr->left <= x2) && (clipRectPtr->right > x2)) { + for (y=top; y < bottom; y++) { + if (CtkPointInRegion(x2, y, winPtr->clipRgn)) { + Move(x2, y); + PutChar(ACS_VLINE); + } + } + } +} ADDED ctkRegion.c Index: ctkRegion.c ================================================================== --- ctkRegion.c +++ ctkRegion.c @@ -0,0 +1,888 @@ +/* + * ctkRegion.c (CTk) -- + * + * Geometry manipulation routines - regions (free form 2-D shapes), + * rectangles, and spans (horizontal segments). + * + * Beware, some of theses routines have special constraints that + * are not obvious from their title. Be sure to examine headers + * for constraints. + * + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * Notes on Geometry Types. + * + * Spans - + * Horizontal line segment. Between left point (inclusive) + * and right point (exclusive). Any span with right <= left + * is considered empty. + * + * Rectangles - + * Analogous to spans top and left points are include, + * and right and bottom points are excluded from area + * rectangle. Any rectangle with right <= left or + * bottom <= top is considered empty. + * + * Region - + * Free form area. Contents of structure are opaque. + * !!! Vertical bounds of region cannot increase !!! + * The rectangle used with CtkCreateRegion() must have the + * maximum top and bottom for the region (the rectangle + * may still be empty if right <= left). + */ + +/* + * Limits for x and y coordinates + * (choose these to work with systems where int is 16-bit). + */ +#define COORD_MAX 32767 +#define COORD_MIN -32768 + + +/* + * Component of a region + */ +typedef struct { + int left; + int right; + int next; /* Index of next span */ +} RegionSpan; +#define NO_SPAN (-1) /* Invalid index (indicates end of span list) */ + +struct CtkRegion { + int top; + int bottom; + int free; + int num_spans; + RegionSpan *spans; +}; + +#define CopySpan(dst, src) (memcpy((dst), (src), sizeof(RegionSpan))) +#define FreeSpan(rgnPtr, index) \ + ((rgnPtr)->spans[(index)].next \ + = (rgnPtr)->free, (rgnPtr)->free = (index)) + +/* + * Private Function Declarations + */ +static void PseudoUnionSpans _ANSI_ARGS_((int *leftPtr, int *rightPtr, + int left2, int right2)); +static int DeleteSpan _ANSI_ARGS_((CtkRegion * rgnPtr, int index, + int priorIndex)); +static void AppendSpan _ANSI_ARGS_((CtkRegion * rgnPtr, int index, + int left, int right)); +static void PrependSpan _ANSI_ARGS_((CtkRegion * rgnPtr, int index, + int left, int right)); +static int AllocSpan _ANSI_ARGS_((CtkRegion * rgnPtr)); +static void MergeSpan _ANSI_ARGS_((CtkRegion * rgnPtr, int left, + int right, int y)); + + +/* + *---------------------------------------------------------------------- + * + * CtkIntersectSpans -- compute intersection of 2 spans + * + * Compute the intersection of the span (*leftPtr,*rightPtr) + * and the span (left2,right2). + * + * Results: + * Stores the resulting span in `leftPtr' and `rightPtr'. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +CtkIntersectSpans(leftPtr, rightPtr, left2, right2) + int *leftPtr; + int *rightPtr; + int left2; + int right2; +{ + if (*leftPtr < left2) *leftPtr = left2; + if (*rightPtr > right2) *rightPtr = right2; +} + +/* + *---------------------------------------------------------------------- + * + * PseudoUnionSpans -- compute union of 2 spans + * + * Compute the union of the span (*leftPtr,*rightPtr) + * and the span (left2,right2). Assumes that the spans overlap. + * If they don't, the result will contain the area between the + * spans also. (A real union would have to be capable of + * returning two disjoint spans.) + * + * Results: + * Stores the resulting span in `leftPtr' and `rightPtr'. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PseudoUnionSpans(leftPtr, rightPtr, left2, right2) + int *leftPtr; + int *rightPtr; + int left2; + int right2; +{ + if (*leftPtr > left2) *leftPtr = left2; + if (*rightPtr < right2) *rightPtr = right2; +} + +/* + *---------------------------------------------------------------------- + * + * CtkSpanMinusSpan - compute difference of 2 spans + * + * Substract span (subL, subR) from span (srcL, srcR). + * (Find segment(s) in first span that do not overlap with + * second span.) + * + * Results: + * Returns the number of resultin spans (0-2). + * Stores the resulting span(s) in remsL[] and remsR[]. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +CtkSpanMinusSpan(srcL, srcR, subL, subR, remsL, remsR) + int srcL; + int srcR; + int subL; + int subR; + int *remsL; + int *remsR; +{ + int numRems = 0; + + if (srcR <= subL || srcL >= subR) return (numRems); + if (srcL < subL) { + remsL[numRems] = srcL; + remsR[numRems] = subL; + numRems += 1; + } + if (srcR > subR) { + remsL[numRems] = subR; + remsR[numRems] = srcR; + numRems += 1; + } + return (numRems); + +} + +/* + *---------------------------------------------------------------------- + * + * CtkIntersectRects -- compute intersection of two rectangles + * + * Computer overlap between rectangles pointed to by + * r1Ptr and r2Ptr. + * + * Results: + * Stores clipped down rectangle in `r1Ptr'. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +CtkIntersectRects(r1Ptr, r2Ptr) + Ctk_Rect * r1Ptr; + CONST Ctk_Rect * r2Ptr; +{ + + if (r1Ptr->left < r2Ptr->left) r1Ptr->left = r2Ptr->left; + if (r1Ptr->top < r2Ptr->top) r1Ptr->top = r2Ptr->top; + if (r1Ptr->right > r2Ptr->right) r1Ptr->right = r2Ptr->right; + if (r1Ptr->bottom > r2Ptr->bottom) r1Ptr->bottom = r2Ptr->bottom; + +} + +/* + *---------------------------------------------------------------------- + * + * CtkCreateRegion -- create a new region + * + * Create a new region and initialize it to the area of + * `rect'. + * + * Results: + * Returns pointer to new region. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +CtkRegion * +CtkCreateRegion(rect) + Ctk_Rect * rect; +{ + CtkRegion * rgnPtr; + int i; + rgnPtr = (CtkRegion *) ckalloc(sizeof(CtkRegion)); + + rgnPtr->top = rect->top; + rgnPtr->bottom = rect->bottom; + rgnPtr->free = NO_SPAN; + rgnPtr->num_spans = rgnPtr->bottom - rgnPtr->top; + if (rgnPtr->num_spans <= 0) { + rgnPtr->num_spans = 0; + rgnPtr->spans = (RegionSpan *) NULL; + } else { + rgnPtr->spans = (RegionSpan *) + ckalloc(rgnPtr->num_spans * sizeof(RegionSpan)); + for (i=0; i < rgnPtr->num_spans; i++) { + rgnPtr->spans[i].left = rect->left; + rgnPtr->spans[i].right = rect->right; + rgnPtr->spans[i].next = NO_SPAN; + } + } + return rgnPtr; +} + +/* + *---------------------------------------------------------------------- + * + * CtkDestroyRegion - release resources held by a region + * + * Free resources for a region - region may not be referenced + * again. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +CtkDestroyRegion(rgnPtr) + CtkRegion *rgnPtr; +{ + if (rgnPtr->spans) { + ckfree((char *) rgnPtr->spans); + } + ckfree((char *) rgnPtr); +} + +/* + *---------------------------------------------------------------------- + * + * CtkRegionMinusRect - remove rectangular area from region + * + * Substract area of rectangle `rectPtr' from region `rgnPtr'. + * + * Results: + * If `wantInter', returns the intersection of the region and + * the rectangle (as a new region - use CtkDestroyRegion() to + * get rid of it). + * Otherwise, returns NULL. + * + * Side effects: + * Contents of `rgnPtr' is changed. + * + *---------------------------------------------------------------------- + */ + +CtkRegion * +CtkRegionMinusRect(rgnPtr, rectPtr, wantInter) + CtkRegion *rgnPtr; + Ctk_Rect *rectPtr; + int wantInter; +{ + int itop = rectPtr->top; + int ibottom = rectPtr->bottom; + RegionSpan *spans = rgnPtr->spans; + int y; + int idx; + int lastIdx; + int rems; + int newLefts[2]; + int newRights[2]; + Ctk_Rect emptyRect; + CtkRegion * intersection = NULL; + + CtkIntersectSpans(&itop, &ibottom, rgnPtr->top, rgnPtr->bottom); + if (wantInter) { + emptyRect.left = 0; + emptyRect.top = itop; + emptyRect.right = 0; + emptyRect.bottom = ibottom; + intersection = (CtkRegion *) CtkCreateRegion(&emptyRect); + } + + for (y = itop; y < ibottom; y++) { + lastIdx = NO_SPAN; + idx = y - rgnPtr->top; + while (idx != NO_SPAN) { + if (spans[idx].left >= rectPtr->right) { + /* + * Remaining spans on this line are right of `rectPtr' + */ + break; + } + if (spans[idx].right <= rectPtr->left) { + /* + * No overlap + */ + lastIdx = idx; + idx = spans[idx].next; + } else { + /* + * Rect and span overlap + */ + rems = CtkSpanMinusSpan( + spans[idx].left, spans[idx].right, + rectPtr->left, rectPtr->right, + newLefts, newRights); + if (wantInter) { + CtkIntersectSpans( + &spans[idx].left, &spans[idx].right, + rectPtr->left, rectPtr->right ); + MergeSpan(intersection, + spans[idx].left, spans[idx].right, y); + } + switch (rems) { + case 0: + idx = DeleteSpan(rgnPtr, idx, lastIdx); + break; + case 1: + spans[idx].left = newLefts[0]; + spans[idx].right = newRights[0]; + lastIdx = idx; + idx = spans[idx].next; + break; + case 2: + spans[idx].left = newLefts[0]; + spans[idx].right = newRights[0]; + AppendSpan(rgnPtr, idx, newLefts[1], newRights[1]); + spans = rgnPtr->spans; + lastIdx = spans[idx].next; + idx = spans[lastIdx].next; + break; + } + } + } /* for (idx) */ + } /* for (y) */ + return intersection; +} + +/* + *---------------------------------------------------------------------- + * + * CtkUnionRegions - merge one region into another + * + * Computes the union of the regions `rgn1Ptr' and `rgn2Ptr', + * and stores it in `rgn1Ptr'. + * !!! The union cannot increase the top and bottom of `rgn1' !!! + * + * Results: + * None. + * + * Side effects: + * `rgn1Ptr' was is (possibly) expanded. + * + *---------------------------------------------------------------------- + */ + +void +CtkUnionRegions(rgn1Ptr, rgn2Ptr) + CtkRegion *rgn1Ptr; + CtkRegion *rgn2Ptr; +{ + RegionSpan *spans2 = rgn2Ptr->spans; + int top2 = rgn2Ptr->top; + int bottom2 = rgn2Ptr->bottom; + int y; + int idx; + + for (y = top2; y < bottom2; y++) { + idx = y - top2; + if (spans2[idx].left >= spans2[idx].right) { + /* Empty scan line */ + continue; + } + /* + * Could eventually expand (repack) region 1 here, + * if line is not within the vertical bounds of the + * first region. + */ + while (idx != NO_SPAN) { + MergeSpan(rgn1Ptr, spans2[idx].left, spans2[idx].right, y); + idx = spans2[idx].next; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CtkForEachSpan -- perform function on every span in a region + * + * Executes function `spanProcPtr' for each span in region. + * Passes `clientData' and the span as arguments to `spanProcPtr'. + * + * Results: + * None. + * + * Side effects: + * `spanProcPtr' is executed. + * + *---------------------------------------------------------------------- + */ + +void +CtkForEachSpan(spanProcPtr, clientData, rgnPtr) + CtkSpanProc *spanProcPtr; + ClientData clientData; + CtkRegion *rgnPtr; +{ + RegionSpan *spans = rgnPtr->spans; + int top = rgnPtr->top; + int bottom = rgnPtr->bottom; + int y; + int idx; + + for (y = top; y < bottom; y++) { + idx = y - top; + if (spans[idx].left >= spans[idx].right) { + /* Empty scan line */ + continue; + } + while (idx != NO_SPAN) { + (*spanProcPtr)(spans[idx].left, spans[idx].right, y, clientData); + idx = spans[idx].next; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CtkForEachIntersectingSpan -- perform function on region/span intersection + * + * Computes the intersection of region `rgnPtr' and the + * span `left',`right' at vertical position `y'. Executes + * function `spanProcPtr' for each span in the intersection. + * Passes `clientData' and the span as arguments to `spanProcPtr'. + * + * Results: + * None. + * + * Side effects: + * `spanProcPtr' is executed. + * + *---------------------------------------------------------------------- + */ + +void +CtkForEachIntersectingSpan(spanProcPtr, clientData, left, right, y, rgnPtr) + CtkSpanProc *spanProcPtr; + ClientData clientData; + int left; + int right; + int y; + CtkRegion *rgnPtr; +{ + RegionSpan *spans = rgnPtr->spans; + int idx; + int ileft; + int iright; + + if (y < rgnPtr->top || y >= rgnPtr->bottom) return; + + for (idx = y - rgnPtr->top; idx != NO_SPAN; idx = spans[idx].next) { + if (spans[idx].left >= right) break; + if (spans[idx].right > left) { + /* + * Spans overlap. + */ + ileft = spans[idx].left; + iright = spans[idx].right; + CtkIntersectSpans(&ileft, &iright, left, right); + (*spanProcPtr)(ileft, iright, y, clientData); + } + } /* for (idx) */ +} + +/* + *---------------------------------------------------------------------- + * + * CtkPointInRegion -- check if point is contained in region + * + * Check if point (x,y) is in the region `rgnPtr'. + * + * Results: + * Returns 1 if point is in region, otherwise returns 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +CtkPointInRegion(x, y, rgnPtr) + int x, y; + CtkRegion *rgnPtr; +{ + RegionSpan *spans = rgnPtr->spans; + int idx; + + if (y >= rgnPtr->top && y < rgnPtr->bottom) { + for (idx = y - rgnPtr->top; idx != NO_SPAN; idx = spans[idx].next) { + if (spans[idx].left > x) break; + if (spans[idx].right > x) { + return 1; + } + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * CtkRegionGetRect -- compute enclosing rectangle of a region + * + * Compute the smallest rectangle that will enclose the + * area of `rgnPtr'. + * + * Results: + * Stores the resulting rectangle in `rectPtr'. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +CtkRegionGetRect(rgnPtr, rectPtr) + CtkRegion *rgnPtr; + Ctk_Rect *rectPtr; +{ + RegionSpan *spans = rgnPtr->spans; + int top = rgnPtr->top; + int numLines = rgnPtr->bottom - top; + int topLine; /* Index of top non-empty scan line */ + int bottomLine; /* Index of bottom non-empty scan line */ + int left = COORD_MAX; + int right = COORD_MIN; + int line; + int i; + + for (topLine = 0; topLine < numLines; topLine++) { + if (spans[topLine].left < spans[topLine].right) { + /* Non-empty scan line */ + break; + } + } + for (bottomLine = numLines-1 ; bottomLine >= topLine; bottomLine--) { + if (spans[bottomLine].left < spans[bottomLine].right) { + /* Non-empty scan line */ + break; + } + } + bottomLine++; + + for (line = topLine; line < bottomLine; line++) + { + if (spans[line].left < spans[line].right) { + /* + * Non-empty scan line, if it goes outside the current + * left and right bounds, then expand the bounds. + */ + if (spans[line].left < left) { + left = spans[line].left; + } + for (i = line; spans[i].next != NO_SPAN; i++); + if (spans[i].right > right) { + right = spans[i].right; + } + } + } + + if (left < right && topLine < bottomLine) { + CtkSetRect(rectPtr, left, top+topLine, right, top+bottomLine); + } else { + CtkSetRect(rectPtr, 0, 0, 0, 0); + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteSpan -- remove a span from a region + * + * Removes the span at `index' from `rgnPtr'. `priorIndex' + * must point to the preceding span, or be NO_SPAN if this + * is the first span of a line. + * + * Results: + * Index of the next span (one after the deleted one). + * + * Side effects: + * The span at the specified index is removed, unless it is the + * first span of scan line in which case is is set to empty. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteSpan(rgnPtr, index, priorIndex) + CtkRegion *rgnPtr; + int index; + int priorIndex; +{ + int nextIndex = rgnPtr->spans[index].next; + + if (priorIndex == NO_SPAN) { + if (nextIndex == NO_SPAN) { + rgnPtr->spans[index].left = rgnPtr->spans[index].right; + } else { + CopySpan(&rgnPtr->spans[index], &rgnPtr->spans[nextIndex]); + FreeSpan(rgnPtr, nextIndex); + nextIndex = index; + } + } else { + rgnPtr->spans[priorIndex].next = nextIndex; + FreeSpan(rgnPtr, index); + } + return nextIndex; +} + +/* + *---------------------------------------------------------------------- + * + * AppendSpan -- add a span to a region + * + * Adds span `left',`right' to region `rgnPtr' + * after the span at `index'. + * + * Results: + * None. + * + * Side effects: + * Changes contents of `rgnPtr'. + * !!! May change the value of rgnPtr->spans !!! + * + *---------------------------------------------------------------------- + */ + +static void +AppendSpan(rgnPtr, index, left, right) + CtkRegion * rgnPtr; + int index; + int left; + int right; +{ + int newIndex = AllocSpan(rgnPtr); + RegionSpan *spans = rgnPtr->spans; + + spans[newIndex].left = left; + spans[newIndex].right = right; + spans[newIndex].next = spans[index].next; + spans[index].next = newIndex; +} + +/* + *---------------------------------------------------------------------- + * + * PrependSpan -- add a span to a region + * + * Adds span `left',`right' to region `rgnPtr' + * before the span at `index'. + * + * Results: + * None. + * + * Side effects: + * Changes contents of `rgnPtr'. + * !!! May change the value of rgnPtr->spans !!! + * + *---------------------------------------------------------------------- + */ + +static void +PrependSpan(rgnPtr, index, left, right) + CtkRegion * rgnPtr; + int index; + int left; + int right; +{ + int newIndex = AllocSpan(rgnPtr); + RegionSpan *spans = rgnPtr->spans; + + CopySpan(&spans[newIndex], &spans[index]); + spans[index].left = left; + spans[index].right = right; + spans[index].next = newIndex; + +} + +/* + *---------------------------------------------------------------------- + * + * AllocSpan -- get a new span for a region + * + * Allocates another span for region `rgnPtr'. + * + * Results: + * Returns index of new span. + * + * Side effects: + * !!! May change the value of rgnPtr->spans !!! + * + *---------------------------------------------------------------------- + */ + +static int +AllocSpan(rgnPtr) + CtkRegion * rgnPtr; +{ + int i; + int old_num; + int new_num; + + if (rgnPtr->free == NO_SPAN) { + /* + * No spans in free list, allocate some more. + */ + old_num = rgnPtr->num_spans; + new_num = old_num + 20; + rgnPtr->spans = (RegionSpan *) + ckrealloc((char *) rgnPtr->spans, (new_num)*sizeof(RegionSpan)); + rgnPtr->num_spans = new_num; + + /* + * Add the new spans (except one) to the regions free list. + */ + for (i=old_num+1; i < new_num; i++) { + rgnPtr->spans[i-1].next = i; + } + rgnPtr->spans[new_num-1].next = NO_SPAN; + rgnPtr->free = old_num+1; + + /* + * Return the remaining new span. + */ + return (old_num); + } else { + /* + * Spans in free list, return one. + */ + i = rgnPtr->free; + rgnPtr->free = rgnPtr->spans[rgnPtr->free].next; + return (i); + } +} + +/* + *---------------------------------------------------------------------- + * + * MergeSpan -- union a span into a region + * + * Computes the union of region `rgnPtr' and span `left',`right' + * at line y, and stores it in `rgnPtr'. + * !!! `y' must be within rgnPtr->top and rgnPtr->bottom !!! + * + * Results: + * None. + * + * Side effects: + * (Possibly) expands the region `rgnPtr'. + * + *---------------------------------------------------------------------- + */ + +static void +MergeSpan(rgnPtr, left, right, y) + CtkRegion * rgnPtr; + int left; + int right; + int y; +{ + RegionSpan *spans = rgnPtr->spans; + int idx = y - rgnPtr->top; + int lastIdx = NO_SPAN; + int mergeIdx = NO_SPAN; + + if (y < rgnPtr->top || y > rgnPtr->bottom) { + panic("Merge span (y=%d) outside of regions vertical bounds (%d-%d)", + y, rgnPtr->top, rgnPtr->bottom); + } + + if (spans[idx].left >= spans[idx].right) { + /* + * Empty scan line, replace it with the new span. + */ + spans[idx].left = left; + spans[idx].right = right; + return; + } + + while (idx != NO_SPAN) { + if (spans[idx].right >= left) { + /* + * This spans is not left of the merge span. + */ + + if (spans[idx].left > right) break; /* right of merge */ + + if (mergeIdx == NO_SPAN) { + PseudoUnionSpans( + &spans[idx].left, &spans[idx].right, left, right); + mergeIdx = idx; + } else { + if (spans[mergeIdx].right < spans[idx].right) { + spans[mergeIdx].right = spans[idx].right; + } + idx = DeleteSpan(rgnPtr, idx, lastIdx); + continue; + } + } + + lastIdx = idx; + idx = spans[idx].next; + } + + if (mergeIdx == NO_SPAN) { + /* + * No merge performed, append merge span to scan line. + */ + if (lastIdx == NO_SPAN) { + PrependSpan(rgnPtr, idx, left, right); + } else { + AppendSpan(rgnPtr, lastIdx, left, right); + } + } +} ADDED cwish.1 Index: cwish.1 ================================================================== --- cwish.1 +++ cwish.1 @@ -0,0 +1,187 @@ +.\" -*- cwish -*- +.de TQ +.br +.ns +.TP \\$1 +.. +.TH CWISH 1 "25 July 1995" "Cwish Version 4.0" +.SH NAME +cwish \- curses windowing shell +.SH SYNOPSIS +.B cwish +[ +.I fileName +] +[ +.IR arg \|.\|.\|.\| +] +.SH DESCRIPTION +\fBCwish\fR is a Tcl shell with the CTk toolkit extension added. +The CTk toolkit is a port of the X11 Tk toolkit to curses. +\fBCwish\fR creates a main window and then processes Tcl commands +from a file, standard input or a dialog window. +.PP +If \fBcwish\fR is invoked with an initial \fIfileName\fR argument +(cannot begin with ``\-''), +then \fIfileName\fR is treated as the name of a script file. +\fBCwish\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. +.PP +If \fIfileName\fR is not specified then \fBcwish\fR runs interactively. +First, if there exists a file \fB.wishrc\fR in the home directory of +the user, \fBcwish\fR evaluates the file as a Tcl script. +If the display has not been redirected +(via the \fB-display\fR option or \fBCTK_DISPLAY\fR environment variable), +then a command dialog is displayed and \fBcwish\fR processes events +until all windows have been deleted. +Otherwise, \fBcwish\fR 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. + +.SH OPTIONS +.PP +\fBCwish\fR automatically processes the following command-line options: +.IP "\fB\-display \fIdevice\fR[:\fItype\fR]" 20 +Display device (and terminal type) on which to display window. +If type is not specified then terminal type is defined by the +\fBTERM\fR enviroment variable. +.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 application for processing options +in the .ctkdefaults file. +.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 \fBcwish\fR interpret them. +.PP +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 and class for an application are used for specifying options +with a .ctkdefaults file +(analogous to a .Xdefaults file). +The application name 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 \fBcwish\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. +The class of the application is the same as its name +except that the first letter is capitalized. + +.SH "VARIABLES" +.PP +\fBCwish\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 \fBcwish\fR was invoked. +.TP 15 +\fBgeometry\fR +If the \fB\-geometry\fR option is specified, \fBcwish\fR copies its +value into this variable. If the variable still exists after +\fIfileName\fR has been evaluated, \fBcwish\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 \fBcwish\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 +.nf + +\fB#!/usr/local/bin/cwish\fR + +.fi +then you can invoke the script file directly from your shell if +you mark it as executable. +This assumes that \fBcwish\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 \fBcwish\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: +.nf + +\fB#!/bin/sh +# the next line restarts using cwish \e +exec cwish "$0" "$@"\fR + +.fi +This approach has three advantages over the approach in the previous +paragraph. First, the location of the \fBcwish\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 \fBcwish\fR is +itself a shell script (this is done on some systems in order to +handle multiple architectures or operating systems: the \fBcwish\fR +script selects one of several binaries to run). The three lines +cause both \fBsh\fR and \fBcwish\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 \fBcwish\fR to reprocess the entire script. +When \fBcwish\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. +.PP +If your system does not have Tk installed, you may want to link +cwish to plain "wish" so that scripts written for the Tk windowing +shell will invoke cwish. Beware that most Tk scripts require some +modification to be usable with CTk. + +.SH "ENVIRONMENT VARIABLES" +.IP CTK_DISPLAY 20 +Define this variable to display to a device other than standard input/output. +The device can be followed by :\fIterm\fR to set the terminal type +for the device. +.IP CTK_LIBRARY 20 +Define this variable to override the CTK_LIBRARY path +that was compiled into the cwish binary. +.IP CTK_TERM 20 +Define this variable to override the value of the \fBTERM\fR +enviroment variable. +.IP TERM 20 +Defines the type of terminal for the standard input and output device. + +.SH AUTHOR +Martin Andrews + +.SH BUGS +Report bugs to andrewm@ccfadm.eeg.ccf.org. +Include a complete, self-contained example +that will allow the bug to be reproduced, +and say which version of CTk and Tcl you are using. + +.SH "SEE ALSO" +.BR tclsh (1) ADDED default.h Index: default.h ================================================================== --- default.h +++ default.h @@ -0,0 +1,166 @@ +/* + * default.h (CTk) -- + * + * This file defines the defaults for all options for all of + * the CTk widgets. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#ifndef _DEFAULT +#define _DEFAULT + +/* + * Defaults for labels, buttons, checkbuttons, and radiobuttons: + */ + +#define DEF_BUTTON_ANCHOR "center" +#define DEF_BUTTON_BORDER_WIDTH "0" +#define DEF_BUTTON_COMMAND "" +#define DEF_BUTTON_HEIGHT "-1" +#define DEF_BUTTON_INDICATOR "1" +#define DEF_BUTTON_JUSTIFY "center" +#define DEF_BUTTON_OFF_VALUE "0" +#define DEF_BUTTON_ON_VALUE "1" +#define DEF_BUTTON_PADX "0" +#define DEF_BUTTON_PADY "0" +#define DEF_BUTTON_STATE "normal" +#define DEF_LABEL_TAKE_FOCUS "0" +#define DEF_BUTTON_TAKE_FOCUS (char *) NULL +#define DEF_BUTTON_TEXT " " +#define DEF_BUTTON_TEXT_VARIABLE "" +#define DEF_BUTTON_UNDERLINE "-1" +#define DEF_BUTTON_VALUE "" +#define DEF_BUTTON_WIDTH "-1" +#define DEF_BUTTON_WRAP_LENGTH "0" +#define DEF_RADIOBUTTON_VARIABLE "selectedButton" +#define DEF_CHECKBUTTON_VARIABLE "" + +/* + * Defaults for entries: + */ + +#define DEF_ENTRY_BORDER_WIDTH "0" +#define DEF_ENTRY_JUSTIFY "left" +#define DEF_ENTRY_SCROLL_COMMAND "" +#define DEF_ENTRY_SHOW (char *) NULL +#define DEF_ENTRY_STATE "normal" +#define DEF_ENTRY_TAKE_FOCUS (char *) NULL +#define DEF_ENTRY_TEXT_VARIABLE "" +#define DEF_ENTRY_WIDTH "20" + +/* + * Defaults for frames: + */ + +#define DEF_FRAME_BORDER_WIDTH "0" +#define DEF_FRAME_CLASS "Frame" +#define DEF_FRAME_HEIGHT "0" +#define DEF_FRAME_TAKE_FOCUS "0" +#define DEF_FRAME_WIDTH "0" + +/* + * Defaults for listboxes: + */ + +#define DEF_LISTBOX_BORDER_WIDTH "1" +#define DEF_LISTBOX_HEIGHT "10" +#define DEF_LISTBOX_SCROLL_COMMAND "" +#define DEF_LISTBOX_SELECT_MODE "browse" +#define DEF_LISTBOX_TAKE_FOCUS (char *) NULL +#define DEF_LISTBOX_WIDTH "20" + +/* + * Defaults for individual entries of menus: + */ + +#define DEF_MENU_ENTRY_ACCELERATOR (char *) NULL +#define DEF_MENU_ENTRY_COMMAND (char *) NULL +#define DEF_MENU_ENTRY_INDICATOR "1" +#define DEF_MENU_ENTRY_LABEL (char *) NULL +#define DEF_MENU_ENTRY_MENU (char *) NULL +#define DEF_MENU_ENTRY_OFF_VALUE "0" +#define DEF_MENU_ENTRY_ON_VALUE "1" +#define DEF_MENU_ENTRY_STATE "normal" +#define DEF_MENU_ENTRY_VALUE (char *) NULL +#define DEF_MENU_ENTRY_CHECK_VARIABLE (char *) NULL +#define DEF_MENU_ENTRY_RADIO_VARIABLE "selectedButton" +#define DEF_MENU_ENTRY_UNDERLINE "-1" + +/* + * Defaults for menus overall: + */ + +#define DEF_MENU_BORDER_WIDTH "1" +#define DEF_MENU_POST_COMMAND "" +#define DEF_MENU_TAKE_FOCUS "0" +#define DEF_MENU_TEAROFF "0" + +/* + * Defaults for menubuttons: + */ + +#define DEF_MENUBUTTON_ANCHOR "center" +#define DEF_MENUBUTTON_BORDER_WIDTH "0" +#define DEF_MENUBUTTON_HEIGHT "-1" +#define DEF_MENUBUTTON_INDICATOR "0" +#define DEF_MENUBUTTON_JUSTIFY "center" +#define DEF_MENUBUTTON_MENU "" +#define DEF_MENUBUTTON_PADX "0" +#define DEF_MENUBUTTON_PADY "0" +#define DEF_MENUBUTTON_STATE "normal" +#define DEF_MENUBUTTON_TAKE_FOCUS (char *) NULL +#define DEF_MENUBUTTON_TEXT " " +#define DEF_MENUBUTTON_TEXT_VARIABLE "" +#define DEF_MENUBUTTON_UNDERLINE "-1" +#define DEF_MENUBUTTON_WIDTH "-1" +#define DEF_MENUBUTTON_WRAP_LENGTH "0" + +/* + * Defaults for scrollbars: + */ + +#define DEF_SCROLLBAR_BORDER_WIDTH "0" +#define DEF_SCROLLBAR_COMMAND "" +#define DEF_SCROLLBAR_ORIENT "vertical" +#define DEF_SCROLLBAR_TAKE_FOCUS "0" +#define DEF_SCROLLBAR_WIDTH "1" + +/* + * Defaults for texts: + */ + +#define DEF_TEXT_BORDER_WIDTH "1" +#define DEF_TEXT_HEIGHT "10" +#define DEF_TEXT_PADX "0" +#define DEF_TEXT_PADY "0" +#define DEF_TEXT_SPACING1 "0" +#define DEF_TEXT_SPACING2 "0" +#define DEF_TEXT_SPACING3 "0" +#define DEF_TEXT_STATE "normal" +#define DEF_TEXT_TABS "" +#define DEF_TEXT_TAKE_FOCUS (char *) NULL +#define DEF_TEXT_WIDTH "40" +#define DEF_TEXT_WRAP "char" +#define DEF_TEXT_XSCROLL_COMMAND "" +#define DEF_TEXT_YSCROLL_COMMAND "" + +/* + * Defaults for toplevels (most of the defaults for frames also apply + * to toplevels): + */ + +#define DEF_TOPLEVEL_BORDER_WIDTH "1" +#define DEF_TOPLEVEL_CLASS "Toplevel" +#define DEF_TOPLEVEL_SCREEN "" +#define DEF_TOPLEVEL_TITLE (char *) NULL + + +#endif /* _DEFAULT */ ADDED install-sh Index: install-sh ================================================================== --- install-sh +++ 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 ADDED interp_violation.out Index: interp_violation.out ================================================================== --- interp_violation.out +++ interp_violation.out @@ -0,0 +1,27 @@ +tkCmds.c: (char *) NULL) == TCL_OK && interp->result[0] != '\0') { +tkCmds.c: if (interp->result[1] == '\0') { +tkCmds.c: if (interp->result[0] == '1') { +tkCmds.c: } else if (interp->result[0] == '0') { +tkCmds.c: if (interp->result[0] == 'd' +tkCmds.c: && strcmp(interp->result, "disabled") == 0) goto nofocus; +tkCmds.c: if (strstr(interp->result, "Key")) goto focus; +tkCmds.c: if (strstr(interp->result, "Focus")) goto focus; +tkCmds.c: if (strstr(interp->result, "Key")) goto focus; +tkCmds.c: if (strstr(interp->result, "Focus")) goto focus; +tkEvent.c: char *errorMsg; /* The error message (interp->result when +tkEvent.c: errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(interp->result) +tkEvent.c: strcpy(errPtr->errorMsg, interp->result); +tkEvent.c: if (strcmp(interp->result, "\"tkerror\" is an invalid command name or ambiguous abbreviation") == 0) { +tkEvent.c: fprintf(stderr, " Error in tkerror: %s\n", interp->result); +tkFrame.c: placeArgv[1], interp->result); +tkMain.c: fprintf(stderr, "%s\n", interp->result); +tkMain.c: fprintf(stderr, "%s\n", interp->result); +tkMain.c: fprintf(stderr, "%s\n", interp->result); +tkMain.c: Tcl_Write(errChannel, interp->result, -1); +tkMain.c: Tcl_Write(errChannel, interp->result, -1); +tkMain.c: Tcl_Write(errChannel, interp->result, -1); +tkMain.c: if (*interp->result != 0) { +tkMain.c: puts(interp->result); +tkMain.c: fprintf(stderr, "%s\n", interp->result); +tkText.c: TkTextPrintIndex(&index1, interp->result); +tkText.c: TkTextPrintIndex(&index, interp->result); ADDED keyCodes.h Index: keyCodes.h ================================================================== --- keyCodes.h +++ keyCodes.h @@ -0,0 +1,150 @@ +/* + * keyCodes.h (CTk) -- + * + * This file defines the mapping from curses key codes to + * to X11 keysyms and modifier masks. + * + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Header: /usrs/andrewm/work/RCS/ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + + { 0001, 0x0061, ControlMask }, /* Control-A */ + { 0002, 0x0062, ControlMask }, /* Control-B */ + { 0003, 0x0063, ControlMask }, /* Control-C */ + { 0004, 0x0064, ControlMask }, /* Control-D */ + { 0005, 0x0065, ControlMask }, /* Control-E */ + { 0006, 0x0066, ControlMask }, /* Control-F */ + { 0007, 0x0067, ControlMask }, /* Control-G */ + { 0010, 0xFF08, 0 }, /* Backspace (Control-H) */ + { 0177, 0xFF08, 0 }, /* Backspace (Control-?) */ + { 0011, 0xFF09, 0 }, /* Tab (Control-I) */ + { 0012, 0x006A, ControlMask }, /* Control-J */ + { 0013, 0x006B, ControlMask }, /* Control-K */ + { 0014, 0x006C, ControlMask }, /* Control-L */ + { 0015, 0xFF0D, 0 }, /* Carriage Return (Control-M) */ + { 0016, 0x006E, ControlMask }, /* Control-N */ + { 0017, 0x006F, ControlMask }, /* Control-O */ + { 0020, 0x0070, ControlMask }, /* Control-P */ + { 0021, 0x0071, ControlMask }, /* Control-Q */ + { 0022, 0x0072, ControlMask }, /* Control-R */ + { 0023, 0x0073, ControlMask }, /* Control-S */ + { 0024, 0x0074, ControlMask }, /* Control-T */ + { 0025, 0x0075, ControlMask }, /* Control-U */ + { 0026, 0x0076, ControlMask }, /* Control-V */ + { 0027, 0x0077, ControlMask }, /* Control-W */ + { 0030, 0x0078, ControlMask }, /* Control-X */ + { 0031, 0x0079, ControlMask }, /* Control-Y */ + { 0032, 0x007A, ControlMask }, /* Control-Z */ + { 0033, 0xFF1B, 0 }, /* Escape (deprecated) */ +#ifdef KEY_BREAK + { KEY_BREAK, 0xFF6B, 0 }, /* Break key (unreliable) */ +#endif +#ifdef KEY_DOWN + { KEY_DOWN, 0xFF54, 0 }, /* Down */ +#endif +#ifdef KEY_UP + { KEY_UP, 0xFF52, 0 }, /* Up */ +#endif +#ifdef KEY_LEFT + { KEY_LEFT, 0xFF51, 0 }, /* Left */ +#endif +#ifdef KEY_RIGHT + { KEY_RIGHT, 0xFF53, 0 }, /* Right */ +#endif +#ifdef KEY_HOME + { KEY_HOME, 0xFF50, 0 }, /* Home key (upward+left arrow) */ +#endif +#ifdef KEY_BACKSPACE + { KEY_BACKSPACE, 0xFF08, 0 }, /* backspace (unreliable) */ +#endif +#ifdef KEY_F + { KEY_F(1), 0xFFBE, 0 }, /* F1 */ + { KEY_F(2), 0xFFBF, 0 }, /* F2 */ + { KEY_F(3), 0xFFC0, 0 }, /* F3 */ + { KEY_F(4), 0xFFC1, 0 }, /* F4 */ + { KEY_F(5), 0xFFC2, 0 }, /* F5 */ + { KEY_F(6), 0xFFC3, 0 }, /* F6 */ + { KEY_F(7), 0xFFC4, 0 }, /* F7 */ + { KEY_F(8), 0xFFC5, 0 }, /* F8 */ + { KEY_F(9), 0xFFC6, 0 }, /* F9 */ + { KEY_F(10), 0xFFC7, 0 }, /* F10 */ +#endif +#ifdef KEY_DL + { KEY_DL, 0xFFFF, ShiftMask }, /* Delete line */ +#endif +#ifdef KEY_IL + { KEY_IL, 0xFF63, ShiftMask }, /* Insert line */ +#endif +#ifdef KEY_DC + { KEY_DC, 0xFFFF, 0 }, /* Delete character */ +#endif +#ifdef KEY_IC + { KEY_IC, 0xFF63, 0 }, /* Insert character/mode */ +#endif +#ifdef KEY_EIC + { KEY_EIC, 0xFF63, 0 }, /* Exit insert mode */ +#endif +#ifdef KEY_CLEAR + { KEY_CLEAR, 0xFF0B, 0 }, /* Clear screen */ +#endif +#ifdef KEY_NPAGE + { KEY_NPAGE, 0xFF56, 0 }, /* Next page */ +#endif +#ifdef KEY_PPAGE + { KEY_PPAGE, 0xFF55, 0 }, /* Previous page */ +#endif +#ifdef KEY_ENTER + { KEY_ENTER, 0xFF8D, 0 }, /* Enter or send (unreliable) */ +#endif +#ifdef KEY_PRINT + { KEY_PRINT, 0xFF61, 0 }, /* Print or copy */ +#endif +#ifdef KEY_LL + { KEY_LL, 0xFF57, ControlMask }, /* home down or bottom (lower left) */ +#endif +#ifdef KEY_BTAB + { KEY_BTAB, 0xFF09, ShiftMask }, /* Back tab */ +#endif +#ifdef KEY_BEG + { KEY_BEG, 0xFF58, 0 }, /* beg(inning) key */ +#endif +#ifdef KEY_CANCEL + { KEY_CANCEL, 0xFF69, 0 }, /* cancel key */ +#endif +#ifdef KEY_COMMAND + { KEY_COMMAND, 0xFF62, 0 }, /* cmd (command) key */ +#endif +#ifdef KEY_END + { KEY_END, 0xFF57, 0 }, /* End key */ +#endif +#ifdef KEY_FIND + { KEY_FIND, 0xFF68, 0 }, /* Find key */ +#endif +#ifdef KEY_HELP + { KEY_HELP, 0xFF6A, 0 }, /* Help key */ +#endif +#ifdef KEY_NEXT + { KEY_NEXT, 0xFF09, 0 }, /* Next object key */ +#endif +#ifdef KEY_OPTIONS + { KEY_OPTIONS, 0xFF67, 0 }, /* Options key */ +#endif +#ifdef KEY_PREVIOUS + { KEY_PREVIOUS, 0xFF09, ShiftMask },/* Previous object key */ +#endif +#ifdef KEY_REDO + { KEY_REDO, 0xFF66, 0 }, /* Redo key */ +#endif +#ifdef KEY_SELECT + { KEY_SELECT, 0xFF60, 0 }, /* Select key */ +#endif +#ifdef KEY_SUSPEND + { KEY_SUSPEND, 0xFF13, 0 }, /* Suspend key */ +#endif +#ifdef KEY_UNDO + { KEY_UNDO, 0xFF65, 0 }, /* Undo key */ +#endif ADDED ks_names.h Index: ks_names.h ================================================================== --- ks_names.h +++ ks_names.h @@ -0,0 +1,917 @@ +/* + * This file is generated from $(INCLUDESRC)/keysymdef.h. Do not edit. + */ +{ "BackSpace", 0xFF08 }, +{ "Tab", 0xFF09 }, +{ "Linefeed", 0xFF0A }, +{ "Clear", 0xFF0B }, +{ "Return", 0xFF0D }, +{ "Pause", 0xFF13 }, +{ "Escape", 0xFF1B }, +{ "Delete", 0xFFFF }, +{ "Multi_key", 0xFF20 }, +{ "Kanji", 0xFF21 }, +{ "Home", 0xFF50 }, +{ "Left", 0xFF51 }, +{ "Up", 0xFF52 }, +{ "Right", 0xFF53 }, +{ "Down", 0xFF54 }, +{ "Prior", 0xFF55 }, +{ "Next", 0xFF56 }, +{ "End", 0xFF57 }, +{ "Begin", 0xFF58 }, +{ "Select", 0xFF60 }, +{ "Print", 0xFF61 }, +{ "Execute", 0xFF62 }, +{ "Insert", 0xFF63 }, +{ "Undo", 0xFF65 }, +{ "Redo", 0xFF66 }, +{ "Menu", 0xFF67 }, +{ "Find", 0xFF68 }, +{ "Cancel", 0xFF69 }, +{ "Help", 0xFF6A }, +{ "Break", 0xFF6B }, +{ "Mode_switch", 0xFF7E }, +{ "script_switch", 0xFF7E }, +{ "Num_Lock", 0xFF7F }, +{ "KP_Space", 0xFF80 }, +{ "KP_Tab", 0xFF89 }, +{ "KP_Enter", 0xFF8D }, +{ "KP_F1", 0xFF91 }, +{ "KP_F2", 0xFF92 }, +{ "KP_F3", 0xFF93 }, +{ "KP_F4", 0xFF94 }, +{ "KP_Equal", 0xFFBD }, +{ "KP_Multiply", 0xFFAA }, +{ "KP_Add", 0xFFAB }, +{ "KP_Separator", 0xFFAC }, +{ "KP_Subtract", 0xFFAD }, +{ "KP_Decimal", 0xFFAE }, +{ "KP_Divide", 0xFFAF }, +{ "KP_0", 0xFFB0 }, +{ "KP_1", 0xFFB1 }, +{ "KP_2", 0xFFB2 }, +{ "KP_3", 0xFFB3 }, +{ "KP_4", 0xFFB4 }, +{ "KP_5", 0xFFB5 }, +{ "KP_6", 0xFFB6 }, +{ "KP_7", 0xFFB7 }, +{ "KP_8", 0xFFB8 }, +{ "KP_9", 0xFFB9 }, +{ "F1", 0xFFBE }, +{ "F2", 0xFFBF }, +{ "F3", 0xFFC0 }, +{ "F4", 0xFFC1 }, +{ "F5", 0xFFC2 }, +{ "F6", 0xFFC3 }, +{ "F7", 0xFFC4 }, +{ "F8", 0xFFC5 }, +{ "F9", 0xFFC6 }, +{ "F10", 0xFFC7 }, +{ "F11", 0xFFC8 }, +{ "L1", 0xFFC8 }, +{ "F12", 0xFFC9 }, +{ "L2", 0xFFC9 }, +{ "F13", 0xFFCA }, +{ "L3", 0xFFCA }, +{ "F14", 0xFFCB }, +{ "L4", 0xFFCB }, +{ "F15", 0xFFCC }, +{ "L5", 0xFFCC }, +{ "F16", 0xFFCD }, +{ "L6", 0xFFCD }, +{ "F17", 0xFFCE }, +{ "L7", 0xFFCE }, +{ "F18", 0xFFCF }, +{ "L8", 0xFFCF }, +{ "F19", 0xFFD0 }, +{ "L9", 0xFFD0 }, +{ "F20", 0xFFD1 }, +{ "L10", 0xFFD1 }, +{ "F21", 0xFFD2 }, +{ "R1", 0xFFD2 }, +{ "F22", 0xFFD3 }, +{ "R2", 0xFFD3 }, +{ "F23", 0xFFD4 }, +{ "R3", 0xFFD4 }, +{ "F24", 0xFFD5 }, +{ "R4", 0xFFD5 }, +{ "F25", 0xFFD6 }, +{ "R5", 0xFFD6 }, +{ "F26", 0xFFD7 }, +{ "R6", 0xFFD7 }, +{ "F27", 0xFFD8 }, +{ "R7", 0xFFD8 }, +{ "F28", 0xFFD9 }, +{ "R8", 0xFFD9 }, +{ "F29", 0xFFDA }, +{ "R9", 0xFFDA }, +{ "F30", 0xFFDB }, +{ "R10", 0xFFDB }, +{ "F31", 0xFFDC }, +{ "R11", 0xFFDC }, +{ "F32", 0xFFDD }, +{ "R12", 0xFFDD }, +{ "R13", 0xFFDE }, +{ "F33", 0xFFDE }, +{ "F34", 0xFFDF }, +{ "R14", 0xFFDF }, +{ "F35", 0xFFE0 }, +{ "R15", 0xFFE0 }, +{ "Shift_L", 0xFFE1 }, +{ "Shift_R", 0xFFE2 }, +{ "Control_L", 0xFFE3 }, +{ "Control_R", 0xFFE4 }, +{ "Caps_Lock", 0xFFE5 }, +{ "Shift_Lock", 0xFFE6 }, +{ "Meta_L", 0xFFE7 }, +{ "Meta_R", 0xFFE8 }, +{ "Alt_L", 0xFFE9 }, +{ "Alt_R", 0xFFEA }, +{ "Super_L", 0xFFEB }, +{ "Super_R", 0xFFEC }, +{ "Hyper_L", 0xFFED }, +{ "Hyper_R", 0xFFEE }, +{ "space", 0x020 }, +{ "exclam", 0x021 }, +{ "quotedbl", 0x022 }, +{ "numbersign", 0x023 }, +{ "dollar", 0x024 }, +{ "percent", 0x025 }, +{ "ampersand", 0x026 }, +{ "quoteright", 0x027 }, +{ "parenleft", 0x028 }, +{ "parenright", 0x029 }, +{ "asterisk", 0x02a }, +{ "plus", 0x02b }, +{ "comma", 0x02c }, +{ "minus", 0x02d }, +{ "period", 0x02e }, +{ "slash", 0x02f }, +{ "0", 0x030 }, +{ "1", 0x031 }, +{ "2", 0x032 }, +{ "3", 0x033 }, +{ "4", 0x034 }, +{ "5", 0x035 }, +{ "6", 0x036 }, +{ "7", 0x037 }, +{ "8", 0x038 }, +{ "9", 0x039 }, +{ "colon", 0x03a }, +{ "semicolon", 0x03b }, +{ "less", 0x03c }, +{ "equal", 0x03d }, +{ "greater", 0x03e }, +{ "question", 0x03f }, +{ "at", 0x040 }, +{ "A", 0x041 }, +{ "B", 0x042 }, +{ "C", 0x043 }, +{ "D", 0x044 }, +{ "E", 0x045 }, +{ "F", 0x046 }, +{ "G", 0x047 }, +{ "H", 0x048 }, +{ "I", 0x049 }, +{ "J", 0x04a }, +{ "K", 0x04b }, +{ "L", 0x04c }, +{ "M", 0x04d }, +{ "N", 0x04e }, +{ "O", 0x04f }, +{ "P", 0x050 }, +{ "Q", 0x051 }, +{ "R", 0x052 }, +{ "S", 0x053 }, +{ "T", 0x054 }, +{ "U", 0x055 }, +{ "V", 0x056 }, +{ "W", 0x057 }, +{ "X", 0x058 }, +{ "Y", 0x059 }, +{ "Z", 0x05a }, +{ "bracketleft", 0x05b }, +{ "backslash", 0x05c }, +{ "bracketright", 0x05d }, +{ "asciicircum", 0x05e }, +{ "underscore", 0x05f }, +{ "quoteleft", 0x060 }, +{ "a", 0x061 }, +{ "b", 0x062 }, +{ "c", 0x063 }, +{ "d", 0x064 }, +{ "e", 0x065 }, +{ "f", 0x066 }, +{ "g", 0x067 }, +{ "h", 0x068 }, +{ "i", 0x069 }, +{ "j", 0x06a }, +{ "k", 0x06b }, +{ "l", 0x06c }, +{ "m", 0x06d }, +{ "n", 0x06e }, +{ "o", 0x06f }, +{ "p", 0x070 }, +{ "q", 0x071 }, +{ "r", 0x072 }, +{ "s", 0x073 }, +{ "t", 0x074 }, +{ "u", 0x075 }, +{ "v", 0x076 }, +{ "w", 0x077 }, +{ "x", 0x078 }, +{ "y", 0x079 }, +{ "z", 0x07a }, +{ "braceleft", 0x07b }, +{ "bar", 0x07c }, +{ "braceright", 0x07d }, +{ "asciitilde", 0x07e }, +{ "nobreakspace", 0x0a0 }, +{ "exclamdown", 0x0a1 }, +{ "cent", 0x0a2 }, +{ "sterling", 0x0a3 }, +{ "currency", 0x0a4 }, +{ "yen", 0x0a5 }, +{ "brokenbar", 0x0a6 }, +{ "section", 0x0a7 }, +{ "diaeresis", 0x0a8 }, +{ "copyright", 0x0a9 }, +{ "ordfeminine", 0x0aa }, +{ "guillemotleft", 0x0ab }, +{ "notsign", 0x0ac }, +{ "hyphen", 0x0ad }, +{ "registered", 0x0ae }, +{ "macron", 0x0af }, +{ "degree", 0x0b0 }, +{ "plusminus", 0x0b1 }, +{ "twosuperior", 0x0b2 }, +{ "threesuperior", 0x0b3 }, +{ "acute", 0x0b4 }, +{ "mu", 0x0b5 }, +{ "paragraph", 0x0b6 }, +{ "periodcentered", 0x0b7 }, +{ "cedilla", 0x0b8 }, +{ "onesuperior", 0x0b9 }, +{ "masculine", 0x0ba }, +{ "guillemotright", 0x0bb }, +{ "onequarter", 0x0bc }, +{ "onehalf", 0x0bd }, +{ "threequarters", 0x0be }, +{ "questiondown", 0x0bf }, +{ "Agrave", 0x0c0 }, +{ "Aacute", 0x0c1 }, +{ "Acircumflex", 0x0c2 }, +{ "Atilde", 0x0c3 }, +{ "Adiaeresis", 0x0c4 }, +{ "Aring", 0x0c5 }, +{ "AE", 0x0c6 }, +{ "Ccedilla", 0x0c7 }, +{ "Egrave", 0x0c8 }, +{ "Eacute", 0x0c9 }, +{ "Ecircumflex", 0x0ca }, +{ "Ediaeresis", 0x0cb }, +{ "Igrave", 0x0cc }, +{ "Iacute", 0x0cd }, +{ "Icircumflex", 0x0ce }, +{ "Idiaeresis", 0x0cf }, +{ "Eth", 0x0d0 }, +{ "Ntilde", 0x0d1 }, +{ "Ograve", 0x0d2 }, +{ "Oacute", 0x0d3 }, +{ "Ocircumflex", 0x0d4 }, +{ "Otilde", 0x0d5 }, +{ "Odiaeresis", 0x0d6 }, +{ "multiply", 0x0d7 }, +{ "Ooblique", 0x0d8 }, +{ "Ugrave", 0x0d9 }, +{ "Uacute", 0x0da }, +{ "Ucircumflex", 0x0db }, +{ "Udiaeresis", 0x0dc }, +{ "Yacute", 0x0dd }, +{ "Thorn", 0x0de }, +{ "ssharp", 0x0df }, +{ "agrave", 0x0e0 }, +{ "aacute", 0x0e1 }, +{ "acircumflex", 0x0e2 }, +{ "atilde", 0x0e3 }, +{ "adiaeresis", 0x0e4 }, +{ "aring", 0x0e5 }, +{ "ae", 0x0e6 }, +{ "ccedilla", 0x0e7 }, +{ "egrave", 0x0e8 }, +{ "eacute", 0x0e9 }, +{ "ecircumflex", 0x0ea }, +{ "ediaeresis", 0x0eb }, +{ "igrave", 0x0ec }, +{ "iacute", 0x0ed }, +{ "icircumflex", 0x0ee }, +{ "idiaeresis", 0x0ef }, +{ "eth", 0x0f0 }, +{ "ntilde", 0x0f1 }, +{ "ograve", 0x0f2 }, +{ "oacute", 0x0f3 }, +{ "ocircumflex", 0x0f4 }, +{ "otilde", 0x0f5 }, +{ "odiaeresis", 0x0f6 }, +{ "division", 0x0f7 }, +{ "oslash", 0x0f8 }, +{ "ugrave", 0x0f9 }, +{ "uacute", 0x0fa }, +{ "ucircumflex", 0x0fb }, +{ "udiaeresis", 0x0fc }, +{ "yacute", 0x0fd }, +{ "thorn", 0x0fe }, +{ "ydiaeresis", 0x0ff }, +{ "Aogonek", 0x1a1 }, +{ "breve", 0x1a2 }, +{ "Lstroke", 0x1a3 }, +{ "Lcaron", 0x1a5 }, +{ "Sacute", 0x1a6 }, +{ "Scaron", 0x1a9 }, +{ "Scedilla", 0x1aa }, +{ "Tcaron", 0x1ab }, +{ "Zacute", 0x1ac }, +{ "Zcaron", 0x1ae }, +{ "Zabovedot", 0x1af }, +{ "aogonek", 0x1b1 }, +{ "ogonek", 0x1b2 }, +{ "lstroke", 0x1b3 }, +{ "lcaron", 0x1b5 }, +{ "sacute", 0x1b6 }, +{ "caron", 0x1b7 }, +{ "scaron", 0x1b9 }, +{ "scedilla", 0x1ba }, +{ "tcaron", 0x1bb }, +{ "zacute", 0x1bc }, +{ "doubleacute", 0x1bd }, +{ "zcaron", 0x1be }, +{ "zabovedot", 0x1bf }, +{ "Racute", 0x1c0 }, +{ "Abreve", 0x1c3 }, +{ "Cacute", 0x1c6 }, +{ "Ccaron", 0x1c8 }, +{ "Eogonek", 0x1ca }, +{ "Ecaron", 0x1cc }, +{ "Dcaron", 0x1cf }, +{ "Nacute", 0x1d1 }, +{ "Ncaron", 0x1d2 }, +{ "Odoubleacute", 0x1d5 }, +{ "Rcaron", 0x1d8 }, +{ "Uring", 0x1d9 }, +{ "Udoubleacute", 0x1db }, +{ "Tcedilla", 0x1de }, +{ "racute", 0x1e0 }, +{ "abreve", 0x1e3 }, +{ "cacute", 0x1e6 }, +{ "ccaron", 0x1e8 }, +{ "eogonek", 0x1ea }, +{ "ecaron", 0x1ec }, +{ "dcaron", 0x1ef }, +{ "nacute", 0x1f1 }, +{ "ncaron", 0x1f2 }, +{ "odoubleacute", 0x1f5 }, +{ "udoubleacute", 0x1fb }, +{ "rcaron", 0x1f8 }, +{ "uring", 0x1f9 }, +{ "tcedilla", 0x1fe }, +{ "abovedot", 0x1ff }, +{ "Hstroke", 0x2a1 }, +{ "Hcircumflex", 0x2a6 }, +{ "Iabovedot", 0x2a9 }, +{ "Gbreve", 0x2ab }, +{ "Jcircumflex", 0x2ac }, +{ "hstroke", 0x2b1 }, +{ "hcircumflex", 0x2b6 }, +{ "idotless", 0x2b9 }, +{ "gbreve", 0x2bb }, +{ "jcircumflex", 0x2bc }, +{ "Cabovedot", 0x2c5 }, +{ "Ccircumflex", 0x2c6 }, +{ "Gabovedot", 0x2d5 }, +{ "Gcircumflex", 0x2d8 }, +{ "Ubreve", 0x2dd }, +{ "Scircumflex", 0x2de }, +{ "cabovedot", 0x2e5 }, +{ "ccircumflex", 0x2e6 }, +{ "gabovedot", 0x2f5 }, +{ "gcircumflex", 0x2f8 }, +{ "ubreve", 0x2fd }, +{ "scircumflex", 0x2fe }, +{ "kappa", 0x3a2 }, +{ "Rcedilla", 0x3a3 }, +{ "Itilde", 0x3a5 }, +{ "Lcedilla", 0x3a6 }, +{ "Emacron", 0x3aa }, +{ "Gcedilla", 0x3ab }, +{ "Tslash", 0x3ac }, +{ "rcedilla", 0x3b3 }, +{ "itilde", 0x3b5 }, +{ "lcedilla", 0x3b6 }, +{ "emacron", 0x3ba }, +{ "gacute", 0x3bb }, +{ "tslash", 0x3bc }, +{ "ENG", 0x3bd }, +{ "eng", 0x3bf }, +{ "Amacron", 0x3c0 }, +{ "Iogonek", 0x3c7 }, +{ "Eabovedot", 0x3cc }, +{ "Imacron", 0x3cf }, +{ "Ncedilla", 0x3d1 }, +{ "Omacron", 0x3d2 }, +{ "Kcedilla", 0x3d3 }, +{ "Uogonek", 0x3d9 }, +{ "Utilde", 0x3dd }, +{ "Umacron", 0x3de }, +{ "amacron", 0x3e0 }, +{ "iogonek", 0x3e7 }, +{ "eabovedot", 0x3ec }, +{ "imacron", 0x3ef }, +{ "ncedilla", 0x3f1 }, +{ "omacron", 0x3f2 }, +{ "kcedilla", 0x3f3 }, +{ "uogonek", 0x3f9 }, +{ "utilde", 0x3fd }, +{ "umacron", 0x3fe }, +{ "overline", 0x47e }, +{ "kana_fullstop", 0x4a1 }, +{ "kana_openingbracket", 0x4a2 }, +{ "kana_closingbracket", 0x4a3 }, +{ "kana_comma", 0x4a4 }, +{ "kana_middledot", 0x4a5 }, +{ "kana_WO", 0x4a6 }, +{ "kana_a", 0x4a7 }, +{ "kana_i", 0x4a8 }, +{ "kana_u", 0x4a9 }, +{ "kana_e", 0x4aa }, +{ "kana_o", 0x4ab }, +{ "kana_ya", 0x4ac }, +{ "kana_yu", 0x4ad }, +{ "kana_yo", 0x4ae }, +{ "kana_tu", 0x4af }, +{ "prolongedsound", 0x4b0 }, +{ "kana_A", 0x4b1 }, +{ "kana_I", 0x4b2 }, +{ "kana_U", 0x4b3 }, +{ "kana_E", 0x4b4 }, +{ "kana_O", 0x4b5 }, +{ "kana_KA", 0x4b6 }, +{ "kana_KI", 0x4b7 }, +{ "kana_KU", 0x4b8 }, +{ "kana_KE", 0x4b9 }, +{ "kana_KO", 0x4ba }, +{ "kana_SA", 0x4bb }, +{ "kana_SHI", 0x4bc }, +{ "kana_SU", 0x4bd }, +{ "kana_SE", 0x4be }, +{ "kana_SO", 0x4bf }, +{ "kana_TA", 0x4c0 }, +{ "kana_TI", 0x4c1 }, +{ "kana_TU", 0x4c2 }, +{ "kana_TE", 0x4c3 }, +{ "kana_TO", 0x4c4 }, +{ "kana_NA", 0x4c5 }, +{ "kana_NI", 0x4c6 }, +{ "kana_NU", 0x4c7 }, +{ "kana_NE", 0x4c8 }, +{ "kana_NO", 0x4c9 }, +{ "kana_HA", 0x4ca }, +{ "kana_HI", 0x4cb }, +{ "kana_HU", 0x4cc }, +{ "kana_HE", 0x4cd }, +{ "kana_HO", 0x4ce }, +{ "kana_MA", 0x4cf }, +{ "kana_MI", 0x4d0 }, +{ "kana_MU", 0x4d1 }, +{ "kana_ME", 0x4d2 }, +{ "kana_MO", 0x4d3 }, +{ "kana_YA", 0x4d4 }, +{ "kana_YU", 0x4d5 }, +{ "kana_YO", 0x4d6 }, +{ "kana_RA", 0x4d7 }, +{ "kana_RI", 0x4d8 }, +{ "kana_RU", 0x4d9 }, +{ "kana_RE", 0x4da }, +{ "kana_RO", 0x4db }, +{ "kana_WA", 0x4dc }, +{ "kana_N", 0x4dd }, +{ "voicedsound", 0x4de }, +{ "semivoicedsound", 0x4df }, +{ "kana_switch", 0xFF7E }, +{ "Arabic_comma", 0x5ac }, +{ "Arabic_semicolon", 0x5bb }, +{ "Arabic_question_mark", 0x5bf }, +{ "Arabic_hamza", 0x5c1 }, +{ "Arabic_maddaonalef", 0x5c2 }, +{ "Arabic_hamzaonalef", 0x5c3 }, +{ "Arabic_hamzaonwaw", 0x5c4 }, +{ "Arabic_hamzaunderalef", 0x5c5 }, +{ "Arabic_hamzaonyeh", 0x5c6 }, +{ "Arabic_alef", 0x5c7 }, +{ "Arabic_beh", 0x5c8 }, +{ "Arabic_tehmarbuta", 0x5c9 }, +{ "Arabic_teh", 0x5ca }, +{ "Arabic_theh", 0x5cb }, +{ "Arabic_jeem", 0x5cc }, +{ "Arabic_hah", 0x5cd }, +{ "Arabic_khah", 0x5ce }, +{ "Arabic_dal", 0x5cf }, +{ "Arabic_thal", 0x5d0 }, +{ "Arabic_ra", 0x5d1 }, +{ "Arabic_zain", 0x5d2 }, +{ "Arabic_seen", 0x5d3 }, +{ "Arabic_sheen", 0x5d4 }, +{ "Arabic_sad", 0x5d5 }, +{ "Arabic_dad", 0x5d6 }, +{ "Arabic_tah", 0x5d7 }, +{ "Arabic_zah", 0x5d8 }, +{ "Arabic_ain", 0x5d9 }, +{ "Arabic_ghain", 0x5da }, +{ "Arabic_tatweel", 0x5e0 }, +{ "Arabic_feh", 0x5e1 }, +{ "Arabic_qaf", 0x5e2 }, +{ "Arabic_kaf", 0x5e3 }, +{ "Arabic_lam", 0x5e4 }, +{ "Arabic_meem", 0x5e5 }, +{ "Arabic_noon", 0x5e6 }, +{ "Arabic_heh", 0x5e7 }, +{ "Arabic_waw", 0x5e8 }, +{ "Arabic_alefmaksura", 0x5e9 }, +{ "Arabic_yeh", 0x5ea }, +{ "Arabic_fathatan", 0x5eb }, +{ "Arabic_dammatan", 0x5ec }, +{ "Arabic_kasratan", 0x5ed }, +{ "Arabic_fatha", 0x5ee }, +{ "Arabic_damma", 0x5ef }, +{ "Arabic_kasra", 0x5f0 }, +{ "Arabic_shadda", 0x5f1 }, +{ "Arabic_sukun", 0x5f2 }, +{ "Arabic_switch", 0xFF7E }, +{ "Serbian_dje", 0x6a1 }, +{ "Macedonia_gje", 0x6a2 }, +{ "Cyrillic_io", 0x6a3 }, +{ "Ukranian_je", 0x6a4 }, +{ "Macedonia_dse", 0x6a5 }, +{ "Ukranian_i", 0x6a6 }, +{ "Ukranian_yi", 0x6a7 }, +{ "Serbian_je", 0x6a8 }, +{ "Serbian_lje", 0x6a9 }, +{ "Serbian_nje", 0x6aa }, +{ "Serbian_tshe", 0x6ab }, +{ "Macedonia_kje", 0x6ac }, +{ "Byelorussian_shortu", 0x6ae }, +{ "Serbian_dze", 0x6af }, +{ "numerosign", 0x6b0 }, +{ "Serbian_DJE", 0x6b1 }, +{ "Macedonia_GJE", 0x6b2 }, +{ "Cyrillic_IO", 0x6b3 }, +{ "Ukranian_JE", 0x6b4 }, +{ "Macedonia_DSE", 0x6b5 }, +{ "Ukranian_I", 0x6b6 }, +{ "Ukranian_YI", 0x6b7 }, +{ "Serbian_JE", 0x6b8 }, +{ "Serbian_LJE", 0x6b9 }, +{ "Serbian_NJE", 0x6ba }, +{ "Serbian_TSHE", 0x6bb }, +{ "Macedonia_KJE", 0x6bc }, +{ "Byelorussian_SHORTU", 0x6be }, +{ "Serbian_DZE", 0x6bf }, +{ "Cyrillic_yu", 0x6c0 }, +{ "Cyrillic_a", 0x6c1 }, +{ "Cyrillic_be", 0x6c2 }, +{ "Cyrillic_tse", 0x6c3 }, +{ "Cyrillic_de", 0x6c4 }, +{ "Cyrillic_ie", 0x6c5 }, +{ "Cyrillic_ef", 0x6c6 }, +{ "Cyrillic_ghe", 0x6c7 }, +{ "Cyrillic_ha", 0x6c8 }, +{ "Cyrillic_i", 0x6c9 }, +{ "Cyrillic_shorti", 0x6ca }, +{ "Cyrillic_ka", 0x6cb }, +{ "Cyrillic_el", 0x6cc }, +{ "Cyrillic_em", 0x6cd }, +{ "Cyrillic_en", 0x6ce }, +{ "Cyrillic_o", 0x6cf }, +{ "Cyrillic_pe", 0x6d0 }, +{ "Cyrillic_ya", 0x6d1 }, +{ "Cyrillic_er", 0x6d2 }, +{ "Cyrillic_es", 0x6d3 }, +{ "Cyrillic_te", 0x6d4 }, +{ "Cyrillic_u", 0x6d5 }, +{ "Cyrillic_zhe", 0x6d6 }, +{ "Cyrillic_ve", 0x6d7 }, +{ "Cyrillic_softsign", 0x6d8 }, +{ "Cyrillic_yeru", 0x6d9 }, +{ "Cyrillic_ze", 0x6da }, +{ "Cyrillic_sha", 0x6db }, +{ "Cyrillic_e", 0x6dc }, +{ "Cyrillic_shcha", 0x6dd }, +{ "Cyrillic_che", 0x6de }, +{ "Cyrillic_hardsign", 0x6df }, +{ "Cyrillic_YU", 0x6e0 }, +{ "Cyrillic_A", 0x6e1 }, +{ "Cyrillic_BE", 0x6e2 }, +{ "Cyrillic_TSE", 0x6e3 }, +{ "Cyrillic_DE", 0x6e4 }, +{ "Cyrillic_IE", 0x6e5 }, +{ "Cyrillic_EF", 0x6e6 }, +{ "Cyrillic_GHE", 0x6e7 }, +{ "Cyrillic_HA", 0x6e8 }, +{ "Cyrillic_I", 0x6e9 }, +{ "Cyrillic_SHORTI", 0x6ea }, +{ "Cyrillic_KA", 0x6eb }, +{ "Cyrillic_EL", 0x6ec }, +{ "Cyrillic_EM", 0x6ed }, +{ "Cyrillic_EN", 0x6ee }, +{ "Cyrillic_O", 0x6ef }, +{ "Cyrillic_PE", 0x6f0 }, +{ "Cyrillic_YA", 0x6f1 }, +{ "Cyrillic_ER", 0x6f2 }, +{ "Cyrillic_ES", 0x6f3 }, +{ "Cyrillic_TE", 0x6f4 }, +{ "Cyrillic_U", 0x6f5 }, +{ "Cyrillic_ZHE", 0x6f6 }, +{ "Cyrillic_VE", 0x6f7 }, +{ "Cyrillic_SOFTSIGN", 0x6f8 }, +{ "Cyrillic_YERU", 0x6f9 }, +{ "Cyrillic_ZE", 0x6fa }, +{ "Cyrillic_SHA", 0x6fb }, +{ "Cyrillic_E", 0x6fc }, +{ "Cyrillic_SHCHA", 0x6fd }, +{ "Cyrillic_CHE", 0x6fe }, +{ "Cyrillic_HARDSIGN", 0x6ff }, +{ "Greek_ALPHAaccent", 0x7a1 }, +{ "Greek_EPSILONaccent", 0x7a2 }, +{ "Greek_ETAaccent", 0x7a3 }, +{ "Greek_IOTAaccent", 0x7a4 }, +{ "Greek_IOTAdiaeresis", 0x7a5 }, +{ "Greek_IOTAaccentdiaeresis", 0x7a6 }, +{ "Greek_OMICRONaccent", 0x7a7 }, +{ "Greek_UPSILONaccent", 0x7a8 }, +{ "Greek_UPSILONdieresis", 0x7a9 }, +{ "Greek_UPSILONaccentdieresis", 0x7aa }, +{ "Greek_OMEGAaccent", 0x7ab }, +{ "Greek_alphaaccent", 0x7b1 }, +{ "Greek_epsilonaccent", 0x7b2 }, +{ "Greek_etaaccent", 0x7b3 }, +{ "Greek_iotaaccent", 0x7b4 }, +{ "Greek_iotadieresis", 0x7b5 }, +{ "Greek_iotaaccentdieresis", 0x7b6 }, +{ "Greek_omicronaccent", 0x7b7 }, +{ "Greek_upsilonaccent", 0x7b8 }, +{ "Greek_upsilondieresis", 0x7b9 }, +{ "Greek_upsilonaccentdieresis", 0x7ba }, +{ "Greek_omegaaccent", 0x7bb }, +{ "Greek_ALPHA", 0x7c1 }, +{ "Greek_BETA", 0x7c2 }, +{ "Greek_GAMMA", 0x7c3 }, +{ "Greek_DELTA", 0x7c4 }, +{ "Greek_EPSILON", 0x7c5 }, +{ "Greek_ZETA", 0x7c6 }, +{ "Greek_ETA", 0x7c7 }, +{ "Greek_THETA", 0x7c8 }, +{ "Greek_IOTA", 0x7c9 }, +{ "Greek_KAPPA", 0x7ca }, +{ "Greek_LAMBDA", 0x7cb }, +{ "Greek_MU", 0x7cc }, +{ "Greek_NU", 0x7cd }, +{ "Greek_XI", 0x7ce }, +{ "Greek_OMICRON", 0x7cf }, +{ "Greek_PI", 0x7d0 }, +{ "Greek_RHO", 0x7d1 }, +{ "Greek_SIGMA", 0x7d2 }, +{ "Greek_TAU", 0x7d4 }, +{ "Greek_UPSILON", 0x7d5 }, +{ "Greek_PHI", 0x7d6 }, +{ "Greek_CHI", 0x7d7 }, +{ "Greek_PSI", 0x7d8 }, +{ "Greek_OMEGA", 0x7d9 }, +{ "Greek_alpha", 0x7e1 }, +{ "Greek_beta", 0x7e2 }, +{ "Greek_gamma", 0x7e3 }, +{ "Greek_delta", 0x7e4 }, +{ "Greek_epsilon", 0x7e5 }, +{ "Greek_zeta", 0x7e6 }, +{ "Greek_eta", 0x7e7 }, +{ "Greek_theta", 0x7e8 }, +{ "Greek_iota", 0x7e9 }, +{ "Greek_kappa", 0x7ea }, +{ "Greek_lambda", 0x7eb }, +{ "Greek_mu", 0x7ec }, +{ "Greek_nu", 0x7ed }, +{ "Greek_xi", 0x7ee }, +{ "Greek_omicron", 0x7ef }, +{ "Greek_pi", 0x7f0 }, +{ "Greek_rho", 0x7f1 }, +{ "Greek_sigma", 0x7f2 }, +{ "Greek_finalsmallsigma", 0x7f3 }, +{ "Greek_tau", 0x7f4 }, +{ "Greek_upsilon", 0x7f5 }, +{ "Greek_phi", 0x7f6 }, +{ "Greek_chi", 0x7f7 }, +{ "Greek_psi", 0x7f8 }, +{ "Greek_omega", 0x7f9 }, +{ "Greek_switch", 0xFF7E }, +{ "leftradical", 0x8a1 }, +{ "topleftradical", 0x8a2 }, +{ "horizconnector", 0x8a3 }, +{ "topintegral", 0x8a4 }, +{ "botintegral", 0x8a5 }, +{ "vertconnector", 0x8a6 }, +{ "topleftsqbracket", 0x8a7 }, +{ "botleftsqbracket", 0x8a8 }, +{ "toprightsqbracket", 0x8a9 }, +{ "botrightsqbracket", 0x8aa }, +{ "topleftparens", 0x8ab }, +{ "botleftparens", 0x8ac }, +{ "toprightparens", 0x8ad }, +{ "botrightparens", 0x8ae }, +{ "leftmiddlecurlybrace", 0x8af }, +{ "rightmiddlecurlybrace", 0x8b0 }, +{ "topleftsummation", 0x8b1 }, +{ "botleftsummation", 0x8b2 }, +{ "topvertsummationconnector", 0x8b3 }, +{ "botvertsummationconnector", 0x8b4 }, +{ "toprightsummation", 0x8b5 }, +{ "botrightsummation", 0x8b6 }, +{ "rightmiddlesummation", 0x8b7 }, +{ "lessthanequal", 0x8bc }, +{ "notequal", 0x8bd }, +{ "greaterthanequal", 0x8be }, +{ "integral", 0x8bf }, +{ "therefore", 0x8c0 }, +{ "variation", 0x8c1 }, +{ "infinity", 0x8c2 }, +{ "nabla", 0x8c5 }, +{ "approximate", 0x8c8 }, +{ "similarequal", 0x8c9 }, +{ "ifonlyif", 0x8cd }, +{ "implies", 0x8ce }, +{ "identical", 0x8cf }, +{ "radical", 0x8d6 }, +{ "includedin", 0x8da }, +{ "includes", 0x8db }, +{ "intersection", 0x8dc }, +{ "union", 0x8dd }, +{ "logicaland", 0x8de }, +{ "logicalor", 0x8df }, +{ "partialderivative", 0x8ef }, +{ "function", 0x8f6 }, +{ "leftarrow", 0x8fb }, +{ "uparrow", 0x8fc }, +{ "rightarrow", 0x8fd }, +{ "downarrow", 0x8fe }, +{ "blank", 0x9df }, +{ "soliddiamond", 0x9e0 }, +{ "checkerboard", 0x9e1 }, +{ "ht", 0x9e2 }, +{ "ff", 0x9e3 }, +{ "cr", 0x9e4 }, +{ "lf", 0x9e5 }, +{ "nl", 0x9e8 }, +{ "vt", 0x9e9 }, +{ "lowrightcorner", 0x9ea }, +{ "uprightcorner", 0x9eb }, +{ "upleftcorner", 0x9ec }, +{ "lowleftcorner", 0x9ed }, +{ "crossinglines", 0x9ee }, +{ "horizlinescan1", 0x9ef }, +{ "horizlinescan3", 0x9f0 }, +{ "horizlinescan5", 0x9f1 }, +{ "horizlinescan7", 0x9f2 }, +{ "horizlinescan9", 0x9f3 }, +{ "leftt", 0x9f4 }, +{ "rightt", 0x9f5 }, +{ "bott", 0x9f6 }, +{ "topt", 0x9f7 }, +{ "vertbar", 0x9f8 }, +{ "emspace", 0xaa1 }, +{ "enspace", 0xaa2 }, +{ "em3space", 0xaa3 }, +{ "em4space", 0xaa4 }, +{ "digitspace", 0xaa5 }, +{ "punctspace", 0xaa6 }, +{ "thinspace", 0xaa7 }, +{ "hairspace", 0xaa8 }, +{ "emdash", 0xaa9 }, +{ "endash", 0xaaa }, +{ "signifblank", 0xaac }, +{ "ellipsis", 0xaae }, +{ "doubbaselinedot", 0xaaf }, +{ "onethird", 0xab0 }, +{ "twothirds", 0xab1 }, +{ "onefifth", 0xab2 }, +{ "twofifths", 0xab3 }, +{ "threefifths", 0xab4 }, +{ "fourfifths", 0xab5 }, +{ "onesixth", 0xab6 }, +{ "fivesixths", 0xab7 }, +{ "careof", 0xab8 }, +{ "figdash", 0xabb }, +{ "leftanglebracket", 0xabc }, +{ "decimalpoint", 0xabd }, +{ "rightanglebracket", 0xabe }, +{ "marker", 0xabf }, +{ "oneeighth", 0xac3 }, +{ "threeeighths", 0xac4 }, +{ "fiveeighths", 0xac5 }, +{ "seveneighths", 0xac6 }, +{ "trademark", 0xac9 }, +{ "signaturemark", 0xaca }, +{ "trademarkincircle", 0xacb }, +{ "leftopentriangle", 0xacc }, +{ "rightopentriangle", 0xacd }, +{ "emopencircle", 0xace }, +{ "emopenrectangle", 0xacf }, +{ "leftsinglequotemark", 0xad0 }, +{ "rightsinglequotemark", 0xad1 }, +{ "leftdoublequotemark", 0xad2 }, +{ "rightdoublequotemark", 0xad3 }, +{ "prescription", 0xad4 }, +{ "minutes", 0xad6 }, +{ "seconds", 0xad7 }, +{ "latincross", 0xad9 }, +{ "hexagram", 0xada }, +{ "filledrectbullet", 0xadb }, +{ "filledlefttribullet", 0xadc }, +{ "filledrighttribullet", 0xadd }, +{ "emfilledcircle", 0xade }, +{ "emfilledrect", 0xadf }, +{ "enopencircbullet", 0xae0 }, +{ "enopensquarebullet", 0xae1 }, +{ "openrectbullet", 0xae2 }, +{ "opentribulletup", 0xae3 }, +{ "opentribulletdown", 0xae4 }, +{ "openstar", 0xae5 }, +{ "enfilledcircbullet", 0xae6 }, +{ "enfilledsqbullet", 0xae7 }, +{ "filledtribulletup", 0xae8 }, +{ "filledtribulletdown", 0xae9 }, +{ "leftpointer", 0xaea }, +{ "rightpointer", 0xaeb }, +{ "club", 0xaec }, +{ "diamond", 0xaed }, +{ "heart", 0xaee }, +{ "maltesecross", 0xaf0 }, +{ "dagger", 0xaf1 }, +{ "doubledagger", 0xaf2 }, +{ "checkmark", 0xaf3 }, +{ "ballotcross", 0xaf4 }, +{ "musicalsharp", 0xaf5 }, +{ "musicalflat", 0xaf6 }, +{ "malesymbol", 0xaf7 }, +{ "femalesymbol", 0xaf8 }, +{ "telephone", 0xaf9 }, +{ "telephonerecorder", 0xafa }, +{ "phonographcopyright", 0xafb }, +{ "caret", 0xafc }, +{ "singlelowquotemark", 0xafd }, +{ "doublelowquotemark", 0xafe }, +{ "cursor", 0xaff }, +{ "leftcaret", 0xba3 }, +{ "rightcaret", 0xba6 }, +{ "downcaret", 0xba8 }, +{ "upcaret", 0xba9 }, +{ "overbar", 0xbc0 }, +{ "downtack", 0xbc2 }, +{ "upshoe", 0xbc3 }, +{ "downstile", 0xbc4 }, +{ "underbar", 0xbc6 }, +{ "jot", 0xbca }, +{ "quad", 0xbcc }, +{ "uptack", 0xbce }, +{ "circle", 0xbcf }, +{ "upstile", 0xbd3 }, +{ "downshoe", 0xbd6 }, +{ "rightshoe", 0xbd8 }, +{ "leftshoe", 0xbda }, +{ "lefttack", 0xbdc }, +{ "righttack", 0xbfc }, +{ "hebrew_aleph", 0xce0 }, +{ "hebrew_beth", 0xce1 }, +{ "hebrew_gimmel", 0xce2 }, +{ "hebrew_daleth", 0xce3 }, +{ "hebrew_he", 0xce4 }, +{ "hebrew_waw", 0xce5 }, +{ "hebrew_zayin", 0xce6 }, +{ "hebrew_het", 0xce7 }, +{ "hebrew_teth", 0xce8 }, +{ "hebrew_yod", 0xce9 }, +{ "hebrew_finalkaph", 0xcea }, +{ "hebrew_kaph", 0xceb }, +{ "hebrew_lamed", 0xcec }, +{ "hebrew_finalmem", 0xced }, +{ "hebrew_mem", 0xcee }, +{ "hebrew_finalnun", 0xcef }, +{ "hebrew_nun", 0xcf0 }, +{ "hebrew_samekh", 0xcf1 }, +{ "hebrew_ayin", 0xcf2 }, +{ "hebrew_finalpe", 0xcf3 }, +{ "hebrew_pe", 0xcf4 }, +{ "hebrew_finalzadi", 0xcf5 }, +{ "hebrew_zadi", 0xcf6 }, +{ "hebrew_kuf", 0xcf7 }, +{ "hebrew_resh", 0xcf8 }, +{ "hebrew_shin", 0xcf9 }, +{ "hebrew_taf", 0xcfa }, +{ "Hebrew_switch", 0xFF7E }, ADDED library/bgerror.tcl Index: library/bgerror.tcl ================================================================== --- library/bgerror.tcl +++ library/bgerror.tcl @@ -0,0 +1,75 @@ +# 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 .] + } +} + ADDED library/button.tcl Index: library/button.tcl ================================================================== --- library/button.tcl +++ library/button.tcl @@ -0,0 +1,79 @@ +# 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. +# +# @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995 Cleveland Clinic Foundation +# +# 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 { + tkCheckRadioInvoke %W +} +bind Button { + if !$tk_strictMotif { + tkCheckRadioInvoke %W + } +} + +bind Radiobutton { + %W selection from insert +} + +bind Entry { + focus [tk_focusNext %W] +} + +bind Entry { + if [tkEntryInsert %W %A] break +} + +# 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 Escape, and Tab. + +bind Entry {# nothing} +bind Entry {# nothing} +bind Entry {# nothing} +bind Entry {# nothing} +bind Entry {# nothing} +bind Entry {# nothing} + +bind Entry { + catch {tkEntryInsert %W [selection get -displayof %W]} +} + +# tkEntryKeySelect -- +# This procedure is invoked when stroking out selections using the +# keyboard. It moves the cursor to a new position, then extends +# the selection to that position. +# +# Arguments: +# w - The entry window. +# new - A new position for the insertion cursor (the cursor hasn't +# actually been moved to this position yet). + +proc tkEntryKeySelect {w new} { + if ![$w selection present] { + $w selection from insert + $w selection to $new + } else { + $w selection adjust $new + } + $w icursor $new +} + +# tkEntryInsert -- +# Insert a string into an entry at the point of the insertion cursor. +# If there is a selection in the entry, and it covers the point of the +# insertion cursor, then delete the selection before inserting. +# +# Arguments: +# w - The entry window in which to insert the string +# s - The string to insert (usually just a single character) +# +# Results: +# Returns 1 if text is inserted, 0 otherwise. + +#proc tkEntryInsert {w s} { -- implemented in C -- } + +# tkEntryBackspace -- +# Backspace over the character just before the insertion cursor. +# If backspacing would move the cursor off the left edge of the +# window, reposition the cursor at about the middle of the window. +# +# Arguments: +# w - The entry window in which to backspace. + +proc tkEntryBackspace w { + if [$w selection present] { + $w delete sel.first sel.last + } else { + set x [expr {[$w index insert] - 1}] + if {$x >= 0} {$w delete $x} + if {[$w index @0] >= [$w index insert]} { + set range [$w xview] + set left [lindex $range 0] + set right [lindex $range 1] + $w xview moveto [expr $left - ($right - $left)/2.0] + } + } +} + +# tkEntrySeeInsert -- +# Make sure that the insertion cursor is visible in the entry window. +# If not, adjust the view so that it is. +# +# Arguments: +# w - The entry window. + +#proc tkEntrySeeInsert w { -- implemented in C -- } + +# tkEntrySetCursor - +# Move the insertion cursor to a given position in an entry. Also +# clears the selection, if there is one in the entry, and makes sure +# that the insertion cursor is visible. +# +# Arguments: +# w - The entry window. +# pos - The desired new position for the cursor in the window. + +proc tkEntrySetCursor {w pos} { + $w icursor $pos + $w selection clear + tkEntrySeeInsert $w +} + +# tkEntryTranspose - +# This procedure implements the "transpose" function for entry widgets. +# It tranposes the characters on either side of the insertion cursor, +# unless the cursor is at the end of the line. In this case it +# transposes the two characters to the left of the cursor. In either +# case, the cursor ends up to the right of the transposed characters. +# +# Arguments: +# w - The entry window. + +proc tkEntryTranspose w { + set i [$w index insert] + if {$i < [$w index end]} { + incr i + } + set first [expr $i-2] + if {$first < 0} { + return + } + set new [string index [$w get] [expr $i-1]][string index [$w get] $first] + $w delete $first $i + $w insert insert $new + tkEntrySeeInsert $w +} ADDED library/license.terms Index: library/license.terms ================================================================== --- library/license.terms +++ library/license.terms @@ -0,0 +1,32 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., Cleveland Clinic Foundation, 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. + +RESTRICTED RIGHTS: Use, duplication or disclosure by the government +is subject to the restrictions as set forth in subparagraph (c) (1) (ii) +of the Rights in Technical Data and Computer Software Clause as DFARS +252.227-7013 and FAR 52.227-19. ADDED library/listbox.tcl Index: library/listbox.tcl ================================================================== --- library/listbox.tcl +++ library/listbox.tcl @@ -0,0 +1,316 @@ +# listbox.tcl -- +# +# This file defines the default bindings for Tk listbox widgets +# and provides procedures that help in implementing those bindings. +# +# @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# Copyright (c) 1995 Cleveland Clinic Foundation +# +# 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 listboxes. +#------------------------------------------------------------------------- + +#-------------------------------------------------------------------------- +# tkPriv elements used in this file: +# +# listboxPrev - The last element to be selected or deselected +# during a selection operation. +# listboxSelection - All of the items that were selected before the +# current selection operation (such as a mouse +# drag) started; used to cancel an operation. +#-------------------------------------------------------------------------- + +bind Listbox { + tkListboxUpDown %W -1 +} +bind Listbox { + tkListboxUpDown %W 1 +} +bind Listbox { + %W xview scroll -1 pages +} +bind Listbox { + %W xview scroll 1 pages +} +bind Listbox { + %W yview scroll -1 pages + tkListboxGoto %W @0,0 +} +bind Listbox { + %W yview scroll 1 pages + tkListboxGoto %W @0,9999999 +} +bind Listbox { + tkListboxGoto %W 0 +} +bind Listbox { + tkListboxGoto %W end +} +#bind Listbox { +# tkListboxBeginSelect %W [%W index active] +#} +bind Listbox { + tkListboxBeginSelect %W [%W index active] + focus [tk_focusNext %W] +} +bind Listbox { + tkMbPost %W + tkMenuFirstEntry [%W cget -menu] +} +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. + +bind Menu { + %W mark set anchor insert +} +bind Text { + catch {tkTextInsert %W [selection get -displayof %W]} +} +bind Text { + if [tkTextInsert %W %A] break +} + +# 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 and . + +bind Text {# nothing } +bind Text {# nothing} +bind Text {# nothing} +bind Text {# nothing} +bind Text {# nothing} +bind Text {# nothing} + +# Additional emacs-like bindings: + +if !$tk_strictMotif { + bind Text { + tkTextSetCursor %W {insert linestart} + } + bind Text { + tkTextSetCursor %W insert-1c + } + bind Text { + %W delete insert + } + bind Text { + tkTextSetCursor %W {insert lineend} + } + bind Text { + tkTextSetCursor %W insert+1c + } + bind Text { + if [%W compare insert == {insert lineend}] { + %W delete insert + } else { + %W delete insert {insert lineend} + } + } + bind Text { + tkTextSetCursor %W [tkTextUpDownLine %W 1] + } + bind Text { + %W insert insert \n + %W mark set insert insert-1c + } + bind Text { + tkTextSetCursor %W [tkTextUpDownLine %W -1] + } + bind Text { + tkTextTranspose %W + } +} +set tkPriv(prevPos) {} + +# tkTextKeyExtend -- +# This procedure handles extending the selection from the keyboard, +# where the point to extend to is really the boundary between two +# characters rather than a particular character. +# +# Arguments: +# w - The text window. +# index - The point to which the selection is to be extended. + +proc tkTextKeyExtend {w index} { + global tkPriv + + set cur [$w index $index] + if [catch {$w index anchor}] { + $w mark set anchor $cur + } + set anchor [$w index anchor] + if [$w compare $cur < anchor] { + set first $cur + set last anchor + } else { + set first anchor + set last $cur + } + $w tag remove sel 0.0 $first + $w tag add sel $first $last + $w tag remove sel $last end +} + +# tkTextSetCursor +# Move the insertion cursor to a given position in a text. Also +# clears the selection, if there is one in the text, and makes sure +# that the insertion cursor is visible. Also, don't let the insertion +# cursor appear on the dummy last line of the text. +# +# Arguments: +# w - The text window. +# pos - The desired new position for the cursor in the window. + +proc tkTextSetCursor {w pos} { + global tkPriv + + if [$w compare $pos == end] { + set pos {end - 1 chars} + } + $w mark set insert $pos + $w tag remove sel 1.0 end + $w see insert +} + +# tkTextKeySelect +# This procedure is invoked when stroking out selections using the +# keyboard. It moves the cursor to a new position, then extends +# the selection to that position. +# +# Arguments: +# w - The text window. +# new - A new position for the insertion cursor (the cursor hasn't +# actually been moved to this position yet). + +proc tkTextKeySelect {w new} { + global tkPriv + + if {[$w tag nextrange sel 1.0 end] == ""} { + if [$w compare $new < insert] { + $w tag add sel $new insert + } else { + $w tag add sel insert $new + } + $w mark set anchor insert + } else { + if [$w compare $new < anchor] { + set first $new + set last anchor + } else { + set first anchor + set last $new + } + $w tag remove sel 1.0 $first + $w tag add sel $first $last + $w tag remove sel $last end + } + $w mark set insert $new + $w see insert + update idletasks +} + +# tkTextInsert -- +# 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. +# +# Arguments: +# w - The text window in which to insert the string +# s - The string to insert (usually just a single character) +# +# Results: +# Returns 1 if any characters are inserted, 0 otherwise. + +proc tkTextInsert {w s} { + if {$s == "" || ([$w cget -state] == "disabled")} {return 0} + catch { + if {[$w compare sel.first <= insert] + && [$w compare sel.last >= insert]} { + $w delete sel.first sel.last + } + } + $w insert insert $s + $w see insert + return 1 +} + +# tkTextUpDownLine -- +# Returns the index of the character one line above or below the +# insertion cursor. There are two tricky things here. First, +# we want to maintain the original column across repeated operations, +# even though some lines that will get passed through don't have +# enough characters to cover the original column. Second, don't +# try to scroll past the beginning or end of the text. +# +# Arguments: +# w - The text window in which the cursor is to move. +# n - The number of lines to move: -1 for up one line, +# +1 for down one line. + +proc tkTextUpDownLine {w n} { + global tkPriv + + set i [$w index insert] + scan $i "%d.%d" line char + if {[string compare $tkPriv(prevPos) $i] != 0} { + set tkPriv(char) $char + } + set new [$w index [expr $line + $n].$tkPriv(char)] + if {[$w compare $new == end] || [$w compare $new == "insert linestart"]} { + set new $i + } + set tkPriv(prevPos) $new + return $new +} + +# tkTextPrevPara -- +# Returns the index of the beginning of the paragraph just before a given +# position in the text (the beginning of a paragraph is the first non-blank +# character after a blank line). +# +# Arguments: +# w - The text window in which the cursor is to move. +# pos - Position at which to start search. + +proc tkTextPrevPara {w pos} { + set pos [$w index "$pos linestart"] + while 1 { + if {(([$w get "$pos - 1 line"] == "\n") && ([$w get $pos] != "\n")) + || ($pos == "1.0")} { + if [regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ + dummy index] { + set pos [$w index "$pos + [lindex $index 0] chars"] + } + if {[$w compare $pos != insert] || ($pos == "1.0")} { + return $pos + } + } + set pos [$w index "$pos - 1 line"] + } +} + +# tkTextNextPara -- +# Returns the index of the beginning of the paragraph just after a given +# position in the text (the beginning of a paragraph is the first non-blank +# character after a blank line). +# +# Arguments: +# w - The text window in which the cursor is to move. +# start - Position at which to start search. + +proc tkTextNextPara {w start} { + set pos [$w index "$start linestart + 1 line"] + while {[$w get $pos] != "\n"} { + if [$w compare $pos == end] { + return [$w index "end - 1c"] + } + set pos [$w index "$pos + 1 line"] + } + while {[$w get $pos] == "\n"} { + set pos [$w index "$pos + 1 line"] + if [$w compare $pos == end] { + return [$w index "end - 1c"] + } + } + if [regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ + dummy index] { + return [$w index "$pos + [lindex $index 0] chars"] + } + return $pos +} + +# tkTextScrollPages -- +# This is a utility procedure used in bindings for moving up and down +# pages and possibly extending the selection along the way. It scrolls +# the view in the widget by the number of pages, and it returns the +# index of the character that is at the same position in the new view +# as the insertion cursor used to be in the old view. +# +# Arguments: +# w - The text window in which the cursor is to move. +# count - Number of pages forward to scroll; may be negative +# to scroll backwards. + +proc tkTextScrollPages {w count} { + set bbox [$w bbox insert] + $w yview scroll $count pages + if {$bbox == ""} { + return [$w index @[expr [winfo height $w]/2],0] + } + return [$w index @[lindex $bbox 0],[lindex $bbox 1]] +} + +# tkTextTranspose -- +# This procedure implements the "transpose" function for text widgets. +# It tranposes the characters on either side of the insertion cursor, +# unless the cursor is at the end of the line. In this case it +# transposes the two characters to the left of the cursor. In either +# case, the cursor ends up to the right of the transposed characters. +# +# Arguments: +# w - Text window in which to transpose. + +proc tkTextTranspose w { + set pos insert + if [$w compare $pos != "$pos lineend"] { + set pos [$w index "$pos + 1 char"] + } + set new [$w get "$pos - 1 char"][$w get "$pos - 2 char"] + if [$w compare "$pos - 1 char" == 1.0] { + return + } + $w delete "$pos - 2 char" $pos + $w insert insert $new + $w see insert +} ADDED library/tkerror.tcl Index: library/tkerror.tcl ================================================================== --- library/tkerror.tcl +++ library/tkerror.tcl @@ -0,0 +1,58 @@ +# tkerror.tcl -- +# +# 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. +# +# @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995 Cleveland Clinic Foundation +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# tkerror -- +# This is the default version of tkerror. 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 tkerror err { + global errorInfo + + set info $errorInfo + set button [tk_dialog .tkerrorDialog "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 .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 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 + + set oldFocus [focus] + set oldGrab [grab current .] + grab $w + focus $w.ok + tkwait window $w + catch {grab $oldGrab} + catch {focus $oldFocus} +} ADDED library/wm.tcl Index: library/wm.tcl ================================================================== --- library/wm.tcl +++ library/wm.tcl @@ -0,0 +1,155 @@ +# wm.tcl -- +# +# Partial implementation of the Tk wm and grab commands for CTk. +# +# @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ +# +# Copyright (c) 1995 Cleveland Clinic Foundation +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + + +# wm -- +# Cheap simulation of Tk's wm. + +proc wm {option window args} { + global tkPriv + + switch -glob -- $option { + deiconify { + ctkWmPlace $window + } + geom* { + if {$args == ""} { + return [winfo geometry $window] + } + set geom [string trim $args =] + set w {} + set h {} + set xsign {} + set x {} + set ysign {} + set y {} + if {[scan $geom {%d x %d %[+-] %d %[+-] %d} w h xsign x ysign y] + < 2} { + set w {} + scan $geom {%[+-] %d %[+-] %d} xsign x ysign y + } + set tkPriv(wm,$window) [list $w $h $xsign$x $ysign$y] + ctkWmPlace $window + } + title { + if {$args == ""} { + return $window cget -title + } + $window configure -title [lindex $args 0] + } + transient { + switch [llength $args] { + 0 { + if [info exists tkPriv(wm-transient,$window)] { + return $tkPriv(wm-transient,$window) + } + } + 1 {set tkPriv(wm-transient,$window) [lindex $args 0]} + default {error {wrong # args}} + } + } + overrideredirect {return 0 } + iconify - + withdraw { place forget $window } + } +} + +# ctkWmPlace -- +# Place toplevel window `w' according to window manager settings. + +proc ctkWmPlace w { + global tkPriv + + if [info exists tkPriv(wm,$w)] { + set width [lindex $tkPriv(wm,$w) 0] + set height [lindex $tkPriv(wm,$w) 1] + set x [lindex $tkPriv(wm,$w) 2] + set y [lindex $tkPriv(wm,$w) 3] + set placeArgs [list -width $width -height $height] + switch -glob -- $x { + "" { } + -* {lappend placeArgs -x [expr [winfo screenwidth $w]+$x] -relx 0} + default {lappend placeArgs -x [expr $x] -relx 0} + } + switch -glob -- $y { + "" { } + -* {lappend placeArgs -y [expr [winfo screenheight $w]+$y] -rely 0} + default {lappend placeArgs -y [expr $y] -rely 0} + } + } else { + set placeArgs {-relx 0.5 -rely 0.5 -width {} -height {} -anchor center} + } + eval place $w $placeArgs +} + +# grab -- +# Cheap simulation of Tk's grab. Currently - a grab has +# no effect on CTk - this will change if I add a real +# window manager. + +proc grab {option args} { + global tkPriv + + if {! [info exists tkPriv(grab)]} { + set tkPriv(grab) {} + } + switch -exact -- $option { + current { return $tkPriv(grab) } + release { + if {$args == $tkPriv(grab)} { + set tkPriv(grab) {} + } + return {} + } + status { + if {$args == $tkPriv(grab)} { + return $tkPriv(grabType) + } else { + return none + } + } + set { + set option [lindex $args 0] + set args [lrange $args 1 end] + # Falls through ... + } + } + if {$option == "-global"} { + set tkPriv(grab) $args + set tkPriv(grabType) global + } else { + set tkPriv(grab) $option + set tkPriv(grabType) local + } +} + +# ctkNextTop +# Pass focus to the next toplevel window after w's toplevel. + +proc ctkNextTop w { + global tkPriv + + if {$tkPriv(grab) != ""} {bell; return} + set cur [winfo toplevel $w] + set tops [lsort ". [winfo children .]"] + set i [lsearch -exact $tops $cur] + set tops "[lrange $tops [expr $i+1] end] [lrange $tops 0 [expr $i-1]]" + foreach top $tops { + if {[winfo toplevel $top] == $top + && ![info exists tkPriv(wm-transient,$top)]} { + wm deiconify $top + raise $top + focus $top + return + } + } +} + ADDED license.terms Index: license.terms ================================================================== --- license.terms +++ license.terms @@ -0,0 +1,32 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., Cleveland Clinic Foundation, 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. + +RESTRICTED RIGHTS: Use, duplication or disclosure by the government +is subject to the restrictions as set forth in subparagraph (c) (1) (ii) +of the Rights in Technical Data and Computer Software Clause as DFARS +252.227-7013 and FAR 52.227-19. ADDED patchlevel.h Index: patchlevel.h ================================================================== --- patchlevel.h +++ patchlevel.h @@ -0,0 +1,23 @@ +/* + * patchlevel.h (CTk) -- + * + * This file does nothing except define a "patch level" for CTk. + * 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 "aZ" or "bZ" for alpha and beta releases, + * respectively (e.g. 4.0b1 is the first beta release of CTk 4.0). + * The patch level ensures that patches are applied in the correct + * order and only to appropriate sources. + * + * 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. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#define CTK_PATCH_LEVEL "4.0" ADDED porting.notes Index: porting.notes ================================================================== --- porting.notes +++ porting.notes @@ -0,0 +1,47 @@ + Porting Notes for the CTk Toolkit + +@(#) $Header: /usrs/andrewm/work/RCS/ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + +This file contains notes for build CTk on various platforms. So +far, all of these notes are from personal experience. Hopefully +I'll get more entries donated. :-) + + + +Linux +----- +Install ncurses, then (with slackware atleast) use: + + configure -with-ncurses -with-incdirs=/usr/include/ncurses + +HP-UX +----- +If using ncurses, you must add -Ae to CFLAGS (to use extended ANSI compiler) +because ncurses.h is in ANSI C. + +HP curses has no curs_set - so the terminal cursor is left flashing +in random places. There seems to be a bug that will leave random +highlights (underlines) on the screen (Wyse 60) (maybe using spaces +to move the cursor while in the highlight mode?) (our highly customized +terminfo entries may be at fault, but they work with ncurses). + +Sun OS +------ +Use the system V compiler, that is: + + CC=/usr/5bin/cc configure + +BSD Curses +---------- +Lots of difficulties, and the output is pretty terrible (only one +display attribute - can't turn of the random flashing cursor - +missing most of the non-ASCII keys). I'm not sure if it is worth +trying to support it. + +When compiling ctkDisplay.c, get in curses.h about "VOID redefined" - +doesn't seem to cause a problem though. + +BSD Curses seems to require a fflush() after a refresh() - even though +my documents say that is should not be necessary. Is there a cleaner +way of doing this? + ADDED test.tcl Index: test.tcl ================================================================== --- test.tcl +++ test.tcl @@ -0,0 +1,14 @@ +#! /usr/bin/env tclsh + +if {![info exists tk_port]} { + set tk_library /home/usace/u4423rsk/Desktop/ctk8.2_working/library + load ./libctk.so Tk +} + +label .l -text "Password" +entry .x +button .y -text "OK" -command exit + +pack .l -side left +pack .x -side right -fill x -expand 1 +pack .y ADDED test/testit.ctk Index: test/testit.ctk ================================================================== --- test/testit.ctk +++ test/testit.ctk @@ -0,0 +1,4824 @@ +#!/usr/local/bin/cwish + + +################################################################################ +# CONSTANTS: +################################################################################ + +################################################################################ +# +# Create Entry Errors List Box +# +proc ToorCreateErrorDialog { title } { + + toplevel .csds_errors -borderwidth 1 + wm geometry .csds_errors "+0+0" + label .csds_errors.message -text "$title - Entry Errors\n" + pack .csds_errors.message -side top + label .csds_errors.msg2 \ + -text "The following entry errors have been found:" \ + -justify left -anchor w + pack .csds_errors.msg2 -side top -fill x + frame .csds_errors.box + pack .csds_errors.box -fill x + listbox .csds_errors.box.list -height 5 -width 60 -borderwidth 1 \ + -yscrollcommand ".csds_errors.box.scroll set" + pack .csds_errors.box.list -side left + scrollbar .csds_errors.box.scroll -command ".csds_errors.box.list yview" + pack .csds_errors.box.scroll -side left -fill y + button .csds_errors.ok -text "OK" -borderwidth 1 \ + -command "destroy .csds_errors" + pack .csds_errors.ok -side top + focus .csds_errors.ok + + label .csds_errors.msg3 \ + -text "Press function key to change windows" \ + -justify left -anchor w + pack .csds_errors.msg3 -side top -fill x + + return .csds_errors.box.list + +} + +################################################################################ +# +# Display Entry Errors +# Note that this impementation is less robust than the "C" implementation: +# 1) Label must be less than 55 characters +# 2) there MUST be a space after the label but before the end of the +# line +# 3) Tabs are ignored, so they will probably do bad things +# 4) width is fixed at 60 characters +# 5) Window is always displayed in the upper right-hand corner of the screen +# 6) There are no Error Widgets next to the f +# +proc ToorDisplayErrors { title args } { + + set blanks " " + + if { [ llength $args ] >= 2 } { + set msg_box [ ToorCreateErrorDialog $title ] + + set index 1 + for {set i [expr [llength $args]-1]} {$i>0} {incr i -2} { + + set e_label [lindex $args 0]; set args [lrange $args 1 end] + set e_text [lindex $args 0]; set args [lrange $args 1 end] + + set e_line "$index. $e_label - " + set indnt [ expr [ string length $e_line ] - 1] + set e_line "$e_line$e_text" + + while { [ string length $e_line ] > 60 } { + set end_idx [ string last " " [ string range $e_line 0 59 ] ] + + $msg_box insert end [ string range $e_line 0 $end_idx ] + set e_line \ + "[string range $blanks 0 $indnt][string range $e_line [expr $end_idx+1] end]" + } + + $msg_box insert end "$e_line" + $msg_box insert end "" + + incr index 1 + } + return F + } else { + return T + } + +} + +################################################################################ +# +# Add error to argument list if error is non-null +# +proc ToorAddToErrorList { err_list field error } { + upvar $err_list his_list + if { $error != "" } { + lappend his_list $field $error + } +} + +################################################################################ +# +# Destroy Entry Errors List Box, if it exists +# +proc ToorDestroyEntryErrorsList { } { + if [ winfo exists .csds_errors ] { + destroy .csds_errors + } +} + + +set TOOR_MY_NAME [info script] + +set TOOR_DATA_DIR "/asas/data" +set TOOR_INIT_DIR "/etc/init_asas.d" +set TOOR_LOG_FILE "/var/log/bootup" +set TOOR_TFTP_DIR "/usr/tftpdir" +set TOOR_DEFAULT_DOMAIN_FILE "/etc/defaultdomain" + +set TOOR_HOST_FILE "/etc/hosts" +set TOOR_FDDI_HOSTNAME "/etc/hostname.nf0" + +set TOOR_BEACON_COMMAND_FILE "/home/users/address/beacon.command" +set TOOR_ORG_IP_UNL_FILE "/home/users/address/unl/org_ip.unl" +set TOOR_ORGANIZ_UNL_FILE "/home/users/address/unl/organiz248.unl" +set TOOR_UNL_CELL_INDEX 0 +set TOOR_UNL_IP_INDEX 1 +set TOOR_UNL_HOST_INDEX 3 +set TOOR_UNL_ROLE_INDEX 4 +set TOOR_UNL_ROLE_TYPE_INDEX 6 +set TOOR_UNL_OR_NAME_INDEX 7 +set TOOR_UNL_URN_INDEX 8 +set TOOR_UNL_UIC_INDEX 10 +set TOOR_ORG_CELL_INDEX 0 +set TOOR_ORG_ORG_INDEX 2 + + +set TOOR_ORACLE_BOOT_FILE "/etc/init.d/dbora" + +set TOOR_CURRENT_CONFIG_DIR "$TOOR_DATA_DIR/current" +set TOOR_LAST_CONFIG_DIR "$TOOR_DATA_DIR/last" +set TOOR_NEW_CONFIG_DIR "$TOOR_DATA_DIR/new" + +set TOOR_DEFAULT_ENCLAVE_FILE "$TOOR_INIT_DIR/enclave_id" +set TOOR_BEACON_BOOT_FILE "$TOOR_INIT_DIR/start_address_book" +set TOOR_SDR_BOOT_FILE "$TOOR_INIT_DIR/toor_inet_supplement.sh" +set TOOR_VALIDATE "$TOOR_INIT_DIR/toor_form_validation_services.ctk" +set TOOR_PE_SITE_FILE "/opt/dcelocal/etc/security/pe_site" + +set TOOR_MASTER_NAME_FILE "subsystem_master" +set TOOR_CELL_NAME_FILE "cell_name" +set TOOR_DCE_MASTER_FILE "dce_master" +set TOOR_HOST_ID_FILE "hostid" +set TOOR_INTERFACE_FILE "interface" +set TOOR_USE_BEACON_FILE "beacon_use" +set TOOR_OR_NAME_FILE "or_name" +set TOOR_FDDI_OR_NAME_FILE "fddi_or_name" +set TOOR_UIC_FILE "unit_id_code" +set TOOR_DOMAIN_SUFFIX_FILE "suffix.dat" +set TOOR_ENCLAVE_FILE "enclave_id" +set TOOR_RECONFIG_NAME "reconfig_needed" +set TOOR_LEFT_VIDEO_FILE "left_video" +set TOOR_RIGHT_VIDEO_FILE "right_video" +set TOOR_LEFT_VIDEO_CMD_FILE "left_video_cmd" +set TOOR_RIGHT_VIDEO_CMD_FILE "right_video_cmd" +set TOOR_SDR_FILE "sdr" +set TOOR_CLIENTS_FILE "clients" +set TOOR_OUR_ORGANIZ_FILE "our_organiz" +set TOOR_OUR_ROLE_TYPE_FILE "our_role_typ" +set TOOR_OUR_ROLE_FILE "our_role" +set TOOR_OUR_URN_FILE "unit_ref_num" +set TOOR_FDDI_ORGANIZ_FILE "fddi_organiz" +set TOOR_FDDI_ROLE_TYPE_FILE "fddi_role_typ" +set TOOR_FDDI_ROLE_FILE "fddi_role" +set TOOR_MST_ORGANIZ_FILE "asas_organiz" +set TOOR_MST_ROLE_TYPE_FILE "asas_role_typ" +set TOOR_MST_ROLE_FILE "asas_role" +set TOOR_DCE_ORGANIZ_FILE "dce_organiz" +set TOOR_DCE_ROLE_TYPE_FILE "dce_role_typ" +set TOOR_DCE_ROLE_FILE "dce_role" +set TOOR_LIST_FILE "list_selection" + + +set TOOR_CELL_ADMIN_PW ".cell_admin" + +set TOOR_RECONFIG_FILE "$TOOR_NEW_CONFIG_DIR/$TOOR_RECONFIG_NAME" +set TOOR_NEED_ACCTS_FILE "$TOOR_NEW_CONFIG_DIR/default_accounts" + +set TOOR_BEACON_OFF_LIST " $TOOR_BEACON_BOOT_FILE " +set TOOR_BEACON_ON_LIST " $TOOR_BEACON_BOOT_FILE.off " + +set TOOR_BEACON_PASS1_OFF_LIST " /etc/rc3.d/S38sendmail \ + /etc/rc3.d/s38sendmail.beacon \ + /etc/rc3.d/S20ncs \ + /etc/rc3.d/S21netls \ + /etc/rc3.d/S22ncs \ + /etc/rc3.d/S23netls \ + /etc/rc3.d/S25dce \ + /etc/rc3.d/S26dce \ + /etc/rc3.d/S15-10dce-clean \ + /etc/rc3.d/S15-20dce \ + /etc/rc3.d/S15-70dfs \ + /etc/rc3.d/S16dfs-gateway " + +set TOOR_BEACON_PASS1_ON_LIST " /etc/rc3.d/s38sendmail \ + /etc/rc3.d/S38sendmail.beacon \ + /etc/rc3.d/s20ncs \ + /etc/rc3.d/s21netls \ + /etc/rc3.d/s22ncs \ + /etc/rc3.d/s23netls \ + /etc/rc3.d/s25dce \ + /etc/rc3.d/s26dce + /etc/rc3.d/s15-10dce-clean \ + /etc/rc3.d/s15-20dce \ + /etc/rc3.d/s15-70dfs \ + /etc/rc3.d/s16dfs-gateway " + +set TOOR_SDR_ON_LIST " $TOOR_SDR_BOOT_FILE " +set TOOR_SDR_OFF_LIST " $TOOR_SDR_BOOT_FILE.off " + +set TOOR_MASTER_OFF_LIST " $TOOR_ORACLE_BOOT_FILE.off " +set TOOR_MASTER_ON_LIST " $TOOR_ORACLE_BOOT_FILE " + +set TOOR_FDDI_ON_LIST " /etc/rc2.d/S98nf_fddidaemon " +set TOOR_FDDI_OFF_LIST " /etc/rc2.d/s98nf_fddidaemon " + +set TOOR_CRONTAB_HOME "/home/users/overlay/caid_crontab" +set TOOR_CRONTAB_DEST "/var/spool/cron/crontabs/overlay" + +################################################################################ +# +# Write message to the log file +# +proc ToorLogMessage { msg } { + global TOOR_LOG_FILE TOOR_MY_NAME + catch { exec /usr/bin/echo "$TOOR_MY_NAME : $msg " >> $TOOR_LOG_FILE } \ + ret_code +} + +################################################################################ +# +# bindings for sun keyboard to make this slightly easier to use +# +bind Button { + tkButtonInvoke %W +} + +bind Checkbutton { + tkCheckRadioInvoke %W +} + +bind Radiobutton { + tkCheckRadioInvoke %W +} + +bind all {focus [tk_focusPrev %W]} + +proc ctk_menu {} { + if ![winfo exists .ctkMenu] { + menu .ctkMenu + .ctkMenu add command -label "Redraw (R)" -underline 8 \ + -command {ctk redraw .ctkMenu} + .ctkMenu add command -label "Exit (X)" -underline 6 -command exit + } + tk_popup .ctkMenu 0 0 0 +} + +bind all ctk_menu +bind all ctk_menu +bind all {ctkNextTop [focus]} +bind all {set toor_go_back_to_first_menu N} +bind all {set toor_go_back_to_first_menu Y} + +if [ file exists $TOOR_VALIDATE ] { + source $TOOR_VALIDATE +} else { + ToorLogMessage "=== UNABLE TO FIND $TOOR_VALIDATE ===" +} + +################################################################################ +# +# Fills input frame with a text label to side $side of a created subframe +# +proc ToorLabelledSubframe { frame name text side border } { + if {![winfo exists $frame]} { + frame $frame + } + label $frame.label -text $text + frame $frame.$name -borderwidth $border + pack $frame.label $frame.$name -side $side -anchor w + pack $frame -side top -anchor w -fill x + return $frame.$name +} + +################################################################################ +# +# Creates an entry box of size width, with the initial value from global +# variable var and with a text label +# +proc ToorLabelledEntry { frame text width var side state } { + upvar #0 $var glob + set initial_value $glob ;# so can use input global as the output + frame $frame + label $frame.label -text $text + entry $frame.entry -width $width -borderwidth 1 -textvariable $var + $frame.entry delete 0 [string length [$frame.entry get]] + $frame.entry insert 0 "$initial_value" + $frame.entry configure -state $state + set entry_cmd [ list $frame.entry selection range 0 ] + set entry_cmd [ concat $entry_cmd { [string length [ } \ + $frame.entry get {]]} ] + bind $frame.entry $entry_cmd + bind $frame.entry "$frame.entry selection range 0 0" + pack $frame.label $frame.entry -side $side -padx 0 +} + +################################################################################ +# +# Creates an empty entry box of size 9, that will echo a * for each input +# character +# +proc ToorLabelledPasswordEntry { frame name state text} { + frame $frame + entry $frame.$name -show "*" -width 9 -borderwidth 1 -state $state + label $frame.l1 -text $text + pack $frame.$name $frame.l1 -side right + return $frame.$name +} + +################################################################################ +# +# Creates a set of radiobuttons with a text label +# +proc ToorLabelledRadiobuttons { frame text var state side border args } { + if {![winfo exists $frame]} { + frame $frame -borderwidth $border + } + set inner_frame [ ToorLabelledSubframe $frame buttons $text $side 0 ] + + for {set i [expr [llength $args]-1]} {$i>0} {incr i -2} { + set b_text [lindex $args 0]; set args [lrange $args 1 end] + set b_value [lindex $args 0]; set args [lrange $args 1 end] + set b_name [string tolower $b_value] + radiobutton $inner_frame.$b_name -text $b_text -anchor w \ + -value $b_value -variable $var -state $state + pack $inner_frame.$b_name -side $side -anchor w + } +} + +################################################################################ +# +# Creates a set of labelled pushbuttons +# +proc ToorButtonSet { frame default ans_var wait_var args } { + frame $frame + for {set i [expr [llength $args]-1]} {$i>0} {incr i -2} { + set b_text [lindex $args 0]; set args [lrange $args 1 end] + set b_value [lindex $args 0]; set args [lrange $args 1 end] + button $frame.b$i -text $b_text -borderwidth 1 \ + -command "set $ans_var $b_value; set $wait_var 0" + pack $frame.b$i -side left -fill x + if {$default == $b_value} { + focus $frame.b$i + } + } +} + +################################################################################# +# Display a hostname in an entry box with a preceding label +# +proc ToorDisplayHost { frame var side state } { + ToorLabelledEntry $frame "Host Name:" 8 $var $side $state +} + +################################################################################ +# +# Display an ip address in an entry box with a preceding label +# +proc ToorDisplayIp { frame var side state } { + ToorLabelledEntry $frame "IP Address:" 15 $var $side $state +} + +################################################################################ +# +# Display a host id (machine id) in an entry box with a preceding label +# +proc ToorDisplayHostId { frame id } { + ToorLabelledEntry $frame "Host Id:" 8 $id top disabled +} + +################################################################################ +# +# Display a unix/nis+ domain in an entry box with a preceding label +# +proc ToorDisplayDomain { frame var side state } { + ToorLabelledEntry $frame "Domain:" 22 $var $side $state +} + +################################################################################ +# +# Display a organization/role in an entry box with a preceding label +# +proc ToorDisplayOrName { frame var side state } { + ToorLabelledEntry $frame "O/R Name: " 33 $var $side $state +} + +################################################################################ +# +# Display a organization/role in an entry box with a preceding label +# (short version truncates 3 characters) +# +proc ToorDisplayOrNameS { frame var side state } { + ToorLabelledEntry $frame "O/R Name:" 30 $var $side $state +} + +################################################################################ +# +# Display an enclave code in an entry box with a preceding label +# Allows only two characters, doesn't allow scrolling past second char +# Note: ctk does not recognize the KeyRelease event, hence the bizarre +# delay and the catches in case the window has bee taken down +# +proc ToorDisplayEnclave { frame side state } { + global toor_enclave_frame + ToorLabelledEntry $frame "Enclave:" 2 toor_vars(new,enclave) top $state + pack $frame -side $side -anchor w + set toor_enclave_frame "$frame.entry" + bind $frame.entry { + after 2 { + if { [winfo exists $toor_enclave_frame] } { + catch { set en_len [ string length [$toor_enclave_frame get]] }\ + ret_code + if { $en_len == 2 } { + catch { $toor_enclave_frame xview 0 } ret_code + catch { $toor_enclave_frame icursor 2 } ret_code + } elseif { $en_len > 2 } { + catch { $toor_enclave_frame delete 0 [ expr $en_len - 2] } \ + ret_code + catch { $toor_enclave_frame xview 0 } ret_code + catch { $toor_enclave_frame icursor 2 } ret_code + } + } + } + } +} + +################################################################################ +# +# Display a Unit Identification code in an entry box with a preceding label +# +proc ToorDisplayUic { frame var label_side side state } { + ToorLabelledEntry $frame "UIC:" 6 $var $label_side $state + pack $frame -side $side -anchor w +} + +################################################################################ +# +# Display a Unit Reference Number in an entry box with a preceding label +# +proc ToorDisplayUrn { frame var label_side side state } { + ToorLabelledEntry $frame "URN:" 7 $var $label_side $state + pack $frame -side $side -anchor w +} + + +################################################################################ +# +# Display the DCE Cell name in an entry box with a preceding label +# +proc ToorDisplayDceCell { frame var side state } { + ToorLabelledEntry $frame "DCE Cell Name:" 30 $var $side $state + pack $frame -side top +} + +################################################################################ +# +# Set up labelled set of radiobuttons asking if address book and beacon +# should be used +# +proc ToorDisplayBeaconInUse { frame state } { + ToorLabelledRadiobuttons $frame "Address Book / Beacon in use:" \ + toor_vars(new,beacon_is_being_used) $state left 0 \ + "Yes" beacon \ + "No" nobeacon +} + +################################################################################ +# +# Display number of seconds until no longer display top screen, value is +# updated as textvariable toor_seconds_to_go is decremented +# +proc ToorDisplaySecondsLeft { frame } { + global toor_seconds_to_go + frame $frame + frame $frame.f1 + label $frame.l1 -text "\"No\" will be assumed if no response is received in" + + label $frame.f1.l1 -textvariable toor_seconds_to_go + label $frame.f1.l2 -text "seconds" + pack $frame.f1.l1 $frame.f1.l2 -side left + pack $frame.l1 $frame.f1 -side top + pack $frame -side top +} + +################################################################################ +# +# Display the Yes/No change of configuration wanted buttons +# +proc ToorDisplayYesNo { frame default } { + ToorButtonSet $frame $default toor_want_to_change_ans toor_seconds_to_go \ + "Yes" Y \ + "No" N + pack $frame -side top + +} + +################################################################################ +# +# Display a scrolled list box with an accompanying entry box +# +proc ToorDisplayList { frame title lines width var side entry_list } { + upvar $entry_list e_list + catch {destroy $frame} err_code + frame $frame + frame $frame.entry + ToorLabelledEntry $frame.entry.info $title $width $var top normal + pack $frame.entry -side top -fill x + pack $frame.entry.info -side left -fill x + frame $frame.sb + pack $frame.sb -side top + scrollbar $frame.sb.scroll -command "$frame.sb.list yview" -takefocus 0 + listbox $frame.sb.list -yscroll "$frame.sb.scroll set" -height $lines \ + -width $width -selectmode single + pack $frame.sb.scroll -side right -fill y + pack $frame.sb.list -side left -fill both + + pack $frame -side $side + set e_list [ concat $e_list $frame.entry.info.entry ] + return $frame.sb.list +} + +################################################################################# +# reconfigure the window in "controlled" to be enabled only if there is +# at least one character in the "test_entry" field +# +proc ToorDecideToEnable { controlled test_entry } { + if { [string length [$test_entry get] ] != 0 } { + $controlled configure -state normal + } else { + $controlled delete 0 \ + [string length [$controlled get]] + $controlled configure -state disabled + } +} + +################################################################################ +# +# Selectively enable the windows on the enable_if_on list and disable those +# on the enable_if_off list based on the value of var. (Or vice versa) +# +proc ToorSelectEntryMethod { enable_if_on enable_if_off var } { + upvar #0 $var select_var + + if { $select_var } { + set state 1 + } else { + set state 0 + } + + foreach listbx $enable_if_on { + $listbx configure -takefocus $state + } + + if { $select_var } { + set state 0 + } else { + set state 1 + } + + foreach listbx $enable_if_off { + $listbx configure -takefocus $state + } +} + +################################################################################ +# +# prompts for password and sets up entry boxes that echo "*" rather than +# the character -- ToorDecideToEnable is bound to keypresses in password +# field making the verify password sensitive only if there's an entry +# in the password +# +proc ToorPasswordPrompt { frame pw_var verf_var } { + upvar $pw_var pw + upvar $verf_var verf + frame $frame + set sub_frame [ ToorLabelledSubframe $frame passwords \ + "If password is unchanged, make no entry and select \"OK\"\n" \ + top 0 ] + + set pw [ToorLabelledPasswordEntry $sub_frame.f1 cell_password normal \ + "New Password: "] + set verf [ToorLabelledPasswordEntry $sub_frame.f2 verify_password disabled \ + "Retype Password to Verify: "] + bind $pw "ToorDecideToEnable $verf $pw" + + pack $sub_frame.f1 $sub_frame.f2 -side top -fill x +} + +################################################################################ +# +# Assure that the named directory exists, and create it if not +# +proc ToorAssureDirectoryExists { direct } { + if { ! [file exists $direct] } { + catch { [ exec /usr/bin/mkdir $direct ] } ret_code + catch { [ exec /usr/bin/chmod 755 $direct ] } ret_code + } +} + +################################################################################ +# +# Assure that the directories we need exists, and create them if not +# +proc ToorCheckHaveDirectories { } { + global TOOR_DATA_DIR TOOR_CURRENT_CONFIG_DIR TOOR_LAST_CONFIG_DIR \ + TOOR_NEW_CONFIG_DIR + + ToorAssureDirectoryExists [ file dirname $TOOR_DATA_DIR ] + ToorAssureDirectoryExists $TOOR_DATA_DIR + ToorAssureDirectoryExists $TOOR_CURRENT_CONFIG_DIR + ToorAssureDirectoryExists $TOOR_LAST_CONFIG_DIR + ToorAssureDirectoryExists $TOOR_NEW_CONFIG_DIR +} + +################################################################################ +# +# Find list of ethernet interfaces on this workstation +# +proc ToorGetEthernetInterfaces { } { + global toor_interfaces toor_fddi_present + set local_interfaces "le0" + catch { set local_interfaces [ exec /etc/prtconf \| /usr/bin/awk "BEGIN {len=0\;hmen=0} \$1 ~ /^(.+,)*le\[,]*\$/{print \"le\"len++} \$1 ~ /^(.+,)*hme\[,]*\$/{print \"hme\"hmen++}" ] } ret_code + set toor_interfaces [ split $local_interfaces " \n" ] + set local_fddi "" + catch { set local_fddi [ exec /etc/prtconf \| /usr/bin/egrep "\[ ,\\t]nf\[ ,]" ] } ret_code + set toor_fddi_present [ expr "{$local_fddi} == {} ? 0 : 1" ] +} + +################################################################################ +# +# Save last 5 boot log files, move each file back one level +# +proc ToorAgeLogFiles { } { + global TOOR_LOG_FILE TOOR_MY_NAME + + for {set file_no 5} {$file_no > 1} {incr file_no -1} { + set old_file [ expr "$file_no - 1"] + catch { exec /usr/bin/mv -f $TOOR_LOG_FILE.$old_file \ + $TOOR_LOG_FILE.$file_no } ret_code + } + catch { exec /usr/bin/mv -f $TOOR_LOG_FILE $TOOR_LOG_FILE.1 } ret_code + catch { set time_is [ exec /usr/bin/date ] } ret_code + catch { exec /usr/bin/echo \ + "$TOOR_MY_NAME : $time_is" > $TOOR_LOG_FILE } ret_code + catch { exec /usr/bin/chown root $TOOR_LOG_FILE } ret_code + catch { exec /usr/bin/chgrp root $TOOR_LOG_FILE } ret_code + catch { exec /usr/bin/chmod 644 $TOOR_LOG_FILE } ret_code + ToorLogMessage "prompting user for reconfiguration" + +} + +################################################################################ +# +# read in the unl file named by file_name and return the lines in unl_list, +# the entries on the lines, separated by "|"s becomes sublists +# values are trimmed of leading & trailing blanks. +# +proc ToorCacheUnl { file_name unl_list {skip 1} } { + upvar 1 $unl_list unl + set to_skip $skip + set unl {} + set org_unl -1 + catch { set org_unl [ open $file_name r ] } ret_code + if { $org_unl != -1 } { + while { [ gets $org_unl organiz_line ] >= 0 } { + if { [ incr to_skip -1 ] < 0 } { + set org_parts [ split $organiz_line "|" ] + set trimmed_parts {} + foreach org_item $org_parts { + lappend trimmed_parts [ string trim $org_item ] + } + lappend unl $trimmed_parts + } + } + catch { close $org_unl } ret_code + } + + return +} + +################################################################################ +# +# Check if input value is a valid DCE Cell name +# Losely based on DNS hostname specification +# +proc ToorCheckCellName { cell } { + + if [ regexp \ +{^[A-Za-z0-9]([A-Za-z0-9-]*[A-Za-z0-9])*(\.[A-Za-z0-9]([A-Za-z0-9-]*[A-Za-z0-9])*)*$} \ + $cell ] { + if { [ string length $cell ] <= 255 } { + return "" + } else { + return "cell name must be 255 or fewer characters" + } + } else { + return "cell name must be present and may contain only letters, numbers, and embedded \"-\"s and \".\"s" + } +} + +################################################################################ +# +# Check if input value is a valid domain name +# Fairly restrictive specification based on RFC 819, see also RFC 1035 for +# length. +# +proc ToorCheckDomainname { domain } { + + if [ regexp \ +{^[A-Za-z]([A-Za-z0-9-]*[A-Za-z0-9])*(\.[A-Za-z]([A-Za-z0-9-]*[A-Za-z0-9])*)*$}\ + $domain ] { + if { [ string length $domain ] <= 255 } { + return "" + } else { + return "Domain Name must be 255 or fewer characters" + } + } else { + return "Domain Name must be present and may contain only letters, numbers, and embedded \"-\"s and \".\"s" + } +} + +################################################################################ +# +# Check if input value is a valid organization name +# At present, test prohibits only the "|" char that is used as a separator. +# String may not start or end with spaces +# +proc ToorCheckOganization { organiz } { + + if [ regexp {^[^| ]+([^|]*[^| ]+)*$} $organiz ] { + return "" + } else { + return "Organization name must be present, may not contain \"|\"s and must not start or end with a space" + } +} + +################################################################################ +# +# Check if input value is a valid organization name, in cases where +# An entry is optional. +# +proc ToorCheckOptOganization { organiz } { + + if { $organiz == "" } { + return "" + } elseif [ regexp {^[^| ]+([^|]*[^| ]+)*$} $organiz ] { + return "" + } else { + return "Organization name may not contain \"|\"s and must not start or end with a space. It may be omitted." + } +} + +################################################################################ +# +# Check if input value is a valid role type +# At present, test prohibits only the "|" char that is used as a separator. +# String may not start or end with spaces +# +proc ToorCheckRoleType { role_type } { + + if [ regexp {^[^| ]+([^|]*[^| ]+)*$} $role_type ] { + return "" + } else { + return "Role Type must be present, may not contain \"|\"s and must not start or end with a space" + } +} + +################################################################################ +# +# Check if input value is a valid role type, used in cases where +# an entry is optional. +# +proc ToorCheckOptRoleType { role_type } { + + if { $role_type == "" } { + return "" + } elseif [ regexp {^[^| ]+([^|]*[^| ]+)*$} $role_type ] { + return "" + } else { + return "Role Type may not contain \"|\"s and must not start or end with a space. It may be omitted." + } +} + +################################################################################ +# +# Check if input value is a valid role +# At present, test prohibits only the "|" char that is used as a separator. +# String may not start or end with spaces +# +proc ToorCheckRole { role } { + + if [ regexp {^[^| ]+([^|]*[^| ]+)*$} $role ] { + return "" + } else { + return "Role must be present, may not contain \"|\"s and must not start or end with a space" + } +} + +################################################################################ +# +# Check if input value is a valid role, used in cases where +# an entry is optional. +# +proc ToorCheckOptRole { role } { + + if { $role == "" } { + return "" + } elseif [ regexp {^[^| ]+([^|]*[^| ]+)*$} $role ] { + return "" + } else { + return "Role may not contain \"|\"s and must not start or end with a space. It may be omitted." + } +} + +################################################################################ +# +# Check if input value is a valid host name +# Names meet most generous standards - excluding only the tab and space +# delimiters (used in /etc/hosts), the dot (DNS domain delimiter), the +# "|" (used by the address book) and control characters. +# Length is from Internic RFC 1035, and is consistent with DANTE. +# Note that RFC 1123 extends host name to 255 characters +# +proc ToorCheckHostname { host } { + + if [ regexp "^\[^.|\001-\ ]+\$" $host ] { + if { [ string length $host ] <= 64 } { + return "" + } else { + return "Host Name must be 64 or fewer characters" + } + } else { + return "Host Name must be present and must not contain spaces, tabs, \"|\"s or \".\"s" + } +} + +################################################################################ +# +# Check if input value is a valid ip address +# Local Address portion = 0 refers to this host, +# Local Address portion = all ones is multicast (broadcast) +# If network is subnetted, additional addresses may be reserved - but are +# allowed by this routine. See Internic RFC 1700 (also RFC 790, RFC 1035) +# URL = ftp://ftp.isi.edu/in-notes/iana/assignments/introduction +# Or: http://sunsite.auc.dk/RFC/std/std2.html +# +proc ToorCheckIPAddr { ip } { + + if [ regexp {^([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$} $ip \ + whole octet1 octet2 octet3 octet4 ] { + if { ( $octet1 > 223 ) } { + return "first number of an IP address must be 223 or less" + } else { + if { ($octet2 > 255) || ($octet3 > 255) || ($octet4 > 255) } { + return "numbers in an IP address must be between 0 and 255" + } + } + if { (( $octet1 <= 127 ) && \ + ((($octet2 == 255) && ($octet3 == 255) && ($octet4 == 255)) \ + || (($octet2 == 0) && ($octet3 == 0) && ($octet4 == 0)))) \ + || (( $octet1 <= 191 ) && \ + ((($octet3 == 255) && ($octet4 == 255)) \ + || (($octet3 == 0) && ($octet4 == 0)))) \ + || (( $octet1 <= 223 ) && \ + (($octet4 == 255) || ($octet4 == 0))) } { + return "You cannot use all \"0\"s or all \"255\"s in the local portion of an IP addresses" + } else { + return "" + } + + } else { + return "IP addresses must be present and must be of the form #.#.#.#, where each # is between 0 and 255" + } +} + +################################################################################ +# +# Check if two ip addresses are on different subnets +# Assumes the current subnet mask of 255.255.255.0 +# +proc ToorCheckIPDiffSubnets { ip1 ip2 } { + + if [ regexp {^([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$} $ip1 \ + whole octet11 octet12 octet13 octet14 ] { + if [ regexp {^([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$} $ip2 \ + whole octet21 octet22 octet23 octet24 ] { + + if { ( $octet11 == $octet21 ) && ( $octet12 == $octet22 ) \ + && ( $octet13 == $octet23 ) } { + return "At least one of the first 3 numbers in these IP addresses must be different" + } else { + return "" ;# different subnets, all is fine + } + } else { + return "" ;# should have been flagged by ip test + } + + } else { + return "" ;# should have been flagged by ip test + } +} + +################################################################################ +# +# Check if input value is a valid UIC +# +proc ToorCheckUIC { uic } { + + if [ regexp {^[A-Z0-9]+$} $uic ] { + if { [ string length $uic ] == 6 } { + return "" + } else { + return "UIC must be 6 characters long" + } + } else { + return "UIC must must be present and may contain only upper-case letters and numbers" + } +} + +################################################################################ +# +# Check if input value is a valid URN +# +proc ToorCheckURN { urn } { + + if [ regexp {^[0-9]+$} $urn ] { + if { [ string length $urn ] <= 7 } { + return "" + } else { + return "Unit Reference Number must be 7 or fewer digits long" + } + } else { + return "Unit Reference Number must be present and may only contain numbers" + } +} + +################################################################################ +# +# Check if input value is a valid Originator/Recipient Name +# +proc ToorCheckORName { orname_val } { + + upvar $orname_val orname + + if [ regexp {^[\ -{}~]+$} $orname ] { + set trim_name [ string trimright $orname ] + + if { [ string length $trim_name ] > 33 } { + return "Originator/Recipient Name must be 33 or fewer characters long" + } else { + + ## Concatinate spaces to fill string to 33 chars + if { [ string length $trim_name ] < 33 } { + set trim_name "$trim_name " + set trim_name [string range $trim_name 0 32] + } + + ## Optional + set subunit_id [ string range $trim_name 0 3 ] + if { [ string index $subunit_id 0 ] == " " && + $subunit_id != " " } { + return "The first 4 characters of the O/R Name are the Subunit ID. It designates units below batallion. This field must either be all blanks or must start with a character other than a blank or a \"|\"" + } + + ## Mandatory + if { [ string index $trim_name 4 ] == " " } { + return "Characters 5 to 13 of the O/R Name form the Unit ID. It designates units above batallion (e.g. 3CORPS). This field is mandatory and must start with a character other than a blank or a \"|\"" + } + + ## Mandatory + if { [ string index $trim_name 13 ] == " " || + [ string index $trim_name 14 ] == " " } { + return "Characters 14 and 15 of the O/R Name designate the Nation. This field is mandatory. Neither character may be a blank or a \"|\". Value is usually \"US\"" + } + + ## Optional + set node_name [ string range $trim_name 15 19 ] + if { [ string index $node_name 0 ] == " " && + $node_name != " " } { + return "Characters 16 to 20 of the O/R Name form the Node. It usually designates the command post (e.g. MAIN). This field must either be all blanks or must start with a character other than a blank or a \"|\"" + } + + ## Mandatory + if { [ string index $trim_name 20 ] == " " } { + return "Characters 21 to 25 of the O/R Name specify the User. It usually designates a user position or function (e.g. ENG). This field is mandatory and must start with a character other than a blank or a \"|\"" + } + + ## Mandatory + if { [ string index $trim_name 25 ] == " " } { + return "Characters 26 to 30 of the O/R Name specify the Element. It usually designates the staff section or component (e.g. OPS). This field is mandatory and must start with a character other than a blank or a \"|\"" + } + + ## Optional + set qualifier [ string range $trim_name 30 32 ] + if { [ string index $qualifier 0 ] == " " && + $qualifier != " " } { + return "Characters 31 to 33 of the O/R Name specify a Qualifier. It is used when two O/R names are otherwise identical (e.g. 1). This field must either be all blanks or must start with a character other than a blank or a \"|\"" + } + + ## Return 33 char string in parameter + set orname $trim_name + return "" + } + } else { + return "Originator/Recipient Name must be present and must not contain any non-printable or \"|\" characters" + } +} + +################################################################################ +# +# Check if Originator/Recipient Names for two different interfaces are unique +# +proc ToorCheckORUnique { orname1 orname2 } { + + if { $orname1 == $orname2 } { + return "These Originator/Recipient Names must be different" + } else { + return "" + } +} + +################################################################################ +# +# Check if two hostnames are unique +# +proc ToorCheckNameUnique { host1 host2 } { + + if { $host1 == $host2 } { + return "These host names must be different" + } else { + return "" + } +} + +################################################################################ +# +# Check if two IP addresses are unique +# +proc ToorCheckIPUnique { ip1 ip2 } { + + if { $ip1 == $ip2 } { + return "These IP addresses must be different" + } else { + return "" + } +} + +################################################################################ +# +# Check if input value is a valid Enclave Code +# +proc ToorCheckEnclaveCode { enclave } { + + if [ regexp {^[A-Z0-9][A-Z0-9]$} $enclave ] { + return "" + } else { + return "Enclave Code must contain 2 upper-case characters or numbers" + } +} + +################################################################################ +# +# Read value of a variable from a file +# +proc ToorSetVarFromFile { variable file } { + upvar $variable my_var + set my_var "" + catch { set my_var [ exec /usr/bin/head \-1 $file ] } ret_code +} + +################################################################################ +# +# Find IP address of "host" from /etc/host file +# +proc ToorGetIpAddress { host their_ip } { + global TOOR_HOST_FILE TOOR_CURRENT_CONFIG_DIR + upvar $their_ip my_ip + set my_ip "" + catch { set my_ip [exec /usr/bin/awk "BEGIN {cnt = 0} \ +\$0 ~ /(\[ \\t\]$host\[ \\t\])|(\[ \\t\]$host\$)/ && cnt == 0 {print \$1; cnt = 1}" $TOOR_HOST_FILE] } ret_code +} + +################################################################################ +# +# Fetch address book org_ip.unl file entry for named host +# +proc ToorFetchUnlRecord { host } { + global TOOR_ORG_IP_UNL_FILE + set line "" + set skipseg "\[\^\|\]\*\\\|" + set entry "\^$skipseg$skipseg$skipseg$host\\\|" + catch { set line [ exec /usr/bin/egrep $entry $TOOR_ORG_IP_UNL_FILE ] } \ + ret_code + return $line +} + +################################################################################ +# +# Fetch IP for given host from unl file +# +proc ToorLookupUnlIpAddr { host } { + global TOOR_UNL_IP_INDEX + + set ip_addr "" + set line [ ToorFetchUnlRecord $host ] + if { $line != "" } { + set parts [ split $line "|" ] + set ip_addr [lindex $parts $TOOR_UNL_IP_INDEX] + } else { + ToorGetIpAddress $host ip_addr + } + return $ip_addr +} + +################################################################################ +# +# Fetch Organization/Role Name for given host and ip +# +proc ToorLookupOrName { host ip file } { + global TOOR_UNL_IP_INDEX TOOR_UNL_OR_NAME_INDEX + + set or_name "" + set line [ ToorFetchUnlRecord $host ] + if { $line != "" } { + set parts [ split $line "|" ] + if { [lindex $parts $TOOR_UNL_IP_INDEX] == $ip } { + set or_name [lindex $parts $TOOR_UNL_OR_NAME_INDEX] + } else { + # Inconsistent hostname and ip, use previous value + ToorSetVarFromFile or_name $file + } + } else { + ToorSetVarFromFile or_name $file + } + return $or_name +} + +################################################################################ +# +# Fetch Unit Identification Code (UIC) for given host and ip +# +proc ToorLookupUic { host ip } { + global TOOR_LAST_CONFIG_DIR TOOR_UIC_FILE \ + TOOR_UNL_IP_INDEX TOOR_UNL_UIC_INDEX + + set uic "" + set line [ ToorFetchUnlRecord $host ] + if { $line != "" } { + set parts [ split $line "|" ] + if { [lindex $parts $TOOR_UNL_IP_INDEX] == $ip } { + set uic [lindex $parts $TOOR_UNL_UIC_INDEX] + } else { + # Inconsistent hostname and ip, use previous value + ToorSetVarFromFile uic $TOOR_LAST_CONFIG_DIR/$TOOR_UIC_FILE + } + } else { + ToorSetVarFromFile uic $TOOR_LAST_CONFIG_DIR/$TOOR_UIC_FILE + } + return $uic +} + +################################################################################ +# +# Fetch Unit Reference Number (URN) for given host and ip +# +proc ToorLookupUrn { host ip } { + global TOOR_LAST_CONFIG_DIR TOOR_OUR_URN_FILE \ + TOOR_UNL_IP_INDEX TOOR_UNL_URN_INDEX + + set urn "" + set line [ ToorFetchUnlRecord $host ] + if { $line != "" } { + set parts [ split $line "|" ] + if { [lindex $parts $TOOR_UNL_IP_INDEX] == $ip } { + set urn [lindex $parts $TOOR_UNL_URN_INDEX] + } else { + # Inconsistent hostname and ip, use previous value + ToorSetVarFromFile urn $TOOR_LAST_CONFIG_DIR/$TOOR_OUR_URN_FILE + } + } else { + ToorSetVarFromFile urn $TOOR_LAST_CONFIG_DIR/$TOOR_OUR_URN_FILE + } + return $urn +} + +################################################################################ +# +# Fetch Cell Name for given host and ip +# +proc ToorLookupCellName { host ip } { + global TOOR_LAST_CONFIG_DIR \ + TOOR_UNL_IP_INDEX TOOR_UNL_CELL_INDEX TOOR_CELL_NAME_FILE \ + toor_vars TOOR_ORGANIZ_UNL_FILE TOOR_ORG_ORG_INDEX + + set cell_name "" + set line [ ToorFetchUnlRecord $host ] + if { $line != "" } { + set parts [ split $line "|" ] + if { [lindex $parts $TOOR_UNL_IP_INDEX] == $ip } { + set cell_name [lindex $parts $TOOR_UNL_CELL_INDEX] + set raw_cell "" + catch { set raw_cell [ lindex \ + [ split \ + [ exec /usr/bin/grep \ + "^$cell_name|" $TOOR_ORGANIZ_UNL_FILE \ + ] "|" \ + ] $TOOR_ORG_ORG_INDEX \ + ] } ret_code + if { $raw_cell != "" } { + catch { set raw_cell [ string trim \ + [ exec /usr/bin/echo $raw_cell | \ + /usr/bin/tr {[A-Z]} {[a-z]} | \ + /usr/bin/tr -cs {[a-z][0-9].} {[-*]} ] "-" ] } ret_code + } + if { $raw_cell != "" } { + set cell_name $raw_cell + } + } else { + # Inconsistent hostname and ip, if this is a new master + if {$toor_vars(new,dce_hostname) != $toor_vars(orig,dce_hostname)} { + # name it's cell based on its host_name + set cell_name "$host-cell" + } else { + # use previous value + ToorSetVarFromFile cell_name \ + $TOOR_LAST_CONFIG_DIR/$TOOR_CELL_NAME_FILE + } + } + } else { + if {$toor_vars(new,dce_hostname) != $toor_vars(orig,dce_hostname)} { + set cell_name "$host-cell" + } else { + # use previous value + ToorSetVarFromFile cell_name \ + $TOOR_LAST_CONFIG_DIR/$TOOR_CELL_NAME_FILE + } + } + return $cell_name +} + +################################################################################ +# +# When a hostname changes, lookup the ip address and o/r name from unl +# files (or /etc/hosts if no unl file) +# +proc ToorNameChanged { old_name new_name ip org uic urn file } { + upvar #0 $ip my_ip + upvar #0 $org my_org + upvar #0 $uic my_uic + upvar #0 $urn my_urn + + ToorPleaseWait + + set newip [ ToorLookupUnlIpAddr $new_name ] + if { $newip != "" } { + set my_ip $newip + set newor [ ToorLookupOrName $new_name $newip $file ] + if { $newor != "" } { + set my_org $newor + } + set newuic [ ToorLookupUic $new_name $newip ] + if { $newuic != "" } { + set my_uic $newuic + } + set newurn [ ToorLookupUrn $new_name $newip ] + if { $newurn != "" } { + set my_urn $newurn + } + } + + +} + +################################################################################ +# +# When a dce master hostname changes, lookup the ip address and cell name from +# unl files (or /etc/hosts if no unl file) +# +proc ToorDceNameChanged { old_name new_name ip cell } { + upvar #0 $ip my_ip + upvar #0 $cell my_cell + set newip [ ToorLookupUnlIpAddr $new_name ] + if { $newip != "" } { + set my_ip $newip + set newcell [ ToorLookupCellName $new_name $newip ] + if { $newcell != "" } { + set my_cell $newcell + } + } +} + +################################################################################ +# +# Return list of items from a specific column of unl file, if args are non-null +# first entry of each pair is a column number that has contents that must +# match the second value of the pair. All args pairs are 'and'ed together +# list_name - list containing each line of unl file, each line is a sublist +# field_number - index (0=first) of column to retrieve +# args - series of pairs, specifies values that other columns must match +# Items are returned in sorted order with duplicate entries suppressed +# +proc ToorGetUnlList { list_name field_number args } { + upvar #0 $list_name l_name + set org_list "" + set org_unl -1 + foreach org_parts $l_name { + set reject_line 0 + if { [ llength $org_parts ] > $field_number } { + for {set i 0} {$i < [expr [llength $args]-1]} {incr i +2} { + set col [lindex $args $i] + set col_value [lindex $args [expr $i + 1]] + if { [ lindex $org_parts $col ] != $col_value } { + set reject_line 1 + break + } + } + if { $reject_line == 0 } { + set org_name [ lindex $org_parts $field_number ] + if { [ lsearch $org_list $org_name ] == -1 } { + lappend org_list $org_name + } + } + } + } + return [ lsort $org_list ] +} + +################################################################################ +# +# If "repopulate" is true, set list of items in the "listbx" listbox +# In either case, activate the entry in listbx that corresponds to +# the value of var. Other variables are just passed to ToorGetUnlList +# +proc ToorSetListContents { listbx repopulate var list field args } { + upvar #0 $var list_var + + if { $repopulate } { + $listbx delete 0 end + set item_list [ eval [ concat ToorGetUnlList $list $field $args ] ] + eval [ concat "$listbx" "insert" "end" $item_list ] + set toor_lists_cached 1 + } else { + set item_list [ $listbx get 0 end ] + } + + set indx [ lsearch $item_list $list_var ] + $listbx selection clear 0 end + if { $indx != -1 } { + $listbx see $indx + $listbx activate $indx + $listbx selection set active + } else { + $listbx yview 0 + $listbx activate 0 + } +} + +################################################################################ +# +# Set global variable var to active entry from listbx, then call proc to update +# other lists that depend on this value +# +proc ToorSetEntryFromList { var listbx proc } { + global toor_vars toor_org toor_type toor_role toor_name + upvar #0 $var list_var + ToorPleaseWait + set list_var [ $listbx get active ] + eval $proc +} + +################################################################################ +# +# Return cell name for organiz unl file corresponding to named organization +# organiz_list is list of lines from organiz unl file with each line split +# into sub-lists +# +proc ToorGetCellFromOrg { organiz_list org } { + global TOOR_ORG_ORG_INDEX TOOR_ORG_CELL_INDEX + upvar #0 $organiz_list o_list + set out_field "" + foreach entry_list $o_list { + if { [ lindex $entry_list $TOOR_ORG_ORG_INDEX ] == $org } { + set out_field [ lindex $entry_list $TOOR_ORG_CELL_INDEX ] + break + } + } + return $out_field +} + +################################################################################ +# +# Set list of roles in listbx that correspond to the selected cell and role_type +# If an entry matches the value in var, select it +# +proc ToorSetRoleList { organiz_list org_ip_list listbx var org typ } { + global TOOR_UNL_CELL_INDEX TOOR_UNL_ROLE_INDEX TOOR_UNL_ROLE_TYPE_INDEX + upvar #0 $org list_org + upvar #0 $typ list_typ + ToorSetListContents $listbx 1 $var $org_ip_list $TOOR_UNL_ROLE_INDEX \ + $TOOR_UNL_CELL_INDEX \ + [ ToorGetCellFromOrg $organiz_list $list_org ] \ + $TOOR_UNL_ROLE_TYPE_INDEX $list_typ + +} + +################################################################################ +# +# set list of role_tyes in listbx that correspond to the selected cell +# if an entry matches the value in "var", select it +# calls ToorSetRoleList to update list of possible roles +# +proc ToorSetRoleTypList { organiz_list org_ip_list listbx var role_bx \ + role_var org } { + global TOOR_UNL_CELL_INDEX TOOR_UNL_ROLE_TYPE_INDEX + upvar #0 $org list_org + ToorSetListContents $listbx 1 $var $org_ip_list $TOOR_UNL_ROLE_TYPE_INDEX \ + $TOOR_UNL_CELL_INDEX \ + [ ToorGetCellFromOrg $organiz_list $list_org ] + ToorSetRoleList $organiz_list $org_ip_list $role_bx $role_var $org $var + +} + +################################################################################ +# +# set list of all possible orgainizations, if an entry matches the value in +# "var", select it +# calls ToorSetRoleTypList to update role_type and role lists +# "repop" should be true for the first call and false thereafter since +# the list of available organizations should not change during a run +# +proc ToorSetOrgList { organiz_list org_ip_list listbx repop var role_typ_bx \ + role_typ_var role_bx role_var } { + global TOOR_ORG_ORG_INDEX + ToorSetListContents $listbx $repop $var $organiz_list $TOOR_ORG_ORG_INDEX + ToorSetRoleTypList $organiz_list $org_ip_list $role_typ_bx $role_typ_var \ + $role_bx $role_var $var + +} + +################################################################################ +# +# save value on entry to field +# +proc ToorSaveEntryValue { window } { + global toor_entry_value + set toor_entry_value [$window get] +} + +################################################################################ +# +# On exit from field, see if value has changed, and if so call procedure +# provided +# +proc ToorCheckEntryChange { window changed_proc args } { + global toor_entry_value + set exit_value [$window get] + if { $exit_value != $toor_entry_value } { + lappend arg_list $toor_entry_value $exit_value + set arg_list [ concat $arg_list $args ] + eval $changed_proc $arg_list + } +} + +################################################################################ +# +# On exit from field, see if value has changed, and if so call procedure +# provided, no indication of old & new values passed to called routine +# +proc ToorCallIfChanged { window changed_proc args } { + global toor_entry_value + set exit_value [$window get] + if { $exit_value != $toor_entry_value } { + ToorPleaseWait + eval $changed_proc $args + } +} + +################################################################################ +# +# Display characteristics of this workstation +# +proc ToorDisplayWorkstationConfig { frame state } { + global toor_interfaces + frame $frame + pack $frame -fill x -side top + set intfc [ ToorLabelledSubframe $frame.title current_workstation \ + "THIS WORKSTATION" left 0 ] + set cmd "ToorLabelledRadiobuttons $intfc" + set i_cnt [ expr 4 - [ llength $toor_interfaces ] ] + set pad "" + for { set cnt 0 } { $cnt < $i_cnt } { incr cnt } { + append pad " " + } + append cmd " \"" $pad " Network Interface:" "\" " \ + "toor_vars(new,net_intfc) disabled left 0 " + foreach ifce $toor_interfaces { + append cmd " " $ifce " " $ifce + } + eval $cmd + + set subframe $frame.low + frame $subframe -borderwidth 1 + pack $subframe -fill x -side top -anchor w + ToorDisplayHost $subframe.host toor_vars(new,local_hostname) top disabled + ToorDisplayIp $subframe.ip toor_vars(new,local_ip) top disabled + ToorDisplayOrNameS $subframe.or toor_vars(new,or_name_s) top disabled + ToorDisplayHostId $subframe.id toor_vars(new,hostid) + pack $subframe.host $subframe.ip $subframe.or -side left + pack $subframe.id -side left -anchor e + +} + +################################################################################ +# +# Display characteristics of the workstation serving as the ASAS subsystem +# master +# +proc ToorDisplaySubsystemConfig { frame state } { + frame $frame + pack $frame -fill x -side top + set mas_client [ToorLabelledSubframe $frame.title dce_info \ + "ASAS SUBSYSTEM" left 0 ] + set mas_cli_btn [ToorLabelledSubframe $mas_client this_one \ + " This Workstation is:" left 0 ] + ToorLabelledRadiobuttons $mas_cli_btn "" \ + toor_vars(new,local_is_asas_master) $state left 0 \ + "Master" asasmaster \ + "Client" asasclient + + set lowframe $frame.low + frame $lowframe + pack $lowframe -fill x -side top -anchor w + set leftframe $lowframe.left + frame $leftframe -borderwidth 1 + pack $leftframe -side left -anchor w + set rightframe $lowframe.right + frame $rightframe -borderwidth 1 + pack $rightframe -fill x -side left -anchor e + + ToorDisplayEnclave $leftframe.enclave top disabled + pack $leftframe.enclave -side left + ToorDisplayDomain $leftframe.domain toor_vars(new,nis_domain) top disabled + pack $leftframe.domain -side left + + label $rightframe.label -justify left \ + -text "\nMaster\nis at" + ToorDisplayHost $rightframe.host toor_vars(new,asas_hostname) top disabled + ToorDisplayIp $rightframe.ip toor_vars(new,asas_ip) top disabled + pack $rightframe.label -fill x -side left -anchor w + pack $rightframe.host $rightframe.ip -side left -anchor e + pack $mas_client -side top +} + +################################################################################ +# +# Display characteristics of the DCE Cell and of the workstation serving as the +# DCE CDS and Security master +# +proc ToorDisplayDceConfig { frame state } { + frame $frame + pack $frame -side top -fill x + set mas_client [ToorLabelledSubframe $frame.title dce_info \ + "DCE CONFIGURATION" left 0 ] + set mas_cli_btn [ToorLabelledSubframe $mas_client this_one \ + " This Workstation is:" left 0 ] + ToorLabelledRadiobuttons $mas_cli_btn "" \ + toor_vars(new,local_is_dce_master) $state left 0 \ + "Master" dcemaster \ + "Client" dceclient + + set lowframe $frame.low + frame $lowframe + pack $lowframe -side top -anchor w -fill x + set leftframe $lowframe.left + frame $leftframe -borderwidth 1 + pack $leftframe -side left -anchor w + set rightframe $lowframe.right + frame $rightframe -borderwidth 1 + pack $rightframe -side left -anchor e -fill x + + ToorDisplayDceCell $leftframe.cell_name toor_vars(new,dce_cell) top disabled + pack $leftframe.cell_name -side left + + label $rightframe.label -justify left \ + -text "DCE\nCell\nMaster\nis at" + ToorDisplayHost $rightframe.host toor_vars(new,dce_hostname) top disabled + ToorDisplayIp $rightframe.ip toor_vars(new,dce_ip) top disabled + pack $rightframe.label -side left -anchor w + pack $rightframe.host $rightframe.ip -side left -anchor e + pack $mas_client -side top + +} + +################################################################################ +# +# Display current (at boot time) configuration of workstation, ASAS Subsystem +# and the DCE Cell, ask user if reconfiguration is needed +# +proc ToorDisplayConfig { frame } { + global toor_vars + frame $frame + label $frame.main_title \ + -text "Previous Workstation Configuration\n" + pack $frame.main_title -side top + ToorDisplayWorkstationConfig $frame.f1 disabled + ToorDisplaySubsystemConfig $frame.f2 disabled + ToorDisplayDceConfig $frame.f3 disabled + ToorDisplayBeaconInUse $frame.f4 disabled + label $frame.main_prompt -text \ + "\nDo you want to change this configuration?" + pack $frame.main_prompt -side top + ToorDisplayYesNo $frame.f5 N + ToorDisplaySecondsLeft $frame.f6 + + pack $frame +} + +################################################################################ +# +# Display desired configuration of workstation, ASAS Subsystem +# and the DCE Cell, as updated by preceding dialogs +# +proc ToorDisplayNewConfig { frame } { + global toor_vars + frame $frame + pack $frame + label $frame.main_title \ + -text "Updated Workstation Configuration\n" + pack $frame.main_title -side top + ToorDisplayWorkstationConfig $frame.f1 disabled + ToorDisplaySubsystemConfig $frame.f2 disabled + ToorDisplayDceConfig $frame.f3 disabled + ToorDisplayBeaconInUse $frame.f4 disabled + label $frame.main_prompt -text \ + "\nIs this new configuration correct?" + pack $frame.main_prompt -side top + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "Yes" N \ + "No" Y + pack $frame.btn -side top + + tkwait variable toor_go_back_to_first_menu + + destroy $frame +} + +################################################################################ +# +# Wait for user to select whether he/she wants to change the configuration +# starts timeout timer, if timer expires, assume no change desired +# +proc ToorWantToChangeConfig { } { + global toor_want_to_change_ans toor_seconds_to_go + set toor_seconds_to_go 30 + set toor_want_to_change_ans N + + after 1000 ToorReduceTimeoutClock + tkwait variable toor_want_to_change_ans + return $toor_want_to_change_ans +} + +################################################################################ +# +# Decrease timeout counter by one, when value goes negative, we're done +# +proc ToorReduceTimeoutClock { } { + global toor_seconds_to_go toor_want_to_change_ans + if { $toor_seconds_to_go <= 0 } { + set toor_want_to_change_ans N + } else { + incr toor_seconds_to_go -1 + after 1000 ToorReduceTimeoutClock + } +} + +################################################################################ +# +# User requested no re-config, check if hostid changed -- if it has user +# must either reconfig or shutdown +# +proc ToorCheckHostId { frame } { + global toor_vars toor_done_with_this_frame toor_reconfig_needed \ + toor_domain_suffix \ + TOOR_DATA_DIR TOOR_CELL_ADMIN_PW TOOR_NEW_CONFIG_DIR + + catch { set toor_vars(new,hostid) [ exec /usr/ucb/hostid ] } ret_code + if { $toor_vars(new,hostid) != $toor_vars(orig,hostid) } { + frame $frame + pack $frame + label $frame.main_title \ + -text "! WARNING: This system has moved to a new workstation\n" + pack $frame.main_title -side top + + label $frame.head \ + -text "The new workstation has" + pack $frame.head -side top + ToorDisplayHostId $frame.id toor_vars(new,hostid) + pack $frame.id -side top + + label $frame.prompt_1 \ + -text "\nDo you want to reconfigure the software products to run" + pack $frame.prompt_1 -side top + label $frame.prompt_2 \ + -text "on this workstation" + pack $frame.prompt_2 -side top + + ToorButtonSet $frame.btn Y toor_done_with_this_frame dummy \ + "Yes" Y \ + "Shutdown" N + pack $frame.btn -side top + + tkwait variable toor_done_with_this_frame + + if {$toor_done_with_this_frame == "N"} { + set init_pid 1 + catch { set init_pid [ exec /usr/bin/ps \-ef | \ + /usr/bin/grep /etc/init | + /usr/bin/grep \-v grep | \ + /usr/bin/awk "{print \$2}" ] } ret_code + catch { exec kill -9 $init_pid } ret_code + catch { exec /usr/sbin/halt -l } ret_code + exit -1 + } + + catch { exec /usr/bin/cp -p $TOOR_DATA_DIR/$TOOR_CELL_ADMIN_PW \ + $TOOR_NEW_CONFIG_DIR/$TOOR_CELL_ADMIN_PW } ret_code + + if { $toor_vars(new,nis_domain) == "" } { + set toor_vars(new,nis_domain) \ + "$toor_vars(new,local_hostname).$toor_domain_suffix" + } + if { $toor_vars(new,asas_hostname) == "" } { + set toor_vars(new,asas_hostname) $toor_vars(new,local_hostname) + } + if { $toor_vars(new,asas_ip) == "" } { + set toor_vars(new,asas_ip) $toor_vars(new,local_ip) + } + if { $toor_vars(new,dce_hostname) == "" } { + set toor_vars(new,dce_hostname) $toor_vars(new,local_hostname) + } + if { $toor_vars(new,dce_ip) == "" } { + set toor_vars(new,dce_ip) $toor_vars(new,local_ip) + } + if { $toor_vars(new,dce_cell) == "" } { + set toor_vars(new,dce_cell) [ ToorLookupCellName \ + $toor_vars(new,dce_hostname) \ + $toor_vars(new,dce_ip) ] + } + if { $toor_vars(new,enclave) == "" } { + set toor_vars(new,enclave) "AA" + } + + if { $toor_vars(new,left_video_cmd) == "" } { + ToorSetDisplayParams $frame.id.entry toor_vars(new,left_video) \ + other toor_vars(new,left_video_cmd) + } + if { $toor_vars(new,right_video_cmd) == "" } { + ToorSetDisplayParams $frame.id.entry toor_vars(new,right_video) \ + other toor_vars(new,right_video_cmd) + } + + set toor_reconfig_needed "Y" + + destroy $frame + } +} + +################################################################################ +# +# Select entry in list of potential clients given by $active_index, +# variables for selection box are also modified +# +proc ToorSelectActiveClient { listbx active_index box_list prompt } { + + global toor_vars toor_org toor_type toor_role toor_name toor_ip \ + toor_selected_client toor_update_pending toor_list_changed + + if { $active_index >= [ $listbx size ] } { + incr active_index -1 + } + if { $active_index >= 0 } { + $listbx selection set $active_index + $listbx activate $active_index + set toor_org [ lindex $toor_vars(new,client_org_list) $active_index ] + set toor_type [ lindex $toor_vars(new,client_type_list) $active_index ] + set toor_role [ lindex $toor_vars(new,client_role_list) $active_index ] + set toor_name [ lindex $toor_vars(new,client_name_list) $active_index ] + set toor_ip [ lindex $toor_vars(new,client_ip_list) $active_index ] + set toor_selected_client $active_index + $prompt configure \ + -text "Information About Selected Client Workstation:\n" + set toor_update_pending 0 + set toor_list_changed 0 + } else { + $listbx activate 0 + set toor_org "" + set toor_type "" + set toor_role "" + set toor_name "" + set toor_ip "" + set toor_selected_client -1 + $prompt configure \ + -text "Enter Information About New Client Workstation:\n" + } + ToorSetOrgList toor_organiz_list toor_org_ip_list \ + [ lindex $box_list 0] 0 toor_org \ + [ lindex $box_list 1] toor_type \ + [ lindex $box_list 2] toor_role +} + +################################################################################ +# +# Delete the currently selected client - selection moves to element +# that moves into the vacated position in the list +# +proc ToorDeleteSelectedClient { listbx sel_boxes prompt } { + global toor_vars toor_selected_client toor_update_pending toor_list_changed + + if { [ $listbx size ] > 0 } { + if { $toor_selected_client >= 0 } { + ToorPleaseWait + set active_index [ lindex $toor_selected_client 0 ] + $listbx delete $toor_selected_client + set toor_vars(new,client_org_list) \ + [ lreplace $toor_vars(new,client_org_list) \ + $toor_selected_client $toor_selected_client ] + set toor_vars(new,client_type_list) \ + [ lreplace $toor_vars(new,client_type_list) \ + $toor_selected_client $toor_selected_client ] + set toor_vars(new,client_role_list) \ + [ lreplace $toor_vars(new,client_role_list) \ + $toor_selected_client $toor_selected_client ] + set toor_vars(new,client_name_list) \ + [ lreplace $toor_vars(new,client_name_list) \ + $toor_selected_client $toor_selected_client ] + set toor_vars(new,client_ip_list) \ + [ lreplace $toor_vars(new,client_ip_list) \ + $toor_selected_client $toor_selected_client ] + ToorSelectActiveClient $listbx $toor_selected_client $sel_boxes \ + $prompt + set toor_update_pending 0 + set toor_list_changed 0 + } + } + +} + +################################################################################ +# +# Apply key processing - If no selected entry, becomes new entry +# otherwise is update to selected entry +# +proc ToorApplyClientUpdate { listbx sel_boxes prompt next_window } { + global toor_vars toor_go_back_to_first_menu \ + toor_org toor_type toor_role toor_name toor_ip \ + toor_selected_client toor_update_pending toor_list_changed + + # first check that entry is OK + + ToorDestroyEntryErrorsList + + set err_list {} + ToorAddToErrorList err_list "Host Name" \ + [ ToorCheckHostname $toor_name ] + ToorAddToErrorList err_list "Client & Local Host Names" \ + [ ToorCheckNameUnique $toor_name \ + $toor_vars(new,local_hostname) ] + if { $toor_vars(new,fddi_used) == "Y" } { + ToorAddToErrorList err_list "Client & FDDI/CDDI Host Names" \ + [ ToorCheckNameUnique $toor_name \ + $toor_vars(new,fddi_hostname) ] + } + set this_index 0 + foreach name $toor_vars(new,client_name_list) { + if { $toor_selected_client != $this_index } { + ToorAddToErrorList err_list "New & Existing Client Host Names" \ + [ ToorCheckNameUnique $toor_name $name ] + } + incr this_index + } + + ToorAddToErrorList err_list "IP Address" \ + [ ToorCheckIPAddr $toor_ip ] + ToorAddToErrorList err_list "Client & Local IP Addresses" \ + [ ToorCheckIPUnique $toor_ip \ + $toor_vars(new,local_ip) ] + if { $toor_vars(new,fddi_used) == "Y" } { + ToorAddToErrorList err_list "Client & FDDI/CDDI IP Addresses" \ + [ ToorCheckIPUnique $toor_ip \ + $toor_vars(new,fddi_ip) ] + } + set this_index 0 + foreach ip $toor_vars(new,client_ip_list) { + if { $toor_selected_client != $this_index } { + ToorAddToErrorList err_list "New & Existing Client IP Addresses" \ + [ ToorCheckIPUnique $toor_ip $ip ] + } + incr this_index + } + ToorAddToErrorList err_list "Organization" \ + [ ToorCheckOptOganization $toor_org ] + ToorAddToErrorList err_list "Role Type" \ + [ ToorCheckOptRoleType $toor_type ] + ToorAddToErrorList err_list "Role" \ + [ ToorCheckOptRole $toor_role ] + set ready_to_apply [ eval ToorDisplayErrors \ + {"Client Workstations in this ASAS Subsystem"} \ + $err_list ] + + if { $ready_to_apply } { + ToorPleaseWait + if { [ string length $toor_name ] < 20 } { + set cname [ string range $toor_name 0 19 ] + } else { + set cname $toor_name + } + set line [ format {%-20s %-15s} $cname $toor_ip ] + + if { $toor_selected_client >= 0 } { + + # there is a selected entry, replace it + $listbx delete $toor_selected_client + $listbx insert $toor_selected_client "$line" + set toor_vars(new,client_org_list) \ + [ lreplace $toor_vars(new,client_org_list) \ + $toor_selected_client \ + $toor_selected_client $toor_org ] + set toor_vars(new,client_type_list) \ + [ lreplace $toor_vars(new,client_type_list) \ + $toor_selected_client \ + $toor_selected_client $toor_type ] + set toor_vars(new,client_role_list) \ + [ lreplace $toor_vars(new,client_role_list) \ + $toor_selected_client \ + $toor_selected_client $toor_role ] + set toor_vars(new,client_name_list) \ + [ lreplace $toor_vars(new,client_name_list) \ + $toor_selected_client \ + $toor_selected_client $toor_name ] + set toor_vars(new,client_ip_list) \ + [ lreplace $toor_vars(new,client_ip_list) \ + $toor_selected_client \ + $toor_selected_client $toor_ip ] + } else { + + # no entry selected, this is a new client + set active_index [ $listbx index active ] + set toor_selected_client $active_index + $listbx insert $active_index "$line" + set toor_vars(new,client_org_list) \ + [ linsert $toor_vars(new,client_org_list) \ + $active_index $toor_org ] + set toor_vars(new,client_type_list) \ + [ linsert $toor_vars(new,client_type_list) \ + $active_index $toor_type ] + set toor_vars(new,client_role_list) \ + [ linsert $toor_vars(new,client_role_list) \ + $active_index $toor_role ] + set toor_vars(new,client_name_list) \ + [ linsert $toor_vars(new,client_name_list) \ + $active_index $toor_name ] + set toor_vars(new,client_ip_list) \ + [ linsert $toor_vars(new,client_ip_list) \ + $active_index $toor_ip ] + } + + ToorSelectActiveClient $listbx $toor_selected_client $sel_boxes \ + $prompt + set toor_update_pending 0 + set toor_list_changed 0 + + focus $next_window + + } + + return $ready_to_apply + +} + +################################################################################ +# +# Allow entry of a new client workstation entry +# +proc ToorDesignateNewClient { listbx enter box_list prompt } { + global toor_org toor_type toor_role toor_name toor_ip toor_selected_client \ + toor_organiz_list toor_org_ip_list toor_update_pending + + ToorPleaseWait + $listbx selection clear 0 end + focus $enter + set toor_org "" + set toor_type "" + set toor_role "" + set toor_name "" + set toor_ip "" + set toor_selected_client -1 + set toor_update_pending 1 + $prompt configure -text "Enter Information About New Client Workstation:\n" + ToorSetOrgList toor_organiz_list toor_org_ip_list \ + [ lindex $box_list 0] 0 toor_org \ + [ lindex $box_list 1] toor_type \ + [ lindex $box_list 2] toor_role + +} + +################################################################################ +# +# Warn about pending changes and see if save needed +# +proc ToorWarnAboutChanges { } { + global toor_warn_reply + + toplevel .warn -borderwidth 1 + label .warn.msg1 -text "? You have made changes " + pack .warn.msg1 -side top -anchor w + label .warn.msg2 -text " Do you want to save the changes?\n" + pack .warn.msg2 -side top -anchor w + ToorButtonSet .warn.btn Y toor_warn_reply dummy \ + "Yes" Y \ + "No" N \ + "Cancel" C + pack .warn.btn -side top + grab .warn + + tkwait variable toor_warn_reply + + destroy .warn +} + +################################################################################ +# +# Sets toor_update_pending to signal that a change has been made to one of +# the data entry fields, and has not yet been applied. args are ignored +# +proc ToorSetChangePending { args } { + global toor_update_pending + + set toor_update_pending 1 +} + +################################################################################ +# +# Record when a field's contents changes +# +proc ToorRecordUpdates { flds } { + upvar $flds fields + + foreach entry_field $fields { + bind $entry_field "+ToorSaveEntryValue $entry_field" + bind $entry_field "+ToorCheckEntryChange $entry_field \ + ToorSetChangePending " + } +} + +################################################################################ +# +# Remove any entry from the list of potential cllients that has the +# same hostname or IP address as either the Ethernet or FDDI interface +# +proc ToorRemoveDuplicateHosts { } { + global toor_vars + + set index [ llength $toor_vars(new,client_name_list) ] + for { incr index -1 } { $index >= 0 } { incr index -1 } { + set name [ lindex $toor_vars(new,client_name_list) $index ] + set ip [ lindex $toor_vars(new,client_ip_list) $index ] + if { $name == $toor_vars(new,local_hostname) \ + || $ip == $toor_vars(new,local_ip) \ + || ( $toor_vars(new,fddi_used) == "Y" \ + && ( $name == $toor_vars(new,fddi_hostname) + || $ip == $toor_vars(new,fddi_ip))) } { + set toor_vars(new,client_org_list) \ + [ lreplace $toor_vars(new,client_org_list) $index $index ] + set toor_vars(new,client_type_list) \ + [ lreplace $toor_vars(new,client_type_list) $index $index ] + set toor_vars(new,client_role_list) \ + [ lreplace $toor_vars(new,client_role_list) $index $index ] + set toor_vars(new,client_name_list) \ + [ lreplace $toor_vars(new,client_name_list) $index $index ] + set toor_vars(new,client_ip_list) \ + [ lreplace $toor_vars(new,client_ip_list) $index $index ] + } + } +} + +################################################################################ +# +# If workstation is a subsystem master, get list of client machines +# +proc ToorGetClients { frame } { + global toor_vars toor_go_back_to_first_menu TOOR_OR_NAME_FILE \ + toor_org toor_type toor_role toor_name toor_ip \ + toor_update_pending toor_warn_reply toor_list_changed + + set toor_org "" + set toor_type "" + set toor_role "" + set toor_name "" + set toor_ip "" + + set toor_entry_list {} + set toor_select_list {} + set defined_list {} + + set toor_update_pending 0 + set toor_list_changed 0 + set toor_warn_reply Y + + ToorRemoveDuplicateHosts + + frame $frame + pack $frame + label $frame.main_title \ + -text "Client Workstations in this ASAS Subsystem\n" + pack $frame.main_title -side top + + set scrolled [ frame $frame.scrolled ] + pack $scrolled -side top + label $scrolled.title -text " Host Name IP Address" + pack $scrolled.title -side top -anchor w + set sb [ frame $scrolled.sb ] + pack $sb -side top + scrollbar $sb.scroll -command "$sb.list yview" -takefocus 0 + listbox $sb.list -yscroll "$sb.scroll set" -height 3 \ + -width 40 -selectmode single + pack $sb.scroll -side right -fill y + pack $sb.list -side left -fill both + + set index 0 + foreach name $toor_vars(new,client_name_list) { + if { [ string length $name ] < 20 } { + set cname [ string range $name 0 19 ] + } else { + set cname $name + } + set line [ format {%-20s %-15s} $cname \ + [ lindex $toor_vars(new,client_ip_list) $index ] ] + incr index + lappend defined_list $line + } + eval [ concat "$sb.list" "insert" "end" $defined_list ] + $sb.list yview 0 + $sb.list selection clear 0 end + + if { [ llength $toor_vars(new,client_name_list) ] > 0 } { + set active_index 0 + } else { + set active_index -1 + } + + set client [ frame $frame.client -borderwidth 1 ] + pack $client -side top + label $client.info \ + -text "Information About Selected Client Workstation:\n" + pack $client.info -side top + + # set up command to update other info when selection changes + set cmd [ ToorCmdToUpdateHostFromList toor_org toor_type toor_role \ + toor_name toor_ip \ + toor_dummy toor_dummy2 toor_dummy3 \ + $TOOR_OR_NAME_FILE ] + + ToorLabelledRadiobuttons $client.select "Data Entry Method:" \ + toor_vars(new,list_selection) normal left 0 \ + "Select From Lists" 1 \ + "Type Information" 0 + + label $client.space -text " " + pack $client.space -side top + set clienth [ frame $client.top ] + set csl [ frame $client.csl ] + set csa [ frame $client.csa ] + pack $clienth $csl $csa -side top -fill x -anchor w + ToorDisplayHost $clienth.host toor_name left normal + pack $clienth.host -side left + ToorDisplayIp $clienth.ip toor_ip left normal + pack $clienth.ip -side left -anchor e + + ToorUnitSelectionLists $csl.lists toor_entry_list toor_select_list \ + toor_organiz_list toor_org_ip_list \ + toor_org toor_type toor_role \ + $cmd + + ToorButtonSet $csa.btn "" toor_apply dummy \ + "Apply" A + pack $csa.btn -side top + + ToorSelectActiveClient $sb.list $active_index $toor_select_list $client.info + + ToorSetListBindings $sb.list 1 \ + [ format {ToorPleaseWait ; ToorSelectActiveClient %s \ + [ %s index active ] %s %s } \ + $sb.list $sb.list [ list $toor_select_list ] \ + $client.info ] + + lappend toor_entry_list $clienth.host.entry $clienth.ip.entry + + ToorPropagateNameChange $clienth.host.entry toor_ip \ + toor_dummy toor_dummy2 toor_dummy3 \ + toor_org toor_type toor_role \ + $TOOR_OR_NAME_FILE \ + $toor_select_list + + ToorRecordUpdates toor_entry_list + + ToorActivateEntryMethod $toor_select_list $toor_entry_list \ + $client.select.buttons + + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "Done" N \ + "New" A \ + "Delete" D \ + "Cancel" Y + + $csa.btn.b1 configure -command " ToorApplyClientUpdate $sb.list \ + [ list $toor_select_list ] \ + $client.info $frame.btn.b7 " + $frame.btn.b3 configure -command " ToorDeleteSelectedClient $sb.list \ + [ list $toor_select_list ] $client.info " + $frame.btn.b5 configure -command " ToorDesignateNewClient $sb.list \ + $client.select.buttons.1 \ + [ list $toor_select_list ] $client.info " + pack $frame.btn -side top + + update + ToorPleaseWait + ToorSetOrgList toor_organiz_list toor_org_ip_list \ + [ lindex $toor_select_list 0 ] 1 toor_org \ + [ lindex $toor_select_list 1 ] toor_type \ + [ lindex $toor_select_list 2 ] toor_role + + set ready_to_exit F + while { $ready_to_exit == "F" } { + + tkwait variable toor_go_back_to_first_menu + + ToorDestroyEntryErrorsList + + if { $toor_go_back_to_first_menu == "Y" } { + set ready_to_exit T + } else { + if { $toor_update_pending || $toor_list_changed } { + ToorWarnAboutChanges + if { $toor_warn_reply == "N" } { + set ready_to_exit T + } elseif { $toor_warn_reply == "Y" } { + if { [ToorApplyClientUpdate $sb.list \ + $toor_select_list \ + $client.info $frame.btn.b7 ]} { + set ready_to_exit T + } + } + } else { + set ready_to_exit T + } + } + } + + ToorPleaseWait + + destroy $frame + +} + +################################################################################ +# +# Enable a window if a variable has a specific value +# +proc ToorEnableWindowOnValue { window variable value } { + upvar $variable his_var + if {$his_var == $value} { + $window configure -state normal + } else { + $window configure -state disabled + } +} + +################################################################################ +# +# If workstation is a subsystem client, remind user that master must know about +# this client +# +proc ToorWarnClient { frame } { + global toor_go_back_to_first_menu toor_vars + + frame $frame + pack $frame + label $frame.line1 -text "! This workstation's hostname and IP address" + pack $frame.line1 -side top + label $frame.line2 -text "must have been identified to workstation" + pack $frame.line2 -side top + label $frame.line3 -text "\"$toor_vars(new,asas_hostname)\" or this " + pack $frame.line3 -side top + label $frame.line4 -text "reconfiguration may fail\n" + pack $frame.line4 -side top + + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "OK" N \ + "Cancel" Y + pack $frame.btn -side top + + tkwait variable toor_go_back_to_first_menu + + ToorPleaseWait + + destroy $frame +} + +################################################################################ +# +# Get information on subsystem master if this machine is a client and +# information on the domain and enclave if this workstation is a +# subsystem master +# +proc ToorGetAsasSubConfig { frame next } { + global toor_vars toor_domain_suffix toor_entry_list toor_select_list \ + TOOR_OR_NAME_FILE + if { [winfo exists $frame.local] } { + destroy $frame.local + } + if { [winfo exists $frame.master] } { + destroy $frame.master + } + + if { $toor_vars(new,local_is_asas_master) == "asasmaster" } { + + set subfr [ frame $frame.local ] + pack $subfr -fill x -side top -anchor w + ToorDisplayEnclave $subfr.enclave left normal + if { $toor_vars(orig,local_is_asas_master) != "asasmaster" || \ + $toor_vars(new,local_hostname) != $toor_vars(orig,local_hostname) \ + || $toor_vars(new,local_ip) != $toor_vars(orig,local_ip) \ + } { + set toor_vars(new,asas_hostname) $toor_vars(new,local_hostname) + set toor_vars(new,asas_ip) $toor_vars(new,local_ip) + set toor_vars(new,mst_organiz) $toor_vars(new,our_organiz) + set toor_vars(new,mst_role_typ) $toor_vars(new,our_role_typ) + set toor_vars(new,mst_role) $toor_vars(new,our_role) + + set toor_vars(new,nis_domain) \ + "$toor_vars(new,local_hostname).$toor_domain_suffix" + } + ToorDisplayDomain $subfr.domain toor_vars(new,nis_domain) top normal + pack $subfr.domain -side left + + set toor_vars(new,local_is_dce_master) \ + $toor_vars(orig,local_is_dce_master) + + # destroy tab bindings in case were previously configured as a client + bind $next {} + bind $next {} + + } else { + set toor_entry_list {} + set toor_select_list {} + set toor_vars(new,asas_hostname) $toor_vars(orig,asas_hostname) + set toor_vars(new,asas_ip) $toor_vars(orig,asas_ip) + set toor_vars(new,mst_organiz) $toor_vars(orig,mst_organiz) + set toor_vars(new,mst_role_typ) $toor_vars(orig,mst_role_typ) + set toor_vars(new,mst_role) $toor_vars(orig,mst_role) + + set toor_vars(new,enclave) $toor_vars(orig,enclave) + set toor_vars(new,nis_domain) $toor_vars(orig,nis_domain) + set sframe [ToorLabelledSubframe $frame.master current_workstation \ + "Where is the ASAS Subsystem Master?\n" top 0 ] + pack $frame.master + pack $sframe -side top + set subframe [ frame $sframe.top ] + set low [ frame $sframe.low ] + pack $subframe $low -side top + # set up command to update other info when selection changes + set cmd [ ToorCmdToUpdateHostFromList toor_vars(new,mst_organiz) \ + toor_vars(new,mst_role_typ) \ + toor_vars(new,mst_role) \ + toor_vars(new,asas_hostname) \ + toor_vars(new,asas_ip) \ + toor_dummy \ + toor_dummy2 \ + toor_dummy3 \ + $TOOR_OR_NAME_FILE ] + + ToorLabelledRadiobuttons $subframe.select "Data Entry Method:" \ + toor_vars(new,list_selection) normal left 0 \ + "Select From Lists" 1 \ + "Type Information" 0 + + ToorDisplayHost $subframe.host toor_vars(new,asas_hostname) left \ + normal + pack $subframe.host -side left + ToorDisplayIp $subframe.ip toor_vars(new,asas_ip) left normal + pack $subframe.ip -side left -anchor e + + ToorUnitSelectionLists $low.lists toor_entry_list \ + toor_select_list \ + toor_organiz_list toor_org_ip_list \ + toor_vars(new,mst_organiz) \ + toor_vars(new,mst_role_typ) \ + toor_vars(new,mst_role) \ + $cmd + + lappend toor_entry_list $subframe.host.entry $subframe.ip.entry + + ToorPropagateNameChange $subframe.host.entry toor_vars(new,asas_ip) \ + toor_dummy toor_dummy2 toor_dummy3 \ + toor_vars(new,mst_organiz) \ + toor_vars(new,mst_role_typ) \ + toor_vars(new,mst_role) $TOOR_OR_NAME_FILE \ + $toor_select_list + + update + ToorPleaseWait + ToorSetOrgList toor_organiz_list toor_org_ip_list \ + [ lindex $toor_select_list 0 ] 1 toor_vars(new,mst_organiz) \ + [ lindex $toor_select_list 1 ] toor_vars(new,mst_role_typ) \ + [ lindex $toor_select_list 2 ] toor_vars(new,mst_role) + + ToorActivateEntryMethod $toor_select_list $toor_entry_list \ + $subframe.select.buttons + + + if { $toor_vars(orig,local_is_asas_master) == "asasmaster" } { + set toor_vars(new,local_is_dce_master) dceclient + } + } + +} + +################################################################################ +# +# Display current "beacon use" and ASAS subsystem master/client status and +# prompt user for updated values +# +proc ToorGetTopConfig { frame } { + global toor_go_back_to_first_menu toor_vars + frame $frame + pack $frame -fill both + label $frame.main_title \ + -text "Workstation Configuration\n" + pack $frame.main_title -side top + label $frame.beacont -text "Should the Address Book and Beacon be used?" + pack $frame.beacont -side top -anchor w + + ToorLabelledRadiobuttons $frame.beacon "" \ + toor_vars(new,beacon_is_being_used) normal left 0 \ + "Yes" beacon \ + "No" nobeacon + + label $frame.sdrt -text "\nIs the Local Area Network connected to a slow-speed router?\n(e.g. SDR, Tactical Radio or Modem in use)" + pack $frame.sdrt -side top -anchor w + ToorLabelledRadiobuttons $frame.sdr "" \ + toor_vars(new,sdr) normal left 0 \ + "Yes" sdr \ + "No" nosdr + + label $frame.asast -text \ + "\nWithin the ASAS subsystem, this workstation should be the" + pack $frame.asast -side top -anchor w + ToorLabelledRadiobuttons $frame.asas "" \ + toor_vars(new,local_is_asas_master) normal \ + left 0 \ + "Master" asasmaster \ + "Client" asasclient + + frame $frame.varframe -borderwidth 1 + pack $frame.varframe -fill x -side top + + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "Done" N \ + "Cancel" Y + pack $frame.btn -side top + + ToorGetAsasSubConfig $frame.varframe $frame.btn.b3 + + $frame.asas.buttons.asasmaster configure \ + -command "ToorGetAsasSubConfig $frame.varframe $frame.btn.b3" + $frame.asas.buttons.asasclient configure \ + -command "ToorPleaseWait ; \ + ToorGetAsasSubConfig $frame.varframe $frame.btn.b3" + + set ready_to_exit F + while { $ready_to_exit == "F" } { + + tkwait variable toor_go_back_to_first_menu + + ToorDestroyEntryErrorsList + + if { $toor_go_back_to_first_menu == "Y" } { + set ready_to_exit T + } else { + set err_list {} + if { $toor_vars(new,local_is_asas_master) == "asasmaster" } { + if { $toor_vars(new,enclave) != "" } { + ToorAddToErrorList err_list "Enclave" \ + [ ToorCheckEnclaveCode $toor_vars(new,enclave) ] + } + ToorAddToErrorList err_list "Domain" \ + [ ToorCheckDomainname $toor_vars(new,nis_domain) ] + } else { + + ToorAddToErrorList err_list "Host Name" \ + [ ToorCheckHostname $toor_vars(new,asas_hostname) ] + ToorAddToErrorList err_list "Master & Local Host Names" \ + [ ToorCheckNameUnique $toor_vars(new,asas_hostname) \ + $toor_vars(new,local_hostname) ] + ToorAddToErrorList err_list "IP Address" \ + [ ToorCheckIPAddr $toor_vars(new,asas_ip) ] + ToorAddToErrorList err_list "Master & Local IP Addresses" \ + [ ToorCheckIPUnique $toor_vars(new,asas_ip) \ + $toor_vars(new,local_ip) ] + ToorAddToErrorList err_list "Organization" \ + [ ToorCheckOptOganization $toor_vars(new,mst_organiz)] + ToorAddToErrorList err_list "Role Type" \ + [ ToorCheckOptRoleType $toor_vars(new,mst_role_typ) ] + ToorAddToErrorList err_list "Role" \ + [ ToorCheckOptRole $toor_vars(new,mst_role) ] + } + set ready_to_exit [ eval ToorDisplayErrors \ + {"Workstation Configuration"} \ + $err_list ] + } + } + + if { $toor_vars(new,enclave) == "" } { + set toor_vars(new,enclave) "AA" + } + + if { $toor_vars(new,local_is_asas_master) == "asasclient" } { + set toor_vars(new,enclave) "??" + set toor_vars(new,nis_domain) "Will Fetch From Master" + } + + ToorPleaseWait + + destroy $frame + + if { $toor_go_back_to_first_menu == "N" } { + if { $toor_vars(new,local_is_asas_master) == "asasmaster" } { + ToorGetClients $frame + } else { + ToorWarnClient $frame + } + } +} + +################################################################################ +# +# Set bindings so user can use either space or return to select entries on a +# listbox. Selection causes to named proc to be invoked +# +proc ToorSetListBindings { listbx last proc } { + bind $listbx $proc + bind $listbx $proc + bind $listbx {+focus [tk_focusNext %W]} + bind $listbx {+focus [tk_focusNext %W]} + if { ! $last } { + bind $listbx {+set toor_list_changed 1} + bind $listbx {+set toor_list_changed 1} + } +} + +################################################################################ +# +# Set bindings for entry boxes associated with selection lists to call proc +# when focus is lost and the value has been changed +# +proc ToorSetEntryForListBindings { entrybx proc } { + bind $entrybx "+ToorSaveEntryValue $entrybx" + bind $entrybx "+ToorCallIfChanged $entrybx $proc " +} + +################################################################################ +# +# Create selection lists for org/role type/role +# +proc ToorUnitSelectionLists { frame e_list s_list organiz_list org_ip_list \ + organiz role_typ role proc } { + global toor_list_changed + upvar 1 $e_list entry_list + upvar 1 $s_list select_list + + catch {destroy $frame} err_code + frame $frame + set toor_list_changed 0 + + set org_list [ ToorDisplayList $frame.org "Organization:" 3 25 \ + $organiz left entry_list ] + set role_type_list [ ToorDisplayList $frame.type "Role Type:" 3 8 \ + $role_typ left entry_list ] + set role_list [ ToorDisplayList $frame.role "Role:" 3 15 \ + $role left entry_list ] + + lappend select_list $org_list $role_type_list $role_list + + ToorSetListBindings $org_list 0 "ToorSetEntryFromList $organiz $org_list \ + { ToorSetRoleTypList $organiz_list $org_ip_list \ + $role_type_list $role_typ $role_list \ + $role $organiz}" + + ToorSetListBindings $role_type_list 0 \ + "ToorSetEntryFromList $role_typ $role_type_list \ + { ToorSetRoleList $organiz_list $org_ip_list $role_list \ + $role $organiz $role_typ }" + + ToorSetListBindings $role_list 1 "ToorSetEntryFromList $role $role_list \ + { $proc ; set toor_list_changed 0 }" + + set cmd { if { $toor_list_changed } } + lappend cmd " $proc ; set toor_list_changed 0 " + + bind $role_list "+$cmd" + bind $org_list "+$cmd" + + ToorSetEntryForListBindings [ lindex $entry_list 0 ] \ + "ToorSetOrgList $organiz_list $org_ip_list $org_list 0 $organiz \ + $role_type_list $role_typ $role_list $role " + ToorSetEntryForListBindings [ lindex $entry_list 1 ] \ + "ToorSetRoleTypList $organiz_list $org_ip_list $role_type_list \ + $role_typ $role_list $role $organiz " + ToorSetEntryForListBindings [ lindex $entry_list 2 ] \ + "ToorSetRoleList $organiz_list $org_ip_list $role_list $role \ + $organiz $role_typ " + + pack $frame + +} + +################################################################################ +# +# Set Organization/Role Type/Role based on host name +# +proc ToorSetOrgRoleFromHost { old_host host organiz_list org_ip_list org \ + role_type role org_listbx type_listbx role_listbx} { + global TOOR_UNL_HOST_INDEX TOOR_UNL_ROLE_INDEX \ + TOOR_UNL_ROLE_TYPE_INDEX TOOR_ORG_CELL_INDEX TOOR_ORG_ORG_INDEX + + upvar #0 $org up_org + upvar #0 $role_type up_role_type + upvar #0 $role up_role + upvar #0 $organiz_list org_list + upvar #0 $org_ip_list ip_list + + ToorPleaseWait + + set found 0 + foreach org_ip_line $ip_list { + if { [ llength $org_ip_line ] > $TOOR_UNL_ROLE_TYPE_INDEX } { + if { $host == [ lindex $org_ip_line $TOOR_UNL_HOST_INDEX ] } { + set local_role [ lindex $org_ip_line $TOOR_UNL_ROLE_INDEX ] + set local_cell [ lindex $org_ip_line $TOOR_ORG_CELL_INDEX ] + set local_role_type [ lindex $org_ip_line \ + $TOOR_UNL_ROLE_TYPE_INDEX ] + set found 1 + break + } + } + } + + if { $found } { + set found 0 + foreach org_line $org_list { + if { [ llength $org_line ] > $TOOR_ORG_ORG_INDEX } { + if { $local_cell == [lindex $org_line $TOOR_ORG_CELL_INDEX] } { + set local_org [ lindex $org_line $TOOR_ORG_ORG_INDEX ] + set found 1 + break + } + } + } + } + + if { $found } { + if { $local_role != "" } { + set up_role $local_role + } + if { $local_role_type != "" } { + set up_role_type $local_role_type + } + if { $local_org != "" } { + set up_org $local_org + } + ToorSetOrgList $organiz_list $org_ip_list $org_listbx 0 $org \ + $type_listbx $role_type $role_listbx $role + } +} + +################################################################################ +# +# Format command to set hostname and associated fields to values that +# correspond to the entries selected in the lists +# +proc ToorCmdToUpdateHostFromList { org_var type_var role_var host_var \ + ip_var or_var uic_var urn_var or_file } { + + global TOOR_LAST_CONFIG_DIR \ + TOOR_UNL_HOST_INDEX TOOR_UNL_CELL_INDEX TOOR_UNL_ROLE_TYPE_INDEX \ + TOOR_UNL_ROLE_INDEX + + set cmd [ format {set tmp [ ToorGetUnlList toor_org_ip_list %s %s \ + [ ToorGetCellFromOrg toor_organiz_list $%s ] \ + %s $%s %s $%s ] ; if {$tmp != ""}} \ + $TOOR_UNL_HOST_INDEX $TOOR_UNL_CELL_INDEX \ + $org_var $TOOR_UNL_ROLE_TYPE_INDEX $type_var \ + $TOOR_UNL_ROLE_INDEX $role_var ] + set sub_cmd [ format {set %s [ lindex $tmp 0 ] ; \ + ToorNameChanged $%s $%s %s %s %s %s %s}\ + $host_var $host_var $host_var $ip_var $or_var $uic_var \ + $urn_var "$TOOR_LAST_CONFIG_DIR/$or_file" ] + lappend cmd $sub_cmd + + return $cmd +} + +################################################################################ +# +# Propagate host name changes to related fields +# +proc ToorPropagateNameChange { host_entry ip_var or_var uic_var urn_var \ + org_var type_var role_var or_file box_list } { + global TOOR_LAST_CONFIG_DIR + + bind $host_entry "+ToorSaveEntryValue $host_entry" + bind $host_entry "+ToorCheckEntryChange $host_entry \ + ToorNameChanged $ip_var \ + $or_var $uic_var $urn_var \ + $TOOR_LAST_CONFIG_DIR/$or_file " + bind $host_entry "+ToorCheckEntryChange $host_entry \ + ToorSetOrgRoleFromHost toor_organiz_list \ + toor_org_ip_list \ + $org_var $type_var $role_var \ + [ lindex $box_list 0] \ + [ lindex $box_list 1] \ + [ lindex $box_list 2]" +} + +################################################################################ +# +# Select proper set of windows for selection method (list selection or typing) +# chosen by user, and set to update when button pressed +# +proc ToorActivateEntryMethod { select_list entry_list select_btn } { + + global toor_vars + + set list_cmd "ToorSelectEntryMethod {$select_list} {$entry_list} \ + toor_vars(new,list_selection)" + eval $list_cmd + $select_btn.0 configure -command $list_cmd + $select_btn.1 configure -command $list_cmd + +} + +################################################################################ +# +# Display "Please Wait" +# +proc ToorPleaseWait { } { + + if { ! [ winfo exists .wait ] } { + toplevel .wait -borderwidth 1 + label .wait.main_title -text "\nPlease Wait\n" + pack .wait.main_title -side top + update + destroy .wait + } +} + +################################################################################ +# +# Allow user to specify new configuration for local workstation +# +proc ToorGetLocalConfig { frame } { + global toor_go_back_to_first_menu toor_vars \ + toor_organiz_list toor_org_ip_list \ + TOOR_OR_NAME_FILE toor_interfaces toor_fddi_present + + set toor_entry_list {} + set toor_select_list {} + + frame $frame + pack $frame + label $frame.main_title \ + -text "Workstation Network Configuration\n" + pack $frame.main_title -side top + + + set local_info [ToorLabelledSubframe $frame.title local \ + "This Workstation's Configuration" top 1 ] + set top [frame $local_info.top] + set mid [frame $local_info.mid] + set low [frame $local_info.low] + pack $top $mid $low -side top -fill x + + # set up command to update other info when selection changes + set cmd [ ToorCmdToUpdateHostFromList toor_vars(new,our_organiz) \ + toor_vars(new,our_role_typ) \ + toor_vars(new,our_role) \ + toor_vars(new,local_hostname) \ + toor_vars(new,local_ip) \ + toor_vars(new,or_name) \ + toor_vars(new,uic) \ + toor_vars(new,our_urn) \ + $TOOR_OR_NAME_FILE ] + + ToorLabelledRadiobuttons $top.select "Data Entry Method:" \ + toor_vars(new,list_selection) normal left 0 \ + "Select From Lists" 1 \ + "Type Information" 0 + + label $top.space -text " " + pack $top.space -side top + + ToorDisplayHost $top.host toor_vars(new,local_hostname) left normal + ToorDisplayIp $top.ip toor_vars(new,local_ip) left normal + pack $top.host $top.ip -side left + ToorDisplayUic $top.uic toor_vars(new,uic) left top normal + ToorDisplayOrName $mid.or toor_vars(new,or_name) left normal + pack $mid.or -side left + ToorDisplayUrn $mid.urn toor_vars(new,our_urn) left left normal + + label $low.spacer -text " " + pack $low.spacer -side top + + ToorUnitSelectionLists $low.lists toor_entry_list toor_select_list \ + toor_organiz_list toor_org_ip_list \ + toor_vars(new,our_organiz) \ + toor_vars(new,our_role_typ) \ + toor_vars(new,our_role) \ + $cmd + + lappend toor_entry_list $top.host.entry $top.ip.entry $top.uic.entry \ + $mid.or.entry $mid.urn.entry + + set cmd "ToorLabelledRadiobuttons $frame.le {Network Interface:} \ + toor_vars(new,net_intfc) normal left 0 " + foreach ifce $toor_interfaces { + append cmd " " $ifce " " $ifce + } + eval $cmd + + label $frame.spacer -text " " + pack $frame.spacer -side top + + if { $toor_fddi_present } { + ToorLabelledRadiobuttons $frame.fddi \ + "Is the FDDI or CDDI Interface in Use?" \ + toor_vars(new,fddi_used) normal \ + left 0 \ + "Yes" Y \ + "No" N + pack $frame.fddi -side top + label $frame.space1 -text " " + pack $frame.space1 -side top + } + + + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "Done" N \ + "Cancel" Y + pack $frame.btn -side top + + catch { set toor_vars(new,hostid) [ exec /usr/ucb/hostid ] } ret_code + + update + ToorPleaseWait + ToorSetOrgList toor_organiz_list toor_org_ip_list \ + [ lindex $toor_select_list 0 ] 1 toor_vars(new,our_organiz) \ + [ lindex $toor_select_list 1 ] toor_vars(new,our_role_typ) \ + [ lindex $toor_select_list 2 ] toor_vars(new,our_role) + + ToorPropagateNameChange $top.host.entry toor_vars(new,local_ip) \ + toor_vars(new,or_name) toor_vars(new,uic) \ + toor_vars(new,our_urn) toor_vars(new,our_organiz) \ + toor_vars(new,our_role_typ) \ + toor_vars(new,our_role) $TOOR_OR_NAME_FILE \ + $toor_select_list + + ToorActivateEntryMethod $toor_select_list $toor_entry_list \ + $top.select.buttons + + set ready_to_exit F + while { $ready_to_exit == "F" } { + + tkwait variable toor_go_back_to_first_menu + + ToorDestroyEntryErrorsList + + if { $toor_go_back_to_first_menu == "Y" } { + set ready_to_exit T + } else { + set err_list {} + ToorAddToErrorList err_list "Host Name" \ + [ ToorCheckHostname $toor_vars(new,local_hostname) ] + ToorAddToErrorList err_list "IP Address" \ + [ ToorCheckIPAddr $toor_vars(new,local_ip) ] + ToorAddToErrorList err_list "O/R Name" \ + [ ToorCheckORName toor_vars(new,or_name) ] + ToorAddToErrorList err_list "UIC" \ + [ ToorCheckUIC $toor_vars(new,uic) ] + ToorAddToErrorList err_list "URN" \ + [ ToorCheckURN $toor_vars(new,our_urn) ] + ToorAddToErrorList err_list "Organization" \ + [ ToorCheckOganization $toor_vars(new,our_organiz) ] + ToorAddToErrorList err_list "Role Type" \ + [ ToorCheckRoleType $toor_vars(new,our_role_typ) ] + ToorAddToErrorList err_list "Role" \ + [ ToorCheckRole $toor_vars(new,our_role) ] + + set ready_to_exit [ eval ToorDisplayErrors \ + {"Workstation Network Configuration"} \ + $err_list ] + } + } + + set toor_vars(new,or_name_s) [string trim $toor_vars(new,or_name)] + + ToorPleaseWait + + destroy $frame +} + +################################################################################ +# +# Allow user to specify new fddi/cddi configuration for local workstation +# +proc ToorGetFddiConfig { frame } { + global toor_go_back_to_first_menu toor_vars \ + toor_organiz_list toor_org_ip_list \ + TOOR_FDDI_OR_NAME_FILE + + set toor_entry_list {} + set toor_select_list {} + + catch {destroy $frame} err_code + + frame $frame + pack $frame + label $frame.main_title \ + -text "Workstation FDDI/CDDI Configuration\n" + pack $frame.main_title -side top + + + set fddi [ frame $frame.fddi_info ] + pack $fddi -side top -anchor w -fill x + ToorLabelledRadiobuttons $fddi.select "Data Entry Method:" \ + toor_vars(new,list_selection) normal left 0 \ + "Select From Lists" 1 \ + "Type Information" 0 + + label $fddi.space -text " " + pack $fddi.space -side top + + # set up command to update other info when selection changes + set cmd [ ToorCmdToUpdateHostFromList toor_vars(new,fddi_organiz) \ + toor_vars(new,fddi_role_typ) \ + toor_vars(new,fddi_role) \ + toor_vars(new,fddi_hostname) \ + toor_vars(new,fddi_ip) \ + toor_vars(new,fddi_or_name) \ + toor_dummy \ + toor_dumm2 \ + $TOOR_FDDI_OR_NAME_FILE ] + + set fddih [ frame $fddi.high ] + set fddim [ frame $fddi.mid ] + set fddil [ frame $fddi.low ] + pack $fddih $fddim $fddil -side top -anchor w -fill x + + ToorDisplayHost $fddih.host toor_vars(new,fddi_hostname) left normal + ToorDisplayIp $fddih.ip toor_vars(new,fddi_ip) left normal + pack $fddih.host $fddih.ip -side left + + ToorDisplayOrName $fddim.or toor_vars(new,fddi_or_name) left normal + pack $fddim.or -fill x + + label $fddil.spacer -text " " + pack $fddil.spacer -side top + + ToorUnitSelectionLists $fddil.lists toor_entry_list toor_select_list \ + toor_organiz_list toor_org_ip_list \ + toor_vars(new,fddi_organiz) \ + toor_vars(new,fddi_role_typ) \ + toor_vars(new,fddi_role) \ + $cmd + + lappend toor_entry_list $fddih.host.entry $fddih.ip.entry $fddim.or.entry + + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "Done" N \ + "Cancel" Y + pack $frame.btn -side top + + update + ToorPleaseWait + ToorSetOrgList toor_organiz_list toor_org_ip_list \ + [ lindex $toor_select_list 0 ] 1 toor_vars(new,fddi_organiz) \ + [ lindex $toor_select_list 1 ] toor_vars(new,fddi_role_typ) \ + [ lindex $toor_select_list 2 ] toor_vars(new,fddi_role) + + ToorPropagateNameChange $fddih.host.entry toor_vars(new,fddi_ip) \ + toor_vars(new,fddi_or_name) toor_dummy toor_dumm2 \ + toor_vars(new,fddi_organiz) \ + toor_vars(new,fddi_role_typ) \ + toor_vars(new,fddi_role) $TOOR_FDDI_OR_NAME_FILE \ + $toor_select_list + + ToorActivateEntryMethod $toor_select_list $toor_entry_list \ + $fddi.select.buttons + + set ready_to_exit F + while { $ready_to_exit == "F" } { + + tkwait variable toor_go_back_to_first_menu + + ToorDestroyEntryErrorsList + + if { $toor_go_back_to_first_menu == "Y" } { + set ready_to_exit T + } else { + set err_list {} + ToorAddToErrorList err_list "FDDI Host Name" \ + [ ToorCheckHostname $toor_vars(new,fddi_hostname) ] + ToorAddToErrorList err_list "Ethernet & FDDI/CDDI Host Names" \ + [ ToorCheckNameUnique \ + $toor_vars(new,local_hostname) \ + $toor_vars(new,fddi_hostname) ] + ToorAddToErrorList err_list "FDDI IP Address" \ + [ ToorCheckIPAddr $toor_vars(new,fddi_ip) ] + ToorAddToErrorList err_list "Ethernet & FDDI IP Addresses" \ + [ ToorCheckIPDiffSubnets $toor_vars(new,local_ip) \ + $toor_vars(new,fddi_ip) ] + ToorAddToErrorList err_list "FDDI/CDDI O/R Name" \ + [ ToorCheckORName toor_vars(new,fddi_or_name) ] + ToorAddToErrorList err_list "Ethernet & FDDI/CDDI O/R Name" \ + [ ToorCheckORUnique $toor_vars(new,or_name) \ + $toor_vars(new,fddi_or_name) ] + ToorAddToErrorList err_list "Organization" \ + [ ToorCheckOganization $toor_vars(new,fddi_organiz)] + ToorAddToErrorList err_list "Role Type" \ + [ ToorCheckRoleType $toor_vars(new,fddi_role_typ) ] + ToorAddToErrorList err_list "Role" \ + [ ToorCheckRole $toor_vars(new,fddi_role) ] + + set ready_to_exit [ eval ToorDisplayErrors \ + {"Workstation FDDI/CDDI Configuration"} \ + $err_list ] + + } + } + + ToorPleaseWait + + destroy $frame +} + +################################################################################ +# +# set value to table entry, then enable or disable field +# +proc ToorSetDisplayParams { window variable value config_string } { + + upvar $variable his_var + upvar $config_string my_cs + + set toor_dev_parms(cgfourteen0) "/dev/cgfourteen0" + set toor_dev_parms(cgfourteen0_h) "/dev/cgfourteen0" + set toor_dev_parms(cgfourteen1) "/dev/cgfourteen1" + set toor_dev_parms(cgfourteen1_h) "/dev/cgfourteen1" + set toor_dev_parms(cgsix0) "/dev/cgsix0" + set toor_dev_parms(tvtwo0) "/dev/fbs/tvtwo0" + set toor_dev_parms(laptop0) "/dev/fb -noport -maxfb" + set toor_dev_parms(none) "" + set toor_dev_parms(other) "/dev/" + set toor_dev_parms(ffb0) "/dev/ffb0" + + set my_cs $toor_dev_parms($his_var) + + ToorEnableWindowOnValue $window his_var $value + +} + +################################################################################ +# +# Allow user to specify new configuration for video displays +# +proc ToorGetDisplayConfig { frame } { + global toor_go_back_to_first_menu toor_vars + + frame $frame + pack $frame + label $frame.main_title \ + -text "Workstation Display Configuration\n" + pack $frame.main_title -side top + set dframe [ frame $frame.displays ] + pack $dframe -side top + + set lframe [ frame $dframe.left -borderwidth 1 ] + pack $lframe -side left + set rframe [ frame $dframe.right -borderwidth 1 ] + pack $rframe -side left + ToorLabelledRadiobuttons $lframe.display \ + "Left or Only Display Device:" toor_vars(new,left_video) normal \ + top 0 \ + "cgfourteen0 - high res" cgfourteen0_h \ + "cgfourteen0" cgfourteen0 \ + "Parallax (tvtwo0)" tvtwo0 \ + "cgsix0" cgsix0 \ + "ffb0" ffb0 \ + "Laptop" laptop0 \ + "Other(Type device & options):" other + + set leframe [ entry $lframe.display.buttons.entry -width 23 -borderwidth 1 \ + -textvariable toor_vars(new,left_video_cmd) ] + $leframe configure -state disabled + pack $leframe -side top -padx 0 -anchor w + + if { $toor_vars(new,left_video) != "other" } { + ToorSetDisplayParams $leframe toor_vars(new,left_video) other \ + toor_vars(new,left_video_cmd) + } + + foreach btn "cgfourteen0 cgfourteen0_h tvtwo0 cgsix0 ffb0 laptop0 other" { + $lframe.display.buttons.$btn configure -command \ + "ToorSetDisplayParams $leframe toor_vars(new,left_video) other \ + toor_vars(new,left_video_cmd)" + } + + ToorLabelledRadiobuttons $rframe.display \ + "Right Display Device:" toor_vars(new,right_video) normal \ + top 0 \ + "cgfourteen1 - high res" cgfourteen1_h \ + "cgfourteen1" cgfourteen1 \ + "Parallax (tvtwo0)" tvtwo0 \ + "cgsix0" cgsix0 \ + "ffb0" ffb0 \ + "None" none \ + "Other(Type device & options):" other + + set reframe [ entry $rframe.display.buttons.entry -width 23 -borderwidth 1 \ + -textvariable toor_vars(new,right_video_cmd) ] + $reframe configure -state disabled + pack $reframe -side top -padx 0 -anchor w + + if { $toor_vars(new,right_video) != "other" } { + ToorSetDisplayParams $reframe toor_vars(new,right_video) other \ + toor_vars(new,right_video_cmd) + } + + foreach btn "cgfourteen1 cgfourteen1_h tvtwo0 cgsix0 ffb0 none other" { + $rframe.display.buttons.$btn configure -command \ + "ToorSetDisplayParams $reframe toor_vars(new,right_video) other \ + toor_vars(new,right_video_cmd)" + } + + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "Done" N \ + "Cancel" Y + + pack $frame.btn -side top + + tkwait variable toor_go_back_to_first_menu + + ToorPleaseWait + + destroy $frame + +} + +################################################################################ +# +# Display error dialog window if date/time group is invalid, User must hit OK +# to exit, since routine does a grab +# +proc ToorDateTimeError { } { + global toor_go_back_to_first_menu + toplevel .oops -borderwidth 1 + label .oops.message -text "! Incorrect Date/Time Format\n" + pack .oops.message -side top + label .oops.msg2 -text "Enter as \"ddhhmmZ MON yy\"" + pack .oops.msg2 -side top + label .oops.msg3 -text "All characters and spaces must be entered" + pack .oops.msg3 -side top + label .oops.msg4 -text "Time is set when \"Set\" selected\n" + pack .oops.msg4 -side top + ToorButtonSet .oops.btn Y toor_go_back_to_first_menu dummy \ + "OK" Y + pack .oops.btn -side top + grab .oops + + tkwait variable toor_go_back_to_first_menu + + destroy .oops +} + +################################################################################ +# +# Display current time, keeping it updated +# +proc ToorDisplayCurrentTime { frame } { + global toor_go_back_to_first_menu toor_time_now + set toor_time_now [ string toupper [ exec /usr/bin/date -u "+%d%H%MZ %h %y" ] ] + if { $toor_go_back_to_first_menu == "" } { + if {![winfo exists $frame]} { + ToorLabelledEntry $frame "Time is Now:" 14 toor_time_now top \ + disabled + pack $frame + } + after 1000 ToorDisplayCurrentTime $frame + } +} + +################################################################################ +# +# Display current time, keeping it updated +# +proc ToorGetCurrentTime { frame } { + global toor_go_back_to_first_menu toor_time_set + + array set mon_tbl [ list {JAN} {01} {FEB} {02} {MAR} {03} {APR} {04} \ + {MAY} {05} {JUN} {06} {JUL} {07} {AUG} {08} \ + {SEP} {09} {OCT} {10} {NOV} {11} {DEC} {12} ] + + array set mon_len [ list {JAN} {31} {FEB} {29} {MAR} {31} {APR} {30} \ + {MAY} {31} {JUN} {30} {JUL} {31} {AUG} {31} \ + {SEP} {30} {OCT} {31} {NOV} {30} {DEC} {31} ] + + frame $frame + pack $frame + label $frame.main_title -text "Set System Time\n" + pack $frame.main_title -side top + frame $frame.dates + pack $frame.dates + frame $frame.dates.left + pack $frame.dates.left -side left + frame $frame.dates.mid + pack $frame.dates.mid -side left + frame $frame.dates.right + pack $frame.dates.right -side left -fill y + + set time_entered_ok 0 + + while {! $time_entered_ok} { + + set toor_time_set \ + [string toupper [exec /usr/bin/date -u "+%d%H%MZ %h %y"]] + set toor_go_back_to_first_menu "" + + if {![winfo exists $frame.dates.left.time]} { + ToorDisplayCurrentTime $frame.dates.left.time + pack $frame.dates.left.time -side top + button $frame.dates.left.btn -text "OK" -borderwidth 1 \ + -command "set toor_go_back_to_first_menu N" + pack $frame.dates.left.btn -side top + focus $frame.dates.left.btn + + ToorLabelledEntry $frame.dates.mid.ent "Update Time To:" 14 \ + toor_time_set top normal + pack $frame.dates.mid.ent -side top + button $frame.dates.mid.btn -text "Set" -borderwidth 1 \ + -command "set toor_go_back_to_first_menu S" + pack $frame.dates.mid.btn -side top + + button $frame.dates.right.btn -text "Cancel" -borderwidth 1 \ + -command "set toor_go_back_to_first_menu Y" + pack $frame.dates.right.btn -side bottom + + } + + tkwait variable toor_go_back_to_first_menu + + if { $toor_go_back_to_first_menu == "S" } { + + if [ string match \ + {[0-3][0-9][0-5][0-9][0-5][0-9]Z [ADFJMNOS][ACEOPU][BCGLNPRTVY] [0-9][0-9]} \ + $toor_time_set ] { + set dd [ string range $toor_time_set 0 1 ] + set HH [ string range $toor_time_set 2 3 ] + set MM [ string range $toor_time_set 4 5 ] + set mon [ string toupper [ string range $toor_time_set 8 10 ] ] + set yy [ string range $toor_time_set 12 13 ] + + # set number of days in February based on year + if { [ expr $yy % 4 ] == 0 } { + set mon_len(FEB) 29 + } else { + set mon_len(FEB) 28 + } + + # Set century to 19xx if year is 50 to 99, + # century is 20xx otherwise + if { $yy >= 50 } { + set cc 19 + } else { + set cc 20 + } + + scan "$dd" "%d" d + + # Even though HH and MM may take on values of 08 and 09 + # that would normally be rejected as invalid octal (due to + # the leading 0) values, tcl defaults to performing a string + # comparison as long as the values can't be interpreted + # as a number. This string comparison yields the correct + # results, so HH and MM are not scan'ed to numeric values + + if { [info exists mon_tbl($mon)] \ + && $d >= 1 && $d <= $mon_len($mon) \ + && $HH <= 23 + && $MM <= 59 } { + set mm $mon_tbl($mon) + + set result [ catch \ + { exec /usr/bin/date -u $mm$dd$HH$MM$cc$yy } ret_code ] + if { $result == 0 } { + set time_entered_ok 1 + set toor_go_back_to_first_menu N + } else { + ToorDateTimeError + } + } else { + ToorDateTimeError + } + } else { + # Error in input format + ToorDateTimeError + } + + } else { + # Cancel or OK selected, exit loop + set time_entered_ok 1 + } + + } ;# end while time not entered correctly + + ToorPleaseWait + + destroy $frame +} + +################################################################################ +# +# Get DCE information for a workstation that will use the address book & beacon +# Beacon will determine who becomes the server and address book will determine +# the dce cell name +# +proc ToorSetBeaconDceConfig { } { + global toor_vars + set toor_vars(new,asas_is_dce_master) "dcemaster" + set toor_vars(new,local_is_dce_master) "addrbk" + set toor_vars(new,dce_hostname) "TBD" + set toor_vars(new,dce_ip) "TBD" + set toor_vars(new,dce_cell) "Address Book Will Set (TBD)" +} + +################################################################################ +# +# Format command to set hostname and associated fields to values that +# correspond to the entries selected in the lists +# +proc ToorCmdToUpdateDceHostFromList { org_var type_var role_var host_var \ + ip_var or_var uic_var urn_var or_file \ + cell_var } { + + global TOOR_LAST_CONFIG_DIR \ + TOOR_UNL_HOST_INDEX TOOR_UNL_CELL_INDEX TOOR_UNL_ROLE_TYPE_INDEX \ + TOOR_UNL_ROLE_INDEX + + set cmd [ format {set tmp [ ToorGetUnlList toor_org_ip_list %s %s \ + [ ToorGetCellFromOrg toor_organiz_list $%s ] \ + %s $%s %s $%s ] ; if {$tmp != ""}} \ + $TOOR_UNL_HOST_INDEX $TOOR_UNL_CELL_INDEX \ + $org_var $TOOR_UNL_ROLE_TYPE_INDEX $type_var \ + $TOOR_UNL_ROLE_INDEX $role_var ] + set sub_cmd [ format {set %s $tmp ; \ + ToorNameChanged $%s $%s %s %s %s %s %s ; \ + ToorDceNameChanged $%s $%s %s %s }\ + $host_var $host_var $host_var $ip_var $or_var $uic_var \ + $urn_var "$TOOR_LAST_CONFIG_DIR/$or_file" \ + $host_var $host_var $ip_var $cell_var ] + lappend cmd $sub_cmd + + return $cmd +} + +################################################################################ +# +# Get DCE information for a workstation that is a subsystem client, +# Always get the cell name, and get host name and ip address if the DCE +# server is on another BFA or ASAS Subsystem +# +proc ToorGetDceSubConfig { frame next } { + global toor_vars TOOR_OR_NAME_FILE + + if { [winfo exists $frame.master] } { + destroy $frame.master + } + if { [winfo exists $frame.cell_name] } { + destroy $frame.cell_name + } + if { [winfo exists $frame.low] } { + destroy $frame.low + } + + set toor_entry_list {} + set toor_select_list {} + + if { $toor_vars(new,asas_is_dce_master) == "dcemaster" } { + set state normal + set toor_vars(new,dce_hostname) $toor_vars(orig,dce_hostname) + set toor_vars(new,dce_ip) $toor_vars(orig,dce_ip) + set toor_vars(new,dce_organiz) $toor_vars(orig,dce_organiz) + set toor_vars(new,dce_role_typ) $toor_vars(orig,dce_role_typ) + set toor_vars(new,dce_role) $toor_vars(orig,dce_role) + + } else { + set state disabled + set toor_vars(new,dce_hostname) $toor_vars(new,asas_hostname) + set toor_vars(new,dce_ip) $toor_vars(new,asas_ip) + set toor_vars(new,dce_organiz) $toor_vars(new,mst_organiz) + set toor_vars(new,dce_role_typ) $toor_vars(new,mst_role_typ) + set toor_vars(new,dce_role) $toor_vars(new,mst_role) + + } + if { $toor_vars(new,dce_hostname) != $toor_vars(orig,dce_hostname) } { + set toor_vars(new,dce_cell) [ ToorLookupCellName \ + $toor_vars(new,dce_hostname) \ + $toor_vars(new,dce_ip) ] + } + set subframe [ToorLabelledSubframe $frame.master dce_workstation \ + "Where is the DCE Master Server?\n" top 0 ] + + # set up command to update other info when selection changes + set cmd [ ToorCmdToUpdateDceHostFromList toor_vars(new,dce_organiz) \ + toor_vars(new,dce_role_typ) \ + toor_vars(new,dce_role) \ + toor_vars(new,dce_hostname) \ + toor_vars(new,dce_ip) \ + toor_dummy \ + toor_dummy2 \ + toor_dummy3 \ + $TOOR_OR_NAME_FILE \ + toor_vars(new,dce_cell) ] + + ToorLabelledRadiobuttons $subframe.select "Data Entry Method:" \ + toor_vars(new,list_selection) normal left 0 \ + "Select From Lists" 1 \ + "Type Information" 0 + + ToorDisplayHost $subframe.host toor_vars(new,dce_hostname) left $state + ToorDisplayIp $subframe.ip toor_vars(new,dce_ip) left $state + pack $subframe.host -side left + pack $subframe.ip -side left + ToorDisplayDceCell $frame.cell_name toor_vars(new,dce_cell) left normal + pack $frame.master -anchor w -fill x + pack $subframe -side top + pack $frame.cell_name -side top -anchor w + set low [ frame $frame.low ] + pack $low -side top + + ToorUnitSelectionLists $low.lists toor_entry_list \ + toor_select_list \ + toor_organiz_list toor_org_ip_list \ + toor_vars(new,dce_organiz) \ + toor_vars(new,dce_role_typ) \ + toor_vars(new,dce_role) \ + $cmd + + lappend toor_entry_list $subframe.host.entry $subframe.ip.entry \ + $frame.cell_name.entry + update + ToorPleaseWait + ToorSetOrgList toor_organiz_list toor_org_ip_list \ + [ lindex $toor_select_list 0 ] 1 toor_vars(new,dce_organiz) \ + [ lindex $toor_select_list 1 ] toor_vars(new,dce_role_typ) \ + [ lindex $toor_select_list 2 ] toor_vars(new,dce_role) + + ToorPropagateNameChange $subframe.host.entry toor_vars(new,dce_ip) \ + toor_dummy toor_dummy2 toor_dummy3 \ + toor_vars(new,dce_organiz) \ + toor_vars(new,dce_role_typ) \ + toor_vars(new,dce_role) $TOOR_OR_NAME_FILE \ + $toor_select_list + + + $low.lists.org.entry.info.entry configure -state $state + $low.lists.type.entry.info.entry configure -state $state + $low.lists.role.entry.info.entry configure -state $state + + ToorActivateEntryMethod $toor_select_list $toor_entry_list \ + $subframe.select.buttons + + if { $state != "normal" } { + $subframe.select.buttons.0 configure -takefocus 0 + $subframe.select.buttons.1 configure -takefocus 0 + $subframe.host.entry configure -takefocus 0 + $subframe.ip.entry configure -takefocus 0 + $low.lists.org.sb.list configure -takefocus 0 + $low.lists.type.sb.list configure -takefocus 0 + $low.lists.role.sb.list configure -takefocus 0 + $low.lists.org.entry.info.entry configure -takefocus 0 + $low.lists.type.entry.info.entry configure -takefocus 0 + $low.lists.role.entry.info.entry configure -takefocus 0 + $frame.cell_name.entry configure -takefocus 1 + bind $next {} + bind $next {} + } + + + bind $subframe.host.entry \ + "+ToorSaveEntryValue $subframe.host.entry" + bind $subframe.host.entry \ + "+ToorCheckEntryChange $subframe.host.entry \ + ToorDceNameChanged toor_vars(new,dce_ip) \ + toor_vars(new,dce_cell)" + bind $subframe.host.entry \ + "+ToorCheckEntryChange $subframe.host.entry \ + ToorSetOrgRoleFromHost toor_organiz_list \ + toor_org_ip_list \ + toor_vars(new,dce_organiz) \ + toor_vars(new,dce_role_typ) \ + toor_vars(new,dce_role) \ + [ lindex $toor_select_list 0] \ + [ lindex $toor_select_list 1] \ + [ lindex $toor_select_list 2]" + +} + +################################################################################ +# +# Get DCE information for a workstation that is a subsystem client, +# DCE Cell server is always on another workstation, but it may be either the +# ASAS subsystem master or on another BFA +# +proc ToorGetClientDceConfig { frame } { + global toor_go_back_to_first_menu toor_vars + frame $frame + pack $frame + label $frame.main_title \ + -text "Workstation Configuration" + pack $frame.main_title -side top + label $frame.title2 \ + -text "DCE Configuration for ASAS Subsystem Client\n" + pack $frame.title2 -side top + ToorLabelledRadiobuttons $frame.dcemstr \ + "Where will the DCE Master Server Run?" \ + toor_vars(new,asas_is_dce_master) normal top 0 \ + "On the ASAS Subsystem Master" asasmaster \ + "On another BFA or ASAS Subsystem" dcemaster + + set varframe [ frame $frame.varframe -borderwidth 1 ] + pack $varframe -fill x -side top + + + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "Done" N \ + "Cancel" Y + pack $frame.btn -side top + + ToorGetDceSubConfig $varframe $frame.btn.b3 + + $frame.dcemstr.buttons.asasmaster configure \ + -command "ToorPleaseWait ; \ + ToorGetDceSubConfig $varframe $frame.btn.b3" + $frame.dcemstr.buttons.dcemaster configure \ + -command "ToorPleaseWait ; \ + ToorGetDceSubConfig $varframe $frame.btn.b3" + + set ready_to_exit F + while { $ready_to_exit == "F" } { + + tkwait variable toor_go_back_to_first_menu + + ToorDestroyEntryErrorsList + + if { $toor_go_back_to_first_menu == "Y" } { + set ready_to_exit T + } else { + set err_list {} + ToorAddToErrorList err_list "Host Name" \ + [ ToorCheckHostname $toor_vars(new,dce_hostname) ] + ToorAddToErrorList err_list "IP Address" \ + [ ToorCheckIPAddr $toor_vars(new,dce_ip) ] + ToorAddToErrorList err_list "DCE Cell Name" \ + [ ToorCheckCellName $toor_vars(new,dce_cell) ] + ToorAddToErrorList err_list "Organization" \ + [ ToorCheckOptOganization $toor_vars(new,dce_organiz) ] + ToorAddToErrorList err_list "Role Type" \ + [ ToorCheckOptRoleType $toor_vars(new,dce_role_typ) ] + ToorAddToErrorList err_list "Role" \ + [ ToorCheckOptRole $toor_vars(new,dce_role) ] + set ready_to_exit [ eval ToorDisplayErrors \ + {"DCE Configuration for ASAS Subsystem Client"} \ + $err_list ] + } + } + + ToorPleaseWait + + destroy $frame +} + +################################################################################ +# +# Get DCE information for a workstation that is a subsystem master, +# Always get the cell name, and get host name and ip address if the DCE +# server is on another BFA or ASAS Subsystem +# +proc ToorGetDceMstrConfig { frame next } { + global toor_vars TOOR_OR_NAME_FILE + + if { [winfo exists $frame.master] } { + destroy $frame.master + } + if { [winfo exists $frame.cell_name] } { + destroy $frame.cell_name + } + if { [winfo exists $frame.low] } { + destroy $frame.low + } + + if { $toor_vars(new,local_is_dce_master) == "dcemaster" } { + set toor_vars(new,dce_hostname) $toor_vars(new,asas_hostname) + set toor_vars(new,dce_ip) $toor_vars(new,asas_ip) + set toor_vars(new,dce_organiz) $toor_vars(new,mst_organiz) + set toor_vars(new,dce_role_typ) $toor_vars(new,mst_role_typ) + set toor_vars(new,dce_role) $toor_vars(new,mst_role) + if { $toor_vars(new,dce_hostname) != $toor_vars(orig,dce_hostname) } { + set toor_vars(new,dce_cell) [ ToorLookupCellName \ + $toor_vars(new,dce_hostname) \ + $toor_vars(new,dce_ip) ] + } + ToorDisplayDceCell $frame.cell_name toor_vars(new,dce_cell) top normal + bind $next {} + bind $next {} + } else { + + set toor_entry_list {} + set toor_select_list {} + + set subframe [ToorLabelledSubframe $frame.master dce_workstation \ + "Where is the DCE Master Server?\n" top 0 ] + set toor_vars(new,dce_cell) $toor_vars(orig,dce_cell) + set toor_vars(new,dce_hostname) $toor_vars(orig,dce_hostname) + set toor_vars(new,dce_ip) $toor_vars(orig,dce_ip) + set toor_vars(new,dce_organiz) $toor_vars(orig,dce_organiz) + set toor_vars(new,dce_role_typ) $toor_vars(orig,dce_role_typ) + set toor_vars(new,dce_role) $toor_vars(orig,dce_role) + if { $toor_vars(new,dce_hostname) != $toor_vars(orig,dce_hostname) } { + set toor_vars(new,dce_cell) [ ToorLookupCellName \ + $toor_vars(new,dce_hostname) \ + $toor_vars(new,dce_ip) ] + } + + # set up command to update other info when selection changes + set cmd [ ToorCmdToUpdateDceHostFromList toor_vars(new,dce_organiz) \ + toor_vars(new,dce_role_typ) \ + toor_vars(new,dce_role) \ + toor_vars(new,dce_hostname) \ + toor_vars(new,dce_ip) \ + toor_dummy \ + toor_dummy2 \ + toor_dummy3 \ + $TOOR_OR_NAME_FILE \ + toor_vars(new,dce_cell) ] + + ToorLabelledRadiobuttons $subframe.select "Data Entry Method:" \ + toor_vars(new,list_selection) normal left 0 \ + "Select From Lists" 1 \ + "Type Information" 0 + set cell [ frame $frame.cell_name ] + set low [ frame $frame.low ] + + ToorDisplayHost $subframe.host toor_vars(new,dce_hostname) left normal + ToorDisplayIp $subframe.ip toor_vars(new,dce_ip) left normal + ToorDisplayDceCell $cell.cell_name \ + toor_vars(new,dce_cell) left normal + pack $subframe.host -side left + pack $subframe.ip -side left + pack $cell.cell_name -side left + pack $frame.master + pack $subframe $cell $low -side top -anchor w + + ToorUnitSelectionLists $low.lists toor_entry_list \ + toor_select_list \ + toor_organiz_list toor_org_ip_list \ + toor_vars(new,dce_organiz) \ + toor_vars(new,dce_role_typ) \ + toor_vars(new,dce_role) \ + $cmd + + lappend toor_entry_list $subframe.host.entry $subframe.ip.entry \ + $cell.cell_name.entry + update + ToorPleaseWait + ToorSetOrgList toor_organiz_list toor_org_ip_list \ + [ lindex $toor_select_list 0 ] 1 toor_vars(new,dce_organiz) \ + [ lindex $toor_select_list 1 ] toor_vars(new,dce_role_typ) \ + [ lindex $toor_select_list 2 ] toor_vars(new,dce_role) + + ToorPropagateNameChange $subframe.host.entry toor_vars(new,dce_ip) \ + toor_dummy toor_dummy2 toor_dummy3 \ + toor_vars(new,dce_organiz) \ + toor_vars(new,dce_role_typ) \ + toor_vars(new,dce_role) $TOOR_OR_NAME_FILE \ + $toor_select_list + + ToorActivateEntryMethod $toor_select_list $toor_entry_list \ + $subframe.select.buttons + + bind $subframe.host.entry \ + "+ToorSaveEntryValue $subframe.host.entry" + bind $subframe.host.entry \ + "+ToorCheckEntryChange $subframe.host.entry \ + ToorDceNameChanged toor_vars(new,dce_ip) \ + toor_vars(new,dce_cell)" + bind $subframe.host.entry \ + "+ToorCheckEntryChange $subframe.host.entry \ + ToorSetOrgRoleFromHost \ + toor_organiz_list \ + toor_org_ip_list \ + toor_vars(new,dce_organiz) \ + toor_vars(new,dce_role_typ) \ + toor_vars(new,dce_role) \ + [ lindex $toor_select_list 0] \ + [ lindex $toor_select_list 1] \ + [ lindex $toor_select_list 2]" + } + +} + +################################################################################ +# +# Get DCE configuration for an ASAS subsystem master, subprompts differ if +# workstation will be the cell master or a client to anther subsystem or BFA +# +proc ToorGetServerDceConfig { frame } { + global toor_go_back_to_first_menu toor_vars + frame $frame + pack $frame + label $frame.main_title \ + -text "Workstation Configuration" + pack $frame.main_title -side top + label $frame.title2 -text "DCE Configuration for ASAS Subsystem Master\n" + pack $frame.title2 -side top + ToorLabelledRadiobuttons $frame.dcemstr \ + "Where will the DCE Master Server Run?" \ + toor_vars(new,local_is_dce_master) normal top 0 \ + "On this Workstation" dcemaster \ + "On another BFA or ASAS Subsystem" dceclient + + set varframe [ frame $frame.varframe -borderwidth 1 ] + pack $varframe -fill x -side top + + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "Done" N \ + "Cancel" Y + pack $frame.btn -side top + + ToorGetDceMstrConfig $varframe $frame.btn.b3 + + $frame.dcemstr.buttons.dcemaster configure \ + -command "ToorGetDceMstrConfig $varframe $frame.btn.b3" + $frame.dcemstr.buttons.dceclient configure \ + -command "ToorPleaseWait ; \ + ToorGetDceMstrConfig $varframe $frame.btn.b3" + + set ready_to_exit F + while { $ready_to_exit == "F" } { + + tkwait variable toor_go_back_to_first_menu + + ToorDestroyEntryErrorsList + + if { $toor_go_back_to_first_menu == "Y" } { + set ready_to_exit T + } else { + set err_list {} + ToorAddToErrorList err_list "Host Name" \ + [ ToorCheckHostname $toor_vars(new,dce_hostname) ] + ToorAddToErrorList err_list "IP Address" \ + [ ToorCheckIPAddr $toor_vars(new,dce_ip) ] + ToorAddToErrorList err_list "DCE Cell Name" \ + [ ToorCheckCellName $toor_vars(new,dce_cell) ] + ToorAddToErrorList err_list "Organization" \ + [ ToorCheckOptOganization $toor_vars(new,dce_organiz) ] + ToorAddToErrorList err_list "Role Type" \ + [ ToorCheckOptRoleType $toor_vars(new,dce_role_typ) ] + ToorAddToErrorList err_list "Role" \ + [ ToorCheckOptRole $toor_vars(new,dce_role) ] + set ready_to_exit [ eval ToorDisplayErrors \ + {"DCE Configuration for ASAS Subsystem Client"} \ + $err_list ] + } + } + + ToorPleaseWait + + destroy $frame +} + +################################################################################ +# +# Display error dialog window if passwords didn't match, User must hit OK +# to exit, since routine does a grab +# +proc ToorPasswordMismatch { } { + global toor_go_back_to_first_menu + toplevel .oops -borderwidth 1 + label .oops.message -text "! Password does not\nmatch Verify\nPassword\n" + pack .oops.message -side top + ToorButtonSet .oops.btn Y toor_go_back_to_first_menu dummy \ + "OK" Y + pack .oops.btn -side top + grab .oops + + tkwait variable toor_go_back_to_first_menu + + destroy .oops +} + +################################################################################ +# +# Prompt user for new dce password and have him verify hit. When both +# passwords are the same, write the value to the file. If no password is +# entered, the old password is used. +# +proc ToorSetDcePassword { frame } { + + global toor_go_back_to_first_menu \ + TOOR_NEW_CONFIG_DIR TOOR_CELL_ADMIN_PW TOOR_DATA_DIR + + set done_with_this_frame N + frame $frame + pack $frame -side top + label $frame.main_title \ + -text "Enter New DCE Cell Administrator Password\n" + pack $frame.main_title -side top + ToorPasswordPrompt $frame.f1 pw verf + label $frame.main_prompt \ + -text "\nEnter new password, then select \"OK\"" + pack $frame.main_prompt -side top + ToorButtonSet $frame.btn N toor_go_back_to_first_menu dummy \ + "OK" N \ + "Cancel" Y + pack $frame.btn -side top + + # wait for OK button with password and verify password the same (or cancel) + + while {$done_with_this_frame != "Y"} { + focus $frame.btn.b3 + tkwait variable toor_go_back_to_first_menu + if { $toor_go_back_to_first_menu == "N" } { + if { [string compare [$pw get] [$verf get]] != 0 } { + set done_with_this_frame N + ToorPasswordMismatch + $pw delete 0 [string length [$pw get]] + ToorDecideToEnable $verf $pw + } else { + set done_with_this_frame Y + } + } else { + set done_with_this_frame Y + } + } + + if { $toor_go_back_to_first_menu == "N" } { + if {[string length [$pw get]] != 0} { + set cell_pw [open $TOOR_NEW_CONFIG_DIR/$TOOR_CELL_ADMIN_PW w+ 0600] + puts $cell_pw [$pw get] + close $cell_pw + } else { + catch { exec /usr/bin/cp -p $TOOR_DATA_DIR/$TOOR_CELL_ADMIN_PW \ + $TOOR_NEW_CONFIG_DIR/$TOOR_CELL_ADMIN_PW } ret_code + } + } + + ToorPleaseWait + + destroy $frame +} + +################################################################################ +# +# Configuration change needed - warn user not to halt reconfiguration +# +proc ToorReconfigWarning { frame } { + global toor_want_to_change_ans + + frame $frame + pack $frame -side bottom + label $frame.line1a -text "*******************" + label $frame.line1b -text "* !!! WARNING !!! *" + label $frame.line1c -text "*******************\n" + pack $frame.line1a $frame.line1b $frame.line1c -side top + label $frame.line2 -text "Workstation Reconfiguration in Progress\n" + pack $frame.line2 -side top + label $frame.line3 -text "Interrupting Power or" + pack $frame.line3 -side top + label $frame.line3a -text "Halting the Boot Process" + pack $frame.line3a -side top + label $frame.line3b -text "May Render the Workstation Unusable\n" + pack $frame.line3b -side top + label $frame.line4 -text "An Automatic Reboot Will Occur\n" + pack $frame.line4 -side top + + after 50 { global toor_want_to_change_ans; set toor_want_to_change_ans Y } + tkwait variable toor_want_to_change_ans + +} + +################################################################################ +# +# rename each file in the old_names list to the corresponding entries name +# in the new_names list +# +proc ToorRenameFileLists { old_names new_names } { + upvar #0 $old_names my_old_names + upvar #0 $new_names my_new_names + set indx 0 + foreach old_name $my_old_names { + set new_name [lindex $my_new_names $indx] + incr indx + catch { exec /usr/bin/mv -f $old_name $new_name } ret_code + } +} + +################################################################################ +# +# return beacon in use status based on presence of startup script +# +proc ToorSetBeaconUseStatus { } { + global TOOR_BEACON_BOOT_FILE + if [ file exists $TOOR_BEACON_BOOT_FILE ] { + return beacon + } else { + return nobeacon + } +} + +################################################################################ +# +# return slow speed router present status based on presence of startup script +# +proc ToorSetSDRPresentStatus { } { + global TOOR_SDR_BOOT_FILE + if [ file exists $TOOR_SDR_BOOT_FILE ] { + return sdr + } else { + return nosdr + } +} + +################################################################################ +# +# return ASAS master/client status based on whether our hostname is same as +# the ASAS master hostname +# +proc ToorSetAsasMasterStatus { } { + global toor_vars + if { $toor_vars(orig,local_hostname) == $toor_vars(orig,asas_hostname) } { + return asasmaster + } else { + return asasclient + } +} + +################################################################################ +# +# return DCE master/client status based on whether our hostname is same as +# the DCE master hostname +# +proc ToorSetDceMasterStatus { } { + global toor_vars + if { $toor_vars(orig,local_hostname) == $toor_vars(orig,dce_hostname) } { + return dcemaster + } else { + return dceclient + } +} + +################################################################################ +# +# return DCE master location (asas or remote) based on whether asas +# master hostname is same as DCE master hostname, used for ASAS subsystem +# clients +# +proc ToorSetClientDceMasterStatus { } { + global toor_vars + if { $toor_vars(orig,asas_hostname) == $toor_vars(orig,dce_hostname) } { + return asasmaster + } else { + return dcemaster + } +} + +################################################################################ +# +# Fetch DCE Cell name from the /opt/dcelocal/dce_cf.db file +# +proc ToorGetCellName { } { + global TOOR_LAST_CONFIG_DIR TOOR_CELL_NAME_FILE + set DCE_CONFIG_FILE "/opt/dcelocal/dce_cf.db" + set cell "" + catch { set cell \ + [ exec /usr/bin/grep cellname $DCE_CONFIG_FILE | \ + /usr/bin/sed -e "s/\^cellname\[ \/\.\]*//" ] } ret_code + if { $cell == "" } { + ToorSetVarFromFile cell $TOOR_LAST_CONFIG_DIR/$TOOR_CELL_NAME_FILE + } + return $cell +} + +################################################################################ +# +# Fetch hostname associated with first fddi or cddi interface +# returns null string if no fddi interface found +# +proc ToorGetFddiName { hostname } { + global TOOR_FDDI_HOSTNAME + upvar $hostname my_host + set my_host "" + if [ file exists $TOOR_FDDI_HOSTNAME ] { + ToorSetVarFromFile my_host $TOOR_FDDI_HOSTNAME + } +} + +################################################################################ +# +# Fetch hostname of the dce security server, look first in pe_site file, next +# in /asas/data/last/dce_master and finally use our hostname if neither +# found or valid +# +proc ToorGetDceHostName { } { + global TOOR_PE_SITE_FILE TOOR_LAST_CONFIG_DIR TOOR_DCE_MASTER_FILE + global toor_vars TOOR_HOST_FILE + set dce_host "" + set site_line "abracadabra" + if [ file exists $TOOR_PE_SITE_FILE ] { + catch { set pe_site [ open $TOOR_PE_SITE_FILE r ] } ret_code + catch { gets $pe_site site_line } ret_code + catch { close $pe_site } ret_code + if [ regexp {:([0-9.]+)\[} $site_line whole dce_ip ] { + catch { set dce_host [exec /usr/bin/awk \ + "\$1 == dce_ip {print \$2; exit}" \ + dce_ip=$dce_ip $TOOR_HOST_FILE] } ret_code + } + + } + if { "$dce_host" == "" } { + ToorSetVarFromFile dce_host \ + $TOOR_LAST_CONFIG_DIR/$TOOR_DCE_MASTER_FILE + if { "$dce_host" == "TBD" || "$dce_host" == ""} { + set dce_host $toor_vars(orig,asas_hostname) + } + } + return $dce_host +} + +################################################################################ +# +# Get list of Potential Client Workstations +# +proc ToorReadClients { } { + global toor_vars TOOR_LAST_CONFIG_DIR TOOR_CLIENTS_FILE + + set toor_vars(orig,client_name_list) {} + set toor_vars(orig,client_ip_list) {} + set toor_vars(orig,client_role_list) {} + set toor_vars(orig,client_type_list) {} + set toor_vars(orig,client_org_list) {} + + set client_fd -1 + catch { set client_fd [ open $TOOR_LAST_CONFIG_DIR/$TOOR_CLIENTS_FILE r ] }\ + ret_code + if { $client_fd != -1 } { + while { [ gets $client_fd client_line ] >= 0 } { + set client_item [ split $client_line "|" ] + if { [ lindex $client_item 0 ] != "" } { + lappend toor_vars(orig,client_name_list) [ lindex $client_item 0 ] + lappend toor_vars(orig,client_ip_list) [ lindex $client_item 1 ] + lappend toor_vars(orig,client_org_list) [ lindex $client_item 2 ] + lappend toor_vars(orig,client_type_list) [ lindex $client_item 3 ] + lappend toor_vars(orig,client_role_list) [ lindex $client_item 4 ] + } + } + catch { close $client_fd } ret_code + } + + return +} + +################################################################################ +# +# display client workstations at selected level (orig, new or last) +# +proc ToorDisplayClients { level } { + global toor_vars + + set num_entries [ llength $toor_vars($level,client_name_list) ] + for { set index 0 } { $index < $num_entries } { incr index } { + + set name [ format {client_%s} $index ] + set ip [ format {client_ip_%s} $index ] + set org [ format {client_organiz_%s} $index ] + set role [ format {client_role_%s} $index ] + set role_type [ format {client_role_typ_%s} $index ] + + ToorLogMessage "$name = [ lindex \ + $toor_vars($level,client_name_list) $index ]" + ToorLogMessage "$ip = [ lindex \ + $toor_vars($level,client_ip_list) $index ]" + ToorLogMessage "$org = [ lindex \ + $toor_vars($level,client_org_list) $index ]" + ToorLogMessage "$role = [ lindex \ + $toor_vars($level,client_type_list) $index ]" + ToorLogMessage "$role_type = [ lindex \ + $toor_vars($level,client_role_list) $index ]" + + } + +} + +################################################################################ +# +# display configuration variables at selected level (orig, new or last) +# +proc ToorDisplayGlobals { level } { + global toor_vars + + ToorLogMessage "=== configuration level $level variables ===" + ToorLogMessage "nis_domain = $toor_vars($level,nis_domain)" + ToorLogMessage "local_hostname = $toor_vars($level,local_hostname)\n" + ToorLogMessage "local_ip = $toor_vars($level,local_ip)" + ToorLogMessage "or_name = $toor_vars($level,or_name)" + ToorLogMessage "uic = $toor_vars($level,uic)" + ToorLogMessage "fddi_used = $toor_vars($level,fddi_used)" + ToorLogMessage "fddi_hostname = $toor_vars($level,fddi_hostname)" + ToorLogMessage "fddi_ip = $toor_vars($level,fddi_ip)" + ToorLogMessage "fddi_or_name = $toor_vars($level,fddi_or_name)" + ToorLogMessage "beacon_is_being_used = $toor_vars($level,beacon_is_being_used)" + ToorLogMessage "sdr = $toor_vars($level,sdr)" + ToorLogMessage "asas_hostname = $toor_vars($level,asas_hostname)" + ToorLogMessage "asas_ip = $toor_vars($level,asas_ip)" + ToorLogMessage "enclave = $toor_vars($level,enclave)" + ToorLogMessage "hostid = $toor_vars($level,hostid)" + ToorLogMessage "net_intfc = $toor_vars($level,net_intfc)" + ToorLogMessage "dce_cell = $toor_vars($level,dce_cell)" + ToorLogMessage "dce_hostname = $toor_vars($level,dce_hostname)" + ToorLogMessage "dce_ip = $toor_vars($level,dce_ip)" + ToorLogMessage "left_video = $toor_vars($level,left_video)" + ToorLogMessage "right_video = $toor_vars($level,right_video)" + ToorLogMessage "left_video_cmd = $toor_vars($level,left_video_cmd)" + ToorLogMessage "right_video_cmd = $toor_vars($level,right_video_cmd)" + ToorLogMessage "our_organiz = $toor_vars($level,our_organiz)" + ToorLogMessage "our_role_typ = $toor_vars($level,our_role_typ)" + ToorLogMessage "our_role = $toor_vars($level,our_role)" + ToorLogMessage "our_urn = $toor_vars($level,our_urn)" + ToorLogMessage "fddi_organiz = $toor_vars($level,fddi_organiz)" + ToorLogMessage "fddi_role_typ = $toor_vars($level,fddi_role_typ)" + ToorLogMessage "fddi_role = $toor_vars($level,fddi_role)" + ToorLogMessage "mst_organiz = $toor_vars($level,mst_organiz)" + ToorLogMessage "mst_role_typ = $toor_vars($level,mst_role_typ)" + ToorLogMessage "mst_role = $toor_vars($level,mst_role)" + ToorLogMessage "dce_organiz = $toor_vars($level,dce_organiz)" + ToorLogMessage "dce_role_typ = $toor_vars($level,dce_role_typ)" + ToorLogMessage "dce_role = $toor_vars($level,dce_role)" + ToorLogMessage "list_selection = $toor_vars($level,list_selection)" + ToorDisplayClients $level +} + +################################################################################ +# +# set initial configuration variables based on current unix/nis+/dce info +# +proc ToorGetInitialConfig {} { + global toor_vars toor_domain_suffix toor_interfaces toor_fddi_present \ + TOOR_CURRENT_CONFIG_DIR TOOR_LAST_CONFIG_DIR TOOR_NEW_CONFIG_DIR \ + TOOR_BEACON_BOOT_FILE TOOR_HOST_FILE \ + TOOR_MASTER_NAME_FILE TOOR_DEFAULT_ENCLAVE_FILE \ + TOOR_CELL_NAME_FILE TOOR_DCE_MASTER_FILE TOOR_SDR_FILE \ + TOOR_HOST_ID_FILE TOOR_INTERFACE_FILE TOOR_DOMAIN_SUFFIX_FILE \ + TOOR_RECONFIG_NAME TOOR_LEFT_VIDEO_FILE \ + TOOR_RIGHT_VIDEO_FILE TOOR_LEFT_VIDEO_CMD_FILE \ + TOOR_RIGHT_VIDEO_CMD_FILE TOOR_DEFAULT_DOMAIN_FILE \ + TOOR_FDDI_OR_NAME_FILE TOOR_OR_NAME_FILE \ + TOOR_OUR_ORGANIZ_FILE TOOR_OUR_ROLE_TYPE_FILE TOOR_OUR_ROLE_FILE \ + TOOR_FDDI_ORGANIZ_FILE TOOR_FDDI_ROLE_TYPE_FILE TOOR_FDDI_ROLE_FILE \ + TOOR_OUR_URN_FILE TOOR_LIST_FILE TOOR_MST_ORGANIZ_FILE \ + TOOR_MST_ROLE_TYPE_FILE TOOR_MST_ROLE_FILE \ + TOOR_DCE_ORGANIZ_FILE TOOR_DCE_ROLE_TYPE_FILE TOOR_DCE_ROLE_FILE + + set NODE_NAME_FILE "/etc/nodename" + + # get current configuration + ToorSetVarFromFile toor_vars(orig,nis_domain) $TOOR_DEFAULT_DOMAIN_FILE + ToorSetVarFromFile toor_vars(orig,local_hostname) $NODE_NAME_FILE + ToorGetIpAddress $toor_vars(orig,local_hostname) toor_vars(orig,local_ip) + catch {set toor_vars(orig,beacon_is_being_used) [ToorSetBeaconUseStatus]}\ + ret_code + ToorSetVarFromFile toor_vars(orig,asas_hostname) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_MASTER_NAME_FILE + set toor_vars(orig,sdr) [ToorSetSDRPresentStatus] + ToorGetIpAddress $toor_vars(orig,asas_hostname) toor_vars(orig,asas_ip) + set toor_vars(orig,local_is_asas_master) "asasmaster" + catch {set toor_vars(orig,local_is_asas_master) [ToorSetAsasMasterStatus]}\ + ret_code + ToorSetVarFromFile toor_vars(orig,enclave) $TOOR_DEFAULT_ENCLAVE_FILE + ToorSetVarFromFile toor_vars(orig,hostid) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_HOST_ID_FILE + ToorSetVarFromFile toor_vars(orig,net_intfc) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_INTERFACE_FILE + set ifce_missing 1 + foreach ifce $toor_interfaces { + if { $toor_vars(orig,net_intfc) == $ifce } { + set ifce_missing 0 + break + } + } + if { $ifce_missing || ("$toor_vars(orig,net_intfc)" == "") } { + set toor_vars(orig,net_intfc) [ lindex $toor_interfaces 0 ] + } + set toor_vars(orig,dce_cell) [ ToorGetCellName ] + set toor_vars(orig,dce_hostname) [ ToorGetDceHostName ] + ToorGetIpAddress $toor_vars(orig,dce_hostname) toor_vars(orig,dce_ip) + set toor_vars(orig,asas_is_dce_master) [ToorSetClientDceMasterStatus] + catch { set toor_vars(orig,local_is_dce_master) [ToorSetDceMasterStatus]}\ + ret_code + set toor_vars(orig,or_name) [ ToorLookupOrName \ + $toor_vars(orig,local_hostname) \ + $toor_vars(orig,local_ip) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_OR_NAME_FILE ] + + set toor_vars(orig,uic) [ ToorLookupUic \ + $toor_vars(orig,local_hostname) \ + $toor_vars(orig,local_ip) ] + + ToorSetVarFromFile toor_vars(orig,left_video) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_LEFT_VIDEO_FILE + if { "$toor_vars(orig,left_video)" == "" } { + set toor_vars(orig,left_video) "cgfourteen0_h" + } + ToorSetVarFromFile toor_vars(orig,right_video) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_RIGHT_VIDEO_FILE + if { "$toor_vars(orig,right_video)" == "" } { + set toor_vars(orig,right_video) "none" + } + ToorSetVarFromFile toor_vars(orig,left_video_cmd) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_LEFT_VIDEO_CMD_FILE + ToorSetVarFromFile toor_vars(orig,right_video_cmd) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_RIGHT_VIDEO_CMD_FILE + + if { $toor_fddi_present } { + ToorGetFddiName toor_vars(orig,fddi_hostname) + } else { + set toor_vars(orig,fddi_hostname) "" + } + if { "$toor_vars(orig,fddi_hostname)" == "" } { + set toor_vars(orig,fddi_used) "N" + set toor_vars(orig,fddi_ip) "" + set toor_vars(orig,fddi_or_name) "" + } else { + set toor_vars(orig,fddi_used) "Y" + ToorGetIpAddress $toor_vars(orig,fddi_hostname) \ + toor_vars(orig,fddi_ip) + set toor_vars(orig,fddi_or_name) [ ToorLookupOrName \ + $toor_vars(orig,fddi_hostname) \ + $toor_vars(orig,fddi_ip) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_FDDI_OR_NAME_FILE ] + } + ToorSetVarFromFile toor_vars(orig,our_organiz) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_OUR_ORGANIZ_FILE + ToorSetVarFromFile toor_vars(orig,our_role_typ) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_OUR_ROLE_TYPE_FILE + ToorSetVarFromFile toor_vars(orig,our_role) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_OUR_ROLE_FILE + ToorSetVarFromFile toor_vars(orig,our_urn) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_OUR_URN_FILE + ToorSetVarFromFile toor_vars(orig,fddi_organiz) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_FDDI_ORGANIZ_FILE + ToorSetVarFromFile toor_vars(orig,fddi_role_typ) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_FDDI_ROLE_TYPE_FILE + ToorSetVarFromFile toor_vars(orig,fddi_role) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_FDDI_ROLE_FILE + ToorSetVarFromFile toor_vars(orig,mst_organiz) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_MST_ORGANIZ_FILE + ToorSetVarFromFile toor_vars(orig,mst_role_typ) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_MST_ROLE_TYPE_FILE + ToorSetVarFromFile toor_vars(orig,mst_role) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_MST_ROLE_FILE + ToorSetVarFromFile toor_vars(orig,dce_organiz) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_DCE_ORGANIZ_FILE + ToorSetVarFromFile toor_vars(orig,dce_role_typ) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_DCE_ROLE_TYPE_FILE + ToorSetVarFromFile toor_vars(orig,dce_role) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_DCE_ROLE_FILE + ToorSetVarFromFile toor_vars(orig,list_selection) \ + $TOOR_LAST_CONFIG_DIR/$TOOR_LIST_FILE + if { "$toor_vars(orig,list_selection)" == "" } { + set toor_vars(orig,list_selection) "1" + } + + ToorReadClients + + # save configuration at the start of the boot + catch { exec /usr/bin/cp $TOOR_HOST_FILE $TOOR_CURRENT_CONFIG_DIR } ret_code + + ToorSetVarFromFile toor_domain_suffix \ + $TOOR_LAST_CONFIG_DIR/$TOOR_DOMAIN_SUFFIX_FILE + if { $toor_domain_suffix == "" } { + set toor_domain_suffix "army.mil" + } + + # so DANTE can tell if reconfig of self resume needed + catch { exec /usr/bin/rm -f $TOOR_LAST_CONFIG_DIR/$TOOR_RECONFIG_NAME } \ + ret_code + +} + +################################################################################ +# +# write list of potential workstations at current level to flat files +# +proc ToorWriteClientFile { level dir } { + global toor_vars TOOR_CLIENTS_FILE + + set num_entries [ llength $toor_vars($level,client_name_list) ] + + set client_fd -1 + catch { set client_fd [ open $dir/$TOOR_CLIENTS_FILE w+ ] }\ + ret_code + if { $client_fd != -1 } { + for { set index 0 } { $index < $num_entries } { incr index } { + + puts $client_fd "[ lindex $toor_vars($level,client_name_list) \ + $index ]|[ lindex \ + $toor_vars($level,client_ip_list) \ + $index ]|[ lindex \ + $toor_vars($level,client_org_list) \ + $index ]|[ lindex \ + $toor_vars($level,client_type_list) \ + $index ]|[ lindex \ + $toor_vars($level,client_role_list) $index ]" + + } + catch { close $client_fd } ret_code + } + + return +} + +################################################################################ +# +# write value of variable to the file named in "file" +# +proc ToorWriteVarToFile { variable file } { + upvar #0 $variable var + catch { [ exec /usr/bin/echo $var > $file ] } ret_code + catch { [ exec /usr/bin/chmod 644 $file ] } ret_code +} + +################################################################################ +# +# write configuration variables at current level to flat files +# +proc ToorWriteConfigFiles { level } { + global toor_vars \ + TOOR_CURRENT_CONFIG_DIR TOOR_LAST_CONFIG_DIR TOOR_NEW_CONFIG_DIR \ + TOOR_BEACON_BOOT_FILE TOOR_HOST_FILE TOOR_SDR_FILE \ + TOOR_MASTER_NAME_FILE TOOR_USE_BEACON_FILE \ + TOOR_CELL_NAME_FILE TOOR_DCE_MASTER_FILE \ + TOOR_HOST_ID_FILE TOOR_INTERFACE_FILE TOOR_OR_NAME_FILE \ + TOOR_ENCLAVE_FILE TOOR_LEFT_VIDEO_FILE \ + TOOR_RIGHT_VIDEO_FILE TOOR_LEFT_VIDEO_CMD_FILE \ + TOOR_RIGHT_VIDEO_CMD_FILE \ + TOOR_UIC_FILE TOOR_FDDI_OR_NAME_FILE \ + TOOR_OUR_ORGANIZ_FILE TOOR_OUR_ROLE_TYPE_FILE TOOR_OUR_ROLE_FILE \ + TOOR_FDDI_ORGANIZ_FILE TOOR_FDDI_ROLE_TYPE_FILE TOOR_FDDI_ROLE_FILE \ + TOOR_OUR_URN_FILE TOOR_LIST_FILE TOOR_MST_ORGANIZ_FILE \ + TOOR_MST_ROLE_TYPE_FILE TOOR_MST_ROLE_FILE \ + TOOR_DCE_ORGANIZ_FILE TOOR_DCE_ROLE_TYPE_FILE TOOR_DCE_ROLE_FILE + + if { $level == "orig" } { + set dir $TOOR_CURRENT_CONFIG_DIR + } elseif { $level == "new" } { + set dir $TOOR_NEW_CONFIG_DIR + } else { + set dir $TOOR_LAST_CONFIG_DIR + } + + set DOMAIN_FILE "domain" + set NODE_NAME_FILE "nodename" + set LOCAL_IP_FILE "local_ip" + set ASAS_IP_FILE "subsystem_ip" + set DCE_IP_FILE "dce_ip" + set FDDI_HOST_NAME_FILE "fddi_hostname" + set FDDI_IP_FILE "fddi_ip" + set FDDI_USED_FILE "fddi_used" + + # write configuration variables + ToorWriteVarToFile toor_vars($level,nis_domain) \ + $dir/$DOMAIN_FILE + + ToorWriteVarToFile toor_vars($level,local_hostname) \ + $dir/$NODE_NAME_FILE + + ToorWriteVarToFile toor_vars($level,local_ip) \ + $dir/$LOCAL_IP_FILE + + ToorWriteVarToFile toor_vars($level,beacon_is_being_used) \ + $dir/$TOOR_USE_BEACON_FILE + + ToorWriteVarToFile toor_vars($level,sdr) \ + $dir/$TOOR_SDR_FILE + + ToorWriteVarToFile toor_vars($level,asas_hostname) \ + $dir/$TOOR_MASTER_NAME_FILE + + ToorWriteVarToFile toor_vars($level,asas_ip) \ + $dir/$ASAS_IP_FILE + + ToorWriteVarToFile toor_vars($level,enclave) \ + $dir/$TOOR_ENCLAVE_FILE + + ToorWriteVarToFile toor_vars($level,hostid) \ + $dir/$TOOR_HOST_ID_FILE + + ToorWriteVarToFile toor_vars($level,net_intfc) \ + $dir/$TOOR_INTERFACE_FILE + + ToorWriteVarToFile toor_vars($level,dce_cell) \ + $dir/$TOOR_CELL_NAME_FILE + + ToorWriteVarToFile toor_vars($level,dce_hostname) \ + $dir/$TOOR_DCE_MASTER_FILE + + ToorWriteVarToFile toor_vars($level,dce_ip) \ + $dir/$DCE_IP_FILE + + ToorWriteVarToFile toor_vars($level,or_name) \ + $dir/$TOOR_OR_NAME_FILE + + ToorWriteVarToFile toor_vars($level,uic) \ + $dir/$TOOR_UIC_FILE + + ToorWriteVarToFile toor_vars($level,left_video) \ + $dir/$TOOR_LEFT_VIDEO_FILE + + ToorWriteVarToFile toor_vars($level,right_video) \ + $dir/$TOOR_RIGHT_VIDEO_FILE + + ToorWriteVarToFile toor_vars($level,left_video_cmd) \ + $dir/$TOOR_LEFT_VIDEO_CMD_FILE + + ToorWriteVarToFile toor_vars($level,right_video_cmd) \ + $dir/$TOOR_RIGHT_VIDEO_CMD_FILE + + ToorWriteVarToFile toor_vars($level,fddi_used) \ + $dir/$FDDI_USED_FILE + + ToorWriteVarToFile toor_vars($level,fddi_hostname) \ + $dir/$FDDI_HOST_NAME_FILE + + ToorWriteVarToFile toor_vars($level,fddi_ip) \ + $dir/$FDDI_IP_FILE + + ToorWriteVarToFile toor_vars($level,fddi_or_name) \ + $dir/$TOOR_FDDI_OR_NAME_FILE + + ToorWriteVarToFile toor_vars($level,our_organiz) \ + $dir/$TOOR_OUR_ORGANIZ_FILE + + ToorWriteVarToFile toor_vars($level,our_role_typ) \ + $dir/$TOOR_OUR_ROLE_TYPE_FILE + + ToorWriteVarToFile toor_vars($level,our_role) \ + $dir/$TOOR_OUR_ROLE_FILE + + ToorWriteVarToFile toor_vars($level,our_urn) \ + $dir/$TOOR_OUR_URN_FILE + + ToorWriteVarToFile toor_vars($level,fddi_organiz) \ + $dir/$TOOR_FDDI_ORGANIZ_FILE + + ToorWriteVarToFile toor_vars($level,fddi_role_typ) \ + $dir/$TOOR_FDDI_ROLE_TYPE_FILE + + ToorWriteVarToFile toor_vars($level,fddi_role) \ + $dir/$TOOR_FDDI_ROLE_FILE + + ToorWriteVarToFile toor_vars($level,mst_organiz) \ + $dir/$TOOR_MST_ORGANIZ_FILE + + ToorWriteVarToFile toor_vars($level,mst_role_typ) \ + $dir/$TOOR_MST_ROLE_TYPE_FILE + + ToorWriteVarToFile toor_vars($level,mst_role) \ + $dir/$TOOR_MST_ROLE_FILE + + ToorWriteVarToFile toor_vars($level,dce_organiz) \ + $dir/$TOOR_DCE_ORGANIZ_FILE + + ToorWriteVarToFile toor_vars($level,dce_role_typ) \ + $dir/$TOOR_DCE_ROLE_TYPE_FILE + + ToorWriteVarToFile toor_vars($level,dce_role) \ + $dir/$TOOR_DCE_ROLE_FILE + + ToorWriteVarToFile toor_vars($level,list_selection) \ + $dir/$TOOR_LIST_FILE + + ToorWriteClientFile $level $dir +} + +################################################################################ +# +# Create default_accounts file if are changing from an ASAS subsystem client +# to an ASAS subsystem master. Signals later scripts to recreate the +# factory accounts +# +proc ToorCheckAccountReload {} { + global toor_vars TOOR_NEED_ACCTS_FILE + if { $toor_vars(new,local_is_asas_master) == "asasmaster" \ + && $toor_vars(orig,local_is_asas_master) == "asasclient" } { + catch { [ exec /usr/bin/touch $TOOR_NEED_ACCTS_FILE ] } ret_code + catch { exec /usr/bin/chmod 644 $TOOR_NEED_ACCTS_FILE } ret_code + } else { + catch { [ exec /usr/bin/rm -f $TOOR_NEED_ACCTS_FILE ] } ret_code + } +} + +################################################################################ +# +# set desired configuration to original configuration +# +proc ToorSetDefaultToInitConfig {} { + global toor_vars + set toor_vars(new,nis_domain) $toor_vars(orig,nis_domain) + set toor_vars(new,local_hostname) $toor_vars(orig,local_hostname) + set toor_vars(new,local_ip) $toor_vars(orig,local_ip) + set toor_vars(new,or_name) $toor_vars(orig,or_name) + set toor_vars(new,or_name_s) [string trim $toor_vars(new,or_name)] + set toor_vars(new,uic) $toor_vars(orig,uic) + set toor_vars(new,beacon_is_being_used) \ + $toor_vars(orig,beacon_is_being_used) + set toor_vars(new,sdr) $toor_vars(orig,sdr) + set toor_vars(new,asas_hostname) $toor_vars(orig,asas_hostname) + set toor_vars(new,asas_ip) $toor_vars(orig,asas_ip) + set toor_vars(new,local_is_asas_master) \ + $toor_vars(orig,local_is_asas_master) + set toor_vars(new,enclave) $toor_vars(orig,enclave) + set toor_vars(new,net_intfc) $toor_vars(orig,net_intfc) + set toor_vars(new,dce_cell) $toor_vars(orig,dce_cell) + set toor_vars(new,dce_hostname) $toor_vars(orig,dce_hostname) + set toor_vars(new,dce_ip) $toor_vars(orig,dce_ip) + set toor_vars(new,local_is_dce_master) $toor_vars(orig,local_is_dce_master) + set toor_vars(new,asas_is_dce_master) $toor_vars(orig,asas_is_dce_master) + set toor_vars(new,hostid) $toor_vars(orig,hostid) + set toor_vars(new,left_video) $toor_vars(orig,left_video) + set toor_vars(new,right_video) $toor_vars(orig,right_video) + set toor_vars(new,left_video_cmd) $toor_vars(orig,left_video_cmd) + set toor_vars(new,right_video_cmd) $toor_vars(orig,right_video_cmd) + set toor_vars(new,fddi_hostname) $toor_vars(orig,fddi_hostname) + set toor_vars(new,fddi_used) $toor_vars(orig,fddi_used) + set toor_vars(new,fddi_ip) $toor_vars(orig,fddi_ip) + set toor_vars(new,fddi_or_name) $toor_vars(orig,fddi_or_name) + set toor_vars(new,our_organiz) $toor_vars(orig,our_organiz) + set toor_vars(new,our_role_typ) $toor_vars(orig,our_role_typ) + set toor_vars(new,our_role) $toor_vars(orig,our_role) + set toor_vars(new,our_urn) $toor_vars(orig,our_urn) + set toor_vars(new,fddi_organiz) $toor_vars(orig,fddi_organiz) + set toor_vars(new,fddi_role_typ) $toor_vars(orig,fddi_role_typ) + set toor_vars(new,fddi_role) $toor_vars(orig,fddi_role) + set toor_vars(new,mst_organiz) $toor_vars(orig,mst_organiz) + set toor_vars(new,mst_role_typ) $toor_vars(orig,mst_role_typ) + set toor_vars(new,mst_role) $toor_vars(orig,mst_role) + set toor_vars(new,dce_organiz) $toor_vars(orig,dce_organiz) + set toor_vars(new,dce_role_typ) $toor_vars(orig,dce_role_typ) + set toor_vars(new,dce_role) $toor_vars(orig,dce_role) + set toor_vars(new,list_selection) $toor_vars(orig,list_selection) + set toor_vars(new,client_name_list) $toor_vars(orig,client_name_list) + set toor_vars(new,client_ip_list) $toor_vars(orig,client_ip_list) + set toor_vars(new,client_org_list) $toor_vars(orig,client_org_list) + set toor_vars(new,client_type_list) $toor_vars(orig,client_type_list) + set toor_vars(new,client_role_list) $toor_vars(orig,client_role_list) + +} + +################################################################################ +# +# FUNCTION: main +# +# DESCRIPTION: Get information on current workstation configuration, prompt +# user for updates, then write out desired configuration for +# use later in the boot process +# +# NOTES: Reconfiguration forces an automatic reboot. When this +# reboot is detected, the desired configuration is moved to the +# new configuration +# +# PARAMETERS: None +# +# GLOBAL VARIABLES AND SIDE EFFECTS: +# current configuration written to /asas/data/current +# desired configuration written to /asas/data/new +# on reboot desired configuration written to /asas/data/new +# +# RETURNS: 0 +# +################################################################################ + +ToorCheckHaveDirectories + +ToorGetEthernetInterfaces + +ToorGetInitialConfig + +ToorWriteConfigFiles orig + +if { ! [file exists $TOOR_RECONFIG_FILE] } { + set toor_go_back_to_first_menu "Y" + + ToorAgeLogFiles + + set toor_organiz_list {} + set toor_org_ip_list {} + ToorCacheUnl $TOOR_ORGANIZ_UNL_FILE toor_organiz_list 2 + ToorCacheUnl $TOOR_ORG_IP_UNL_FILE toor_org_ip_list + + ToorDisplayGlobals orig + + while {$toor_go_back_to_first_menu == "Y"} { + + set toor_reconfig_needed "N" + set toor_go_back_to_first_menu "N" + ToorSetDefaultToInitConfig + + # show current config and ask if change needed + ToorDisplayConfig .f1 + + if { [ ToorWantToChangeConfig ] == "Y" } { + + # user wants to change configuration, prompt for values, + # The cancel keys will set toor_go_back_to_first_menu = Y and we'll + # go back to displaying the original configuration + + set toor_reconfig_needed "Y" + ToorPleaseWait + destroy .f1 + ToorGetLocalConfig .f1 + + if { $toor_go_back_to_first_menu == "N" } { + if { $toor_vars(new,fddi_used) == "Y" } { + ToorGetFddiConfig .f1 + } + } + + if { $toor_go_back_to_first_menu == "N" } { + ToorGetDisplayConfig .f1 + } + + if { $toor_go_back_to_first_menu == "N" } { + ToorGetTopConfig .f1 + } + + if { $toor_go_back_to_first_menu == "N" } { + if { $toor_vars(new,beacon_is_being_used) == "beacon" } { + ToorSetBeaconDceConfig + } else { + # not using beacon, get dce configuration info from user + if {$toor_vars(new,local_is_asas_master) == "asasmaster"} { + ToorGetCurrentTime .f1 + if { $toor_go_back_to_first_menu == "N" } { + ToorGetServerDceConfig .f1 + } + } else { + ToorGetClientDceConfig .f1 + } + } + } + + if { $toor_go_back_to_first_menu == "N" } { + ToorSetDcePassword .f1 + } + + if { $toor_go_back_to_first_menu == "N" } { + ToorDisplayNewConfig .f1 + } + + } else { + + # no change requested, make sure hostid hasn't changed + + destroy .f1 + ToorCheckHostId .f1 + + } + + } + + if { $toor_reconfig_needed == "Y" } { + + # something has changed, turn off beacon script and enable reconfig + + ToorReconfigWarning .f1 + ToorLogMessage "reconfiguration needed" + ToorDisplayGlobals new + ToorWriteConfigFiles new + ToorWriteVarToFile toor_reconfig_needed $TOOR_RECONFIG_FILE + ToorCheckAccountReload + ToorRenameFileLists TOOR_BEACON_OFF_LIST TOOR_BEACON_ON_LIST + if { $toor_vars(new,beacon_is_being_used) == "beacon" } { + ToorRenameFileLists TOOR_BEACON_PASS1_OFF_LIST \ + TOOR_BEACON_PASS1_ON_LIST + catch { exec /usr/bin/rm -f $TOOR_BEACON_COMMAND_FILE } ret_code + } else { + ToorRenameFileLists TOOR_BEACON_PASS1_ON_LIST \ + TOOR_BEACON_PASS1_OFF_LIST + } + + if { $toor_vars(new,sdr) == "sdr" } { + ToorRenameFileLists TOOR_SDR_OFF_LIST TOOR_SDR_ON_LIST + } else { + ToorRenameFileLists TOOR_SDR_ON_LIST TOOR_SDR_OFF_LIST + } + + if { $toor_vars(new,fddi_used) == "Y" } { + ToorRenameFileLists TOOR_FDDI_OFF_LIST TOOR_FDDI_ON_LIST + } else { + ToorRenameFileLists TOOR_FDDI_ON_LIST TOOR_FDDI_OFF_LIST + } + + } else { + ToorLogMessage "NO reconfiguration requested" + } + +} else { + + # Entered after automatic reboot after a reconfiguration + ToorLogMessage "detected automatic reboot" + + # set beacon active as requested by user + ToorSetVarFromFile use_beacon $TOOR_NEW_CONFIG_DIR/$TOOR_USE_BEACON_FILE + if { $use_beacon == "beacon" } { + ToorRenameFileLists TOOR_BEACON_ON_LIST TOOR_BEACON_OFF_LIST + } else { + ToorRenameFileLists TOOR_BEACON_OFF_LIST TOOR_BEACON_ON_LIST + } + + # enable some scripts based on subsystem master/client status + ToorSetVarFromFile master $TOOR_NEW_CONFIG_DIR/$TOOR_MASTER_NAME_FILE + if { $master == $toor_vars(orig,local_hostname) } { + ToorRenameFileLists TOOR_MASTER_OFF_LIST TOOR_MASTER_ON_LIST + + catch { exec /usr/bin/cp $TOOR_CRONTAB_HOME $TOOR_CRONTAB_DEST } \ + ret_code + catch { exec /usr/bin/chown root:analyst $TOOR_CRONTAB_DEST } \ + ret_code + catch { exec /usr/bin/chmod 400 $TOOR_CRONTAB_DEST } \ + ret_code + } else { + ToorRenameFileLists TOOR_MASTER_ON_LIST TOOR_MASTER_OFF_LIST + + catch { exec /usr/bin/rm -f TOOR_CRONTAB_DEST } ret_code + } + + foreach file_name [ glob -nocomplain $TOOR_LAST_CONFIG_DIR/*.nis ] { + catch { exec /usr/bin/cp -p $file_name $TOOR_CURRENT_CONFIG_DIR } \ + ret_code + } + foreach file_name [ glob -nocomplain $TOOR_LAST_CONFIG_DIR/*.new ] { + catch { exec /usr/bin/cp -p $file_name $TOOR_CURRENT_CONFIG_DIR } \ + ret_code + } + foreach file_name [ glob -nocomplain $TOOR_NEW_CONFIG_DIR/* ] { + catch { exec /usr/bin/cp -p $file_name $TOOR_LAST_CONFIG_DIR } ret_code + } + foreach file_name [ glob -nocomplain $TOOR_NEW_CONFIG_DIR/*.nis ] { + catch { exec /usr/bin/rm -f $file_name } ret_code + } + catch { exec /usr/bin/mv -f $TOOR_NEW_CONFIG_DIR/$TOOR_CELL_ADMIN_PW \ + $TOOR_DATA_DIR/$TOOR_CELL_ADMIN_PW } ret_code + catch { exec /usr/bin/cp -p $TOOR_NEW_CONFIG_DIR/$TOOR_ENCLAVE_FILE \ + $TOOR_DEFAULT_ENCLAVE_FILE } ret_code + catch { exec /usr/bin/rm -f $TOOR_RECONFIG_FILE } ret_code + catch { exec /usr/bin/chmod 644 $TOOR_DEFAULT_ENCLAVE_FILE } ret_code + catch { exec /usr/bin/chmod 644 $TOOR_LAST_CONFIG_DIR/$TOOR_ENCLAVE_FILE } \ + ret_code + catch { exec /usr/bin/cp $TOOR_NEW_CONFIG_DIR/$TOOR_ENCLAVE_FILE \ + $TOOR_TFTP_DIR/$TOOR_ENCLAVE_FILE } ret_code + catch { exec /usr/bin/chmod 644 $TOOR_TFTP_DIR/$TOOR_ENCLAVE_FILE } ret_code + catch { exec /usr/bin/chown nobody $TOOR_TFTP_DIR/$TOOR_ENCLAVE_FILE } \ + ret_code + catch { exec /usr/bin/chgrp nobody $TOOR_TFTP_DIR/$TOOR_ENCLAVE_FILE } \ + ret_code + catch { exec /usr/bin/cp $TOOR_DEFAULT_DOMAIN_FILE \ + $TOOR_TFTP_DIR/domain } ret_code + catch { exec /usr/bin/chmod 644 $TOOR_TFTP_DIR/domain } ret_code + catch { exec /usr/bin/chown nobody $TOOR_TFTP_DIR/domain } ret_code + catch { exec /usr/bin/chgrp nobody $TOOR_TFTP_DIR/domain } ret_code + +} + +exit ADDED tk.h Index: tk.h ================================================================== --- tk.h +++ tk.h @@ -0,0 +1,850 @@ +/* + * tk.h (installed as ctk.h) (CTk) -- + * + * 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 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Header: /usrs/andrewm/work/RCS/ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#ifndef _TK +#define _TK + +#define TK_VERSION "8.0" +#define TK_MAJOR_VERSION 8 +#define TK_MINOR_VERSION 0 +#define TK_PORT_CURSES + +#ifndef _TCL +#include +#endif +#ifdef __STDC__ +#include +#endif + +/* + * Dummy types that are used by clients: + */ + +typedef struct Tk_BindingTable_ *Tk_BindingTable; +typedef struct Tk_TimerToken_ *Tk_TimerToken; +typedef struct TkWindow *Tk_Window; + +/* + * Additional types exported to clients. + */ + +typedef char *Tk_Uid; + +/* + * Definitions that shouldn't be used by clients, but its simpler + * to put them here. + */ +typedef struct CtkRegion CtkRegion; +typedef struct TkMainInfo TkMainInfo; +typedef struct TkDisplay TkDisplay; +typedef struct TkEventHandler TkEventHandler; + +/* + * CTk specific definitions. + */ + +typedef struct { + int left; + int top; + int right; + int bottom; +} Ctk_Rect; + +typedef enum { + CTK_INVISIBLE_STYLE, CTK_PLAIN_STYLE, CTK_UNDERLINE_STYLE, + CTK_REVERSE_STYLE, CTK_DIM_STYLE, CTK_BOLD_STYLE, + CTK_DISABLED_STYLE, CTK_BUTTON_STYLE, CTK_CURSOR_STYLE, + CTK_SELECTED_STYLE +} Ctk_Style; + +typedef enum { + CTK_MAP_EVENT, CTK_UNMAP_EVENT, CTK_EXPOSE_EVENT, + CTK_FOCUS_EVENT, CTK_UNFOCUS_EVENT, CTK_KEY_EVENT, + CTK_DESTROY_EVENT, CTK_UNSUPPORTED_EVENT +} Ctk_EventType; + +/* + * Event groupings. + */ + +#define CTK_MAP_EVENT_MASK (1<<0) +#define CTK_EXPOSE_EVENT_MASK (1<<1) +#define CTK_FOCUS_EVENT_MASK (1<<2) +#define CTK_KEY_EVENT_MASK (1<<3) +#define CTK_DESTROY_EVENT_MASK (1<<4) +#define CTK_UNSUPPORTED_EVENT_MASK (1<<5) + +/* + * Various X11 definitions to ease porting of Tk code. + */ + +#define MapNotify CTK_MAP_EVENT +#define ConfigureNotify CTK_MAP_EVENT +#define UnmapNotify CTK_UNMAP_EVENT +#define Expose CTK_EXPOSE_EVENT +#define FocusIn CTK_FOCUS_EVENT +#define FocusOut CTK_UNFOCUS_EVENT +#define KeyPress CTK_KEY_EVENT +#define DestroyNotify CTK_DESTROY_EVENT + +#define StructureNotifyMask (CTK_MAP_EVENT_MASK|CTK_DESTROY_EVENT_MASK) + +#define ShiftMask (1<<0) +#define LockMask (1<<1) +#define ControlMask (1<<2) +#define Mod1Mask (1<<3) +#define Mod2Mask (1<<4) +#define Mod3Mask (1<<5) +#define Mod4Mask (1<<6) +#define Mod5Mask (1<<7) +#define Button1Mask (1<<8) +#define Button2Mask (1<<9) +#define Button3Mask (1<<10) +#define Button4Mask (1<<11) +#define Button5Mask (1<<12) +#define AnyModifier (1<<15) + +#define Above 0 +#define Below 1 + +typedef unsigned long Time; +typedef unsigned long KeySym; +typedef struct { + short x, y; +} XPoint; + +/* + * One of these structures is created for every event that occurs. + * They are stored in a queue for the appropriate display. + */ + +typedef struct Ctk_Event { + Ctk_EventType type; /* Type of event. */ + Tk_Window window; /* Window where event occured. */ + unsigned long serial; /* Assigned by Tk_HandleEvent() */ + struct Ctk_Event *nextPtr; /* Next event in queue. */ + + union { /* Detail info according to type: */ + struct { + KeySym sym; /* X-style key symbol. */ + unsigned int state; /* Modifier key mask. */ + Time time; /* When key was pressed. */ + } key; + Ctk_Rect expose; /* Rectangle to redraw. */ + } u; +} Ctk_Event, XEvent; + +/* + * CTk special routines. + */ + +EXTERN Tk_Window Ctk_ParentByName _ANSI_ARGS_((Tcl_Interp *interp, + char *pathName, Tk_Window)); +EXTERN int Ctk_Unsupported _ANSI_ARGS_((Tcl_Interp *interp, + char *feature)); +EXTERN void Ctk_Map _ANSI_ARGS_((Tk_Window tkwin, + int x1, int y1, int x2, int y2)); +EXTERN void Ctk_Unmap _ANSI_ARGS_((Tk_Window tkwin)); + +/* + * Window info + */ + +#define Ctk_Left(tkwin) ((tkwin)->rect.left) +#define Ctk_Top(tkwin) ((tkwin)->rect.top) +#define Ctk_Right(tkwin) ((tkwin)->rect.right) +#define Ctk_Bottom(tkwin) ((tkwin)->rect.bottom) +#define Ctk_AbsLeft(tkwin) ((tkwin)->absLeft) +#define Ctk_AbsTop(tkwin) ((tkwin)->absTop) + + +EXTERN Tk_Window Ctk_PriorSibling _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN Tk_Window Ctk_NextSibling _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN Tk_Window Ctk_BottomChild _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN Tk_Window Ctk_TopChild _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN Tk_Window Ctk_TopLevel _ANSI_ARGS_((Tk_Window tkwin)); + + +/* + * Display Device definitions. + * + * Meant to mask curses level I/O so it could be swapped with + * another (DOS character I/O for example). + */ + +EXTERN void Ctk_DisplayFlush _ANSI_ARGS_((TkDisplay *dispPtr)); +EXTERN int Ctk_DisplayWidth _ANSI_ARGS_((TkDisplay *dispPtr)); +EXTERN int Ctk_DisplayHeight _ANSI_ARGS_((TkDisplay *dispPtr)); +EXTERN void Ctk_DisplayRedraw _ANSI_ARGS_((TkDisplay *dispPtr)); +EXTERN void Ctk_DrawString _ANSI_ARGS_((Tk_Window tkwin, + int x, int y, Ctk_Style style, + char *string, int length)); +EXTERN void Ctk_DrawCharacter _ANSI_ARGS_((Tk_Window tkwin, + int x, int y, Ctk_Style style, int ch)); +EXTERN void Ctk_DrawRect _ANSI_ARGS_((Tk_Window tkwin, + int x1, int y1, int x2, int y2, Ctk_Style style)); +EXTERN void Ctk_FillRect _ANSI_ARGS_((Tk_Window tkwin, + int x1, int y1, int x2, int y2, + Ctk_Style style, int ch)); +EXTERN void Ctk_ClearWindow _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Ctk_DrawBorder _ANSI_ARGS_((Tk_Window, Ctk_Style, + char *title)); +EXTERN void Ctk_SetCursor _ANSI_ARGS_((Tk_Window, int x, int y)); + +/* + * 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_JUSTIFY 13 +#define TK_CONFIG_ANCHOR 14 +#define TK_CONFIG_SYNONYM 15 +#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 + +/* + * Special return value from Tk_FileProc2 procedures indicating that + * an event was successfully processed. + */ + +#define TK_FILE_HANDLED -1 + +/* + * Flag values to pass to Tk_DoOneEvent to disable searches + * for some kinds of events: + */ + +#define TK_DONT_WAIT TCL_DONT_WAIT +#define TK_X_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 + +/* + * 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 + +/* + * 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 + + +/* + *-------------------------------------------------------------- + * + * Macros for querying Tk_Window structures. See the + * manual entries for documentation. + * + *-------------------------------------------------------------- + */ + +#define Tk_Display(tkwin) ((tkwin)->dispPtr) +#define Tk_Depth(tkwin) 1 +#define Tk_WindowId(tkwin) (tkwin) +#define Tk_PathName(tkwin) ((tkwin)->pathName) +#define Tk_Name(tkwin) ((tkwin)->nameUid) +#define Tk_Class(tkwin) ((tkwin)->classUid) +#define Tk_X(tkwin) ((tkwin)->rect.left) +#define Tk_Y(tkwin) ((tkwin)->rect.top) +#define Tk_Width(tkwin) \ + ((tkwin)->rect.right - (tkwin)->rect.left) +#define Tk_Height(tkwin) \ + ((tkwin)->rect.bottom - (tkwin)->rect.top) +#define Tk_IsMapped(tkwin) ((tkwin)->flags & TK_MAPPED) +#define Tk_IsTopLevel(tkwin) ((tkwin)->flags & TK_TOP_LEVEL) +#define Tk_ReqWidth(tkwin) ((tkwin)->reqWidth) +#define Tk_ReqHeight(tkwin) ((tkwin)->reqHeight) +#define Tk_InternalBorderWidth(tkwin) ((tkwin)->borderWidth) +#define Tk_BorderWidth(tkwin) 0 +#define Tk_Parent(tkwin) ((tkwin)->parentPtr) + + +typedef struct TkWindow { + /* + * Relatives + */ + struct TkWindow *priorPtr; + struct TkWindow *nextPtr; + struct TkWindow *parentPtr; + struct { + struct TkWindow *priorPtr; /* Top child */ + struct TkWindow *nextPtr; /* Bottom child */ + } childList; + + char *pathName; /* Full name of window */ + Tk_Uid nameUid; /* Name of the window within its parent + * (unique within the parent). */ + Tk_Uid classUid; /* Widget class */ + int flags; /* Various status flags, see below */ + TkMainInfo *mainPtr; /* Information shared by all windows + * associated with a particular main + * window. */ + TkDisplay *dispPtr; /* Display for window. */ + + /* + * Geometry + */ + Ctk_Rect rect; /* Window outline, relative to parent. + * Undefined if window is not mapped. */ + int absLeft, absTop; /* Absolute screen position. Undefined if + * window is not displayed. */ + int borderWidth; /* Internal border width. Does not affect + * the window's local coordinate system, + * but the border area is removed from + * the clipRect so that widget can't draw + * on border. */ + Ctk_Rect maskRect; /* In absolute coordinates. Represents clipping + * by parents. Used for computing overlap with + * other windows. */ + Ctk_Rect clipRect; /* In absolute coordinates. Represents clipping + * by parents and internal border. Undefined + * if window is not displayed. */ + CtkRegion *clipRgn; /* In absolute coordinates, represents clipping + * by siblings, shared by entire tree of + * a top-level window. Undefined if window + * is not displayed. */ + + /* + * Background fill + */ + Ctk_Style fillStyle; + int fillChar; + + /* + * 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 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 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. */ +} TkWindow; + +typedef TkWindow Tk_FakeWin; + +/* + * Flag values for TkWindow (and Tk_FakeWin) structures are: + * + * TK_MAPPED Is the window positioned in the parent window? + * Window has a relative position, but not necessarily + * an absolute one. + * + * TK_ALREADY_DEAD If true, free_proc will be called during next + * idle period. BEWARE: Most of the field are + * undefined if this flag is set. (Which are + * valid?). + * + * TK_TOP_LEVEL: 1 means this is a top-level window (it + * was or will be created as a child of + * a root window). + * + * CTK_DISPLAYED Is window and all its ancestors mapped? Window has an + * absolute position. + * + * CTK_HAS_TOPLEVEL_CHILD + * 1 means this window has top-level children (which + * won't be in the standard linked list of children + * for this window - the will be found as a child + * of a root window and must be located by name.) + */ +#define TK_MAPPED (1<<0) +#define TK_ALREADY_DEAD (1<<1) +#define TK_TOP_LEVEL (1<<2) +#define CTK_DISPLAYED (1<<3) +#define CTK_HAS_TOPLEVEL_CHILD (1<<4) + + + +/* + *-------------------------------------------------------------- + * + * Additional procedure types defined by Tk. + * + *-------------------------------------------------------------- + */ + +typedef void (Tk_EventProc) _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +typedef void (Tk_FileProc) _ANSI_ARGS_((ClientData clientData, int mask)); +typedef int (Tk_FileProc2) _ANSI_ARGS_((ClientData clientData, int mask, + int flags)); +typedef void (Tk_FreeProc) _ANSI_ARGS_((ClientData clientData)); +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_IdleProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tk_LostSelProc) _ANSI_ARGS_((ClientData clientData)); +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 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 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 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 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_CreateFileHandler2 _ANSI_ARGS_((int fd, + Tk_FileProc2 *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 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 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_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_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_EventuallyFree _ANSI_ARGS_((ClientData clientData, + Tk_FreeProc *freeProc)); +EXTERN void Tk_FreeOptions _ANSI_ARGS_((Tk_ConfigSpec *specs, + char *widgRec, int needFlags)); +EXTERN void Tk_GeometryRequest _ANSI_ARGS_((Tk_Window tkwin, + int reqWidth, int reqHeight)); +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_GetBinding _ANSI_ARGS_((Tcl_Interp *interp, + Tk_BindingTable bindingTable, ClientData object, + char *eventString)); +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 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 Tk_Uid Tk_GetUid _ANSI_ARGS_((char *string)); +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 int Tk_Init _ANSI_ARGS_((Tcl_Interp *interp)); +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)); +#define Tk_MapWindow(tkwin) \ + Ctk_Map(tkwin, Ctk_Left(tkwin), Ctk_Top(tkwin), \ + Ctk_Right(tkwin), Ctk_Bottom(tkwin)) +#define Tk_MoveResizeWindow(tkwin, x, y, width, height) \ + Ctk_Map(tkwin, x, y, (x)+(width), (y)+(height)) +EXTERN char * Tk_NameOfAnchor _ANSI_ARGS_((Tk_Anchor anchor)); +EXTERN char * Tk_NameOfJustify _ANSI_ARGS_((Tk_Justify justify)); +EXTERN Tk_Window Tk_NameToWindow _ANSI_ARGS_((Tcl_Interp *interp, + char *pathName, Tk_Window tkwin)); +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 void Tk_Release _ANSI_ARGS_((ClientData clientData)); +EXTERN int Tk_RestackWindow _ANSI_ARGS_((Tk_Window tkwin, + int aboveBelow, Tk_Window other)); +EXTERN char * Tk_SetAppName _ANSI_ARGS_((Tk_Window tkwin, + char *name)); +EXTERN void Tk_SetClass _ANSI_ARGS_((Tk_Window tkwin, + char *className)); +EXTERN void Tk_SetInternalBorder _ANSI_ARGS_((Tk_Window tkwin, + int width)); +EXTERN void Tk_Sleep _ANSI_ARGS_((int ms)); +EXTERN int Tk_StrictMotif _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_UnmaintainGeometry _ANSI_ARGS_((Tk_Window slave, + Tk_Window master)); +#define Tk_UnmapWindow(tkwin) Ctk_Unmap(tkwin) + + +EXTERN int tk_NumMainWindows; + +/* + * Tcl commands peculiar to CTk. + */ + +EXTERN int Ctk_CtkCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Ctk_CtkEventCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Ctk_TkFocusNextCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Ctk_TkFocusPrevCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Ctk_TkEntryInsertCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int Ctk_TkEntrySeeInsertCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); + +/* + * 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_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_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_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_GrabCmd _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_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_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 */ ADDED tkAppInit.c Index: tkAppInit.c ================================================================== --- tkAppInit.c +++ tkAppInit.c @@ -0,0 +1,120 @@ +/* + * tkAppInit.c (CTk) -- + * + * Provides a default version of the Tcl_AppInit procedure for + * use in wish and similar Tk-based applications. + * + * 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. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + + +#include "tk.h" /* may need to change this to ctk.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; + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * This is the main program for the application. + * + * Results: + * None: Tk_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. */ +{ + Tk_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; + } + if (Tk_Init(interp) == TCL_ERROR) { + 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. + */ + + /* + * 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", "~/.cwishrc", TCL_GLOBAL_ONLY); + return TCL_OK; +} + +#if TCL_MAJOR_VERSION >= 8 +#if 0 +void panic(const char *msg) +{ + fprintf(stderr, msg); + exit(1); +} +#endif +#else + #error TCL_MAJOR_VERSION +#endif ADDED tkArgv.c Index: tkArgv.c ================================================================== --- tkArgv.c +++ tkArgv.c @@ -0,0 +1,437 @@ +/* + * tkArgv.c (CTk) -- + * + * This file contains a procedure that handles table-based + * argv-argc parsing. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "tk.h" + +/* + * Default table of argument descriptors. These are normally available + * in every application. + */ + +static Tk_ArgvInfo defaultTable[] = { + {"-help", TK_ARGV_HELP, (char *) NULL, (char *) NULL, + "Print summary of command-line options and abort"}, + {NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, + (char *) NULL} +}; + +/* + * Forward declarations for procedures defined in this file: + */ + +static void PrintUsage _ANSI_ARGS_((Tcl_Interp *interp, + Tk_ArgvInfo *argTable, int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tk_ParseArgv -- + * + * Process an argv array according to a table of expected + * command-line options. See the manual page for more details. + * + * Results: + * The return value is a standard Tcl return value. If an + * error occurs then an error message is left in interp->result. + * Under normal conditions, both *argcPtr and *argv are modified + * to return the arguments that couldn't be processed here (they + * didn't match the option table, or followed an TK_ARGV_REST + * argument). + * + * Side effects: + * Variables may be modified, resources may be entered for tkwin, + * or procedures may be called. It all depends on the arguments + * and their entries in argTable. See the user documentation + * for details. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ParseArgv(interp, tkwin, argcPtr, argv, argTable, flags) + Tcl_Interp *interp; /* Place to store error message. */ + Tk_Window tkwin; /* Window to use for setting Tk options. + * NULL means ignore Tk option specs. */ + int *argcPtr; /* Number of arguments in argv. Modified + * to hold # args left in argv at end. */ + char **argv; /* Array of arguments. Modified to hold + * those that couldn't be processed here. */ + Tk_ArgvInfo *argTable; /* Array of option descriptions */ + int flags; /* Or'ed combination of various flag bits, + * such as TK_ARGV_NO_DEFAULTS. */ +{ + register Tk_ArgvInfo *infoPtr; + /* Pointer to the current entry in the + * table of argument descriptions. */ + Tk_ArgvInfo *matchPtr; /* Descriptor that matches current argument. */ + char *curArg; /* Current argument */ + register char c; /* Second character of current arg (used for + * quick check for matching; use 2nd char. + * because first char. will almost always + * be '-'). */ + int srcIndex; /* Location from which to read next argument + * from argv. */ + int dstIndex; /* Index into argv to which next unused + * argument should be copied (never greater + * than srcIndex). */ + int argc; /* # arguments in argv still to process. */ + size_t length; /* Number of characters in current argument. */ + int i; + + if (flags & TK_ARGV_DONT_SKIP_FIRST_ARG) { + srcIndex = dstIndex = 0; + argc = *argcPtr; + } else { + srcIndex = dstIndex = 1; + argc = *argcPtr-1; + } + + while (argc > 0) { + curArg = argv[srcIndex]; + srcIndex++; + argc--; + if (length > 0) { + c = curArg[1]; + } else { + c = 0; + } + length = strlen(curArg); + + /* + * Loop throught the argument descriptors searching for one with + * the matching key string. If found, leave a pointer to it in + * matchPtr. + */ + + matchPtr = NULL; + for (i = 0; i < 2; i++) { + if (i == 0) { + infoPtr = argTable; + } else { + infoPtr = defaultTable; + } + for (; (infoPtr != NULL) && (infoPtr->type != TK_ARGV_END); + infoPtr++) { + if (infoPtr->key == NULL) { + continue; + } + if ((infoPtr->key[1] != c) + || (strncmp(infoPtr->key, curArg, length) != 0)) { + continue; + } + if ((tkwin == NULL) + && ((infoPtr->type == TK_ARGV_CONST_OPTION) + || (infoPtr->type == TK_ARGV_OPTION_VALUE) + || (infoPtr->type == TK_ARGV_OPTION_NAME_VALUE))) { + continue; + } + if (infoPtr->key[length] == 0) { + matchPtr = infoPtr; + goto gotMatch; + } + if (flags & TK_ARGV_NO_ABBREV) { + continue; + } + if (matchPtr != NULL) { + Tcl_AppendResult(interp, "ambiguous option \"", curArg, + "\"", (char *) NULL); + return TCL_ERROR; + } + matchPtr = infoPtr; + } + } + if (matchPtr == NULL) { + + /* + * Unrecognized argument. Just copy it down, unless the caller + * prefers an error to be registered. + */ + + if (flags & TK_ARGV_NO_LEFTOVERS) { + Tcl_AppendResult(interp, "unrecognized argument \"", + curArg, "\"", (char *) NULL); + return TCL_ERROR; + } + argv[dstIndex] = curArg; + dstIndex++; + continue; + } + + /* + * Take the appropriate action based on the option type + */ + + gotMatch: + infoPtr = matchPtr; + switch (infoPtr->type) { + case TK_ARGV_CONSTANT: + *((int *) infoPtr->dst) = (int) infoPtr->src; + break; + case TK_ARGV_INT: + if (argc == 0) { + goto missingArg; + } else { + char *endPtr; + + *((int *) infoPtr->dst) = + strtol(argv[srcIndex], &endPtr, 0); + if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) { + Tcl_AppendResult(interp, "expected integer argument ", + "for \"", infoPtr->key, "\" but got \"", + argv[srcIndex], "\"", (char *) NULL); + return TCL_ERROR; + } + srcIndex++; + argc--; + } + break; + case TK_ARGV_STRING: + if (argc == 0) { + goto missingArg; + } else { + *((char **)infoPtr->dst) = argv[srcIndex]; + srcIndex++; + argc--; + } + break; + case TK_ARGV_UID: + if (argc == 0) { + goto missingArg; + } else { + *((Tk_Uid *)infoPtr->dst) = Tk_GetUid(argv[srcIndex]); + srcIndex++; + argc--; + } + break; + case TK_ARGV_REST: + *((int *) infoPtr->dst) = dstIndex; + goto argsDone; + case TK_ARGV_FLOAT: + if (argc == 0) { + goto missingArg; + } else { + char *endPtr; + + *((double *) infoPtr->dst) = + strtod(argv[srcIndex], &endPtr); + if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) { + Tcl_AppendResult(interp, "expected floating-point ", + "argument for \"", infoPtr->key, + "\" but got \"", argv[srcIndex], "\"", + (char *) NULL); + return TCL_ERROR; + } + srcIndex++; + argc--; + } + break; + case TK_ARGV_FUNC: { + int (*handlerProc)(); + + handlerProc = (int (*)())infoPtr->src; + + if ((*handlerProc)(infoPtr->dst, infoPtr->key, + argv[srcIndex])) { + srcIndex += 1; + argc -= 1; + } + break; + } + case TK_ARGV_GENFUNC: { + int (*handlerProc)(); + + handlerProc = (int (*)())infoPtr->src; + + argc = (*handlerProc)(infoPtr->dst, interp, infoPtr->key, + argc, argv+srcIndex); + if (argc < 0) { + return TCL_ERROR; + } + break; + } + case TK_ARGV_HELP: + PrintUsage (interp, argTable, flags); + return TCL_ERROR; + case TK_ARGV_CONST_OPTION: + Tk_AddOption(tkwin, infoPtr->dst, infoPtr->src, + TK_INTERACTIVE_PRIO); + break; + case TK_ARGV_OPTION_VALUE: + if (argc < 1) { + goto missingArg; + } + Tk_AddOption(tkwin, infoPtr->dst, argv[srcIndex], + TK_INTERACTIVE_PRIO); + srcIndex++; + argc--; + break; + case TK_ARGV_OPTION_NAME_VALUE: + if (argc < 2) { + Tcl_AppendResult(interp, "\"", curArg, + "\" option requires two following arguments", + (char *) NULL); + return TCL_ERROR; + } + Tk_AddOption(tkwin, argv[srcIndex], argv[srcIndex+1], + TK_INTERACTIVE_PRIO); + srcIndex += 2; + argc -= 2; + break; + default: + { + char buffer[100]; + sprintf(buffer, "bad argument type %d in Tk_ArgvInfo", + infoPtr->type); + Tcl_SetResult(interp, buffer, TCL_VOLATILE); + } + return TCL_ERROR; + } + } + + /* + * If we broke out of the loop because of an OPT_REST argument, + * copy the remaining arguments down. + */ + + argsDone: + while (argc) { + argv[dstIndex] = argv[srcIndex]; + srcIndex++; + dstIndex++; + argc--; + } + argv[dstIndex] = (char *) NULL; + *argcPtr = dstIndex; + return TCL_OK; + + missingArg: + Tcl_AppendResult(interp, "\"", curArg, + "\" option requires an additional argument", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * PrintUsage -- + * + * Generate a help string describing command-line options. + * + * Results: + * Interp->result will be modified to hold a help string + * describing all the options in argTable, plus all those + * in the default table unless TK_ARGV_NO_DEFAULTS is + * specified in flags. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PrintUsage(interp, argTable, flags) + Tcl_Interp *interp; /* Place information in this interp's + * result area. */ + Tk_ArgvInfo *argTable; /* Array of command-specific argument + * descriptions. */ + int flags; /* If the TK_ARGV_NO_DEFAULTS bit is set + * in this word, then don't generate + * information for default options. */ +{ + register Tk_ArgvInfo *infoPtr; + int width, i, numSpaces; +#define NUM_SPACES 20 + static char spaces[] = " "; + char tmp[30]; + + /* + * First, compute the width of the widest option key, so that we + * can make everything line up. + */ + + width = 4; + for (i = 0; i < 2; i++) { + for (infoPtr = i ? defaultTable : argTable; + infoPtr->type != TK_ARGV_END; infoPtr++) { + int length; + if (infoPtr->key == NULL) { + continue; + } + length = strlen(infoPtr->key); + if (length > width) { + width = length; + } + } + } + + Tcl_AppendResult(interp, "Command-specific options:", (char *) NULL); + for (i = 0; ; i++) { + for (infoPtr = i ? defaultTable : argTable; + infoPtr->type != TK_ARGV_END; infoPtr++) { + if ((infoPtr->type == TK_ARGV_HELP) && (infoPtr->key == NULL)) { + Tcl_AppendResult(interp, "\n", infoPtr->help, (char *) NULL); + continue; + } + Tcl_AppendResult(interp, "\n ", infoPtr->key, ":", (char *) NULL); + numSpaces = width + 1 - strlen(infoPtr->key); + while (numSpaces > 0) { + if (numSpaces >= NUM_SPACES) { + Tcl_AppendResult(interp, spaces, (char *) NULL); + } else { + Tcl_AppendResult(interp, spaces+NUM_SPACES-numSpaces, + (char *) NULL); + } + numSpaces -= NUM_SPACES; + } + Tcl_AppendResult(interp, infoPtr->help, (char *) NULL); + switch (infoPtr->type) { + case TK_ARGV_INT: { + sprintf(tmp, "%d", *((int *) infoPtr->dst)); + Tcl_AppendResult(interp, "\n\t\tDefault value: ", + tmp, (char *) NULL); + break; + } + case TK_ARGV_FLOAT: { + sprintf(tmp, "%g", *((double *) infoPtr->dst)); + Tcl_AppendResult(interp, "\n\t\tDefault value: ", + tmp, (char *) NULL); + break; + } + case TK_ARGV_STRING: { + char *string; + + string = *((char **) infoPtr->dst); + if (string != NULL) { + Tcl_AppendResult(interp, "\n\t\tDefault value: \"", + string, "\"", (char *) NULL); + } + break; + } + default: { + break; + } + } + } + + if ((flags & TK_ARGV_NO_DEFAULTS) || (i > 0)) { + break; + } + Tcl_AppendResult(interp, "\nGeneric options for all commands:", + (char *) NULL); + } +} ADDED tkBind.c Index: tkBind.c ================================================================== --- tkBind.c +++ tkBind.c @@ -0,0 +1,1874 @@ +/* + * tkBind.c (CTk) -- + * + * 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-1995 Sun Microsystems, Inc. + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "tkInt.h" +#ifdef USE_NCURSES_H +# include +#else +# include +#endif + +/* + * 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). */ + 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 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. + */ + +#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 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; +static 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. + */ + +#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}, + {"Mod2", Mod2Mask, 0}, + {"M2", 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[] = { + {"Motion", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Button", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"ButtonPress", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"ButtonRelease", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Colormap", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Enter", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Leave", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Expose", CTK_EXPOSE_EVENT, CTK_EXPOSE_EVENT_MASK}, + {"FocusIn", CTK_FOCUS_EVENT, CTK_FOCUS_EVENT_MASK}, + {"FocusOut", CTK_UNFOCUS_EVENT, CTK_FOCUS_EVENT_MASK}, + {"Key", CTK_KEY_EVENT, CTK_KEY_EVENT_MASK}, + {"KeyPress", CTK_KEY_EVENT, CTK_KEY_EVENT_MASK}, + {"KeyRelease", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Property", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Circulate", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Configure", CTK_MAP_EVENT, CTK_MAP_EVENT_MASK}, + {"Destroy", CTK_DESTROY_EVENT, CTK_DESTROY_EVENT_MASK}, + {"Gravity", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Map", CTK_MAP_EVENT, CTK_MAP_EVENT_MASK}, + {"Reparent", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {"Unmap", CTK_UNMAP_EVENT, CTK_MAP_EVENT_MASK}, + {"Visibility", CTK_UNSUPPORTED_EVENT, CTK_UNSUPPORTED_EVENT_MASK}, + {(char *) NULL, 0, 0} +}; +static Tcl_HashTable eventTable; + +/* + * Prototypes for local procedures defined in this file: + */ + +static void ChangeScreen _ANSI_ARGS_((Tcl_Interp *interp, + char *dispName)); +static void ExpandPercents _ANSI_ARGS_((TkWindow *winPtr, + char *before, XEvent *eventPtr, KeySym keySym, + Tcl_DString *dsPtr)); +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 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) { + if (eventMask) { + Tcl_ResetResult(interp); + } + return eventMask; + } + 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; + 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 returning result or + * error. */ + 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; + Tcl_DString ds; + char c, buffer[10]; + int patsLeft, needMods; + register ModInfo *modPtr; + register EventInfo *eiPtr; + + 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) { + Tcl_DStringSetLength(&ds, 0); + + /* + * 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 == CTK_KEY_EVENT) + && (patPtr->needMods == 0) + && (patPtr->detail < 128) + && isprint(UCHAR(patPtr->detail)) + && (patPtr->detail != '<') + && (patPtr->detail != ' ')) { + + c = patPtr->detail; + Tcl_DStringAppend(&ds, &c, 1); + 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(&ds, "<", 1); + 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--; + Tcl_DStringAppend(&ds, "Triple-", 7); + } else { + Tcl_DStringAppend(&ds, "Double-", 7); + } + } + + for (needMods = patPtr->needMods, modPtr = modArray; + needMods != 0; modPtr++) { + if (modPtr->mask & needMods) { + needMods &= ~modPtr->mask; + Tcl_DStringAppend(&ds, modPtr->name, -1); + Tcl_DStringAppend(&ds, "-", 1); + } + } + + for (eiPtr = eventArray; eiPtr->name != NULL; eiPtr++) { + if (eiPtr->type == patPtr->eventType) { + Tcl_DStringAppend(&ds, eiPtr->name, -1); + if (patPtr->detail != 0) { + Tcl_DStringAppend(&ds, "-", 1); + } + break; + } + } + + if (patPtr->detail != 0) { + if (patPtr->eventType == CTK_KEY_EVENT) { + register KeySymInfo *kPtr; + + for (kPtr = keyArray; kPtr->name != NULL; kPtr++) { + if (patPtr->detail == (int) kPtr->value) { + Tcl_DStringAppend(&ds, kPtr->name, -1); + break; + } + } + } else { + sprintf(buffer, "%d", patPtr->detail); + Tcl_DStringAppend(&ds, buffer, -1); + } + } + Tcl_DStringAppend(&ds, ">", 1); + } + 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; + 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; + TkMainInfo *mainPtr; + TkDisplay *oldDispPtr; + XEvent *ringPtr; + PatSeq *matchPtr; + PatternTableKey key; + Tcl_HashEntry *hPtr; + int detail, code; + Tcl_Interp *interp; + Tcl_DString scripts, savedResult; + char *p, *end; + + /* + * Add the new event to the ring of saved events for the + * binding table. Two tricky points: + */ + + 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 == CTK_KEY_EVENT) { + detail = ringPtr->u.key.sym; + } + bindPtr->detailRing[bindPtr->curEvent] = detail; + + /* + * 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++) { + + /* + * 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) { + ExpandPercents((TkWindow *) tkwin, matchPtr->command, eventPtr, + (KeySym) detail, &scripts); + Tcl_DStringAppend(&scripts, "", 1); + } + } + + /* + * 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. + * 3. When the screen changes, must invoke a Tcl script to update + * Tcl level information such as tkPriv. + */ + + mainPtr = ((TkWindow *) tkwin)->mainPtr; + oldDispPtr = mainPtr->curDispPtr; + interp = bindPtr->interp; + Tcl_DStringInit(&savedResult); + Tcl_DStringGetResult(interp, &savedResult); + p = Tcl_DStringValue(&scripts); + end = p + Tcl_DStringLength(&scripts); + while (p != end) { + if (dispPtr != mainPtr->curDispPtr) { + mainPtr->curDispPtr = dispPtr; + ChangeScreen(interp, dispPtr->name); + } + mainPtr->bindingDepth += 1; + Tcl_AllowExceptions(interp); + code = Tcl_GlobalEval(interp, p); + mainPtr->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 (mainPtr->bindingDepth == 0 && mainPtr->refCount == 0) { + TkDeleteMain(mainPtr); + } else if ((mainPtr->bindingDepth != 0) + && (oldDispPtr != mainPtr->curDispPtr)) { + /* + * Some other binding script is currently executing, but its + * screen is no longer current. Change the current display + * back again. + */ + + mainPtr->curDispPtr = oldDispPtr; + ChangeScreen(interp, oldDispPtr->name); + } + Tcl_DStringResult(interp, &savedResult); + Tcl_DStringFree(&scripts); +} + +/* + *---------------------------------------------------------------------- + * + * 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) + Tcl_Interp *interp; /* Interpreter in which to invoke + * command. */ + char *dispName; /* Name of new display. */ +{ + Tcl_DString cmd; + int code; + + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, "tkScreenChanged ", 16); + Tcl_DStringAppend(&cmd, dispName, -1); + code = Tcl_GlobalEval(interp, Tcl_DStringValue(&cmd)); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (changing screen in event binding)"); + Tcl_BackgroundError(interp); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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, or if the pattern + * includes events not supported by CTk (like button presses) + * 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. If an error occurs, then *maskPtr is set + * to zero, and if the pattern contains unsupported events + * then *maskPtr is set to CTK_UNSUPPORTED_EVENT_MASK. + * + * 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 48 + char field[FIELD_SIZE]; + int flags, count, new; + size_t sequenceSize; + unsigned long eventMask; + PatternTableKey key; + char error_buffer[100]; + + /* + *------------------------------------------------------------- + * 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; + patPtr->detail = 0; + while (isspace(UCHAR(*p))) { + p++; + } + if (*p == '\0') { + break; + } + + /* + * Handle simple ASCII characters. + */ + + if (*p != '<') { + char string[2]; + + patPtr->eventType = CTK_KEY_EVENT; + eventMask |= CTK_KEY_EVENT_MASK; + 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(error_buffer, + "bad ASCII character 0x%x", (unsigned char) *p); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + goto error; + } + } + 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. + */ + + 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; + } + } + while ((*p == '-') || isspace(UCHAR(*p))) { + p++; + } + } + hPtr = Tcl_FindHashEntry(&eventTable, field); + if (hPtr != NULL) { + register EventInfo *eiPtr; + eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); + if (eiPtr->type == CTK_UNSUPPORTED_EVENT) { + goto unsupported; + } + 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')) { + if (patPtr->eventType == -1) { + /* + * Button press pattern. + */ + goto unsupported; + } else if (patPtr->eventType == CTK_KEY_EVENT) { + goto getKeysym; + } else { + Tcl_AppendResult(interp, "specified button \"", field, + "\" for non-button event", (char *) NULL); + goto error; + } + } else { + getKeysym: + hPtr = Tcl_FindHashEntry(&keySymTable, (char *) field); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "bad event type or keysym \"", + field, "\"", (char *) NULL); + goto error; + } + patPtr->detail = (int) Tcl_GetHashValue(hPtr); + if (patPtr->eventType == -1) { + patPtr->eventType = CTK_KEY_EVENT; + eventMask |= CTK_KEY_EVENT_MASK; + } else if (patPtr->eventType != CTK_KEY_EVENT) { + Tcl_AppendResult(interp, "specified keysym \"", field, + "\" for non-key event", (char *) NULL); + goto error; + } + } + } else if (patPtr->eventType == -1) { + Tcl_SetResult(interp, "no event type or button # or keysym", TCL_STATIC); + goto error; + } + while ((*p == '-') || isspace(UCHAR(*p))) { + p++; + } + if (*p != '>') { + Tcl_SetResult(interp, "missing \">\" in binding", TCL_STATIC); + goto error; + } + 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) { + Tcl_SetResult(interp, "no events specified in binding", TCL_STATIC); + goto error; + } + 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); + goto error; + } + 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; + + error: + *maskPtr = 0; + return NULL; + + unsupported: + Tcl_SetResult(interp, "Unsupported event type", TCL_STATIC); + *maskPtr = CTK_UNSUPPORTED_EVENT_MASK; + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; + Tk_Window window; + int *detailPtr; + int patCount, ringCount, 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->window; + patPtr = psPtr->pats; + patCount = psPtr->numPats; + ringCount = EVENT_BUFFER_SIZE; + while (patCount > 0) { + if (ringCount <= 0) { + goto nextSequence; + } + if (eventPtr->type != patPtr->eventType) { + goto nextEvent; + } + if (eventPtr->window != window) { + goto nextSequence; + } + + if (eventPtr->type == CTK_KEY_EVENT) { + state = eventPtr->u.key.state; + } else { + state = 0; + } + if (patPtr->needMods != 0) { + modMask = patPtr->needMods; + if ((state & modMask) != modMask) { + goto nextSequence; + } + } + if ((patPtr->detail != 0) && (patPtr->detail != *detailPtr)) { + goto nextSequence; + } + if (psPtr->flags & PAT_NEARBY) { + register XEvent *firstPtr; + int timeDiff; + + firstPtr = &bindPtr->eventRing[bindPtr->curEvent]; + timeDiff = (Time) firstPtr->u.key.time - eventPtr->u.key.time; + if (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--; + } + + /* + * This sequence matches. If we've already got another match, + * pick whichever is most specific. Detail is most important, + * then needMods. + */ + + 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 if ((patPtr->needMods & patPtr2->needMods) + == patPtr2->needMods) { + goto newBest; + } + } + } + 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 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. */ + 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). */ + 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, length; +#define NUM_SIZE 40 + register char *string; + char numStorage[NUM_SIZE+1]; + + 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->serial; + goto doNumber; + case 'c': + number = 0; + goto doNumber; + case 'h': + if (eventPtr->type == CTK_EXPOSE_EVENT) { + number = eventPtr->u.expose.bottom - eventPtr->u.expose.top; + } else if (eventPtr->type == CTK_MAP_EVENT) { + number = Tk_Height(eventPtr->window); + } + goto doNumber; + case 'k': + if (eventPtr->type == CTK_KEY_EVENT) { + number = eventPtr->u.key.sym; + } + goto doNumber; + case 's': + if (eventPtr->type == CTK_KEY_EVENT) { + number = eventPtr->u.key.state; + } + goto doNumber; + case 't': + if (eventPtr->type == CTK_KEY_EVENT) { + number = (int) eventPtr->u.key.time; + } + goto doNumber; + case 'w': + if (eventPtr->type == CTK_EXPOSE_EVENT) { + number = eventPtr->u.expose.right - eventPtr->u.expose.left; + } else if (eventPtr->type == CTK_MAP_EVENT) { + number = Tk_Width(eventPtr->window); + } + goto doNumber; + case 'x': + if (eventPtr->type == CTK_EXPOSE_EVENT) { + number = eventPtr->u.expose.left; + } else if (eventPtr->type == CTK_MAP_EVENT) { + number = Tk_X(eventPtr->window); + } + goto doNumber; + case 'y': + if (eventPtr->type == CTK_EXPOSE_EVENT) { + number = eventPtr->u.expose.top; + } else if (eventPtr->type == CTK_MAP_EVENT) { + number = Tk_Y(eventPtr->window); + } + goto doNumber; + case 'A': + if (eventPtr->type == CTK_KEY_EVENT) { + KeySym key = eventPtr->u.key.sym; + if (key >= 0 && key <= UCHAR_MAX) { + numStorage[0] = key; + numStorage[1] = '\0'; + } else { + numStorage[0] = '\0'; + } + } + string = numStorage; + goto doString; + case 'K': + if (eventPtr->type == CTK_KEY_EVENT) { + 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 'T': + number = eventPtr->type; + goto doNumber; + case 'W': { + string = Tk_PathName(eventPtr->window); + goto doString; + } + case 'X': { + number = Ctk_AbsLeft(eventPtr->window); + goto doNumber; + } + case 'Y': { + number = Ctk_AbsTop(eventPtr->window); + 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; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * Ctk_CtkEventCmd -- + * + * This procedure implements the "ctk_event" command. It allows + * events to be generated on the fly. Handy for remapping keys. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and handles events. + * + *---------------------------------------------------------------------- + */ + +int +Ctk_CtkEventCmd(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; + XEvent event; + EventInfo *eiPtr; + char *field, *value; + int i; + Tcl_HashEntry *hPtr; + + 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; + } + memset((VOID *) &event, 0, sizeof(event)); + event.window = tkwin; + + /* + * Get the type of the event. + */ + + hPtr = Tcl_FindHashEntry(&eventTable, argv[2]); + if (!hPtr) { + Tcl_AppendResult(interp, "bad event type \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); + event.type = eiPtr->type; + + /* + * Process the remaining arguments to fill in additional fields + * of the event. + */ + + for (i = 3; i < argc; i += 2) { + field = argv[i]; + value = argv[i+1]; + if (event.type == KeyPress && strcmp(field, "-key") == 0) { + hPtr = Tcl_FindHashEntry(&keySymTable, value); + if (hPtr) { + event.u.key.sym = (int) Tcl_GetHashValue(hPtr); + } else { + Tcl_AppendResult(interp, "unknown keysym \"", value, + "\"", (char *) NULL); + return TCL_ERROR; + } + } else if (event.type == KeyPress && strcmp(field, "-modifier") == 0) { + register ModInfo *modPtr; + hPtr = Tcl_FindHashEntry(&modTable, value); + if (hPtr) { + modPtr = (ModInfo *) Tcl_GetHashValue(hPtr); + event.u.key.state |= modPtr->mask; + } else { + Tcl_AppendResult(interp, "unknown modifier \"", value, + "\"", (char *) NULL); + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "bad option \"", field, "\"", + (char *) NULL); + return TCL_ERROR; + } + } + Tk_HandleEvent(&event); + return TCL_OK; +} ADDED tkButton.c Index: tkButton.c ================================================================== --- tkButton.c +++ tkButton.c @@ -0,0 +1,1207 @@ +/* + * tkButton.c (CTk) -- + * + * This module implements a collection of button-like + * widgets for the Tk toolkit. The widgets implemented + * include labels, buttons, check buttons, and radio + * buttons. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "default.h" +#include "tkPort.h" +#include "tkInt.h" + +/* + * A data structure of the following type is kept for each + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the button. NULL + * means that the window has been destroyed. */ + 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. */ + + /* + * Information about what's in the button. + */ + + char *text; /* Text to display in button (malloc'ed) + * or NULL. */ + 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. */ + + /* + * Information used when displaying widget: + */ + + Tk_Uid state; /* State of button for display purposes: + * normal, active, or disabled. */ + int borderWidth; /* Width of border. */ + int width, height; /* If > 0, these specify dimensions to request + * for window, in characters. In this case the actual + * size of the text string 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 (pixels to leave + * on each side). Ignored for bitmaps and + * images. */ + Tk_Anchor anchor; /* Where text/bitmap should be displayed + * inside button region. */ + Tk_Justify justify; /* Justification to use for multi-line text. */ + int indicatorOn; /* True means draw indicator, false means + * don't draw it. */ + int textWidth; /* Width needed to display text as requested, + * in pixels. */ + int textHeight; /* Height needed to display text as requested, + * in pixels. */ + + /* + * For check and radio buttons, the fields below are used + * to manage the variable indicating the button's state. + */ + + char *selVarName; /* Name of variable used to control selected + * state of button. Malloc'ed (if + * not NULL). */ + char *onValue; /* Value to store in variable when + * this button is selected. Malloc'ed (if + * not NULL). */ + char *offValue; /* Value to store in variable when this + * button isn't selected. Malloc'ed + * (if not NULL). Valid only for check + * buttons. */ + + /* + * Miscellaneous 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 *command; /* Command to execute when button is + * invoked; valid for buttons only. + * If not NULL, it's malloc-ed. */ + int flags; /* Various flags; see below for + * definitions. */ +} Button; + +/* + * Possible "type" values for buttons. These are the kinds of + * widgets supported by this file. The ordering of the type + * numbers is significant: greater means more features and is + * used in the code. + */ + +#define TYPE_LABEL 0 +#define TYPE_BUTTON 1 +#define TYPE_CHECK_BUTTON 2 +#define TYPE_RADIO_BUTTON 3 + +/* + * Class names for buttons, indexed by one of the type values above. + */ + +static char *classNames[] = {"Label", "Button", "Checkbutton", "Radiobutton"}; + +/* + * Flag bits for buttons: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * 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 + * configuration specs: + */ + +#define LABEL_MASK TK_CONFIG_USER_BIT +#define BUTTON_MASK TK_CONFIG_USER_BIT << 1 +#define CHECK_BUTTON_MASK TK_CONFIG_USER_BIT << 2 +#define RADIO_BUTTON_MASK TK_CONFIG_USER_BIT << 3 +#define ALL_MASK (LABEL_MASK | BUTTON_MASK \ + | CHECK_BUTTON_MASK | RADIO_BUTTON_MASK) + +static int configFlags[] = {LABEL_MASK, BUTTON_MASK, + CHECK_BUTTON_MASK, RADIO_BUTTON_MASK}; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_ANCHOR, "-anchor", "anchor", "Anchor", + DEF_BUTTON_ANCHOR, Tk_Offset(Button, anchor), ALL_MASK}, + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, ALL_MASK}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_BUTTON_BORDER_WIDTH, Tk_Offset(Button, borderWidth), ALL_MASK}, + {TK_CONFIG_STRING, "-command", "command", "Command", + DEF_BUTTON_COMMAND, Tk_Offset(Button, command), + BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-height", "height", "Height", + DEF_BUTTON_HEIGHT, Tk_Offset(Button, height), ALL_MASK}, + {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}, + {TK_CONFIG_STRING, "-onvalue", "onValue", "Value", + 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}, + {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", + DEF_BUTTON_PADY, Tk_Offset(Button, padY), ALL_MASK}, + {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_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_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} +}; + +/* + * String to print out in error messages, identifying options for + * widget commands for different types of labels or buttons: + */ + +static char *optionStrings[] = { + "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 char * ButtonTextVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static char * ButtonVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static int ButtonWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +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 DisplayButton _ANSI_ARGS_((ClientData clientData)); +static int InvokeButton _ANSI_ARGS_((Button *butPtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_ButtonCmd, Tk_CheckbuttonCmd, Tk_LabelCmd, Tk_RadiobuttonCmd -- + * + * These procedures are invoked to process the "button", "label", + * "radiobutton", and "checkbutton" 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_ButtonCmd(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_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; + Tk_Window tkwin = (Tk_Window) clientData; + Tk_Window new; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Create the new window. + */ + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + /* + * Initialize the data structure for the button. + */ + + butPtr = (Button *) ckalloc(sizeof(Button)); + butPtr->tkwin = new; + butPtr->widgetCmd = Tcl_CreateCommand(interp, Tk_PathName(butPtr->tkwin), + ButtonWidgetCmd, (ClientData) butPtr, ButtonCmdDeletedProc); + butPtr->interp = interp; + butPtr->type = type; + butPtr->text = NULL; + butPtr->numChars = 0; + butPtr->underline = -1; + butPtr->textVarName = NULL; + butPtr->state = tkNormalUid; + butPtr->borderWidth = 0; + butPtr->width = 0; + butPtr->height = 0; + butPtr->wrapLength = 0; + butPtr->padX = 0; + butPtr->padY = 0; + butPtr->anchor = TK_ANCHOR_CENTER; + butPtr->justify = TK_JUSTIFY_CENTER; + butPtr->indicatorOn = 0; + butPtr->selVarName = NULL; + butPtr->onValue = NULL; + butPtr->offValue = NULL; + butPtr->command = NULL; + butPtr->takeFocus = NULL; + butPtr->flags = 0; + + Tk_SetClass(new, classNames[type]); + Tk_CreateEventHandler(butPtr->tkwin, + CTK_EXPOSE_EVENT_MASK|CTK_DESTROY_EVENT_MASK|CTK_FOCUS_EVENT_MASK, + ButtonEventProc, (ClientData) butPtr); + if (ConfigureButton(interp, butPtr, argc-2, argv+2, + configFlags[type]) != TCL_OK) { + Tk_DestroyWindow(butPtr->tkwin); + return TCL_ERROR; + } + + Tcl_SetResult(interp, Tk_PathName(butPtr->tkwin), TCL_VOLATILE); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ButtonWidgetCmd -- + * + * 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 +ButtonWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about button widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Button *butPtr = (Button *) clientData; + int result = TCL_OK; + size_t length; + int c; + char error_buffer[120]; + + if (argc < 2) { + sprintf(error_buffer, + "wrong # args: should be \"%.50s option ?arg arg ...?\"", + argv[0]); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + return TCL_ERROR; + } + Tk_Preserve((ClientData) butPtr); + 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, 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]); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, butPtr->tkwin, configSpecs, + (char *) butPtr, argv[2], + configFlags[butPtr->type]); + } else { + result = ConfigureButton(interp, butPtr, argc-2, argv+2, + configFlags[butPtr->type] | TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'd') && (strncmp(argv[1], "deselect", length) == 0) + && (butPtr->type >= TYPE_CHECK_BUTTON)) { + if (argc > 2) { + sprintf(error_buffer, + "wrong # args: should be \"%.50s deselect\"", + argv[0]); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + goto error; + } + if (butPtr->type == TYPE_CHECK_BUTTON) { + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->offValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + } else if (butPtr->flags & SELECTED) { + 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)) { + int i; + + if (argc > 2) { + sprintf(error_buffer, + "wrong # args: should be \"%.50s flash\"", + argv[0]); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + goto error; + } + if (butPtr->state != tkDisabledUid) { + for (i = 0; i < 4; i++) { + butPtr->state = (butPtr->state == tkNormalUid) + ? tkActiveUid : tkNormalUid; + 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); + Ctk_DisplayFlush(Tk_Display(butPtr->tkwin)); + Tcl_Sleep(50); + } + } + } else if ((c == 'i') && (strncmp(argv[1], "invoke", length) == 0) + && (butPtr->type > TYPE_LABEL)) { + if (argc > 2) { + sprintf(error_buffer, + "wrong # args: should be \"%.50s invoke\"", + argv[0]); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + goto error; + } + if (butPtr->state != tkDisabledUid) { + result = InvokeButton(butPtr); + } + } else if ((c == 's') && (strncmp(argv[1], "select", length) == 0) + && (butPtr->type >= TYPE_CHECK_BUTTON)) { + if (argc > 2) { + sprintf(error_buffer, + "wrong # args: should be \"%.50s select\"", + argv[0]); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + goto error; + } + 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(error_buffer, + "wrong # args: should be \"%.50s toggle\"", + argv[0]); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + goto error; + } + if (butPtr->flags & SELECTED) { + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->offValue, + TCL_GLOBAL_ONLY) == NULL) { + result = TCL_ERROR; + } + } else { + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->onValue, + TCL_GLOBAL_ONLY) == NULL) { + result = TCL_ERROR; + } + } + } else { + sprintf(error_buffer, + "bad option \"%.50s\": must be %s", argv[1], + optionStrings[butPtr->type]); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + goto error; + } + Tk_Release((ClientData) butPtr); + return result; + + error: + Tk_Release((ClientData) butPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyButton -- + * + * 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 widget is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyButton(clientData) + ClientData clientData; /* Info about entry 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 + * stuff. + */ + + if (butPtr->textVarName != NULL) { + Tcl_UntraceVar(butPtr->interp, butPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonTextVarProc, (ClientData) butPtr); + } + if (butPtr->selVarName != NULL) { + Tcl_UntraceVar(butPtr->interp, butPtr->selVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonVarProc, (ClientData) butPtr); + } + Tk_FreeOptions(configSpecs, (char *) butPtr, configFlags[butPtr->type]); + ckfree((char *) butPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureButton -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a button 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 butPtr; old resources get freed, if there + * were any. The button is redisplayed. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureButton(interp, butPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Button *butPtr; /* 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. */ +{ + /* + * Eliminate any existing trace on variables monitored by the button. + */ + + if (butPtr->textVarName != NULL) { + Tcl_UntraceVar(interp, butPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonTextVarProc, (ClientData) butPtr); + } + if (butPtr->selVarName != NULL) { + Tcl_UntraceVar(interp, butPtr->selVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonVarProc, (ClientData) butPtr); + } + + if (Tk_ConfigureWidget(interp, butPtr->tkwin, configSpecs, + argc, argv, (char *) butPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few options need special processing, such as setting the + * background from a 3-D border, or filling in complicated + * defaults that couldn't be specified to Tk_ConfigureWidget. + */ + + 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); + butPtr->state = tkNormalUid; + return TCL_ERROR; + } + if (butPtr->padX < 0) { + butPtr->padX = 0; + } + if (butPtr->padY < 0) { + butPtr->padY = 0; + } + + if (butPtr->type >= TYPE_CHECK_BUTTON) { + char *value; + + if (butPtr->selVarName == NULL) { + butPtr->selVarName = (char *) ckalloc((unsigned) + (strlen(Tk_Name(butPtr->tkwin)) + 1)); + strcpy(butPtr->selVarName, Tk_Name(butPtr->tkwin)); + } + + /* + * Select the button if the associated variable has the + * appropriate value, initialize the variable if it doesn't + * exist, then set a trace on the variable to monitor future + * changes to its value. + */ + + value = Tcl_GetVar(interp, butPtr->selVarName, TCL_GLOBAL_ONLY); + butPtr->flags &= ~SELECTED; + if (value != NULL) { + if (strcmp(value, butPtr->onValue) == 0) { + butPtr->flags |= SELECTED; + } + } else { + if (Tcl_SetVar(interp, butPtr->selVarName, + (butPtr->type == TYPE_CHECK_BUTTON) ? butPtr->offValue : "", + 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, + ButtonVarProc, (ClientData) butPtr); + } + + if (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) { + 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 = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(butPtr->text, value); + } + Tcl_TraceVar(interp, butPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonTextVarProc, (ClientData) butPtr); + } + + Tk_SetInternalBorder(butPtr->tkwin, butPtr->borderWidth); + ComputeButtonGeometry(butPtr); + + /* + * Lastly, arrange for the button to be redisplayed. + */ + + if (Tk_IsMapped(butPtr->tkwin) && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DisplayButton -- + * + * 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. The REDRAW_PENDING flag is cleared. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayButton(clientData) + ClientData clientData; /* Information about widget. */ +{ + register Button *butPtr = (Button *) clientData; + register Tk_Window tkwin = butPtr->tkwin; + Ctk_Style style; + int x, y; + unsigned int width = Tk_Width(tkwin); + unsigned int height = Tk_Height(tkwin); + char buf[4]; + int indicatorSpace = 0; + + butPtr->flags &= ~REDRAW_PENDING; + if ((tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + + if ((butPtr->type == TYPE_CHECK_BUTTON) + || (butPtr->type == TYPE_RADIO_BUTTON)) { + indicatorSpace = 3; + buf[0] = (butPtr->type == TYPE_CHECK_BUTTON) ? '[' : '<'; + buf[1] = (butPtr->flags & SELECTED) ? '*' : ' '; + buf[2] = (butPtr->type == TYPE_CHECK_BUTTON) ? ']' : '>'; + buf[3] = '\0'; + } + + if (butPtr->type == TYPE_LABEL) { + style = CTK_PLAIN_STYLE; + } else if (butPtr->state == tkDisabledUid) { + style = CTK_DISABLED_STYLE; + } else { + style = CTK_BUTTON_STYLE; + } + + switch (butPtr->anchor) { + case TK_ANCHOR_NW: case TK_ANCHOR_W: case TK_ANCHOR_SW: + x = butPtr->borderWidth + butPtr->padX + indicatorSpace; + break; + case TK_ANCHOR_N: case TK_ANCHOR_CENTER: case TK_ANCHOR_S: + x = (width + indicatorSpace - butPtr->textWidth)/2; + break; + default: + x = width - butPtr->borderWidth - butPtr->padX - butPtr->textWidth; + break; + } + switch (butPtr->anchor) { + case TK_ANCHOR_NW: case TK_ANCHOR_N: case TK_ANCHOR_NE: + y = butPtr->borderWidth + butPtr->padY; + break; + case TK_ANCHOR_W: case TK_ANCHOR_CENTER: case TK_ANCHOR_E: + y = (height - butPtr->textHeight)/2; + break; + default: + y = height - butPtr->borderWidth - butPtr->padY - butPtr->textHeight; + break; + } + + /* + * Clear rect. + */ + Ctk_FillRect(tkwin, 0, 0, width, height, style, ' '); + + /* + * Draw text. + */ + TkDisplayText(tkwin, style, butPtr->text, butPtr->numChars, + x, y, butPtr->textWidth, butPtr->justify, butPtr->underline); + + /* + * Draw Indicator. + */ + if (indicatorSpace) { + x -= indicatorSpace; + y += butPtr->textHeight/2; + Ctk_DrawString(tkwin, x, y, style, buf, indicatorSpace); + } + + /* + * Draw border. + */ + Ctk_DrawBorder(tkwin, style, (char *)NULL); + + /* + * Position cursor. + */ + if (butPtr->flags & GOT_FOCUS) { + Ctk_SetCursor(tkwin, butPtr->borderWidth, butPtr->borderWidth); + } +} + +/* + *-------------------------------------------------------------- + * + * ButtonEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on buttons. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +ButtonEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Button *butPtr = (Button *) clientData; + if (eventPtr->type == CTK_EXPOSE_EVENT) { + if ((butPtr->tkwin != NULL) && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } + } else if (eventPtr->type == CTK_DESTROY_EVENT) { + if (butPtr->tkwin != NULL) { + butPtr->tkwin = NULL; + Tcl_DeleteCommand(butPtr->interp, + Tcl_GetCommandName(butPtr->interp, butPtr->widgetCmd)); + } + if (butPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayButton, (ClientData) butPtr); + } + Tk_EventuallyFree((ClientData) butPtr, DestroyButton); + } else if (eventPtr->type == CTK_FOCUS_EVENT) { + butPtr->flags |= GOT_FOCUS; + Ctk_SetCursor(butPtr->tkwin, butPtr->borderWidth, butPtr->borderWidth); + } else if (eventPtr->type == CTK_UNFOCUS_EVENT) { + butPtr->flags &= ~GOT_FOCUS; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * ComputeButtonGeometry -- + * + * After changes in a button's text or bitmap, this procedure + * recomputes the button's geometry and passes this information + * along to the geometry manager for the window. + * + * Results: + * None. + * + * Side effects: + * The button's window may change size. + * + *---------------------------------------------------------------------- + */ + +static void +ComputeButtonGeometry(butPtr) + register Button *butPtr; /* Button whose geometry may have changed. */ +{ + int width, height; + int indicatorSpace = 0; + + if (butPtr->type == TYPE_RADIO_BUTTON + || butPtr->type == TYPE_CHECK_BUTTON) { + indicatorSpace = 3; + } + + butPtr->numChars = strlen(butPtr->text); + TkComputeTextGeometry(butPtr->text, butPtr->numChars, + butPtr->wrapLength, + &butPtr->textWidth, &butPtr->textHeight); + width = butPtr->width; + if (width < 0) { + width = butPtr->textWidth; + } + height = butPtr->height; + if (height < 0) { + height = butPtr->textHeight; + } + width += 2*butPtr->padX; + height += 2*butPtr->padY; + + Tk_GeometryRequest(butPtr->tkwin, + width + indicatorSpace + 2*butPtr->borderWidth, + height + 2*butPtr->borderWidth); +} + +/* + *---------------------------------------------------------------------- + * + * InvokeButton -- + * + * This procedure is called to carry out the actions associated + * with a button, such as invoking a Tcl command or setting a + * variable. This procedure is invoked, for example, when the + * button is invoked via the mouse. + * + * Results: + * A standard Tcl return value. Information is also left in + * interp->result. + * + * Side effects: + * Depends on the button and its associated command. + * + *---------------------------------------------------------------------- + */ + +static int +InvokeButton(butPtr) + register Button *butPtr; /* Information about button. */ +{ + if (butPtr->type == TYPE_CHECK_BUTTON) { + if (butPtr->flags & SELECTED) { + if (Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->offValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + } else { + 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) { + 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); + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ButtonVarProc -- + * + * This procedure is invoked when someone changes the + * state variable associated with a radio button. Depending + * on the new value of the button's variable, the button + * may be selected or deselected. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The button may become selected or deselected. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +ButtonVarProc(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 Button *butPtr = (Button *) clientData; + char *value; + + /* + * If the variable is being unset, then just re-establish the + * trace unless the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + butPtr->flags &= ~SELECTED; + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar(interp, butPtr->selVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonVarProc, clientData); + } + goto redisplay; + } + + /* + * Use the value of the variable to update the selected status of + * the button. + */ + + 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; + } + butPtr->flags |= SELECTED; + } else if (butPtr->flags & SELECTED) { + butPtr->flags &= ~SELECTED; + } else { + return (char *) NULL; + } + + redisplay: + if ((butPtr->tkwin != NULL) && Tk_IsMapped(butPtr->tkwin) + && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } + return (char *) NULL; +} + +/* + *-------------------------------------------------------------- + * + * ButtonTextVarProc -- + * + * This procedure is invoked when someone changes the variable + * whose contents are to be displayed in a button. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The text displayed in the button will change to match the + * variable. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +ButtonTextVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about button. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Not used. */ + char *name2; /* Not used. */ + int flags; /* Information about what happened. */ +{ + register Button *butPtr = (Button *) clientData; + char *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_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_GetVar(interp, butPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + if (butPtr->text != NULL) { + ckfree(butPtr->text); + } + 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)) { + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } + return (char *) NULL; +} ADDED tkCmds.c Index: tkCmds.c ================================================================== --- tkCmds.c +++ tkCmds.c @@ -0,0 +1,1685 @@ +/* + * tkCmds.c (CTk) -- + * + * This file contains a collection of Tk-related Tcl commands + * that didn't fit in any particular file of the toolkit. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "tkInt.h" +#include + +/* + * Forward declarations for procedures defined later in this file: + */ + +static char * WaitVariableProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); + +static int GetFocusOk _ANSI_ARGS_((Tcl_Interp *interp, + TkWindow *winPtr, int *flagPtr)); +static char error_buffer[200]; + +/* + *---------------------------------------------------------------------- + * + * Tk_BellCmd -- + * + * This procedure is invoked to process the "bell" 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_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. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + size_t length; + + if ((argc != 1) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-displayof window?\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 3) { + 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; + } + } + CtkDisplayBell(Tk_Display(tkwin)); + Ctk_DisplayFlush(Tk_Display(tkwin)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_BindCmd -- + * + * This procedure is invoked to process the "bind" 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_BindCmd(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; + ClientData object; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " window ?pattern? ?command?\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[1][0] == '.') { + winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + object = (ClientData) winPtr->pathName; + } else { + winPtr = (TkWindow *) clientData; + object = (ClientData) Tk_GetUid(argv[1]); + } + + if (argc == 4) { + int append = 0; + unsigned long mask; + + if (argv[3][0] == 0) { + return Tk_DeleteBinding(interp, winPtr->mainPtr->bindingTable, + object, argv[2]); + } + if (argv[3][0] == '+') { + argv[3]++; + append = 1; + } + mask = Tk_CreateBinding(interp, winPtr->mainPtr->bindingTable, + object, argv[2], argv[3], append); + if (mask == 0) { + return TCL_ERROR; + } + } else if (argc == 3) { + char *command; + + command = Tk_GetBinding(interp, winPtr->mainPtr->bindingTable, + object, argv[2]); + if (command == NULL) { + Tcl_ResetResult(interp); + return TCL_OK; + } + Tcl_SetResult(interp, command, TCL_VOLATILE); + } else { + Tk_GetAllBindings(interp, winPtr->mainPtr->bindingTable, object); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkBindEventProc -- + * + * This procedure is invoked by Tk_HandleEvent for each event; it + * causes any appropriate bindings for that event to be invoked. + * + * Results: + * None. + * + * Side effects: + * Depends on what bindings have been established with the "bind" + * command. + * + *---------------------------------------------------------------------- + */ + +void +TkBindEventProc(winPtr, eventPtr) + TkWindow *winPtr; /* Pointer to info about window. */ + XEvent *eventPtr; /* Information about event. */ +{ +#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; + } + + 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; + } + 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; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DestroyCmd -- + * + * This procedure is invoked to process the "destroy" 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_DestroyCmd(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 window; + Tk_Window tkwin = (Tk_Window) clientData; + int i; + + for (i = 1; i < argc; i++) { + window = Tk_NameToWindow(interp, argv[i], tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_DestroyWindow(window); + } + 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; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_LowerCmd -- + * + * This procedure is invoked to process the "lower" 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 +Tk_LowerCmd(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 main = (Tk_Window) clientData; + Tk_Window tkwin, other; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window ?belowThis?\"", (char *) NULL); + return TCL_ERROR; + } + + tkwin = Tk_NameToWindow(interp, argv[1], main); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (argc == 2) { + other = NULL; + } else { + other = Tk_NameToWindow(interp, argv[2], main); + if (other == NULL) { + return TCL_ERROR; + } + } + if (Tk_RestackWindow(tkwin, Below, other) != TCL_OK) { + Tcl_AppendResult(interp, "can't lower \"", argv[1], "\" above \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RaiseCmd -- + * + * This procedure is invoked to process the "raise" 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 +Tk_RaiseCmd(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 main = (Tk_Window) clientData; + Tk_Window tkwin, other; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window ?aboveThis?\"", (char *) NULL); + return TCL_ERROR; + } + + tkwin = Tk_NameToWindow(interp, argv[1], main); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (argc == 2) { + other = NULL; + } else { + other = Tk_NameToWindow(interp, argv[2], main); + if (other == NULL) { + return TCL_ERROR; + } + } + if (Tk_RestackWindow(tkwin, Above, other) != TCL_OK) { + Tcl_AppendResult(interp, "can't raise \"", argv[1], "\" above \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_TkCmd -- + * + * This procedure is invoked to process the "tk" 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 +Tk_TkCmd(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. */ +{ + char c; + size_t length; + + 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 == 'a') && (strncmp(argv[1], "appname", length) == 0)) { + return Ctk_Unsupported(interp, "tk appname"); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be appname", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_TkwaitCmd -- + * + * This procedure is invoked to process the "tkwait" 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 +Tk_TkwaitCmd(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 c, done; + size_t length; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " variable|visible|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)) { + if (Tcl_TraceVar(interp, argv[2], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + } + done = 0; + while (!done) { + Tk_DoOneEvent(0); + } + Tcl_UntraceVar(interp, argv[2], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done); + } else if ((c == 'v') && (strncmp(argv[1], "visibility", length) == 0) + && (length >= 2)) { + Tk_Window window; + + window = Tk_NameToWindow(interp, argv[2], tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, CTK_MAP_EVENT_MASK|CTK_DESTROY_EVENT_MASK, + WaitWindowProc, (ClientData) &done); + done = 0; + while (!done) { + Tk_DoOneEvent(0); + } + Tk_DeleteEventHandler(window, CTK_MAP_EVENT_MASK|CTK_DESTROY_EVENT_MASK, + WaitWindowProc, (ClientData) &done); + } else if ((c == 'w') && (strncmp(argv[1], "window", length) == 0)) { + Tk_Window window; + + window = Tk_NameToWindow(interp, argv[2], tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, CTK_DESTROY_EVENT_MASK, + WaitWindowProc, (ClientData) &done); + done = 0; + while (!done) { + Tk_DoOneEvent(0); + } + /* + * Note: there's no need to delete the event handler. It was + * deleted automatically when the window was destroyed. + */ + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be variable, visibility, or window", (char *) NULL); + return TCL_ERROR; + } + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + return TCL_OK; +} + + /* ARGSUSED */ +static char * +WaitVariableProc(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; +} + + /*ARGSUSED*/ +static void +WaitWindowProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event. */ +{ + int *donePtr = (int *) clientData; + *donePtr = 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_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 +Tk_UpdateCmd(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 flags; + + if (argc == 1) { + flags = TK_DONT_WAIT; + } else if (argc == 2) { + if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { + Tcl_AppendResult(interp, "bad argument \"", argv[1], + "\": must be idletasks", (char *) NULL); + return TCL_ERROR; + } + flags = TK_IDLE_EVENTS; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?idletasks?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Handle all pending events. + */ + + while (Tk_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; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_WinfoCmd -- + * + * This procedure is invoked to process the "winfo" 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_WinfoCmd(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; + size_t length; + char c, *argName; + Tk_Window window; + register TkWindow *winPtr; + int result = TCL_OK; + +#define SETUP(name) \ + if (argc != 3) {\ + argName = name; \ + goto wrongArgs; \ + } \ + window = Tk_NameToWindow(interp, argv[2], tkwin); \ + if (window == NULL) { \ + return TCL_ERROR; \ + } + + 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 == 'a') && (strcmp(argv[1], "atom") == 0)) { + result = Ctk_Unsupported(interp, "winfo atom"); + } else if ((c == 'a') && (strncmp(argv[1], "atomname", length) == 0) + && (length >= 5)) { + result = Ctk_Unsupported(interp, "winfo atomname"); + } else if ((c == 'c') && (strncmp(argv[1], "cells", length) == 0) + && (length >= 2)) { + Tcl_SetResult(interp,"2", TCL_STATIC); + } else if ((c == 'c') && (strncmp(argv[1], "children", length) == 0) + && (length >= 2)) { + SETUP("children"); + for (winPtr = Ctk_BottomChild(window); winPtr != NULL; + winPtr = Ctk_NextSibling(winPtr)) { + Tcl_AppendElement(interp, winPtr->pathName); + } + if (window->flags & CTK_HAS_TOPLEVEL_CHILD) { + /* + * This window has toplevel children, which are not stored + * in the child list. Check all the children of all root + * windows to see if their name is an extension of this + * windows name - if so append path name to result. + */ + char *path = Tk_PathName(window); + int length = strlen(path); + TkDisplay *dispPtr; + char *childPath; + int len2; + + for (dispPtr = tkDisplayList; dispPtr != NULL; + dispPtr = dispPtr->nextPtr) { + for (winPtr = Ctk_BottomChild(dispPtr->rootPtr); winPtr != NULL; + winPtr = Ctk_NextSibling(winPtr)) { + childPath = Tk_PathName(winPtr); + if (strncmp(childPath, path, length) == 0) { + len2 = strrchr(childPath, '.') - childPath; + if ((length == 1 && len2 == 0 && winPtr != window) + || length == len2) { + Tcl_AppendElement(interp, childPath); + } + } + } + } + } + } else if ((c == 'c') && (strncmp(argv[1], "class", length) == 0) + && (length >= 2)) { + SETUP("class"); + Tcl_SetResult(interp,Tk_Class(window), TCL_VOLATILE); + } else if ((c == 'c') && (strncmp(argv[1], "colormapfull", length) == 0) + && (length >= 3)) { + Tcl_SetResult(interp,"0", TCL_STATIC); + } else if ((c == 'c') && (strncmp(argv[1], "containing", length) == 0) + && (length >= 2)) { + /* + * This one could be implemented... + */ + result = Ctk_Unsupported(interp, "winfo containing"); + } else if ((c == 'd') && (strncmp(argv[1], "depth", length) == 0)) { + Tcl_SetResult(interp,"1", TCL_STATIC); + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { + if (argc != 3) { + argName = "exists"; + goto wrongArgs; + } + winPtr = Tk_NameToWindow(interp, argv[2], tkwin); + if ((winPtr == (TkWindow *)NULL) || (winPtr->flags & TK_ALREADY_DEAD)) { + Tcl_SetResult(interp,"0",TCL_STATIC); + } else { + Tcl_SetResult(interp,"1",TCL_STATIC); + } + } else if ((c == 'f') && (strncmp(argv[1], "fpixels", length) == 0) + && (length >= 2)) { + /* + * This one could be implemented... + */ + result = Ctk_Unsupported(interp, "winfo fpixels"); + } else if ((c == 'g') && (strncmp(argv[1], "geometry", length) == 0)) { + SETUP("geometry"); + sprintf(error_buffer, "%dx%d+%d+%d", + Tk_Width(window), Tk_Height(window), + Tk_X(window), Tk_Y(window)); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + } else if ((c == 'h') && (strncmp(argv[1], "height", length) == 0)) { + SETUP("height"); + sprintf(error_buffer, "%d", Tk_Height(window)); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + } else if ((c == 'i') && (strcmp(argv[1], "id") == 0)) { + result = Ctk_Unsupported(interp, "winfo id"); + } else if ((c == 'i') && (strncmp(argv[1], "interps", length) == 0) + && (length >= 2)) { + result = Ctk_Unsupported(interp, "winfo interps"); + } else if ((c == 'i') && (strncmp(argv[1], "ismapped", length) == 0) + && (length >= 2)) { + SETUP("ismapped"); + Tcl_SetResult(interp, Tk_IsMapped(window) ? "1" : "0", TCL_STATIC); + } else if ((c == 'm') && (strncmp(argv[1], "manager", length) == 0)) { + SETUP("manager"); + winPtr = (TkWindow *) window; + if (winPtr->geomMgrPtr != NULL) { + Tcl_SetResult(interp,winPtr->geomMgrPtr->name, TCL_VOLATILE); + } + } else if ((c == 'n') && (strncmp(argv[1], "name", length) == 0)) { + SETUP("name"); + Tcl_SetResult(interp, Tk_Name(window), TCL_VOLATILE); + } else if ((c == 'p') && (strncmp(argv[1], "parent", length) == 0)) { + SETUP("parent"); + winPtr = Ctk_ParentByName(interp, Tk_PathName(window), window); + if (winPtr) { + Tcl_SetResult(interp,winPtr->pathName,TCL_VOLATILE); + } else { + return TCL_ERROR; + } + } else if ((c == 'p') && (strncmp(argv[1], "pathname", length) == 0) + && (length >= 2)) { + result = Ctk_Unsupported(interp, "winfo pathname"); + } else if ((c == 'p') && (strncmp(argv[1], "pixels", length) == 0) + && (length >= 2)) { + int pixels; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pixels window number\"", (char *) NULL); + return TCL_ERROR; + } + window = Tk_NameToWindow(interp, argv[2], tkwin); + if (window == NULL) { + return TCL_ERROR; + } + if (Tk_GetPixels(interp, window, argv[3], &pixels) != TCL_OK) { + return TCL_ERROR; + } + sprintf(error_buffer, "%d", pixels); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + } else if ((c == 'p') && (strcmp(argv[1], "pointerx") == 0)) { + result = Ctk_Unsupported(interp, "winfo pointerx"); + } else if ((c == 'p') && (strcmp(argv[1], "pointerxy") == 0)) { + result = Ctk_Unsupported(interp, "winfo pointerxy"); + } else if ((c == 'p') && (strcmp(argv[1], "pointery") == 0)) { + result = Ctk_Unsupported(interp, "winfo pointery"); + } else if ((c == 'r') && (strncmp(argv[1], "reqheight", length) == 0) + && (length >= 4)) { + SETUP("reqheight"); + sprintf(error_buffer, "%d", Tk_ReqHeight(window)); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + } else if ((c == 'r') && (strncmp(argv[1], "reqwidth", length) == 0) + && (length >= 4)) { + SETUP("reqwidth"); + sprintf(error_buffer, "%d", Tk_ReqWidth(window)); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + } else if ((c == 'r') && (strncmp(argv[1], "rgb", length) == 0) + && (length >= 2)) { + result = Ctk_Unsupported(interp, "winfo rgb"); + } else if ((c == 'r') && (strcmp(argv[1], "rootx") == 0)) { + SETUP("rootx"); + sprintf(error_buffer, "%d", Ctk_AbsLeft(window)); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + } else if ((c == 'r') && (strcmp(argv[1], "rooty") == 0)) { + SETUP("rooty"); + sprintf(error_buffer, "%d", Ctk_AbsTop(window)); + Tcl_SetResult(interp, error_buffer, TCL_VOLATILE); + } else if ((c == 's') && (strcmp(argv[1], "screen") == 0)) { + SETUP("screen"); + Tcl_AppendResult(interp, Tk_Display(window)->name, ".", (char *) NULL); + } else if ((c == 's') && (strncmp(argv[1], "screencells", length) == 0) + && (length >= 7)) { + Tcl_SetResult(interp,"2",TCL_STATIC); + } else if ((c == 's') && (strncmp(argv[1], "screendepth", length) == 0) + && (length >= 7)) { + Tcl_SetResult(interp,"1",TCL_STATIC); + } else if ((c == 's') && (strncmp(argv[1], "screenheight", length) == 0) + && (length >= 7)) { + SETUP("screenheight"); + sprintf(error_buffer, "%d", Ctk_DisplayHeight(Tk_Display(window))); + Tcl_SetResult(interp,error_buffer,TCL_VOLATILE); + } else if ((c == 's') && (strncmp(argv[1], "screenmmheight", length) == 0) + && (length >= 9)) { + result = Ctk_Unsupported(interp, "winfo screenmmheight"); + } else if ((c == 's') && (strncmp(argv[1], "screenmmwidth", length) == 0) + && (length >= 9)) { + result = Ctk_Unsupported(interp, "winfo screenmmheight"); + } else if ((c == 's') && (strncmp(argv[1], "screenvisual", length) == 0) + && (length >= 7)) { + Tcl_SetResult(interp,"staticgray",TCL_STATIC); + } else if ((c == 's') && (strncmp(argv[1], "screenwidth", length) == 0) + && (length >= 7)) { + SETUP("screenwidth"); + sprintf(error_buffer, "%d", Ctk_DisplayWidth(Tk_Display(window))); + Tcl_SetResult(interp,error_buffer,TCL_VOLATILE); + } else if ((c == 's') && (strncmp(argv[1], "server", length) == 0) + && (length >= 2)) { + result = Ctk_Unsupported(interp, "winfo server"); + } else if ((c == 't') && (strncmp(argv[1], "toplevel", length) == 0)) { + SETUP("toplevel"); + Tcl_SetResult(interp,Tk_PathName(Ctk_TopLevel(window)), TCL_STATIC); + } else if ((c == 'v') && (strncmp(argv[1], "viewable", length) == 0) + && (length >= 3)) { + SETUP("viewable"); + Tcl_SetResult(interp,(window->flags & CTK_DISPLAYED) ? "1" : "0", + TCL_STATIC); + } else if ((c == 'v') && (strncmp(argv[1], "visual", length) == 0)) { + Tcl_SetResult(interp,"staticgray",TCL_STATIC); + } else if ((c == 'v') && (strncmp(argv[1], "visualsavailable", length) == 0) + && (length >= 7)) { + Tcl_SetResult(interp,"staticgray 1",TCL_STATIC); + } else if ((c == 'v') && (strncmp(argv[1], "vrootheight", length) == 0) + && (length >= 6)) { + SETUP("vrootheight"); + sprintf(error_buffer, "%d", Ctk_DisplayHeight(Tk_Display(window))); + Tcl_SetResult(interp,error_buffer,TCL_VOLATILE); + } else if ((c == 'v') && (strncmp(argv[1], "vrootwidth", length) == 0) + && (length >= 6)) { + SETUP("vrootwidth"); + sprintf(error_buffer, "%d", Ctk_DisplayWidth(Tk_Display(window))); + Tcl_SetResult(interp,error_buffer,TCL_VOLATILE); + } else if ((c == 'v') && (strcmp(argv[1], "vrootx") == 0)) { + Tcl_SetResult(interp,"0",TCL_STATIC); + } else if ((c == 'v') && (strcmp(argv[1], "vrooty") == 0)) { + Tcl_SetResult(interp,"0",TCL_STATIC); + } else if ((c == 'w') && (strncmp(argv[1], "width", length) == 0)) { + SETUP("width"); + sprintf(error_buffer, "%d", Tk_Width(window)); + Tcl_SetResult(interp,error_buffer,TCL_VOLATILE); + } else if ((c == 'x') && (argv[1][1] == '\0')) { + SETUP("x"); + sprintf(error_buffer, "%d", Tk_X(window)); + Tcl_SetResult(interp,error_buffer,TCL_VOLATILE); + } else if ((c == 'y') && (argv[1][1] == '\0')) { + SETUP("y"); + sprintf(error_buffer, "%d", Tk_Y(window)); + Tcl_SetResult(interp,error_buffer,TCL_VOLATILE); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": 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, server, ", + "toplevel, viewable, visual, visualsavailable, ", + "vrootheight, vrootwidth, vrootx, vrooty, ", + "width, x, or y", (char *) NULL); + return TCL_ERROR; + } + return result; + + wrongArgs: + Tcl_AppendResult(interp, "wrong # arguments: must be \"", + argv[0], " ", argName, " window\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TkDeadAppCmd -- + * + * If an application has been deleted then all Tk commands will be + * re-bound to this procedure. + * + * Results: + * A standard Tcl error is reported to let the user know that + * the application is dead. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TkDeadAppCmd(clientData, interp, argc, argv) + ClientData clientData; /* Dummy. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "can't invoke \"", argv[0], + "\" command: application has been destroyed", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Ctk_TkFocusNextCmd -- + * + * Get the next window in "focus order" after specified window + * (the window that should receive the focus next if Tab is typed). + * "Next" is defined by a pre-order search of a top-level and its + * non-top-level descendants, with the stacking order determining + * the order of siblings. The "-takefocus" options on windows + * determine whether or not they should be skipped. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May execute arbitrary commands specified by the "-takefocus" + * options of the widgets. + * + *---------------------------------------------------------------------- + */ + +int +Ctk_TkFocusNextCmd(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 mainWin = (Tk_Window) clientData; + Tk_Window win, startWin, nextWin; + int flag; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window\"", (char *) NULL); + return TCL_ERROR; + } + startWin = Tk_NameToWindow(interp, argv[1], mainWin); + if (!startWin) return TCL_ERROR; + + win = startWin; + do { + /* + * First try to traverse to first child. If that fails, + * find the first ancestor that has a next sibling and + * traverse to that sibling. If the top-level is reached, + * stop there. + */ + + nextWin = Ctk_BottomChild(win); + while (!nextWin) { + if (Tk_IsTopLevel(win)) goto gotit; + nextWin = Ctk_NextSibling(win); + win = Tk_Parent(win); + } + win = nextWin; + +gotit: + /* + * Stop traversing if we have gone full circle or + * this window can get the focus. + */ + + if (win == startWin) break; + if (GetFocusOk(interp, win, &flag) != TCL_OK) return TCL_ERROR; + } while (!flag); + Tcl_SetResult(interp, Tk_PathName(win), TCL_STATIC); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Ctk_TkFocusPrevCmd -- + * + * Get the previous window in "focus order" before specified window + * (the window that should receive the focus next if Shift-Tab is + * typed). "Previous" is defined by a pre-order search of a top-level + * and its non-top-level descendants, with the stacking order + * determining the order of siblings. The "-takefocus" options + * on windows determine whether or not they should be skipped. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May execute arbitrary commands specified by the "-takefocus" + * options of the widgets. + * + *---------------------------------------------------------------------- + */ + +int +Ctk_TkFocusPrevCmd(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 mainWin = (Tk_Window) clientData; + Tk_Window win, startWin, nextWin; + int flag; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window\"", (char *) NULL); + return TCL_ERROR; + } + startWin = Tk_NameToWindow(interp, argv[1], mainWin); + if (!startWin) return TCL_ERROR; + + win = startWin; + do { + /* + * If window is a top-level, repeatedly traverse to topmost + * (last) children till a leaf is reached. Otherwise, to + * prior sibling and then traverse to topmost descendant. + * If there is no prior sibling (and this is not a top-level). + * Traverse to parent. + */ + + if (Tk_IsTopLevel(win)) { + nextWin = win; + } else { + nextWin = Ctk_PriorSibling(win); + if (!nextWin) win = Tk_Parent(win); + } + + /* + * Stop traversing if we have gone full circle or + * this window can get the focus. + */ + + while (nextWin) { + win = nextWin; + nextWin = Ctk_TopChild(win); + } + if (win == startWin) break; + if (GetFocusOk(interp, win, &flag) != TCL_OK) return TCL_ERROR; + } while (!flag); + Tcl_SetResult(interp, Tk_PathName(win), TCL_STATIC); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetFocusOk -- + * + * Get the previous window in "focus order" before specified window + * (the window that should receive the focus next if Shift-Tab is + * typed). "Previous" is defined by a pre-order search of a top-level + * and its non-top-level descendants, with the stacking order + * determining the order of siblings. The "-takefocus" options + * on windows determine whether or not they should be skipped. + * + * Results: + * If succesful, returns TCL_OK and stores 1 in *flagPtr if + * the window should get the focus and 0 if it shouldn't. If + * an error occurs while trying to determine focusability, + * returns TCL_ERROR and stores an error message in the interpreter + * result. + * + * Side effects: + * May execute an arbitrary command specified by the "-takefocus" + * options of the widget. + * + *---------------------------------------------------------------------- + */ + +static int +GetFocusOk(interp, winPtr, flagPtr) + Tcl_Interp *interp; + TkWindow *winPtr; + int *flagPtr; +{ + /* + * If window is not viewable, don't focus. + */ + + if (! (winPtr->flags & CTK_DISPLAYED)) goto nofocus; + + /* + * Check widget's -takefocus option. + */ + + if (Tcl_VarEval(interp, Tk_PathName(winPtr), " cget -takefocus", + (char *) NULL) == TCL_OK && interp->result[0] != '\0') { + + /* + * Try to interpret option value as simple 1 or 0. + */ + + if (interp->result[1] == '\0') { + if (interp->result[0] == '1') { + goto focus; + } else if (interp->result[0] == '0') { + goto nofocus; + } + } + { + + /* + * The -takefocus option is not 1 or 0, append window + * pathname to the option value and evaluate as script. + * Interpret result as boolean. + */ + + Tcl_DString dStr; + int result; + + Tcl_DStringInit(&dStr); + Tcl_DStringGetResult(interp, &dStr); + Tcl_DStringAppend(&dStr, " ", 1); + Tcl_DStringAppend(&dStr, Tk_PathName(winPtr), -1); + Tcl_GlobalEval(interp, Tcl_DStringValue(&dStr)); + + Tcl_DStringGetResult(interp, &dStr); + result = Tcl_GetBoolean(interp, Tcl_DStringValue(&dStr), flagPtr); + Tcl_DStringFree(&dStr); + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (-takefocus script)"); + } + return result; + } + } + + /* + * Check widget's -state option. If value is "disaabled", + * don't focus. + */ + + if (Tcl_VarEval(interp, Tk_PathName(winPtr), " cget -state", + (char *) NULL) == TCL_OK) { + if (interp->result[0] == 'd' + && strcmp(interp->result, "disabled") == 0) goto nofocus; + } + + /* + * Check if widget has any Keyboard related bindings (check + * individual widget tag and its class tag). + */ + + if (Tcl_VarEval(interp, "bind ", Tk_PathName(winPtr), (char *) NULL) + != TCL_OK) return TCL_ERROR; + if (strstr(interp->result, "Key")) goto focus; + if (strstr(interp->result, "Focus")) goto focus; + + if (Tcl_VarEval(interp, "bind ", Tk_Class(winPtr), (char *) NULL) + != TCL_OK) return TCL_ERROR; + if (strstr(interp->result, "Key")) goto focus; + if (strstr(interp->result, "Focus")) goto focus; + +nofocus: + *flagPtr = 0; + return TCL_OK; + +focus: + *flagPtr = 1; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Ctk_CtkCmd -- + * + * This procedure is invoked to process the "ctk" 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 +Ctk_CtkCmd(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 mainWin = (Tk_Window) clientData; + char c; + size_t length; + + 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 == 'r') && (strncmp(argv[1], "redraw", length) == 0)) { + Tk_Window tkwin; + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " redraw window\"", (char *) NULL); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, argv[2], mainWin); + if (tkwin == NULL) { + return TCL_ERROR; + } + Ctk_DisplayRedraw(Tk_Display(tkwin)); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be redraw", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Ctk_TkEntryInsertCmd -- + * + * This procedure is invoked to process the "tkEntryInsert" + * Tcl command. Insert a string into an entry at the point + * of the insertion cursor. If there is a selection in the + * entry, and it covers the point of the insertion cursor, + * then delete the selection before inserting. + * + * First thought about letting this function use the entry + * widget internals - but that would not work with the + * object widget systems (like mine, and [incr Tk]). + * + * The payoff for these entry commands is not nearly + * as high as the focus processing ones above. Is it + * worth it? + * + * Results: + * A standard Tcl result. Sets result to "1" if characters + * are inserted, and "0" otherwise. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Ctk_TkEntryInsertCmd(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. */ +{ + Tcl_DString dStr; + Tcl_CmdInfo cmdInfo; + char *widgetArgv[5]; + int insert, first, last; + int result = TCL_ERROR; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window string\"", (char *) NULL); + return TCL_ERROR; + } + if (!Tcl_GetCommandInfo(interp, argv[1], &cmdInfo)) { + Tcl_AppendResult(interp, "widget command \"", argv[1], + "\" is not defined", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] == '\0') { + Tcl_SetResult(interp, "0", TCL_STATIC); + return TCL_OK; + } + Tcl_DStringInit(&dStr); + widgetArgv[0] = argv[1]; + + /* + * Check if insertion point is in the selection region. + */ + + widgetArgv[1] = "index"; + widgetArgv[2] = "insert"; + widgetArgv[3] = NULL; + if ( (cmdInfo.proc)(cmdInfo.clientData, interp, 3, widgetArgv) ) goto doit; + Tcl_DStringGetResult(interp, &dStr); + if (Tcl_GetInt(interp, Tcl_DStringValue(&dStr), &insert)) goto done; + + widgetArgv[1] = "index"; + widgetArgv[2] = "sel.first"; + widgetArgv[3] = NULL; + if ( (cmdInfo.proc)(cmdInfo.clientData, interp, 3, widgetArgv) ) goto doit; + Tcl_DStringGetResult(interp, &dStr); + if (Tcl_GetInt(interp, Tcl_DStringValue(&dStr), &first)) goto done; + + if (first <= insert) { + widgetArgv[1] = "index"; + widgetArgv[2] = "sel.last"; + widgetArgv[3] = NULL; + if ( (cmdInfo.proc)(cmdInfo.clientData, interp, 3, widgetArgv) ) + goto doit; + Tcl_DStringGetResult(interp, &dStr); + if (Tcl_GetInt(interp, Tcl_DStringValue(&dStr), &last)) goto done; + + if (last >= insert) { + widgetArgv[1] = "delete"; + widgetArgv[2] = "sel.first"; + widgetArgv[3] = "sel.last"; + widgetArgv[4] = NULL; + if ( (cmdInfo.proc)(cmdInfo.clientData, interp, 4, widgetArgv) ) + goto doit; + } + } + + /* + * Perform the insertion, then update view to contain the new + * insertion point. + */ + +doit: + widgetArgv[1] = "insert"; + widgetArgv[2] = "insert"; + widgetArgv[3] = argv[2]; + widgetArgv[4] = NULL; + Tcl_ResetResult(interp); + if ( (cmdInfo.proc)(cmdInfo.clientData, interp, 4, widgetArgv) ) goto done; + + widgetArgv[1] = argv[1]; + widgetArgv[2] = NULL; + Tcl_ResetResult(interp); + result = Ctk_TkEntrySeeInsertCmd(clientData, interp, 2, widgetArgv); + if (result == TCL_OK) { + Tcl_SetResult(interp, "1", TCL_STATIC); + } + +done: + Tcl_DStringFree(&dStr); + return result; +} + +/* + *-------------------------------------------------------------- + * + * Ctk_TkEntrySeeInsertCmd -- + * + * This procedure is invoked to process the "tkEntrySeeInsert" + * Tcl command. Makes sure that the insertion cursor is + * visible in the entry window. If not, adjust the view so + * that it is. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Ctk_TkEntrySeeInsertCmd(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 mainWin = (Tk_Window) clientData; + Tk_Window tkwin; + Tcl_DString dStr; + int result = TCL_ERROR; + Tcl_CmdInfo cmdInfo; + char *widgetArgv[4]; + int c, left, x, i; + char buf[50]; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window\"", (char *) NULL); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, argv[1], mainWin); + if (!tkwin) return TCL_ERROR; + if (!Tcl_GetCommandInfo(interp, argv[1], &cmdInfo)) { + Tcl_AppendResult(interp, "widget command \"", argv[1], + "\" is not defined", (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringInit(&dStr); + widgetArgv[0] = argv[1]; + widgetArgv[3] = NULL; + + widgetArgv[1] = "index"; + widgetArgv[2] = "insert"; + if ( (cmdInfo.proc)(cmdInfo.clientData, interp, 3, widgetArgv) ) goto done; + Tcl_DStringGetResult(interp, &dStr); + if (Tcl_GetInt(interp, Tcl_DStringValue(&dStr), &c)) goto done; + + widgetArgv[1] = "index"; + widgetArgv[2] = "@0"; + if ( (cmdInfo.proc)(cmdInfo.clientData, interp, 3, widgetArgv) ) goto done; + Tcl_DStringGetResult(interp, &dStr); + if (Tcl_GetInt(interp, Tcl_DStringValue(&dStr), &left)) goto done; + + if (left > c) { + sprintf(buf, "%d", c); + widgetArgv[1] = "xview"; + widgetArgv[2] = buf; + result = (cmdInfo.proc)(cmdInfo.clientData, interp, 3, widgetArgv); + goto done; + } + + x = Tk_Width(tkwin); + while (1) { + sprintf(buf, "@%d", x); + widgetArgv[1] = "index"; + widgetArgv[2] = buf; + if ( (cmdInfo.proc)(cmdInfo.clientData, interp, 3, widgetArgv) ) + goto done; + Tcl_DStringGetResult(interp, &dStr); + if (Tcl_GetInt(interp, Tcl_DStringValue(&dStr), &i)) goto done; + if (i > c || left >= c) break; + + left++; + sprintf(buf, "%d", left); + widgetArgv[1] = "xview"; + widgetArgv[2] = buf; + if ( (cmdInfo.proc)(cmdInfo.clientData, interp, 3, widgetArgv) ) + goto done; + Tcl_ResetResult(interp); + } + result = TCL_OK; +done: + Tcl_DStringFree(&dStr); + return result; +} ADDED tkConfig.c Index: tkConfig.c ================================================================== --- tkConfig.c +++ tkConfig.c @@ -0,0 +1,922 @@ +/* + * tkConfig.c (CTk) -- + * + * This file contains the Tk_ConfigureWidget procedure. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "tk.h" + +/* + * Values for "flags" field of Tk_ConfigSpec structures. Be sure + * to coordinate these values with those defined in tk.h + * (TK_CONFIG_COLOR_ONLY, etc.). There must not be overlap! + * + * INIT - Non-zero means (char *) things have been + * converted to Tk_Uid's. + */ + +#define INIT 0x20 + +/* + * Valid Tk options that are not supported by CTk, and their fixed values. + * Need to set more of the defaults to sensible values. + */ +static char *unsupportedOptions[] = { + "-activebackground", + "", + "-activeborderwidth", + "0", + "-activerelief", + "", + "-background", + "black", + "-bg", + "black", + "-bitmap", + "", + "-borderwidth", + "0", + "-colormap", + "", + "-cursor", + "", + "-disabledforeground", + "", + "-exportselection", + "", + "-fg", + "white", + "-font", + "fixed", + "-foreground", + "white", + "-highlightcolor", + "", + "-highlightbackground", + "", + "-highlightthickness", + "0", + "-image", + "", + "-insertbackground", + "", + "-insertborderwidth", + "", + "-insertofftime", + "", + "-insertontime", + "", + "-insertwidth", + "", + "-indicatoron", + "", + "-jump", + "", + "-relief", + "", + "-repeatdelay", + "", + "-repeatinterval", + "", + "-screen", + "", + "-selectbackground", + "", + "-selectborderwidth", + "", + "-selectcolor", + "", + "-selectforeground", + "", + "-selectimage", + "", + "-setgrid", + "", + "-tearoff", + "", + "-troughcolor", + "", + "-visual", + "", + (char *) NULL +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +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, + Tk_ConfigSpec *specs, char *argvName, + int needFlags, int hateFlags)); +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)); + +/* + *-------------------------------------------------------------- + * + * Tk_ConfigureWidget -- + * + * Process command-line options and database options to + * fill in fields of a widget record with resources and + * other parameters. + * + * Results: + * A standard Tcl return value. In case of an error, + * interp->result will hold an error message. + * + * Side effects: + * The fields of widgRec get filled in with information + * from argc/argv and the option database. Old information + * in widgRec's fields gets recycled. + * + *-------------------------------------------------------------- + */ + +int +Tk_ConfigureWidget(interp, tkwin, specs, argc, argv, widgRec, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Window containing widget (needed to + * set up X resources). */ + Tk_ConfigSpec *specs; /* Describes legal options. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Command-line options. */ + char *widgRec; /* Record whose fields are to be + * modified. Values must be properly + * initialized. */ + int flags; /* Used to specify additional flags + * that must be present in config specs + * for them to be considered. Also, + * may have TK_CONFIG_ARGV_ONLY set. */ +{ + register Tk_ConfigSpec *specPtr; + Tk_Uid value; /* Value of option from database. */ + int needFlags; /* Specs must contain this set of flags + * or else they are not considered. */ + int hateFlags; /* If a spec contains any bits here, it's + * not considered. */ + + needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); + if (Tk_Depth(tkwin) <= 1) { + hateFlags = TK_CONFIG_COLOR_ONLY; + } else { + hateFlags = TK_CONFIG_MONO_ONLY; + } + + /* + * Pass one: scan through all the option specs, replacing strings + * with Tk_Uids (if this hasn't been done already) and clearing + * the TK_CONFIG_OPTION_SPECIFIED flags. + */ + + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if (!(specPtr->specFlags & INIT) && (specPtr->argvName != NULL)) { + if (specPtr->dbName != NULL) { + specPtr->dbName = Tk_GetUid(specPtr->dbName); + } + if (specPtr->dbClass != NULL) { + specPtr->dbClass = Tk_GetUid(specPtr->dbClass); + } + if (specPtr->defValue != NULL) { + specPtr->defValue = Tk_GetUid(specPtr->defValue); + } + } + specPtr->specFlags = (specPtr->specFlags & ~TK_CONFIG_OPTION_SPECIFIED) + | INIT; + } + + /* + * Pass two: scan through all of the arguments, processing those + * that match entries in the specs. + */ + + for ( ; argc > 0; argc -= 2, argv += 2) { + specPtr = FindConfigSpec(interp, specs, *argv, needFlags, hateFlags); + if (specPtr == NULL) { + size_t length = strlen(*argv); + char **optionPtr; + + for (optionPtr = unsupportedOptions; + *optionPtr != (char *) NULL; + optionPtr += 2) { + if (*optionPtr[0] == *argv[0] && + strncmp(*optionPtr, *argv, length) == 0) { + Tcl_ResetResult(interp); + goto match; + } + } + return TCL_ERROR; +match: + continue; + } + + /* + * Process the entry. + */ + + if (argc < 2) { + Tcl_AppendResult(interp, "value for \"", *argv, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + if (DoConfig(interp, tkwin, specPtr, argv[1], 0, widgRec) != TCL_OK) { + char msg[100]; + + sprintf(msg, "\n (processing \"%.40s\" option)", + specPtr->argvName); + Tcl_AddErrorInfo(interp, msg); + return TCL_ERROR; + } + specPtr->specFlags |= TK_CONFIG_OPTION_SPECIFIED; + } + + /* + * Pass three: scan through all of the specs again; if no + * command-line argument matched a spec, then check for info + * in the option database. If there was nothing in the + * database, then use the default. + */ + + if (!(flags & TK_CONFIG_ARGV_ONLY)) { + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if ((specPtr->specFlags & TK_CONFIG_OPTION_SPECIFIED) + || (specPtr->argvName == NULL) + || (specPtr->type == TK_CONFIG_SYNONYM)) { + continue; + } + if (((specPtr->specFlags & needFlags) != needFlags) + || (specPtr->specFlags & hateFlags)) { + continue; + } + value = NULL; + if (specPtr->dbName != NULL) { + value = Tk_GetOption(tkwin, specPtr->dbName, specPtr->dbClass); + } + if (value != NULL) { + if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) != + TCL_OK) { + char msg[200]; + + sprintf(msg, "\n (%s \"%.50s\" in widget \"%.50s\")", + "database entry for", + specPtr->dbName, Tk_PathName(tkwin)); + Tcl_AddErrorInfo(interp, msg); + return TCL_ERROR; + } + } else { + value = specPtr->defValue; + if ((value != NULL) && !(specPtr->specFlags + & TK_CONFIG_DONT_SET_DEFAULT)) { + if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) != + TCL_OK) { + char msg[200]; + + sprintf(msg, + "\n (%s \"%.50s\" in widget \"%.50s\")", + "default value for", + specPtr->dbName, Tk_PathName(tkwin)); + Tcl_AddErrorInfo(interp, msg); + return TCL_ERROR; + } + } + } + } + } + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * FindConfigSpec -- + * + * Search through a table of configuration specs, looking for + * one that matches a given argvName. + * + * Results: + * The return value is a pointer to the matching entry, or NULL + * if nothing matched. In that case an error message is left + * in interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static Tk_ConfigSpec * +FindConfigSpec(interp, specs, argvName, needFlags, hateFlags) + Tcl_Interp *interp; /* Used for reporting errors. */ + Tk_ConfigSpec *specs; /* Pointer to table of configuration + * specifications for a widget. */ + char *argvName; /* Name (suitable for use in a "config" + * command) identifying particular option. */ + int needFlags; /* Flags that must be present in matching + * entry. */ + int hateFlags; /* Flags that must NOT be present in + * matching entry. */ +{ + register Tk_ConfigSpec *specPtr; + register char c; /* First character of current argument. */ + Tk_ConfigSpec *matchPtr; /* Matching spec, or NULL. */ + size_t length; + + c = argvName[1]; + length = strlen(argvName); + matchPtr = NULL; + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if (specPtr->argvName == NULL) { + continue; + } + if ((specPtr->argvName[1] != c) + || (strncmp(specPtr->argvName, argvName, length) != 0)) { + continue; + } + if (((specPtr->specFlags & needFlags) != needFlags) + || (specPtr->specFlags & hateFlags)) { + continue; + } + if (specPtr->argvName[length] == 0) { + matchPtr = specPtr; + goto gotMatch; + } + if (matchPtr != NULL) { + Tcl_AppendResult(interp, "ambiguous option \"", argvName, + "\"", (char *) NULL); + return (Tk_ConfigSpec *) NULL; + } + matchPtr = specPtr; + } + + if (matchPtr == NULL) { + Tcl_AppendResult(interp, "unknown option \"", argvName, + "\"", (char *) NULL); + return (Tk_ConfigSpec *) NULL; + } + + /* + * Found a matching entry. If it's a synonym, then find the + * entry that it's a synonym for. + */ + + gotMatch: + specPtr = matchPtr; + if (specPtr->type == TK_CONFIG_SYNONYM) { + for (specPtr = specs; ; specPtr++) { + if (specPtr->type == TK_CONFIG_END) { + Tcl_AppendResult(interp, + "couldn't find synonym for option \"", + argvName, "\"", (char *) NULL); + return (Tk_ConfigSpec *) NULL; + } + if ((specPtr->dbName == matchPtr->dbName) + && (specPtr->type != TK_CONFIG_SYNONYM) + && ((specPtr->specFlags & needFlags) == needFlags) + && !(specPtr->specFlags & hateFlags)) { + break; + } + } + } + return specPtr; +} + +/* + *-------------------------------------------------------------- + * + * DoConfig -- + * + * This procedure applies a single configuration option + * to a widget record. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * WidgRec is modified as indicated by specPtr and value. + * The old value is recycled, if that is appropriate for + * the value type. + * + *-------------------------------------------------------------- + */ + +static int +DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Window containing widget (needed to + * set up X resources). */ + Tk_ConfigSpec *specPtr; /* Specifier to apply. */ + char *value; /* Value to use to fill in widgRec. */ + int valueIsUid; /* Non-zero means value is a Tk_Uid; + * zero means it's an ordinary string. */ + char *widgRec; /* Record whose fields are to be + * modified. Values must be properly + * initialized. */ +{ + char *ptr; + Tk_Uid uid; + int nullValue; + + nullValue = 0; + if ((*value == 0) && (specPtr->specFlags & TK_CONFIG_NULL_OK)) { + nullValue = 1; + } + + do { + ptr = widgRec + specPtr->offset; + switch (specPtr->type) { + case TK_CONFIG_BOOLEAN: + if (Tcl_GetBoolean(interp, value, (int *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_INT: + if (Tcl_GetInt(interp, value, (int *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_DOUBLE: + if (Tcl_GetDouble(interp, value, (double *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_STRING: { + char *old, *new; + + if (nullValue) { + new = NULL; + } else { + new = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(new, value); + } + old = *((char **) ptr); + if (old != NULL) { + ckfree(old); + } + *((char **) ptr) = new; + break; + } + case TK_CONFIG_UID: + if (nullValue) { + *((Tk_Uid *) ptr) = NULL; + } else { + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + *((Tk_Uid *) ptr) = uid; + } + break; + case TK_CONFIG_JUSTIFY: + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + if (Tk_GetJustify(interp, uid, (Tk_Justify *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_ANCHOR: + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + if (Tk_GetAnchor(interp, uid, (Tk_Anchor *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_PIXELS: + if (Tk_GetPixels(interp, tkwin, value, (int *) ptr) + != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_MM: + if (Tk_GetScreenMM(interp, tkwin, value, (double *) ptr) + != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_WINDOW: { + Tk_Window tkwin2; + + if (nullValue) { + tkwin2 = NULL; + } else { + tkwin2 = Tk_NameToWindow(interp, value, tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + } + *((Tk_Window *) ptr) = tkwin2; + break; + } + case TK_CONFIG_CUSTOM: + if ((*specPtr->customPtr->parseProc)( + specPtr->customPtr->clientData, interp, tkwin, + value, widgRec, specPtr->offset) != TCL_OK) { + return TCL_ERROR; + } + break; + default: { + char buffer[100]; + sprintf(buffer, "bad config table: unknown type %d", + specPtr->type); + Tcl_SetResult(interp, buffer, TCL_VOLATILE); + return TCL_ERROR; + } + } + specPtr++; + } while ((specPtr->argvName == NULL) && (specPtr->type != TK_CONFIG_END)); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_ConfigureInfo -- + * + * Return information about the configuration options + * for a window, and their current values. + * + * Results: + * Always returns TCL_OK. Interp->result will be modified + * hold a description of either a single configuration option + * available for "widgRec" via "specs", or all the configuration + * options available. In the "all" case, the result will + * available for "widgRec" via "specs". The result will + * be a list, each of whose entries describes one option. + * Each entry will itself be a list containing the option's + * name for use on command lines, database name, database + * class, default value, and current value (empty string + * if none). For options that are synonyms, the list will + * contain only two values: name and synonym name. If the + * "name" argument is non-NULL, then the only information + * returned is that for the named argument (i.e. the corresponding + * entry in the overall list is returned). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_ConfigureInfo(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; /* If non-NULL, indicates a single option + * whose info is to be returned. Otherwise + * info is returned for all options. */ + int flags; /* Used to specify additional flags + * that must be present in config specs + * for them to be considered. */ +{ + register Tk_ConfigSpec *specPtr; + int needFlags, hateFlags; + char *list; + char *leader = "{"; + + needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); + if (Tk_Depth(tkwin) <= 1) { + hateFlags = TK_CONFIG_COLOR_ONLY; + } else { + hateFlags = TK_CONFIG_MONO_ONLY; + } + + /* + * If information is only wanted for a single configuration + * spec, then handle that one spec specially. + */ + + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + if (argvName != NULL) { + specPtr = FindConfigSpec(interp, specs, argvName, needFlags, + hateFlags); + if (specPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, + FormatConfigInfo(interp, tkwin, specPtr, widgRec), + (Tcl_FreeProc *) free); + return TCL_OK; + } + + /* + * Loop through all the specs, creating a big list with all + * their information. + */ + + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if ((argvName != NULL) && (specPtr->argvName != argvName)) { + continue; + } + if (((specPtr->specFlags & needFlags) != needFlags) + || (specPtr->specFlags & hateFlags)) { + continue; + } + if (specPtr->argvName == NULL) { + continue; + } + list = FormatConfigInfo(interp, tkwin, specPtr, widgRec); + Tcl_AppendResult(interp, leader, list, "}", (char *) NULL); + ckfree(list); + leader = " {"; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * FormatConfigInfo -- + * + * Create a valid Tcl list holding the configuration information + * for a single configuration option. + * + * Results: + * A Tcl list, dynamically allocated. The caller is expected to + * arrange for this list to be freed eventually. + * + * Side effects: + * Memory is allocated. + * + *-------------------------------------------------------------- + */ + +static char * +FormatConfigInfo(interp, tkwin, specPtr, widgRec) + Tcl_Interp *interp; /* Interpreter to use for things + * like floating-point precision. */ + Tk_Window tkwin; /* Window corresponding to widget. */ + register Tk_ConfigSpec *specPtr; /* Pointer to information describing + * option. */ + char *widgRec; /* Pointer to record holding current + * values of info for widget. */ +{ + char *argv[6], *result; + char buffer[200]; + Tcl_FreeProc *freeProc = (Tcl_FreeProc *) NULL; + + argv[0] = specPtr->argvName; + argv[1] = specPtr->dbName; + argv[2] = specPtr->dbClass; + argv[3] = specPtr->defValue; + if (specPtr->type == TK_CONFIG_SYNONYM) { + return Tcl_Merge(2, argv); + } + argv[4] = FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, + &freeProc); + if (argv[1] == NULL) { + argv[1] = ""; + } + if (argv[2] == NULL) { + argv[2] = ""; + } + if (argv[3] == NULL) { + argv[3] = ""; + } + if (argv[4] == NULL) { + argv[4] = ""; + } + result = Tcl_Merge(5, argv); + if (freeProc != NULL) { + if (freeProc == (Tcl_FreeProc *) free) { + ckfree(argv[4]); + } else { + (*freeProc)(argv[4]); + } + } + 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_JUSTIFY: + result = Tk_NameOfJustify(*((Tk_Justify *) ptr)); + break; + case TK_CONFIG_ANCHOR: + result = Tk_NameOfAnchor(*((Tk_Anchor *) 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) { + size_t length = strlen(argvName); + char **optionPtr; + + for (optionPtr = unsupportedOptions; + *optionPtr != (char *) NULL; + optionPtr += 2) { + if (*optionPtr[0] == argvName[0] && + strncmp(*optionPtr, argvName, length) == 0) { + Tcl_SetResult(interp, *(optionPtr+1), TCL_STATIC); + return TCL_OK; + } + } + return TCL_ERROR; + } + { + char buffer[200]; + char *cp; + Tcl_FreeProc *fp = 0; + cp = FormatConfigValue(interp, tkwin, specPtr, widgRec, + buffer, &fp); + Tcl_SetResult(interp, cp, fp); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeOptions -- + * + * Free up all resources associated with configuration options. + * + * Results: + * None. + * + * Side effects: + * Any resource in widgRec that is controlled by a configuration + * option (e.g. a Tk_3DBorder or XColor) is freed in the appropriate + * fashion. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +Tk_FreeOptions(specs, widgRec, needFlags) + Tk_ConfigSpec *specs; /* Describes legal options. */ + char *widgRec; /* Record whose fields contain current + * values for options. */ + int needFlags; /* Used to specify additional flags + * that must be present in config specs + * for them to be considered. */ +{ + register Tk_ConfigSpec *specPtr; + char *ptr; + + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if ((specPtr->specFlags & needFlags) != needFlags) { + continue; + } + ptr = widgRec + specPtr->offset; + switch (specPtr->type) { + case TK_CONFIG_STRING: + if (*((char **) ptr) != NULL) { + ckfree(*((char **) ptr)); + *((char **) ptr) = NULL; + } + break; + } + } +} ADDED tkEntry.c Index: tkEntry.c ================================================================== --- tkEntry.c +++ tkEntry.c @@ -0,0 +1,1678 @@ +/* + * tkEntry.c (CTk) -- + * + * This module implements entry widgets for the Tk + * toolkit. An entry displays a string and allows + * the string to be edited. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "default.h" +#include "tkPort.h" +#include "tkInt.h" + +/* + * A data structure of the following type is kept for each entry + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the entry. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + 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; + * NULL-terminated; malloc-ed. */ + char *textVarName; /* Name of variable (malloc'ed) or NULL. + * If non-NULL, entry's string tracks the + * contents of this variable and vice versa. */ + Tk_Uid state; /* Normal or disabled. Entry is read-only + * when disabled. */ + + /* + * Information used when displaying widget: + */ + + int borderWidth; /* Width of 3-D border around window. */ + Tk_Justify justify; /* Justification to use for text within + * window. */ + int prefWidth; /* Desired width of window, measured in + * average characters. */ + 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. + */ + + int selectFirst; /* Index of first selected character (-1 means + * nothing selected. */ + int selectLast; /* Index of last selected character (-1 means + * nothing selected. */ + int selectAnchor; /* Fixed end of selection (i.e. "select to" + * operation will use this as one end of the + * selection). */ + + /* + * Miscellaneous 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 *scrollCmd; /* Command prefix for communicating with + * scrollbar(s). Malloc'ed. NULL means + * no command to issue. */ + int flags; /* Miscellaneous flags; see below for + * definitions. */ +} Entry; + +/* + * Assigned bits of "flags" fields of Entry structures, and what those + * bits mean: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler has + * already been queued to redisplay the entry. + * BORDER_NEEDED: Non-zero means 3-D border must be redrawn + * around window during redisplay. Normally + * only text portion needs to be redrawn. + * GOT_FOCUS: Non-zero means this window has the input + * focus. + * UPDATE_SCROLLBAR: Non-zero means scrollbar should be updated + * during next redisplay operation. + */ + +#define REDRAW_PENDING 1 +#define BORDER_NEEDED 2 +#define GOT_FOCUS 4 +#define UPDATE_SCROLLBAR 8 + +/* + * The following macro defines how many extra pixels to leave on each + * side of the text in the entry. + */ + +#define XPAD 1 +#define YPAD 1 + +/* + * Information used for argv parsing. + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_ENTRY_BORDER_WIDTH, Tk_Offset(Entry, borderWidth), 0}, + {TK_CONFIG_JUSTIFY, "-justify", "justify", "Justify", + DEF_ENTRY_JUSTIFY, Tk_Offset(Entry, justify), 0}, + {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} +}; + +/* + * Flags for GetEntryIndex procedure: + */ + +#define ZERO_OK 1 +#define LAST_PLUS_ONE_OK 2 + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int ConfigureEntry _ANSI_ARGS_((Tcl_Interp *interp, + Entry *entryPtr, int argc, char **argv, + int flags)); +static void DeleteChars _ANSI_ARGS_((Entry *entryPtr, int index, + int count)); +static void DestroyEntry _ANSI_ARGS_((ClientData clientData)); +static void DisplayEntry _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 EventuallyRedraw _ANSI_ARGS_((Entry *entryPtr)); +static void EntrySetValue _ANSI_ARGS_((Entry *entryPtr, + char *value)); +static void EntrySelectTo _ANSI_ARGS_(( + Entry *entryPtr, int index)); +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)); + +/* + *-------------------------------------------------------------- + * + * Tk_EntryCmd -- + * + * This procedure is invoked to process the "entry" 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_EntryCmd(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 Entry *entryPtr; + 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 the fields of the structure that won't be initialized + * by ConfigureEntry, or that ConfigureEntry requires to be + * initialized already (e.g. resource pointers). + */ + + entryPtr = (Entry *) ckalloc(sizeof(Entry)); + entryPtr->tkwin = 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'; + entryPtr->textVarName = NULL; + entryPtr->state = tkNormalUid; + entryPtr->borderWidth = 0; + entryPtr->justify = TK_JUSTIFY_LEFT; + entryPtr->prefWidth = 0; + 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; + entryPtr->takeFocus = NULL; + entryPtr->scrollCmd = NULL; + entryPtr->flags = 0; + + Tk_SetClass(entryPtr->tkwin, "Entry"); + Tk_CreateEventHandler(entryPtr->tkwin, + CTK_EXPOSE_EVENT_MASK|CTK_MAP_EVENT_MASK|CTK_DESTROY_EVENT_MASK + |CTK_FOCUS_EVENT_MASK, + EntryEventProc, (ClientData) entryPtr); + if (ConfigureEntry(interp, entryPtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + Tcl_SetResult(interp,Tk_PathName(entryPtr->tkwin), TCL_VOLATILE); + return TCL_OK; + + error: + Tk_DestroyWindow(entryPtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * EntryWidgetCmd -- + * + * 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 +EntryWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about entry widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Entry *entryPtr = (Entry *) 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; + } + Tk_Preserve((ClientData) entryPtr); + 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, 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); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, entryPtr->tkwin, configSpecs, + (char *) entryPtr, argv[2], 0); + } else { + result = ConfigureEntry(interp, entryPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { + int first, last; + + if ((argc < 3) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delete firstIndex ?lastIndex?\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[2], &first) != TCL_OK) { + goto error; + } + if (argc == 3) { + 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-first); + } + } 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; + } + Tcl_SetResult(interp,entryPtr->string,TCL_VOLATILE); + } else if ((c == 'i') && (strncmp(argv[1], "icursor", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " icursor pos\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[2], &entryPtr->insertPos) + != TCL_OK) { + goto error; + } + EventuallyRedraw(entryPtr); + } 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 string\"", (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { + goto error; + } + { + char buffer[20]; + sprintf(buffer, "%d", index); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) + && (length >= 3)) { + int index; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " insert index text\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { + goto error; + } + if (entryPtr->state == tkNormalUid) { + InsertChars(entryPtr, index, argv[3]); + } + } else if ((c == 's') && (length >= 2) + && (strncmp(argv[1], "scan", length) == 0)) { + result = Ctk_Unsupported(interp, "entry scan"); + } else if ((c == 's') && (length >= 2) + && (strncmp(argv[1], "selection", length) == 0)) { + int index, index2; + + if (argc < 3) { + 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') && (strncmp(argv[2], "clear", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection clear\"", (char *) NULL); + goto error; + } + if (entryPtr->selectFirst != -1) { + entryPtr->selectFirst = entryPtr->selectLast = -1; + 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) { + Tcl_SetResult(interp,"0",TCL_STATIC); + } else { + Tcl_SetResult(interp,"1",TCL_STATIC); + } + goto done; + } + if (argc >= 4) { + if (GetEntryIndex(interp, entryPtr, argv[3], &index) != TCL_OK) { + goto error; + } + } + if ((c == 'a') && (strncmp(argv[2], "adjust", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection adjust index\"", + (char *) NULL); + goto error; + } + if (entryPtr->selectFirst >= 0) { + 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], " 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 { + entryPtr->selectFirst = index; + entryPtr->selectLast = index2; + } + EventuallyRedraw(entryPtr); + } else if ((c == 't') && (strncmp(argv[2], "to", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection to index\"", + (char *) NULL); + goto error; + } + EntrySelectTo(entryPtr, index); + } else { + Tcl_AppendResult(interp, "bad selection option \"", argv[2], + "\": must be adjust, clear, from, present, range, or to", + (char *) NULL); + goto error; + } + } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { + int index, type, count, charsPerPage; + double fraction, first, last; + + if (argc == 2) { + char buffer[40]; + EntryVisibleRange(entryPtr, &first, &last); + sprintf(buffer, "%g %g", first, last); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + 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); + break; + case TK_SCROLL_PAGES: + charsPerPage = Tk_Width(entryPtr->tkwin) + - 2*entryPtr->borderWidth - 2; + if (charsPerPage < 1) { + charsPerPage = 1; + } + index += charsPerPage*count; + break; + case TK_SCROLL_UNITS: + index += count; + break; + } + } + if (index >= entryPtr->numChars) { + index = entryPtr->numChars-1; + } + 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 cget, configure, delete, get, ", + "icursor, index, insert, scan, selection, or xview", + (char *) NULL); + goto error; + } + done: + Tk_Release((ClientData) entryPtr); + return result; + + error: + Tk_Release((ClientData) entryPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyEntry -- + * + * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * to clean up the internal structure of an entry at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the entry is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyEntry(clientData) + ClientData clientData; /* Info about entry widget. */ +{ + register Entry *entryPtr = (Entry *) clientData; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + ckfree(entryPtr->string); + if (entryPtr->textVarName != NULL) { + Tcl_UntraceVar(entryPtr->interp, entryPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + EntryTextVarProc, (ClientData) entryPtr); + } + if (entryPtr->displayString != NULL) { + ckfree(entryPtr->displayString); + } + Tk_FreeOptions(configSpecs, (char *) entryPtr, 0); + ckfree((char *) entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureEntry -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or reconfigure) + * an entry 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 entryPtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureEntry(interp, entryPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Entry *entryPtr; /* 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. */ +{ + /* + * Eliminate any existing trace on a variable monitored by the entry. + */ + + if (entryPtr->textVarName != NULL) { + Tcl_UntraceVar(interp, entryPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + EntryTextVarProc, (ClientData) entryPtr); + } + + if (Tk_ConfigureWidget(interp, entryPtr->tkwin, configSpecs, + argc, argv, (char *) entryPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the entry is tied to the value of a variable, then set up + * a trace on the variable's value, create the variable if it doesn't + * exist, and set the entry's value from the variable's value. + */ + + if (entryPtr->textVarName != NULL) { + char *value; + + value = Tcl_GetVar(interp, entryPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + EntryValueChanged(entryPtr); + } else { + EntrySetValue(entryPtr, value); + } + Tcl_TraceVar(interp, entryPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + EntryTextVarProc, (ClientData) entryPtr); + } + + /* + * A few other options also need special processing, such as parsing + * the geometry and setting the background from a 3-D border. + */ + + if ((entryPtr->state != tkNormalUid) + && (entryPtr->state != tkDisabledUid)) { + Tcl_AppendResult(interp, "bad state value \"", entryPtr->state, + "\": must be normal or disabled", (char *) NULL); + entryPtr->state = tkNormalUid; + return TCL_ERROR; + } + + /* + * Recompute the window's geometry and arrange for it to be + * redisplayed. + */ + + Tk_SetInternalBorder(entryPtr->tkwin, entryPtr->borderWidth); + EntryComputeGeometry(entryPtr); + entryPtr->flags |= UPDATE_SCROLLBAR; + EventuallyRedraw(entryPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DisplayEntry -- + * + * This procedure redraws the contents of an entry window. + * + * Results: + * None. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +static void +DisplayEntry(clientData) + ClientData clientData; /* Information about window. */ +{ + register Entry *entryPtr = (Entry *) clientData; + register Tk_Window tkwin = entryPtr->tkwin; + int baseY, selStartX, selEndX, index, cursorX; + int xBound, count; + char *displayString; + + if ((entryPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + goto done; + } + + /* + * Update the scrollbar if that's needed. + */ + + if (entryPtr->flags & UPDATE_SCROLLBAR) { + EntryUpdateScrollbar(entryPtr); + } + + /* + * Compute x-coordinate of the pixel just after last visible + * one, plus vertical position of baseline of text. + */ + + xBound = Tk_Width(tkwin) - entryPtr->borderWidth; + baseY = Tk_Height(tkwin)/2; + + /* + * Draw the background. + */ + + Ctk_FillRect(tkwin, entryPtr->borderWidth, baseY, xBound, baseY+1, + CTK_UNDERLINE_STYLE, ' '); + + if (entryPtr->displayString == NULL) { + displayString = entryPtr->string; + } else { + displayString = entryPtr->displayString; + } + if (entryPtr->selectLast > entryPtr->leftIndex) { + if (entryPtr->selectFirst <= entryPtr->leftIndex) { + selStartX = entryPtr->leftX; + index = entryPtr->leftIndex; + } else { + (void) TkMeasureChars( + 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 < xBound) { + (void) TkMeasureChars( + displayString + index, entryPtr->selectLast - index, + selStartX, xBound, entryPtr->tabOrigin, + TK_PARTIAL_OK|TK_NEWLINES_NOT_SPECIAL, &selEndX); + } else { + selEndX = xBound; + } + } + + /* + * Draw the text in three pieces: first the piece to the left of + * the selection, then the selection, then the piece to the right + * of the selection. + */ + + if (entryPtr->selectLast <= entryPtr->leftIndex) { + TkDisplayChars(tkwin, CTK_UNDERLINE_STYLE, + 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(tkwin, CTK_UNDERLINE_STYLE, + displayString + entryPtr->leftIndex, + count, entryPtr->leftX, baseY, entryPtr->tabOrigin, + TK_NEWLINES_NOT_SPECIAL); + index = entryPtr->selectFirst; + } else { + index = entryPtr->leftIndex; + } + count = entryPtr->selectLast - index; + if ((selStartX < xBound) && (count > 0)) { + TkDisplayChars(tkwin, CTK_SELECTED_STYLE, + displayString + index, count, + selStartX, baseY, entryPtr->tabOrigin, + TK_NEWLINES_NOT_SPECIAL); + } + count = entryPtr->numChars - entryPtr->selectLast; + if ((selEndX < xBound) && (count > 0)) { + TkDisplayChars(tkwin, CTK_UNDERLINE_STYLE, + displayString + entryPtr->selectLast, + count, selEndX, baseY, entryPtr->tabOrigin, + TK_NEWLINES_NOT_SPECIAL); + } + } + + /* + * Position the cursor. + */ + + if ((entryPtr->insertPos >= entryPtr->leftIndex) + && (entryPtr->state == tkNormalUid) + && (entryPtr->flags & GOT_FOCUS)) { + (void) TkMeasureChars( + displayString + entryPtr->leftIndex, + entryPtr->insertPos - entryPtr->leftIndex, entryPtr->leftX, + xBound, entryPtr->tabOrigin, + TK_PARTIAL_OK|TK_NEWLINES_NOT_SPECIAL, &cursorX); + if (cursorX < xBound) { + Ctk_SetCursor(tkwin, cursorX, baseY); + } + } + + if (entryPtr->flags & BORDER_NEEDED) { + Ctk_DrawBorder(tkwin, CTK_PLAIN_STYLE, (char *)NULL); + } + + done: + entryPtr->flags &= ~(REDRAW_PENDING|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 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(displayString, entryPtr->numChars, + 0, INT_MAX, 0, TK_NEWLINES_NOT_SPECIAL, &totalLength); + totalLength++; + overflow = totalLength + - (Tk_Width(entryPtr->tkwin) - 2*entryPtr->borderWidth); + if (overflow <= 0) { + entryPtr->leftIndex = 0; + if (entryPtr->justify == TK_JUSTIFY_LEFT) { + entryPtr->leftX = entryPtr->borderWidth; + } else if (entryPtr->justify == TK_JUSTIFY_RIGHT) { + entryPtr->leftX = Tk_Width(entryPtr->tkwin) - entryPtr->borderWidth + - 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 more than one empty space on + * the right of the window, then don't let leftIndex be any + * greater than that. + */ + + maxOffScreen = TkMeasureChars(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(displayString, + entryPtr->leftIndex, 0, INT_MAX, 0, + TK_NEWLINES_NOT_SPECIAL|TK_PARTIAL_OK, &rightX); + entryPtr->leftX = entryPtr->borderWidth; + entryPtr->tabOrigin = entryPtr->leftX - rightX; + } + + height = 1 + 2*entryPtr->borderWidth + 2*(YPAD-XPAD); + if (entryPtr->prefWidth > 0) { + width = entryPtr->prefWidth + 2*entryPtr->borderWidth; + } else { + if (totalLength == 0) { + width = 1 + 2*entryPtr->borderWidth; + } else { + width = totalLength + 2*entryPtr->borderWidth; + } + } + Tk_GeometryRequest(entryPtr->tkwin, width, height); +} + +/* + *---------------------------------------------------------------------- + * + * InsertChars -- + * + * Add new characters to an entry widget. + * + * Results: + * None. + * + * Side effects: + * New information gets added to entryPtr; it will be redisplayed + * soon, but not necessarily immediately. + * + *---------------------------------------------------------------------- + */ + +static void +InsertChars(entryPtr, index, string) + register Entry *entryPtr; /* Entry that is to get the new + * elements. */ + int index; /* Add the new elements before this + * element. */ + char *string; /* New characters to add (NULL-terminated + * string). */ +{ + int length; + char *new; + + length = strlen(string); + if (length == 0) { + return; + } + new = (char *) ckalloc((unsigned) (entryPtr->numChars + length + 1)); + strncpy(new, entryPtr->string, (size_t) index); + strcpy(new+index, string); + strcpy(new+index+length, entryPtr->string+index); + ckfree(entryPtr->string); + entryPtr->string = new; + entryPtr->numChars += length; + + /* + * Inserting characters invalidates all indexes into the string. + * Touch up the indexes so that they still refer to the same + * 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) { + entryPtr->selectLast += length; + } + if ((entryPtr->selectAnchor > index) || (entryPtr->selectFirst >= index)) { + entryPtr->selectAnchor += length; + } + if (entryPtr->leftIndex > index) { + entryPtr->leftIndex += length; + } + if (entryPtr->insertPos >= index) { + entryPtr->insertPos += length; + } + EntryValueChanged(entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteChars -- + * + * Remove one or more characters from an entry widget. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed, the entry gets modified and (eventually) + * redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteChars(entryPtr, index, count) + register Entry *entryPtr; /* Entry widget to modify. */ + int index; /* Index of first character to delete. */ + int count; /* How many characters to delete. */ +{ + char *new; + + if ((index + count) > entryPtr->numChars) { + count = entryPtr->numChars - index; + } + if (count <= 0) { + return; + } + + new = (char *) ckalloc((unsigned) (entryPtr->numChars + 1 - count)); + strncpy(new, entryPtr->string, (size_t) index); + strcpy(new+index, entryPtr->string+index+count); + ckfree(entryPtr->string); + entryPtr->string = new; + entryPtr->numChars -= count; + + /* + * Deleting characters results in the remaining characters being + * renumbered. Update the various indexes into the string to reflect + * this change. + */ + + if (entryPtr->selectFirst >= index) { + if (entryPtr->selectFirst >= (index+count)) { + entryPtr->selectFirst -= count; + } else { + entryPtr->selectFirst = index; + } + } + if (entryPtr->selectLast >= index) { + if (entryPtr->selectLast >= (index+count)) { + entryPtr->selectLast -= count; + } else { + entryPtr->selectLast = index; + } + } + if (entryPtr->selectLast <= entryPtr->selectFirst) { + entryPtr->selectFirst = entryPtr->selectLast = -1; + } + if (entryPtr->selectAnchor >= index) { + if (entryPtr->selectAnchor >= (index+count)) { + entryPtr->selectAnchor -= count; + } else { + entryPtr->selectAnchor = index; + } + } + if (entryPtr->leftIndex > index) { + if (entryPtr->leftIndex >= (index+count)) { + entryPtr->leftIndex -= count; + } else { + entryPtr->leftIndex = index; + } + } + if (entryPtr->insertPos >= index) { + if (entryPtr->insertPos >= (index+count)) { + entryPtr->insertPos -= count; + } else { + 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. + * + *---------------------------------------------------------------------- + */ + +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); + } +} + +/* + *---------------------------------------------------------------------- + * + * EntrySetValue -- + * + * Replace the contents of a text entry with a given value. This + * procedure is invoked when updating the entry from the entry's + * associated variable. + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +EntrySetValue(entryPtr, value) + register Entry *entryPtr; /* Entry whose value is to be + * changed. */ + char *value; /* New text to display in entry. */ +{ + ckfree(entryPtr->string); + 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; + + entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); + EventuallyRedraw(entryPtr); +} + +/* + *-------------------------------------------------------------- + * + * EntryEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on entryes. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +EntryEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Entry *entryPtr = (Entry *) clientData; + if (eventPtr->type == CTK_EXPOSE_EVENT) { + EventuallyRedraw(entryPtr); + entryPtr->flags |= BORDER_NEEDED; + } else if (eventPtr->type == CTK_DESTROY_EVENT) { + if (entryPtr->tkwin != NULL) { + entryPtr->tkwin = NULL; + Tcl_DeleteCommand(entryPtr->interp, + Tcl_GetCommandName(entryPtr->interp, entryPtr->widgetCmd)); + } + if (entryPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayEntry, (ClientData) entryPtr); + } + Tk_EventuallyFree((ClientData) entryPtr, DestroyEntry); + } else if (eventPtr->type == CTK_MAP_EVENT) { + Tk_Preserve((ClientData) entryPtr); + entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); + EventuallyRedraw(entryPtr); + Tk_Release((ClientData) entryPtr); + } else if (eventPtr->type == CTK_FOCUS_EVENT) { + entryPtr->flags |= GOT_FOCUS; + EventuallyRedraw(entryPtr); + } else if (eventPtr->type == CTK_UNFOCUS_EVENT) { + entryPtr->flags &= ~GOT_FOCUS; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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); + } +} + +/* + *-------------------------------------------------------------- + * + * GetEntryIndex -- + * + * Parse an index into an entry and return either its value + * or an error. + * + * Results: + * A standard Tcl result. If all went well, then *indexPtr is + * filled in with the index (into entryPtr) corresponding to + * string. The index value is guaranteed to lie between 0 and + * the number of characters in the string, inclusive. If an + * error occurs then an error message is left in interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +GetEntryIndex(interp, entryPtr, string, indexPtr) + Tcl_Interp *interp; /* For error messages. */ + Entry *entryPtr; /* Entry for which the index is being + * specified. */ + char *string; /* Specifies character in entryPtr. */ + int *indexPtr; /* Where to store converted index. */ +{ + size_t length; + + length = strlen(string); + + if (string[0] == 'a') { + if (strncmp(string, "anchor", length) == 0) { + *indexPtr = entryPtr->selectAnchor; + } else { + badIndex: + + /* + * Some of the paths here leave messages in interp->result, + * so we have to clear it out before storing our own message. + */ + + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + Tcl_AppendResult(interp, "bad entry index \"", string, + "\"", (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; + } else { + goto badIndex; + } + } else if (string[0] == 's') { + if (entryPtr->selectFirst == -1) { + Tcl_SetResult(interp,"selection isn't in entry",TCL_STATIC); + return TCL_ERROR; + } + if (length < 5) { + goto badIndex; + } + if (strncmp(string, "sel.first", length) == 0) { + *indexPtr = entryPtr->selectFirst; + } else if (strncmp(string, "sel.last", length) == 0) { + *indexPtr = entryPtr->selectLast; + } else { + goto badIndex; + } + } else if (string[0] == '@') { + int x, dummy, roundUp; + + if (Tcl_GetInt(interp, string+1, &x) != TCL_OK) { + goto badIndex; + } + if (x < entryPtr->borderWidth) { + x = entryPtr->borderWidth; + } + roundUp = 0; + if (x >= (Tk_Width(entryPtr->tkwin) - entryPtr->borderWidth)) { + x = Tk_Width(entryPtr->tkwin) - entryPtr->borderWidth - 1; + roundUp = 1; + } + if (entryPtr->numChars == 0) { + *indexPtr = 0; + } else { + *indexPtr = TkMeasureChars( + (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) { + goto badIndex; + } + if (*indexPtr < 0){ + *indexPtr = 0; + } else if (*indexPtr > entryPtr->numChars) { + *indexPtr = entryPtr->numChars; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * EntrySelectTo -- + * + * 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 +EntrySelectTo(entryPtr, index) + register Entry *entryPtr; /* Information about widget. */ + int index; /* Index of element that is to + * become the "other" end of the + * selection. */ +{ + int newFirst, newLast; + + /* + * Pick new starting and ending points for the selection. + */ + + 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); +} + +/* + *---------------------------------------------------------------------- + * + * EventuallyRedraw -- + * + * Ensure that an entry is eventually redrawn on the display. + * + * Results: + * None. + * + * Side effects: + * Information gets redisplayed. Right now we don't do selective + * redisplays: the whole window will be redrawn. This doesn't + * seem to hurt performance noticeably, but if it does then this + * could be changed. + * + *---------------------------------------------------------------------- + */ + +static void +EventuallyRedraw(entryPtr) + register Entry *entryPtr; /* Information about widget. */ +{ + if ((entryPtr->tkwin == NULL) || !Tk_IsMapped(entryPtr->tkwin)) { + return; + } + + /* + * Right now we don't do selective redisplays: the whole window + * will be redrawn. This doesn't seem to hurt performance noticeably, + * but if it does then this could be changed. + */ + + if (!(entryPtr->flags & REDRAW_PENDING)) { + entryPtr->flags |= REDRAW_PENDING; + 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( + displayString + entryPtr->leftIndex, + entryPtr->numChars - entryPtr->leftIndex, entryPtr->borderWidth, + Tk_Width(entryPtr->tkwin) - entryPtr->borderWidth, entryPtr->borderWidth, + TK_AT_LEAST_ONE|TK_NEWLINES_NOT_SPECIAL, &endX); + *firstPtr = ((double) entryPtr->leftIndex)/entryPtr->numChars; + *lastPtr = ((double) (entryPtr->leftIndex + charsInWindow)) + /entryPtr->numChars; + } +} + +/* + *---------------------------------------------------------------------- + * + * EntryUpdateScrollbar -- + * + * This procedure is invoked whenever information has changed in + * an entry in a way that would invalidate a scrollbar display. + * If there is an associated scrollbar, then this procedure updates + * it by invoking a Tcl command. + * + * Results: + * None. + * + * Side effects: + * A Tcl command is invoked, and an additional command may be + * invoked to process errors in the command. + * + *---------------------------------------------------------------------- + */ + +static void +EntryUpdateScrollbar(entryPtr) + Entry *entryPtr; /* Information about widget. */ +{ + char args[100]; + int code; + double first, last; + + if (entryPtr->scrollCmd == NULL) { + return; + } + + EntryVisibleRange(entryPtr, &first, &last); + sprintf(args, " %g %g", first, last); + code = Tcl_VarEval(entryPtr->interp, entryPtr->scrollCmd, args, + (char *) NULL); + if (code != TCL_OK) { + Tcl_AddErrorInfo(entryPtr->interp, + "\n (horizontal scrolling command executed by entry)"); + Tcl_BackgroundError(entryPtr->interp); + } + Tcl_SetResult(entryPtr->interp, (char *) NULL, TCL_STATIC); +} + +/* + *-------------------------------------------------------------- + * + * EntryTextVarProc -- + * + * This procedure is invoked when someone changes the variable + * whose contents are to be displayed in an entry. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The text displayed in the entry will change to match the + * variable. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +EntryTextVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about button. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Not used. */ + char *name2; /* Not used. */ + int flags; /* Information about what happened. */ +{ + register Entry *entryPtr = (Entry *) clientData; + char *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_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); + } + return (char *) NULL; + } + + /* + * Update the entry's text with the value of the variable, unless + * the entry already has that value (this happens when the variable + * changes value because we changed it because someone typed in + * the entry). + */ + + value = Tcl_GetVar(interp, entryPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + if (strcmp(value, entryPtr->string) != 0) { + EntrySetValue(entryPtr, value); + } + return (char *) NULL; +} ADDED tkFocus.c Index: tkFocus.c ================================================================== --- tkFocus.c +++ tkFocus.c @@ -0,0 +1,314 @@ +/* + * tkFocus.c (CTk) -- + * + * 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. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * Hash table mapping top-level windows to their local focus (a descendant + * window). Both key and values are window pointers. There is an + * entry for every top-level window that has ever recieved the focus. + */ + +static Tcl_HashTable focusTable; + +/* + * Has files static data been initialized? + */ + +static int initialized = 0; + + +/* + *-------------------------------------------------------------- + * + * 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; + char c; + size_t length; + Tcl_HashEntry *hPtr; + + /* + * If invoked with no arguments, just return the current focus window. + */ + + if (argc == 1) { + focusWinPtr = TkGetFocus(winPtr); + if (focusWinPtr != NULL) { + Tcl_SetResult(interp,focusWinPtr->pathName,TCL_VOLATILE); + } + 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)) { + CtkSetFocus(newPtr); + } + 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) { + Tcl_SetResult(interp,newPtr->pathName,TCL_VOLATILE); + } + } 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[1], tkwin); + if (newPtr == NULL) { + return TCL_ERROR; + } + CtkSetFocus(newPtr); + } 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; + } + topLevelPtr = Ctk_TopLevel(newPtr); + hPtr = Tcl_FindHashEntry(&focusTable, (char *) topLevelPtr); + if (hPtr && (newPtr = (TkWindow *) Tcl_GetHashValue(hPtr))) { + Tcl_SetResult(interp,topLevelPtr->pathName,TCL_VOLATILE); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be -displayof, -force, or -lastfor", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CtkSetFocus -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +void +CtkSetFocus(winPtr) + TkWindow *winPtr; +{ + TkWindow *focusPtr = winPtr->dispPtr->focusPtr; + Ctk_Event event; + Tcl_HashEntry *hPtr; + int new; + + if (!initialized) { + Tcl_InitHashTable(&focusTable, TCL_ONE_WORD_KEYS); + initialized = 1; + } + if (winPtr == (TkWindow *)NULL || (winPtr->flags & TK_ALREADY_DEAD)) { + panic("Attempt to set focus to null/dead window"); + } + + if (Tk_IsTopLevel(winPtr)) { + /* + * Window is a top-level. + * Change focus destination to local focus of top-level. + */ + hPtr = Tcl_FindHashEntry(&focusTable, (char *) winPtr); + if (hPtr && Tcl_GetHashValue(hPtr)) { + winPtr = (TkWindow *) Tcl_GetHashValue(hPtr); + } + } else { + /* + * Set local focus of winPtr's top-level to winPtr. + */ + hPtr = Tcl_CreateHashEntry(&focusTable, (char *) Ctk_TopLevel(winPtr), + &new); + Tcl_SetHashValue(hPtr, (ClientData) winPtr); + } + + if (winPtr != focusPtr) { + if (focusPtr && !(focusPtr->flags & TK_ALREADY_DEAD)) { + event.type = CTK_UNFOCUS_EVENT; + event.window = focusPtr; + Tk_HandleEvent(&event); + } + winPtr->dispPtr->focusPtr = winPtr; + Ctk_SetCursor(winPtr, 0, 0); + event.type = CTK_FOCUS_EVENT; + event.window = winPtr; + Tk_HandleEvent(&event); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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; +{ + return winPtr->dispPtr->focusPtr; +} + +/* + *---------------------------------------------------------------------- + * + * 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: + * The input focus for the window's display may change. + * + *---------------------------------------------------------------------- + */ + +void +TkFocusDeadWindow(winPtr) + TkWindow *winPtr; +{ + if (initialized) { + /* + * Remove window from focusTable. Delete hash entry if winPtr + * is a top-level. Clear hash entry value if winPtr has a local + * focus. + */ + Tcl_HashEntry *hPtr; + TkWindow *focusPtr; + + if (Tk_IsTopLevel(winPtr)) { + hPtr = Tcl_FindHashEntry(&focusTable, (char *) winPtr); + if (hPtr) Tcl_DeleteHashEntry(hPtr); + } else { + hPtr = Tcl_FindHashEntry(&focusTable, + (char *) Ctk_TopLevel(winPtr)); + if (hPtr && winPtr == (TkWindow *) Tcl_GetHashValue(hPtr)) { + Tcl_SetHashValue(hPtr, (ClientData) (TkWindow *) NULL); + } + } + } + + if (winPtr == winPtr->dispPtr->focusPtr) { + /* + * This window has the focus, try to pass focus first to + * window's top-level, then to topmost visible top-level, + * then to main top-level. If none of these exist + * then give up - the application will have exited + * before any more key events will be processed). + */ + TkWindow *newFocusPtr = Ctk_TopLevel(winPtr); + + if (!(newFocusPtr->flags & TK_ALREADY_DEAD)) goto gotfocus; + for (newFocusPtr = Ctk_TopChild(winPtr->dispPtr->rootPtr); + newFocusPtr != NULL; + newFocusPtr = Ctk_PriorSibling(newFocusPtr)) { + if (!(newFocusPtr->flags & TK_ALREADY_DEAD) + && (newFocusPtr->flags & CTK_DISPLAYED)) { + goto gotfocus; + } + } + newFocusPtr = Ctk_BottomChild(winPtr->dispPtr->rootPtr); + if (newFocusPtr && !(newFocusPtr->flags & TK_ALREADY_DEAD)) { +gotfocus: + CtkSetFocus(newFocusPtr); + } + } +} ADDED tkFont.c Index: tkFont.c ================================================================== --- tkFont.c +++ tkFont.c @@ -0,0 +1,422 @@ +/* + * tkFont.c (CTk) -- + * + * CTk does not have fonts, but Tk's utility procedures + * for measuring and displaying text are provided. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * Characters used when displaying control sequences. + */ + +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 +}; + +/* + * Width of tabs, in characters. + */ + +#define TAB_WIDTH 8 + + +/* + *-------------------------------------------------------------- + * + * TkMeasureChars -- + * + * Measure the number of characters from a string that + * will fit in a given horizontal span. The measurement + * is done under the assumption that TkDisplayChars will + * be used to actually display the characters. + * + * Results: + * The return value is the number of characters from source + * that fit in the span given by startX and maxX. *nextXPtr + * is filled in with the x-coordinate at which the first + * character that didn't fit would be drawn, if it were to + * be drawn. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkMeasureChars(source, maxChars, startX, maxX, tabOrigin, flags, nextXPtr) + char *source; /* Characters to be displayed. Need not + * be NULL-terminated. */ + int maxChars; /* Maximum # of characters to consider from + * source. */ + int startX; /* X-postion at which first character will + * 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 + * possible. TK_AT_LEAST_ONE means always + * return a value of at least one, even + * if the character doesn't fit. + * TK_PARTIAL_OK means it's OK to display only + * 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. + * TK_IGNORE_TABS means give all tabs zero + * width. */ + int *nextXPtr; /* Return x-position of terminating + * character here. */ +{ + register char *p; /* Current character. */ + register int c; + char *term; /* Pointer to most recent character that + * may legally be a terminating character. */ + int termX; /* X-position just after term. */ + int curX; /* X-position corresponding to p. */ + int newX; /* X-position corresponding to p+1. */ + int rem; + + /* + * Scan the input string one character at a time, until a character + * is found that crosses maxX. + */ + + newX = curX = startX; + termX = 0; /* Not needed, but eliminates compiler warning. */ + term = source; + for (p = source, c = *p & 0xff; maxChars > 0; p++, maxChars--) { + if (isprint(UCHAR(c))) { + newX++; + } else if (c == '\t') { + if (!(flags & TK_IGNORE_TABS)) { + newX += TAB_WIDTH; + rem = (newX - tabOrigin) % TAB_WIDTH; + if (rem < 0) { + rem += TAB_WIDTH; + } + newX -= rem; + } + } else { + if (c == '\n' && !(flags & TK_NEWLINES_NOT_SPECIAL)) { + break; + } + if (c >= 0 && c < sizeof(mapChars) && mapChars[c]) { + newX += 2; + } else { + newX += 4; + } + } + + if (newX > maxX) { + break; + } + if (maxChars > 1) { + c = p[1] & 0xff; + } else { + c = 0; + } + if (isspace(UCHAR(c)) || (c == 0)) { + term = p+1; + termX = newX; + } + curX = newX; + } + + /* + * P points to the first character that doesn't fit in the desired + * span. Use the flags to figure out what to return. + */ + + if ((flags & TK_PARTIAL_OK) && (curX < maxX)) { + curX = newX; + p++; + } + if ((flags & TK_AT_LEAST_ONE) && (term == source) && (maxChars > 0) + && !isspace(UCHAR(*term))) { + term = p; + termX = curX; + if (term == source) { + term++; + termX = newX; + } + } else if ((maxChars == 0) || !(flags & TK_WHOLE_WORDS)) { + term = p; + termX = curX; + } + *nextXPtr = termX; + return term-source; +} + +/* + *-------------------------------------------------------------- + * + * CtkDisplayChars -- + * + * Draw a string of characters on the screen, converting + * tabs to the right number of spaces and control characters + * to sequences of the form "\xhh" where hh are two hex + * digits. + * + * Results: + * None. + * + * Side effects: + * Information gets drawn on the screen. + * + *-------------------------------------------------------------- + */ + +void +TkDisplayChars(win, style, string, numChars, x, y, tabOrigin, flags) + Tk_Window win; /* Window in which to draw. */ + Ctk_Style style; /* Display characters using this style. */ + char *string; /* Characters to be displayed. */ + 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 and TK_IGNORE_TABS + * are supported right now. See + * TkMeasureChars for information about it. */ +{ + register char *p; /* Current character being scanned. */ + register int c; + char *start; /* First character waiting to be displayed. */ + int startX; /* X-coordinate corresponding to start. */ + int curX; /* X-coordinate corresponding to p. */ + char replace[10]; + int rem; + + /* + * Scan the string one character at a time. Display control + * characters immediately, but delay displaying normal characters + * in order to pass many characters to the server all together. + */ + + startX = curX = x; + start = string; + for (p = string; numChars > 0; numChars--, p++) { + c = *p & 0xff; + if (isprint(UCHAR(c))) { + curX++; + continue; + } + if (p != start) { + Ctk_DrawString(win, startX, y, style, start, p - start); + startX = curX; + } + if (c == '\t') { + if (!(flags & TK_IGNORE_TABS)) { + curX += TAB_WIDTH; + rem = (curX - tabOrigin) % TAB_WIDTH; + if (rem < 0) { + rem += TAB_WIDTH; + } + curX -= rem; + Ctk_FillRect(win, startX, y, startX+1, y+1, style, ' '); + } + } else { + if (c == '\n' && !(flags & TK_NEWLINES_NOT_SPECIAL)) { + y++; + curX = x; + } else { + if (c >= 0 && c < sizeof(mapChars) && mapChars[c]) { + replace[0] = '\\'; + replace[1] = mapChars[c]; + Ctk_DrawString(win, startX, y, style, replace, 2); + curX += 2; + } else { + replace[0] = '\\'; + replace[1] = 'x'; + replace[2] = hexChars[(c >> 4) & 0xf]; + replace[3] = hexChars[c & 0xf]; + Ctk_DrawString(win, startX, y, style, replace, 4); + curX += 4; + } + } + } + startX = curX; + start = p+1; + } + + /* + * At the very end, there may be one last batch of normal characters + * to display. + */ + + if (p != start) { + Ctk_DrawString(win, startX, y, style, start, p - start); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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(string, numChars, wrapLength, widthPtr, heightPtr) + 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(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; +} + +/* + *---------------------------------------------------------------------- + * + * 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 window with the given style etc. + * + *---------------------------------------------------------------------- + */ + +void +TkDisplayText(win, style, string, numChars, x, y, + length, justify, underline) + Tk_Window win; /* Window in which to draw the text. */ + Ctk_Style style; /* Style in which to draw characters + * (except for underlined char). */ + 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. */ +{ + char *p; + int charsThisLine, lengthThisLine, xThisLine; + int underlineOffset; + + /* + * 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. + */ + + for (p = string; numChars > 0; ) { + charsThisLine = TkMeasureChars(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(win, style, p, charsThisLine, + xThisLine, y, xThisLine, 0); + if ((underline >= 0) && (underline < charsThisLine)) { + (void) TkMeasureChars(p, underline, 0, length, 0, + TK_WHOLE_WORDS|TK_AT_LEAST_ONE, &underlineOffset); + TkDisplayChars(win, CTK_UNDERLINE_STYLE, p+underline, 1, + xThisLine+underlineOffset, y, xThisLine, 0); + } + p += charsThisLine; + numChars -= charsThisLine; + underline -= charsThisLine; + y++; + + /* + * If the character that didn't fit was a space character, skip it. + */ + + if (isspace(UCHAR(*p))) { + p++; + numChars--; + underline--; + } + } +} ADDED tkFrame.c Index: tkFrame.c ================================================================== --- tkFrame.c +++ tkFrame.c @@ -0,0 +1,597 @@ +/* + * tkFrame.c (CTk) -- + * + * 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. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#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. */ + 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. */ + int borderWidth; /* Width of 3-D border (if any). */ + 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 *title; /* Title of window. Only valid for toplevels + * Malloc-ed, may be null. */ + 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. + * CLEAR_NEEDED; Need to clear the window when redrawing. + */ + +#define REDRAW_PENDING 1 +#define CLEAR_NEEDED 2 + +/* + * 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_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, BOTH}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_FRAME_BORDER_WIDTH, Tk_Offset(Frame, borderWidth), FRAME}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_TOPLEVEL_BORDER_WIDTH, Tk_Offset(Frame, borderWidth), TOPLEVEL}, + {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_PIXELS, "-height", "height", "Height", + DEF_FRAME_HEIGHT, Tk_Offset(Frame, height), 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, "-title", "title", "Title", + DEF_TOPLEVEL_TITLE, Tk_Offset(Frame, title), + TOPLEVEL|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_((ClientData clientData)); +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)); + +/* + *-------------------------------------------------------------- + * + * 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; + Frame *framePtr; + Tk_Window new = NULL; + char *className, *screenName, *arg; + int i, c, length, toplevel; + + 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" and "-screen" options. These + * arguments need to be processed specially, before the window + * is configured using the usual Tk mechanisms. + */ + + toplevel = (argv[0][0] == 't'); + className = screenName = NULL; + 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 == 's') && toplevel + && (strncmp(arg, "-screen", strlen(arg)) == 0)) { + screenName = argv[i+1]; + } + } + + /* + * Create the window, and deal with the special options -classname, + * and -screenname. 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; + } + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], screenName); + 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); + + /* + * 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 *) TkInitFrame(interp, new, toplevel, argc-2, argv+2); + if (framePtr == NULL) { + return TCL_ERROR; + } + return TCL_OK; + + error: + if (new != NULL) { + Tk_DestroyWindow(new); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * 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: + * Returns NULL if an error occurred while initializing the + * frame. Otherwise returns a pointer to the frame's widget + * record (for use by Tk_FrameCmd, if it was the caller). + * + * Side effects: + * A widget record gets allocated, handlers get set up, etc.. + * + *---------------------------------------------------------------------- + */ + +char * +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->interp = interp; + framePtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(framePtr->tkwin), FrameWidgetCmd, + (ClientData) framePtr, FrameCmdDeletedProc); + framePtr->className = NULL; + framePtr->mask = (toplevel) ? TOPLEVEL : FRAME; + framePtr->screenName = NULL; + framePtr->borderWidth = 0; + framePtr->width = 0; + framePtr->height = 0; + framePtr->title = NULL; + framePtr->takeFocus = NULL; + framePtr->flags = 0; + Tk_CreateEventHandler(framePtr->tkwin, + CTK_EXPOSE_EVENT_MASK|CTK_DESTROY_EVENT_MASK, + FrameEventProc, (ClientData) framePtr); + if (ConfigureFrame(interp, framePtr, argc, argv, 0) != TCL_OK) { + Tk_DestroyWindow(framePtr->tkwin); + return NULL; + } + + if (toplevel) { + char *placeArgv[9]; + + placeArgv[0] = "place"; + placeArgv[1] = Tk_PathName(framePtr->tkwin); + placeArgv[2] = "-relx"; + placeArgv[3] = "0.5"; + placeArgv[4] = "-rely"; + placeArgv[5] = "0.5"; + placeArgv[6] = "-anchor"; + placeArgv[7] = "center"; + placeArgv[8] = NULL; + if (Tk_PlaceCmd((ClientData) framePtr->tkwin, interp, + 8, placeArgv) != TCL_OK) { + panic("place failed for toplevel: %s: %s", + placeArgv[1], interp->result); + } + } else { + tkwin->fillStyle = CTK_INVISIBLE_STYLE; + } + Tcl_SetResult(interp,Tk_PathName(framePtr->tkwin),TCL_VOLATILE); + return (char *) framePtr; +} + +/* + *-------------------------------------------------------------- + * + * 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; + } + Tk_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: + 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->mask); + 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; + } + + Tk_SetInternalBorder(framePtr->tkwin, framePtr->borderWidth); + 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|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 ((tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + Ctk_DrawBorder(tkwin, CTK_PLAIN_STYLE, framePtr->title); +} + +/* + *-------------------------------------------------------------- + * + * 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 == CTK_EXPOSE_EVENT) { + if ((framePtr->tkwin != NULL) && !(framePtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayFrame, (ClientData) framePtr); + framePtr->flags |= REDRAW_PENDING; + } + } else if (eventPtr->type == CTK_DESTROY_EVENT) { + 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); + } + Tk_EventuallyFree((ClientData) framePtr, DestroyFrame); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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); + } +} ADDED tkGeometry.c Index: tkGeometry.c ================================================================== --- tkGeometry.c +++ tkGeometry.c @@ -0,0 +1,540 @@ +/* + * tkGeometry.c (CTk) -- + * + * 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. + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#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_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, CTK_DESTROY_EVENT_MASK, 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, + CTK_MAP_EVENT_MASK|CTK_DESTROY_EVENT_MASK, + 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 (map) { + if (!Tk_IsMapped(slavePtr->slave) + || (x != Tk_X(slavePtr->slave)) + || (y != Tk_Y(slavePtr->slave)) + || (width != Tk_Width(slavePtr->slave)) + || (height != Tk_Height(slavePtr->slave))) { + Ctk_Map(slavePtr->slave, x, y, x + width, y + height); + } + } else { + Tk_UnmapWindow(slavePtr->slave); + } + break; + } + x += Tk_X(ancestor); + y += Tk_Y(ancestor); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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, CTK_DESTROY_EVENT_MASK, + MaintainSlaveProc, (ClientData) slavePtr); + ckfree((char *) slavePtr); + if (masterPtr->slavePtr == NULL) { + if (masterPtr->ancestor != NULL) { + for (ancestor = master; ; ancestor = Tk_Parent(ancestor)) { + Tk_DeleteEventHandler(ancestor, + CTK_MAP_EVENT_MASK|CTK_DESTROY_EVENT_MASK, + 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 == CTK_MAP_EVENT) + || (eventPtr->type == CTK_UNMAP_EVENT)) { + if (!masterPtr->checkScheduled) { + masterPtr->checkScheduled = 1; + Tcl_DoWhenIdle(MaintainCheckProc, (ClientData) masterPtr); + } + } else if (eventPtr->type == CTK_DESTROY_EVENT) { + /* + * 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 == CTK_DESTROY_EVENT) { + 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 (map) { + if (!Tk_IsMapped(slavePtr->slave) + || (x != Tk_X(slavePtr->slave)) + || (y != Tk_Y(slavePtr->slave))) { + Ctk_Map(slavePtr->slave, x, y, + x + Tk_Width(slavePtr->slave), + y + Tk_Height(slavePtr->slave)); + } + } else { + Tk_UnmapWindow(slavePtr->slave); + } + break; + } + x += Tk_X(ancestor); + y += Tk_Y(ancestor); + } + } +} ADDED tkGet.c Index: tkGet.c ================================================================== --- tkGet.c +++ tkGet.c @@ -0,0 +1,433 @@ +/* + * tkGet.c (CTk) -- + * + * This file contains a number of "Tk_GetXXX" procedures, which + * parse text strings into useful forms for Tk. This file has + * the simpler procedures, like Tk_GetDirection and Tk_GetUid. + * The more complex procedures like Tk_GetColor are in separate + * files. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * Used by Tk_GetPixel() and Tk_GetScreenMM() to convert + * absolute distances to display pixels. + * Assume that all terminals screens are ~10 inches wide. + * Even if this is the correct width, can have strange + * behavior with vertical distances because aspect ratios + * are not 1:1 (nowhere near). + */ +#define WidthMMOfScreen(dispPtr) 254 + +/* + * The hash table below is used to keep track of all the Tk_Uids created + * so far. + */ + +static Tcl_HashTable uidTable; +static int initialized = 0; + +/* + *-------------------------------------------------------------- + * + * Tk_GetAnchor -- + * + * Given a string, return the corresponding Tk_Anchor. + * + * Results: + * The return value is a standard Tcl return result. If + * TCL_OK is returned, then everything went well and the + * position is stored at *anchorPtr; otherwise TCL_ERROR + * is returned and an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetAnchor(interp, string, anchorPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + char *string; /* String describing a direction. */ + Tk_Anchor *anchorPtr; /* Where to store Tk_Anchor corresponding + * to string. */ +{ + switch (string[0]) { + case 'n': + if (string[1] == 0) { + *anchorPtr = TK_ANCHOR_N; + return TCL_OK; + } else if ((string[1] == 'e') && (string[2] == 0)) { + *anchorPtr = TK_ANCHOR_NE; + return TCL_OK; + } else if ((string[1] == 'w') && (string[2] == 0)) { + *anchorPtr = TK_ANCHOR_NW; + return TCL_OK; + } + goto error; + case 's': + if (string[1] == 0) { + *anchorPtr = TK_ANCHOR_S; + return TCL_OK; + } else if ((string[1] == 'e') && (string[2] == 0)) { + *anchorPtr = TK_ANCHOR_SE; + return TCL_OK; + } else if ((string[1] == 'w') && (string[2] == 0)) { + *anchorPtr = TK_ANCHOR_SW; + return TCL_OK; + } else { + goto error; + } + case 'e': + if (string[1] == 0) { + *anchorPtr = TK_ANCHOR_E; + return TCL_OK; + } + goto error; + case 'w': + if (string[1] == 0) { + *anchorPtr = TK_ANCHOR_W; + return TCL_OK; + } + goto error; + case 'c': + if (strncmp(string, "center", strlen(string)) == 0) { + *anchorPtr = TK_ANCHOR_CENTER; + return TCL_OK; + } + goto error; + } + + error: + Tcl_AppendResult(interp, "bad anchor position \"", string, + "\": must be n, ne, e, se, s, sw, w, nw, or center", + (char *) NULL); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfAnchor -- + * + * Given a Tk_Anchor, return the string that corresponds + * to it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfAnchor(anchor) + Tk_Anchor anchor; /* Anchor for which identifying string + * is desired. */ +{ + switch (anchor) { + case TK_ANCHOR_N: return "n"; + case TK_ANCHOR_NE: return "ne"; + case TK_ANCHOR_E: return "e"; + case TK_ANCHOR_SE: return "se"; + case TK_ANCHOR_S: return "s"; + case TK_ANCHOR_SW: return "sw"; + case TK_ANCHOR_W: return "w"; + case TK_ANCHOR_NW: return "nw"; + case TK_ANCHOR_CENTER: return "center"; + } + return "unknown anchor position"; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetJustify -- + * + * Given a string, return the corresponding Tk_Justify. + * + * Results: + * The return value is a standard Tcl return result. If + * TCL_OK is returned, then everything went well and the + * justification is stored at *justifyPtr; otherwise + * TCL_ERROR is returned and an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetJustify(interp, string, justifyPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + char *string; /* String describing a justification style. */ + Tk_Justify *justifyPtr; /* Where to store Tk_Justify corresponding + * to string. */ +{ + int c; + size_t length; + + c = string[0]; + length = strlen(string); + + if ((c == 'l') && (strncmp(string, "left", length) == 0)) { + *justifyPtr = TK_JUSTIFY_LEFT; + return TCL_OK; + } + if ((c == 'r') && (strncmp(string, "right", length) == 0)) { + *justifyPtr = TK_JUSTIFY_RIGHT; + return TCL_OK; + } + if ((c == 'c') && (strncmp(string, "center", length) == 0)) { + *justifyPtr = TK_JUSTIFY_CENTER; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad justification \"", string, + "\": must be left, right, or center", + (char *) NULL); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfJustify -- + * + * Given a Tk_Justify, return the string that corresponds + * to it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfJustify(justify) + Tk_Justify justify; /* Justification style for which + * identifying string is desired. */ +{ + switch (justify) { + case TK_JUSTIFY_LEFT: return "left"; + case TK_JUSTIFY_RIGHT: return "right"; + case TK_JUSTIFY_CENTER: return "center"; + } + return "unknown justification style"; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetUid -- + * + * Given a string, this procedure returns a unique identifier + * for the string. + * + * Results: + * This procedure returns a Tk_Uid corresponding to the "string" + * argument. The Tk_Uid has a string value identical to string + * (strcmp will return 0), but it's guaranteed that any other + * calls to this procedure with a string equal to "string" will + * return exactly the same result (i.e. can compare Tk_Uid + * *values* directly, without having to call strcmp on what they + * point to). + * + * Side effects: + * New information may be entered into the identifier table. + * + *---------------------------------------------------------------------- + */ + +Tk_Uid +Tk_GetUid(string) + char *string; /* String to convert. */ +{ + int dummy; + + if (!initialized) { + Tcl_InitHashTable(&uidTable, TCL_STRING_KEYS); + initialized = 1; + } + return (Tk_Uid) Tcl_GetHashKey(&uidTable, + Tcl_CreateHashEntry(&uidTable, string, &dummy)); +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetScreenMM -- + * + * Given a string, returns the number of screen millimeters + * 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 + * screen distance is stored at *doublePtr; otherwise + * TCL_ERROR is returned and an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetScreenMM(interp, tkwin, string, doublePtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + Tk_Window tkwin; /* Window whose screen determines conversion + * from centimeters and other absolute + * units. */ + char *string; /* String describing a screen distance. */ + double *doublePtr; /* Place to store converted result. */ +{ + char *end; + double d; + + d = strtod(string, &end); + if (end == string) { + error: + Tcl_AppendResult(interp, "bad screen distance \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + switch (*end) { + case 0: + d /= Ctk_DisplayWidth(Tk_Display(tkwin)); + d *= WidthMMOfScreen(Tk_Display(tkwin)); + break; + case 'c': + d *= 10; + end++; + break; + case 'i': + d *= 25.4; + end++; + break; + case 'm': + end++; + break; + case 'p': + d *= 25.4/72.0; + end++; + break; + default: + goto error; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto error; + } + *doublePtr = d; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetPixels -- + * + * Given a string, returns the number of pixels 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 + * rounded pixel distance is stored at *intPtr; otherwise + * TCL_ERROR is returned and an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetPixels(interp, tkwin, string, intPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + Tk_Window tkwin; /* Window whose screen determines conversion + * from centimeters and other absolute + * units. */ + char *string; /* String describing a justification style. */ + int *intPtr; /* Place to store converted result. */ +{ + char *end; + double d; + + d = strtod(string, &end); + if (end == string) { + error: + Tcl_AppendResult(interp, "bad screen distance \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + switch (*end) { + case 0: + break; + case 'c': + d *= 10*Ctk_DisplayWidth(Tk_Display(tkwin)); + d /= WidthMMOfScreen(Tk_Display(tkwin)); + end++; + break; + case 'i': + d *= 25.4*Ctk_DisplayWidth(Tk_Display(tkwin)); + d /= WidthMMOfScreen(Tk_Display(tkwin)); + end++; + break; + case 'm': + d *= Ctk_DisplayWidth(Tk_Display(tkwin)); + d /= WidthMMOfScreen(Tk_Display(tkwin)); + end++; + break; + case 'p': + d *= (25.4/72.0)*Ctk_DisplayWidth(Tk_Display(tkwin)); + d /= WidthMMOfScreen(Tk_Display(tkwin)); + end++; + break; + default: + goto error; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto error; + } + if (d < 0) { + *intPtr = (int) (d - 0.5); + } else { + *intPtr = (int) (d + 0.5); + } + return TCL_OK; +} ADDED tkInt.h Index: tkInt.h ================================================================== --- tkInt.h +++ tkInt.h @@ -0,0 +1,256 @@ +/* + * tkInt.h (CTk) -- + * + * 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 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Header: /usrs/andrewm/work/RCS/ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#ifndef _TKINT +#define _TKINT + +#ifndef _TK +#include "tk.h" +#endif +#include + +/* + * One of the following structures is maintained for each display + * containing a window managed by Tk: + */ + +struct TkDisplay { + /* + * Maintained by ctkDisplay.c + */ + char *name; /* Name of display device. Malloc-ed. */ + char *type; /* Device type. Malloc-ed. */ + ClientData display; /* Curses's info about display. */ + Tcl_Channel chan; /* Input channel for the device */ + int fd; /* Input file descriptor for device. */ + FILE *inPtr; /* Input file pointer for device. */ + TkWindow *cursorPtr; /* Window to display cursor in. */ + int cursorX, cursorY; /* Position in `cursWinPtr' to display + * cursor. */ + + /* + * Maintained by tkWindow.c + */ + int numWindows; /* Windows currently existing in display + * (including root). */ + TkWindow *rootPtr; /* Root window of display. */ + TkWindow *focusPtr; /* Window that has the keyboard focus. */ + struct TkDisplay *nextPtr; /* Next in list of all displays. */ +}; + +/* + * One of the following structures exists for each event handler + * created by calling Tk_CreateEventHandler. This information + * is used by tkEvent.c only. + */ + +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). */ +}; + +/* + * 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. + */ + +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. */ + TkDisplay *curDispPtr; /* Display for last binding command invoked + * in this application; used only by + * tkBind.c. */ + int bindingDepth; /* Number of active instances of Tk_BindEvent + * in this application. Used only by + * tkBind.c. */ + 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. */ +}; + +/* + * 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 + +/* + * Location of library directory containing Tk scripts. This value + * is put in the $tkLibrary variable for each application. + */ + +#ifndef CTK_LIBRARY +#define CTK_LIBRARY "/usr/local/lib/ctk" +#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)) + +/* + * Miscellaneous variables shared among Tk modules but not exported + * to the outside world: + */ + +extern Tk_Uid tkActiveUid; +extern void (*tkDelayedEventProc) _ANSI_ARGS_((void)); +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 void TkBindEventProc _ANSI_ARGS_((TkWindow *winPtr, + XEvent *eventPtr)); +extern void TkComputeTextGeometry _ANSI_ARGS_(( + char *string, + int numChars, int wrapLength, int *widthPtr, + int *heightPtr)); +extern int TkCopyAndGlobalEval _ANSI_ARGS_((Tcl_Interp *interp, + char *script)); +extern Time TkCurrentTime _ANSI_ARGS_((void)); +extern int TkDeadAppCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +extern void TkDisplayChars _ANSI_ARGS_((TkWindow *winPtr, + Ctk_Style style, char *string, + int numChars, int x, int y, int tabOrigin, + int flags)); +extern void TkDisplayText _ANSI_ARGS_((TkWindow *winPtr, + Ctk_Style style, + char *string, int numChars, int x, int y, + int length, Tk_Justify justify, int underline)); +extern void TkEventCleanupProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +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 TkFreeBindingTags _ANSI_ARGS_((TkWindow *winPtr)); +extern TkWindow * TkGetFocus _ANSI_ARGS_((TkWindow *winPtr)); +extern int TkGetInterpNames _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin)); +extern char * TkInitFrame _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int toplevel, int argc, + char *argv[])); +extern int TkMeasureChars _ANSI_ARGS_(( + 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 void TkQueueEvent _ANSI_ARGS_((TkDisplay *dispPtr, + XEvent *eventPtr)); + +extern void TkDeleteMain _ANSI_ARGS_((TkMainInfo *mainPtr)); + +#define CtkIsDisplayed(tkwin) (((tkwin)->flags)& CTK_DISPLAYED) + +typedef void (CtkSpanProc) _ANSI_ARGS_((int left, int right, int y, + ClientData data)); + +#define CtkSpanIsEmpty(left, right) ((left) >= (right)) +#define CtkCopyRect(dr,sr) (memcpy((dr), (sr), sizeof(Ctk_Rect))) +#define CtkMoveRect(rect,x,y) \ + ((rect)->left += (x), (rect)->top += (y), \ + (rect)->right += (x), (rect)->bottom += (y)) +#define CtkSetRect(rect,l,t,r,b) \ + ((rect)->left = (l), (rect)->top = (t), \ + (rect)->right = (r), (rect)->bottom = (b)) + + +EXTERN int CtkDisplayInit _ANSI_ARGS_((Tcl_Interp *interp, + TkDisplay *dispPtr, char *displayName)); +EXTERN void CtkDisplayEnd _ANSI_ARGS_((TkDisplay *dispPtr)); +EXTERN void CtkDisplayBell _ANSI_ARGS_((TkDisplay *dispPtr)); + +EXTERN void CtkSetFocus _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void Ctk_Forget _ANSI_ARGS_((Tk_Window tkwin)); + +EXTERN void CtkFillRegion _ANSI_ARGS_((TkDisplay *dispPtr, + CtkRegion *rgn_ptr, Ctk_Style style, int ch)); + +EXTERN void CtkIntersectSpans _ANSI_ARGS_((int *left_ptr, + int *right_ptr, int left2, int right2)); +EXTERN void CtkIntersectRects _ANSI_ARGS_((Ctk_Rect *r1_ptr, + CONST Ctk_Rect *r2_ptr)); +EXTERN CtkRegion * CtkCreateRegion _ANSI_ARGS_((Ctk_Rect *rect)); +EXTERN void CtkDestroyRegion _ANSI_ARGS_((CtkRegion *rgn)); +EXTERN void CtkForEachIntersectingSpan _ANSI_ARGS_(( + CtkSpanProc *func, + ClientData func_data, int left, int right, int y, + CtkRegion *rgn)); +EXTERN void CtkForEachSpan _ANSI_ARGS_((CtkSpanProc *func, + ClientData func_data, CtkRegion *rgn)); +EXTERN CtkRegion * CtkRegionMinusRect _ANSI_ARGS_((CtkRegion *rgn_id, + Ctk_Rect *rect, int want_inter)); +EXTERN void CtkUnionRegions _ANSI_ARGS_((CtkRegion *rgn1, + CtkRegion *rgn2)); +EXTERN void CtkRegionGetRect _ANSI_ARGS_((CtkRegion *rgn, + Ctk_Rect *rect_ptr)); +EXTERN int CtkPointInRegion _ANSI_ARGS_((int x, int y, + CtkRegion *rgn)); + +#endif /* _TKINT */ ADDED tkListbox.c Index: tkListbox.c ================================================================== --- tkListbox.c +++ tkListbox.c @@ -0,0 +1,1698 @@ +/* + * tkListbox.c (CTk) -- + * + * This module implements listbox widgets for the Tk + * toolkit. A listbox displays a collection of strings, + * one per line, and provides scrolling and selection. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "default.h" +#include "tkInt.h" + +/* + * One record of the following type is kept for each element + * associated with a listbox widget: + */ + +typedef struct Element { + int textLength; /* # non-NULL characters in text. */ + 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- + * terminated. The actual space allocated + * here will be as large as needed (> 4, + * most likely). Must be the last field + * of the record. */ +} Element; + +#define ElementSize(stringLength) \ + ((unsigned) (sizeof(Element) - 3 + stringLength)) + +/* + * A data structure of the following type is kept for each listbox + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the listbox. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + 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 *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: + */ + + int borderWidth; /* Width of 3-D border around window. */ + int width; /* Desired width of window, in characters. */ + int height; /* Desired height of window, in lines. */ + int topIndex; /* Index of top-most element visible in + * window. */ + int numLines; /* Actual number of lines (elements) that + * currently fit in window. */ + + /* + * Information to support horizontal scrolling: + */ + + int maxWidth; /* Width (in pixels) of widest string in + * listbox. */ + int xOffset; /* The left edge of each string in the + * listbox is offset to the left by this + * many pixels (0 means no offset, positive + * means there is an offset). */ + + /* + * Information about what's selected or active, if any. + */ + + 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 active; /* Index of "active" element (the one that + * has been selected by keyboard traversal). + * -1 means none. */ + + /* + * Miscellaneous 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 *yScrollCmd; /* Command prefix for communicating with + * vertical scrollbar. NULL means no command + * to issue. Malloc'ed. */ + char *xScrollCmd; /* Command prefix for communicating with + * horizontal scrollbar. NULL means no command + * to issue. Malloc'ed. */ + int flags; /* Various flag bits: see below for + * definitions. */ +} Listbox; + +/* + * Flag bits for listboxes: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * UPDATE_V_SCROLLBAR: Non-zero means vertical scrollbar needs + * 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. + * BORDER_NEEDED: Non-zero means 3-D border must be redrawn + * around window during redisplay. Normally + * only elements needs to be redrawn. + */ + +#define REDRAW_PENDING 1 +#define UPDATE_V_SCROLLBAR 2 +#define UPDATE_H_SCROLLBAR 4 +#define GOT_FOCUS 8 +#define BORDER_NEEDED 16 + +/* + * Information used for argv parsing: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_LISTBOX_BORDER_WIDTH, Tk_Offset(Listbox, borderWidth), 0}, + {TK_CONFIG_INT, "-height", "height", "Height", + DEF_LISTBOX_HEIGHT, Tk_Offset(Listbox, height), 0}, + {TK_CONFIG_UID, "-selectmode", "selectMode", "SelectMode", + DEF_LISTBOX_SELECT_MODE, Tk_Offset(Listbox, selectMode), 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}, + {TK_CONFIG_STRING, "-yscrollcommand", "yScrollCommand", "ScrollCommand", + DEF_LISTBOX_SCROLL_COMMAND, Tk_Offset(Listbox, yScrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Width of element indicator in characters. + */ + +#define INDICATOR_WIDTH 0 + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void ChangeListboxOffset _ANSI_ARGS_((Listbox *listPtr, + int offset)); +static void ChangeListboxView _ANSI_ARGS_((Listbox *listPtr, + int index)); +static int ConfigureListbox _ANSI_ARGS_((Tcl_Interp *interp, + Listbox *listPtr, int argc, char **argv, + int flags)); +static void DeleteEls _ANSI_ARGS_((Listbox *listPtr, int first, + int last)); +static void DestroyListbox _ANSI_ARGS_((ClientData clientData)); +static void DisplayListbox _ANSI_ARGS_((ClientData clientData)); +static int GetListboxIndex _ANSI_ARGS_((Tcl_Interp *interp, + Listbox *listPtr, char *string, int numElsOK, + int *indexPtr)); +static void InsertEls _ANSI_ARGS_((Listbox *listPtr, int index, + int argc, char **argv)); +static void ListboxCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void ListboxComputeGeometry _ANSI_ARGS_((Listbox *listPtr, + int maxIsStale)); +static void ListboxEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void ListboxRedrawRange _ANSI_ARGS_((Listbox *listPtr, + int first, int last)); +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, + Tcl_Interp *interp, int argc, char **argv)); +static int NearestListboxElement _ANSI_ARGS_((Listbox *listPtr, + int y)); + +/* + *-------------------------------------------------------------- + * + * Tk_ListboxCmd -- + * + * This procedure is invoked to process the "listbox" 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_ListboxCmd(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. */ +{ + register Listbox *listPtr; + Tk_Window new; + Tk_Window tkwin = (Tk_Window) clientData; + + 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 the fields of the structure that won't be initialized + * by ConfigureListbox, or that ConfigureListbox requires to be + * initialized already (e.g. resource pointers). + */ + + listPtr = (Listbox *) ckalloc(sizeof(Listbox)); + listPtr->tkwin = new; + listPtr->interp = interp; + listPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(listPtr->tkwin), ListboxWidgetCmd, + (ClientData) listPtr, ListboxCmdDeletedProc); + listPtr->numElements = 0; + listPtr->firstPtr = NULL; + listPtr->lastPtr = NULL; + listPtr->borderWidth = 0; + listPtr->width = 0; + listPtr->height = 0; + listPtr->topIndex = 0; + listPtr->numLines = 1; + listPtr->maxWidth = 0; + listPtr->xOffset = 0; + listPtr->selectMode = NULL; + listPtr->numSelected = 0; + listPtr->selectAnchor = 0; + listPtr->active = 0; + listPtr->takeFocus = NULL; + listPtr->xScrollCmd = NULL; + listPtr->yScrollCmd = NULL; + listPtr->flags = 0; + + Tk_SetClass(listPtr->tkwin, "Listbox"); + Tk_CreateEventHandler(listPtr->tkwin, + CTK_EXPOSE_EVENT_MASK|CTK_MAP_EVENT_MASK|CTK_DESTROY_EVENT_MASK + |CTK_FOCUS_EVENT_MASK, + ListboxEventProc, (ClientData) listPtr); + if (ConfigureListbox(interp, listPtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + Tcl_SetResult(interp,Tk_PathName(listPtr->tkwin),TCL_VOLATILE); + return TCL_OK; + + error: + Tk_DestroyWindow(listPtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * ListboxWidgetCmd -- + * + * 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 +ListboxWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about listbox widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Listbox *listPtr = (Listbox *) 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; + } + Tk_Preserve((ClientData) listPtr); + c = argv[1][0]; + length = strlen(argv[1]); + 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->numLines))) { + char buffer[60]; + x = listPtr->borderWidth - listPtr->xOffset; + y = index - listPtr->topIndex + listPtr->borderWidth; + sprintf(buffer, "%d %d %d %d", x, y, elPtr->textLength, 1); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } 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, + (char *) listPtr, (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, listPtr->tkwin, configSpecs, + (char *) listPtr, argv[2], 0); + } else { + result = ConfigureListbox(interp, listPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'c') && (strncmp(argv[1], "curselection", length) == 0) + && (length >= 2)) { + int i, count; + char index[20]; + Element *elPtr; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " curselection\"", + (char *) NULL); + goto error; + } + 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; + + if ((argc < 3) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delete firstIndex ?lastIndex?\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 0, &first) != TCL_OK) { + goto error; + } + if (argc == 3) { + last = first; + } else { + if (GetListboxIndex(interp, listPtr, argv[3], 0, &last) != TCL_OK) { + goto error; + } + } + DeleteEls(listPtr, first, last); + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + int first, last, i; + Element *elPtr; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get first ?last?\"", (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 0, &first) != TCL_OK) { + goto error; + } + if ((argc == 4) && (GetListboxIndex(interp, listPtr, argv[3], + 0, &last) != TCL_OK)) { + goto error; + } + for (elPtr = listPtr->firstPtr, i = 0; i < first; + i++, elPtr = elPtr->nextPtr) { + /* Empty loop body. */ + } + if (elPtr != NULL) { + if (argc == 3) { + Tcl_SetResult(interp,elPtr->text,TCL_VOLATILE); + } else { + for ( ; i <= last; i++, elPtr = elPtr->nextPtr) { + Tcl_AppendElement(interp, elPtr->text); + } + } + } + } 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; + } + { + char buffer[20]; + sprintf(buffer, "%d", index); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) + && (length >= 3)) { + int index; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " insert index ?element element ...?\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 1, &index) + != TCL_OK) { + goto error; + } + InsertEls(listPtr, index, argc-3, argv+3); + } else if ((c == 'n') && (strncmp(argv[1], "nearest", length) == 0)) { + int index, y; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " nearest y\"", (char *) NULL); + goto error; + } + if (Tcl_GetInt(interp, argv[2], &y) != TCL_OK) { + goto error; + } + index = NearestListboxElement(listPtr, y); + { + char buffer[20]; + sprintf(buffer, "%d", index); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } else if ((c == 's') && (length >= 2) + && (strncmp(argv[1], "scan", length) == 0)) { + result = Ctk_Unsupported(interp, "listbox scan"); + } 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], " see index\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + diff = listPtr->topIndex-index; + if (diff > 0) { + if (diff <= (listPtr->numLines/3)) { + ChangeListboxView(listPtr, index); + } else { + ChangeListboxView(listPtr, index - (listPtr->numLines-1)/2); + } + } else { + diff = index - (listPtr->topIndex + listPtr->numLines - 1); + if (diff > 0) { + if (diff <= (listPtr->numLines/3)) { + ChangeListboxView(listPtr, listPtr->topIndex + diff); + } else { + ChangeListboxView(listPtr, + index - (listPtr->numLines-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)) { + Tcl_SetResult(interp,"1",TCL_STATIC); + } else { + Tcl_SetResult(interp,"0",TCL_STATIC); + } + } 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; + } + { + char buffer[20]; + sprintf(buffer, "%d", listPtr->numElements); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } 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->borderWidth; + if (argc == 2) { + if (listPtr->maxWidth == 0) { + Tcl_SetResult(interp,"0 1",TCL_STATIC); + } else { + fraction = listPtr->xOffset/((double) listPtr->maxWidth); + fraction2 = (listPtr->xOffset + windowWidth) + /((double) listPtr->maxWidth); + if (fraction2 > 1.0) { + fraction2 = 1.0; + } + { + char buffer[60]; + sprintf(buffer, "%g %g", fraction, fraction2); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } + } else if (argc == 3) { + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + goto error; + } + ChangeListboxOffset(listPtr, index); + } 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; + if (windowUnits > 2) { + offset = listPtr->xOffset + count*(windowUnits-2); + } else { + offset = listPtr->xOffset + count; + } + break; + case TK_SCROLL_UNITS: + offset = listPtr->xOffset + count; + 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) { + Tcl_SetResult(interp,"0 1", TCL_STATIC); + } else { + fraction = listPtr->topIndex/((double) listPtr->numElements); + fraction2 = (listPtr->topIndex+listPtr->numLines) + /((double) listPtr->numElements); + if (fraction2 > 1.0) { + fraction2 = 1.0; + } + { + char buffer[60]; + sprintf(buffer, "%g %g", fraction, fraction2); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } + } 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->numLines > 2) { + index = listPtr->topIndex + + count*(listPtr->numLines-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 activate, bbox, cget, configure, ", + "curselection, delete, get, index, insert, nearest, ", + "scan, see, selection, size, ", + "xview, or yview", (char *) NULL); + goto error; + } + Tk_Release((ClientData) listPtr); + return result; + + error: + Tk_Release((ClientData) listPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyListbox -- + * + * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * to clean up the internal structure of a listbox at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the listbox is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyListbox(clientData) + ClientData clientData; /* Info about listbox widget. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + register Element *elPtr, *nextPtr; + + /* + * Free up all of the list elements. + */ + + for (elPtr = listPtr->firstPtr; elPtr != NULL; ) { + nextPtr = elPtr->nextPtr; + ckfree((char *) elPtr); + elPtr = nextPtr; + } + Tk_FreeOptions(configSpecs, (char *) listPtr, 0); + ckfree((char *) listPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureListbox -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or reconfigure) + * a listbox 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 listPtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureListbox(interp, listPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Listbox *listPtr; /* 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, listPtr->tkwin, configSpecs, + argc, argv, (char *) listPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Register the desired geometry for the window and arrange for + * the window to be redisplayed. + */ + + Tk_SetInternalBorder(listPtr->tkwin, listPtr->borderWidth); + ListboxComputeGeometry(listPtr, 1); + listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; + ListboxRedrawRange(listPtr, 0, listPtr->numElements-1); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DisplayListbox -- + * + * This procedure redraws the contents of a listbox window. + * + * Results: + * None. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +static void +DisplayListbox(clientData) + ClientData clientData; /* Information about window. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + register Tk_Window tkwin = listPtr->tkwin; + register Element *elPtr; + int width = Tk_Width(tkwin); + int height = Tk_Height(tkwin); + int yCurs = listPtr->borderWidth; /* Vertical position for + * cursor. */ + int i, x, y, limit; + + listPtr->flags &= ~REDRAW_PENDING; + if (listPtr->flags & UPDATE_V_SCROLLBAR) { + ListboxUpdateVScrollbar(listPtr); + } + if (listPtr->flags & UPDATE_H_SCROLLBAR) { + ListboxUpdateHScrollbar(listPtr); + } + listPtr->flags &= ~(REDRAW_PENDING|UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR); + if ((listPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + + /* + * Draw background. + */ + + Ctk_FillRect(tkwin, listPtr->borderWidth, listPtr->borderWidth, + width - listPtr->borderWidth, height - listPtr->borderWidth, + CTK_PLAIN_STYLE, ' '); + + /* + * Loop through elements. + */ + + x = listPtr->borderWidth + INDICATOR_WIDTH - listPtr->xOffset ; + y = listPtr->borderWidth; + limit = listPtr->topIndex + listPtr->numLines - 1; + for (elPtr = listPtr->firstPtr, i = 0; (elPtr != NULL) && (i <= limit); + elPtr = elPtr->nextPtr, i++) { + if (i < listPtr->topIndex) { + continue; + } + if (elPtr->selected) { + Ctk_FillRect(tkwin, listPtr->borderWidth, y, + width - listPtr->borderWidth, y+1, + CTK_SELECTED_STYLE, ' '); + Ctk_DrawString(tkwin, x, y, CTK_SELECTED_STYLE, + elPtr->text, elPtr->textLength); + } else { + Ctk_DrawString(tkwin, x, y, CTK_PLAIN_STYLE, + elPtr->text, elPtr->textLength); + } + if (i == listPtr->active) { + yCurs = y; + } + y++; + } + + if (listPtr->flags & GOT_FOCUS) { + Ctk_SetCursor(tkwin, listPtr->borderWidth, yCurs); + } + + if (listPtr->flags & BORDER_NEEDED) { + Ctk_DrawBorder(tkwin, CTK_PLAIN_STYLE, (char *) NULL); + listPtr->flags &= ~BORDER_NEEDED; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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 + * information is also set. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxComputeGeometry(listPtr, maxIsStale) + Listbox *listPtr; /* Listbox whose geometry is to be + * recomputed. */ + int maxIsStale; /* Non-zero means the "maxWidth" field may + * no longer be up-to-date and must + * be recomputed. */ +{ + register Element *elPtr; + int width, height; + + if (maxIsStale) { + listPtr->maxWidth = 0; + for (elPtr = listPtr->firstPtr; elPtr != NULL; elPtr = elPtr->nextPtr) { + if (elPtr->textLength > listPtr->maxWidth) { + listPtr->maxWidth = elPtr->textLength; + } + } + } + width = listPtr->width; + if (width <= 0) { + width = listPtr->maxWidth; + if (width < 1) { + width = 1; + } + } + width += 2*listPtr->borderWidth + INDICATOR_WIDTH; + height = listPtr->height; + if (height <= 0) { + height = listPtr->numElements; + if (height < 1) { + height = 1; + } + } + height += 2*listPtr->borderWidth; + Tk_GeometryRequest(listPtr->tkwin, width, height); +} + +/* + *---------------------------------------------------------------------- + * + * InsertEls -- + * + * Add new elements to a listbox widget. + * + * Results: + * None. + * + * Side effects: + * New information gets added to listPtr; it will be redisplayed + * soon, but not immediately. + * + *---------------------------------------------------------------------- + */ + +static void +InsertEls(listPtr, index, argc, argv) + register Listbox *listPtr; /* Listbox that is to get the new + * elements. */ + int index; /* Add the new elements before this + * element. */ + int argc; /* Number of new elements to add. */ + char **argv; /* New elements (one per entry). */ +{ + register Element *prevPtr, *newPtr; + int length, i, oldMaxWidth; + + /* + * Find the element before which the new ones will be inserted. + */ + + if (index <= 0) { + index = 0; + } + if (index > listPtr->numElements) { + index = listPtr->numElements; + } + if (index == 0) { + prevPtr = NULL; + } else if (index == listPtr->numElements) { + prevPtr = listPtr->lastPtr; + } else { + for (prevPtr = listPtr->firstPtr, i = index - 1; i > 0; i--) { + prevPtr = prevPtr->nextPtr; + } + } + + /* + * For each new element, create a record, initialize it, and link + * it into the list of elements. + */ + + oldMaxWidth = listPtr->maxWidth; + for (i = argc ; i > 0; i--, argv++, prevPtr = newPtr) { + length = strlen(*argv); + newPtr = (Element *) ckalloc(ElementSize(length)); + newPtr->textLength = length; + strcpy(newPtr->text, *argv); + if (newPtr->textLength > listPtr->maxWidth) { + listPtr->maxWidth = newPtr->textLength; + } + newPtr->selected = 0; + if (prevPtr == NULL) { + 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 and other indexes to account for the + * renumbering that has just occurred. Then arrange for the new + * information to be displayed. + */ + + if (index <= listPtr->selectAnchor) { + listPtr->selectAnchor += 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); + ListboxRedrawRange(listPtr, index, listPtr->numElements-1); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteEls -- + * + * Remove one or more elements from a listbox widget. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed, the listbox gets modified and (eventually) + * redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteEls(listPtr, first, last) + register Listbox *listPtr; /* Listbox widget to modify. */ + int first; /* Index of first element to delete. */ + int last; /* Index of last element to delete. */ +{ + register Element *prevPtr, *elPtr; + int count, i, widthChanged; + + /* + * Adjust the range to fit within the existing elements of the + * listbox, and make sure there's something to delete. + */ + + if (first < 0) { + first = 0; + } + if (last >= listPtr->numElements) { + last = listPtr->numElements-1; + } + count = last + 1 - first; + if (count <= 0) { + return; + } + + /* + * Find the element just before the ones to delete. + */ + + if (first == 0) { + prevPtr = NULL; + } else { + for (i = first-1, prevPtr = listPtr->firstPtr; i > 0; i--) { + prevPtr = prevPtr->nextPtr; + } + } + + /* + * Delete the requested number of elements. + */ + + widthChanged = 0; + for (i = count; i > 0; i--) { + if (prevPtr == NULL) { + 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->textLength == listPtr->maxWidth) { + widthChanged = 1; + } + if (elPtr->selected) { + listPtr->numSelected -= 1; + } + ckfree((char *) elPtr); + } + listPtr->numElements -= count; + + /* + * Update the selection and viewing information to reflect the change + * in the element numbering, and redisplay to slide information up over + * the elements that were deleted. + */ + + if (first <= listPtr->selectAnchor) { + listPtr->selectAnchor -= count; + if (listPtr->selectAnchor < first) { + listPtr->selectAnchor = first; + } + } + if (first <= listPtr->topIndex) { + listPtr->topIndex -= count; + if (listPtr->topIndex < first) { + listPtr->topIndex = first; + } + } + if (listPtr->topIndex > (listPtr->numElements - listPtr->numLines)) { + listPtr->topIndex = listPtr->numElements - listPtr->numLines; + 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, widthChanged); + if (widthChanged) { + listPtr->flags |= UPDATE_H_SCROLLBAR; + } + ListboxRedrawRange(listPtr, first, listPtr->numElements-1); +} + +/* + *-------------------------------------------------------------- + * + * ListboxEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on listboxes. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +ListboxEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Listbox *listPtr = (Listbox *) clientData; + + if (eventPtr->type == CTK_EXPOSE_EVENT) { + ListboxRedrawRange(listPtr, + NearestListboxElement(listPtr, eventPtr->u.expose.top), + NearestListboxElement(listPtr, eventPtr->u.expose.bottom)); + listPtr->flags |= BORDER_NEEDED; + } else if (eventPtr->type == CTK_DESTROY_EVENT) { + if (listPtr->tkwin != NULL) { + listPtr->tkwin = NULL; + Tcl_DeleteCommand(listPtr->interp, + Tcl_GetCommandName(listPtr->interp, listPtr->widgetCmd)); + } + if (listPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayListbox, (ClientData) listPtr); + } + Tk_EventuallyFree((ClientData) listPtr, DestroyListbox); + } else if (eventPtr->type == CTK_MAP_EVENT) { + listPtr->numLines = Tk_Height(listPtr->tkwin) - 2*listPtr->borderWidth; + listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; + ChangeListboxView(listPtr, listPtr->topIndex); + ChangeListboxOffset(listPtr, listPtr->xOffset); + } else if (eventPtr->type == CTK_FOCUS_EVENT) { + listPtr->flags |= GOT_FOCUS; + if (listPtr->active != -1) { + ListboxRedrawRange(listPtr, listPtr->active, listPtr->active); + } + } else if (eventPtr->type == CTK_UNFOCUS_EVENT) { + listPtr->flags &= ~GOT_FOCUS; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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) { + listPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * GetListboxIndex -- + * + * Parse an index into a listbox and return either its value + * or an error. + * + * Results: + * A standard Tcl result. If all went well, then *indexPtr is + * filled in with the index (into listPtr) corresponding to + * string. Otherwise an error message is left in interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +GetListboxIndex(interp, listPtr, string, numElsOK, indexPtr) + Tcl_Interp *interp; /* For error messages. */ + Listbox *listPtr; /* Listbox for which the index is being + * specified. */ + 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. */ +{ + 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; + } else if (c == '@') { + int x, y; + char *p, *end; + + p = string+1; + x = strtol(p, &end, 0); + if ((end == p) || (*end != ',')) { + goto badIndex; + } + 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; +} + +/* + *---------------------------------------------------------------------- + * + * ChangeListboxView -- + * + * Change the view on a listbox widget. + * + * Results: + * None. + * + * Side effects: + * What's displayed on the screen is changed. If there is a + * scrollbar associated with this widget, then the scrollbar + * is instructed to change its display too. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeListboxView(listPtr, index) + register Listbox *listPtr; /* Information about widget. */ + int index; /* Index of element in listPtr. */ +{ + if (index >= (listPtr->numElements - listPtr->numLines)) { + index = listPtr->numElements - listPtr->numLines; + } + if (index < 0) { + index = 0; + } + if (listPtr->topIndex != index) { + listPtr->topIndex = index; + if (!(listPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayListbox, (ClientData) listPtr); + listPtr->flags |= REDRAW_PENDING; + } + listPtr->flags |= UPDATE_V_SCROLLBAR; + } +} + +/* + *---------------------------------------------------------------------- + * + * ChangListboxOffset -- + * + * Change the horizontal offset for a listbox. + * + * Results: + * None. + * + * Side effects: + * The listbox may be redrawn to reflect its new horizontal + * offset. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeListboxOffset(listPtr, offset) + register Listbox *listPtr; /* Information about widget. */ + int offset; /* Desired new "xOffset" for + * listbox. */ +{ + int maxOffset; + + /* + * Make sure that the new offset is within the allowable range. + */ + + maxOffset = listPtr->maxWidth + - (Tk_Width(listPtr->tkwin) - 2*listPtr->borderWidth - 1); + if (offset > maxOffset) { + offset = maxOffset; + } + if (offset < 0) { + offset = 0; + } + if (offset != listPtr->xOffset) { + listPtr->xOffset = offset; + listPtr->flags |= UPDATE_H_SCROLLBAR; + ListboxRedrawRange(listPtr, 0, listPtr->numElements); + } +} + +/* + *---------------------------------------------------------------------- + * + * NearestListboxElement -- + * + * Given a y-coordinate inside a listbox, compute the index of + * the element under that y-coordinate (or closest to that + * y-coordinate). + * + * Results: + * The return value is an index of an element of listPtr. If + * listPtr has no elements, then 0 is always returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NearestListboxElement(listPtr, y) + register Listbox *listPtr; /* Information about widget. */ + int y; /* Y-coordinate in listPtr's window. */ +{ + int index; + + index = y - listPtr->borderWidth; + if (index >= listPtr->numLines) { + index = listPtr->numLines-1; + } + if (index < 0) { + index = 0; + } + index += listPtr->topIndex; + if (index >= listPtr->numElements) { + index = listPtr->numElements-1; + } + return index; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxSelect -- + * + * Select or deselect one or more elements in a listbox.. + * + * Results: + * None. + * + * Side effects: + * 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 +ListboxSelect(listPtr, first, last, select) + register Listbox *listPtr; /* Information about widget. */ + 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. */ +{ + int i, firstRedisplay, lastRedisplay, increment, oldCount; + Element *elPtr; + + if (last < first) { + i = first; + first = last; + last = i; + } + if (first >= listPtr->numElements) { + return; + } + oldCount = listPtr->numSelected; + firstRedisplay = -1; + increment = select ? 1 : -1; + for (i = 0, elPtr = listPtr->firstPtr; i < first; + i++, elPtr = elPtr->nextPtr) { + /* Empty loop body. */ + } + for ( ; i <= last; i++, elPtr = elPtr->nextPtr) { + if (elPtr->selected == select) { + continue; + } + listPtr->numSelected += increment; + elPtr->selected = select; + if (firstRedisplay < 0) { + firstRedisplay = i; + } + lastRedisplay = i; + } + if (firstRedisplay >= 0) { + ListboxRedrawRange(listPtr, first, last); + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxRedrawRange -- + * + * Ensure that a given range of elements is eventually redrawn on + * the display (if those elements in fact appear on the display). + * + * Results: + * None. + * + * Side effects: + * Information gets redisplayed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ListboxRedrawRange(listPtr, first, last) + register Listbox *listPtr; /* Information about widget. */ + int first; /* Index of first element in list + * that needs to be redrawn. */ + int last; /* Index of last element in list + * that needs to be redrawn. May + * be less than first; + * these just bracket a range. */ +{ + if ((listPtr->tkwin == NULL) || !Tk_IsMapped(listPtr->tkwin) + || (listPtr->flags & REDRAW_PENDING)) { + return; + } + Tcl_DoWhenIdle(DisplayListbox, (ClientData) listPtr); + listPtr->flags |= REDRAW_PENDING; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxUpdateVScrollbar -- + * + * This procedure is invoked whenever information has changed in + * a listbox in a way that would invalidate a vertical scrollbar + * display. If there is an associated scrollbar, then this command + * updates it by invoking a Tcl command. + * + * Results: + * None. + * + * Side effects: + * A Tcl command is invoked, and an additional command may be + * invoked to process errors in the command. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxUpdateVScrollbar(listPtr) + register Listbox *listPtr; /* Information about widget. */ +{ + char string[100]; + double first, last; + int result; + + if (listPtr->yScrollCmd == NULL) { + return; + } + if (listPtr->numElements == 0) { + first = 0.0; + last = 1.0; + } else { + first = listPtr->topIndex/((double) listPtr->numElements); + last = (listPtr->topIndex+listPtr->numLines) + /((double) listPtr->numElements); + if (last > 1.0) { + last = 1.0; + } + } + sprintf(string, " %g %g", first, last); + result = Tcl_VarEval(listPtr->interp, listPtr->yScrollCmd, string, + (char *) NULL); + if (result != TCL_OK) { + Tcl_AddErrorInfo(listPtr->interp, + "\n (vertical scrolling command executed by listbox)"); + Tcl_BackgroundError(listPtr->interp); + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxUpdateHScrollbar -- + * + * This procedure is invoked whenever information has changed in + * a listbox in a way that would invalidate a horizontal scrollbar + * display. If there is an associated horizontal scrollbar, then + * this command updates it by invoking a Tcl command. + * + * Results: + * None. + * + * Side effects: + * A Tcl command is invoked, and an additional command may be + * invoked to process errors in the command. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxUpdateHScrollbar(listPtr) + register Listbox *listPtr; /* Information about widget. */ +{ + char string[60]; + int result, windowWidth; + double first, last; + + if (listPtr->xScrollCmd == NULL) { + return; + } + windowWidth = Tk_Width(listPtr->tkwin) - 2*listPtr->borderWidth; + 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, " %g %g", first, last); + result = Tcl_VarEval(listPtr->interp, listPtr->xScrollCmd, string, + (char *) NULL); + if (result != TCL_OK) { + Tcl_AddErrorInfo(listPtr->interp, + "\n (horizontal scrolling command executed by listbox)"); + Tcl_BackgroundError(listPtr->interp); + } +} ADDED tkMain.c Index: tkMain.c ================================================================== --- tkMain.c +++ tkMain.c @@ -0,0 +1,511 @@ +/* + * tkMain.c (CTk) -- + * + * 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-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + + +#include +#include +#include +#include +#include "tk.h" +#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 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. */ +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. */ +static char errorExitCmd[] = "exit 1"; + +/* + * Command-line options: + */ + +static char *fileName = NULL; +static char *name = NULL; +static char *display = NULL; +static char *geometry = NULL; +static int rest = 0; + +static Tk_ArgvInfo argTable[] = { + {"-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"}, + {"--", 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 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 befort starting + * to execute commands. */ +{ + char *args, *p, *msg, *argv0, *class; + char buf[20]; + int code; + size_t length; + Tcl_Channel inChannel, outChannel, errChannel, chan; + + 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. Also check + * for other standard arguments, such as "-geometry", anywhere + * in the argument list. + */ + + argv0 = argv[0]; + 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++; + } + 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; + } + } + + /* + * 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 : argv0, + TCL_GLOBAL_ONLY); + + /* + * If a display was specified, put it into the CTK_DISPLAY + * environment variable so that it will be available for + * any sub-processes created by us. + */ + + if (display != NULL) { + Tcl_SetVar2(interp, "env", "CTK_DISPLAY", display, TCL_GLOBAL_ONLY); + } + + /* + * Initialize the Tk application. If a -name option was provided, + * use it; otherwise, if a file name was provided, use the last + * element of its path as the name of the application; otherwise + * use the last element of the program name. For the application's + * class, capitalize the first letter of the name. + */ + + if (name == NULL) { + p = (fileName != NULL) ? fileName : argv0; + name = strrchr(p, '/'); + if (name != NULL) { + name++; + } else { + name = p; + } + } + class = (char *) ckalloc((unsigned) (strlen(name) + 1)); + strcpy(class, name); + class[0] = toupper((unsigned char) class[0]); + mainWindow = Tk_CreateMainWindow(interp, display, name, class); + ckfree(class); + if (mainWindow == NULL) { + fprintf(stderr, "%s\n", interp->result); + exit(1); + } + + /* + * Set the "tcl_interactive" variable. + */ + + tty = isatty(0); + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + /* + * 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) { + fprintf(stderr, "%s\n", interp->result); + } + } + + /* + * 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); + } + + goto error; + } + + /* + * 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 { + /* + * Commands will come from standard input, so set up an event + * handler for standard input. Evaluate 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. + */ + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + if (fileName != NULL) { + Tcl_DString buffer; + char *fullName; + + fullName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (fullName == NULL) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else { + + /* + * NOTE: The following relies on O_RDONLY==0. + */ + + chan = Tcl_OpenFileChannel(interp, fullName, "r", 0); + if (chan != (Tcl_Channel) NULL) { + Tcl_Close(NULL, chan); + 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(&buffer); + } + if (tty && + !Tcl_GetVar2(interp, "env", "CTK_DISPLAY", TCL_GLOBAL_ONLY)) { + /* + * Input is a terminal, and display was never set. Instead + * of reading command from stdin, pop-up a command dialog + * (since we are probably displaying to stdin/stdout). + */ + if (Tcl_Eval(interp, "ctkDialog") != TCL_OK) { + goto error; + } + } else { + Tcl_CreateFileHandler(0, TCL_READABLE, StdinProc, (ClientData) 0); + 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(); + + /* + * 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: + /* + * 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_CreateFileHandler(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; + + 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); +} ADDED tkMenu.c Index: tkMenu.c ================================================================== --- tkMenu.c +++ tkMenu.c @@ -0,0 +1,1932 @@ +/* + * tkMenu.c (CTk) -- + * + * This module implements menus for the Tk toolkit. The menus + * support normal button entries, plus check buttons, radio + * buttons, iconic forms of all of the above, and separator + * entries. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "default.h" +#include "tkInt.h" + +/* + * One of the following data structures is kept for each entry of each + * menu managed by this file: + */ + +typedef struct MenuEntry { + int type; /* Type of menu entry; see below for + * valid types. */ + struct Menu *menuPtr; /* Menu with which this entry is associated. */ + char *label; /* Main text label displayed in entry (NULL + * if no label). Malloc'ed. */ + int labelLength; /* Number of non-NULL characters in label. */ + int underline; /* Index of character to underline. */ + char *accel; /* Accelerator string displayed at right + * of menu entry. NULL means no such + * accelerator. Malloc'ed. */ + int accelLength; /* Number of non-NULL characters in + * accelerator. */ + + /* + * Information related to displaying entry: + */ + + Tk_Uid state; /* State of button for display purposes: + * normal, active, or disabled. */ + int indicatorOn; /* True means draw indicator, false means + * don't draw it. */ + + /* + * Information used to implement this entry's action: + */ + + char *command; /* Command to invoke when entry is invoked. + * Malloc'ed. */ + char *name; /* Name of variable (for check buttons and + * radio buttons) or menu (for cascade + * entries). Malloc'ed.*/ + char *onValue; /* Value to store in variable when selected + * (only for radio and check buttons). + * Malloc'ed. */ + char *offValue; /* Value to store in variable when not + * selected (only for check buttons). + * Malloc'ed. */ + + /* + * Miscellaneous information: + */ + + int flags; /* Various flags. See below for definitions. */ +} MenuEntry; + +/* + * Flag values defined for menu entries: + * + * ENTRY_SELECTED: Non-zero means this is a radio or check + * button and that it should be drawn in + * the "selected" state. + * ENTRY_NEEDS_REDISPLAY: Non-zero means the entry should be redisplayed. + */ + +#define ENTRY_SELECTED 1 +#define ENTRY_NEEDS_REDISPLAY 4 + +/* + * Types defined for MenuEntries: + */ + +#define COMMAND_ENTRY 0 +#define SEPARATOR_ENTRY 1 +#define CHECK_BUTTON_ENTRY 2 +#define RADIO_BUTTON_ENTRY 3 +#define CASCADE_ENTRY 4 +#define TEAROFF_ENTRY 5 + +/* + * Mask bits for above types: + */ + +#define COMMAND_MASK TK_CONFIG_USER_BIT +#define SEPARATOR_MASK (TK_CONFIG_USER_BIT << 1) +#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 | TEAROFF_MASK) + +/* + * Configuration specs for individual menu entries: + */ + +static Tk_ConfigSpec entryConfigSpecs[] = { + {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 + |TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-command", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_COMMAND, Tk_Offset(MenuEntry, command), + 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}, + {TK_CONFIG_STRING, "-menu", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_MENU, Tk_Offset(MenuEntry, name), + CASCADE_MASK|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-offvalue", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_OFF_VALUE, Tk_Offset(MenuEntry, offValue), + CHECK_BUTTON_MASK}, + {TK_CONFIG_STRING, "-onvalue", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_ON_VALUE, Tk_Offset(MenuEntry, onValue), + 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 + |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}, + {TK_CONFIG_STRING, "-variable", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_CHECK_VARIABLE, Tk_Offset(MenuEntry, name), + CHECK_BUTTON_MASK|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-variable", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_RADIO_VARIABLE, Tk_Offset(MenuEntry, name), + RADIO_BUTTON_MASK}, + {TK_CONFIG_INT, "-underline", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_UNDERLINE, Tk_Offset(MenuEntry, underline), + COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK + |TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * A data structure of the following type is kept for each + * menu managed by this file: + */ + +typedef struct Menu { + Tk_Window tkwin; /* Window that embodies the pane. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + 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. */ + int active; /* Index of active entry. -1 means + * nothing active. */ + + /* + * Information used when displaying widget: + */ + + int borderWidth; /* Width of border around whole menu. */ + int labelWidth; /* Number of pixels to allow for displaying + * labels in menu entries. */ + int columnWidth; /* Number of pixels to allow for a column + * of entries (includes space for label, + * accelerator, and indicators). */ + int numRows; /* Number of entries per column. */ + + /* + * Miscellaneous information: + */ + + int tearOff; /* 1 means this is a tear-off menu, so the + * first entry always shows a dashed stripe + * for tearing off. */ + 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 + * submenu that is currently posted, or + * NULL if no submenu posted. */ + int flags; /* Various flags; see below for + * definitions. */ +} Menu; + +/* + * Flag bits for menus: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * RESIZE_PENDING: Non-zero means a call to ComputeMenuGeometry + * has already been scheduled. + * BORDER_NEEDED: Non-zero means 3-D border must be redrawn + * around window during redisplay. Normally + * only text portion needs to be redrawn. + * GOT_FOCUS: Non-zero means this menu currently + * has the input focus. + */ + +#define REDRAW_PENDING 1 +#define RESIZE_PENDING 2 +#define BORDER_NEEDED 4 +#define GOT_FOCUS 8 + +/* + * Configuration specs valid for the menu as a whole: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_MENU_BORDER_WIDTH, Tk_Offset(Menu, borderWidth), 0}, + {TK_CONFIG_STRING, "-postcommand", "postCommand", "Command", + DEF_MENU_POST_COMMAND, Tk_Offset(Menu, postCommand), TK_CONFIG_NULL_OK}, + {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_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int ActivateMenuEntry _ANSI_ARGS_((Menu *menuPtr, + int index)); +static void ComputeMenuGeometry _ANSI_ARGS_(( + ClientData clientData)); +static int ConfigureMenu _ANSI_ARGS_((Tcl_Interp *interp, + Menu *menuPtr, int argc, char **argv, + int flags)); +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 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 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 MenuEntry * MenuNewEntry _ANSI_ARGS_((Menu *menuPtr, int index, + int type)); +static char * MenuVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static int MenuWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int PostSubmenu _ANSI_ARGS_((Tcl_Interp *interp, + Menu *menuPtr, MenuEntry *mePtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_MenuCmd -- + * + * This procedure is invoked to process the "menu" 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_MenuCmd(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 Menu *menuPtr; + + 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], ""); + if (new == NULL) { + return TCL_ERROR; + } + + /* + * Initialize the data structure for the menu. + */ + + menuPtr = (Menu *) ckalloc(sizeof(Menu)); + menuPtr->tkwin = 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->borderWidth = 0; + menuPtr->labelWidth = 0; + menuPtr->columnWidth = 0; + menuPtr->numRows = 0; + menuPtr->tearOff = 1; + menuPtr->takeFocus = NULL; + menuPtr->postCommand = NULL; + menuPtr->postedCascade = NULL; + menuPtr->flags = 0; + + Tk_SetClass(new, "Menu"); + Tk_CreateEventHandler(menuPtr->tkwin, + CTK_EXPOSE_EVENT_MASK|CTK_DESTROY_EVENT_MASK|CTK_FOCUS_EVENT_MASK, + MenuEventProc, (ClientData) menuPtr); + if (ConfigureMenu(interp, menuPtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + Tcl_SetResult(interp,Tk_PathName(menuPtr->tkwin), TCL_VOLATILE); + return TCL_OK; + + error: + Tk_DestroyWindow(menuPtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * MenuWidgetCmd -- + * + * 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 +MenuWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about menu widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Menu *menuPtr = (Menu *) clientData; + register MenuEntry *mePtr; + 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; + } + Tk_Preserve((ClientData) menuPtr); + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0) + && (length >= 2)) { + int index; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " activate index\"", (char *) NULL); + goto error; + } + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + if (menuPtr->active == index) { + goto done; + } + if (index >= 0) { + if ((menuPtr->entries[index]->type == SEPARATOR_ENTRY) + || (menuPtr->entries[index]->state == tkDisabledUid)) { + index = -1; + } + } + result = ActivateMenuEntry(menuPtr, index); + } else if ((c == 'a') && (strncmp(argv[1], "add", length) == 0) + && (length >= 2)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " add type ?options?\"", (char *) NULL); + goto error; + } + if (MenuAddOrInsert(interp, menuPtr, (char *) NULL, + argc-2, argv+2) != TCL_OK) { + goto error; + } + } 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, 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); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, menuPtr->tkwin, configSpecs, + (char *) menuPtr, argv[2], 0); + } else { + result = ConfigureMenu(interp, menuPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { + int first, last, i, numDeleted; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delete first ?last?\"", (char *) NULL); + goto error; + } + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &first) != TCL_OK) { + goto error; + } + if (argc == 3) { + last = first; + } else { + 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], + DestroyMenuEntry); + } + for (i = last+1; i < menuPtr->numEntries; i++) { + menuPtr->entries[i-numDeleted] = menuPtr->entries[i]; + } + menuPtr->numEntries -= numDeleted; + if ((menuPtr->active >= first) && (menuPtr->active <= last)) { + menuPtr->active = -1; + } else if (menuPtr->active > last) { + menuPtr->active -= numDeleted; + } + if (!(menuPtr->flags & RESIZE_PENDING)) { + menuPtr->flags |= RESIZE_PENDING; + Tcl_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); + } + } else if ((c == 'e') && (length >= 7) + && (strncmp(argv[1], "entrycget", length) == 0)) { + int index; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " entrycget index option\"", + (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]; + Tk_Preserve((ClientData) mePtr); + result = Tk_ConfigureValue(interp, menuPtr->tkwin, entryConfigSpecs, + (char *) mePtr, argv[3], COMMAND_MASK << mePtr->type); + Tk_Release((ClientData) mePtr); + } else if ((c == 'e') && (length >= 7) + && (strncmp(argv[1], "entryconfigure", length) == 0)) { + int index; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " entryconfigure index ?option value ...?\"", + (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]; + Tk_Preserve((ClientData) mePtr); + if (argc == 3) { + result = Tk_ConfigureInfo(interp, menuPtr->tkwin, entryConfigSpecs, + (char *) mePtr, (char *) NULL, + COMMAND_MASK << mePtr->type); + } else if (argc == 4) { + result = Tk_ConfigureInfo(interp, menuPtr->tkwin, entryConfigSpecs, + (char *) mePtr, argv[3], COMMAND_MASK << mePtr->type); + } else { + result = ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc-3, + argv+3, TK_CONFIG_ARGV_ONLY | COMMAND_MASK << mePtr->type); + } + Tk_Release((ClientData) mePtr); + } 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 string\"", (char *) NULL); + goto error; + } + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + if (index < 0) { + Tcl_SetResult(interp,"none", TCL_STATIC); + } else { + char buffer[20]; + sprintf(buffer, "%d", index); + Tcl_SetResult(interp, buffer, TCL_VOLATILE); + } + } 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; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " invoke 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]; + if (mePtr->state == tkDisabledUid) { + goto done; + } + Tk_Preserve((ClientData) mePtr); + if (mePtr->type == CHECK_BUTTON_ENTRY) { + if (mePtr->flags & ENTRY_SELECTED) { + if (Tcl_SetVar(interp, mePtr->name, mePtr->offValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + } else { + 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) { + if (Tcl_SetVar(interp, mePtr->name, mePtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + } + if ((result == TCL_OK) && (mePtr->command != NULL)) { + result = TkCopyAndGlobalEval(interp, mePtr->command); + } + if ((result == TCL_OK) && (mePtr->type == CASCADE_ENTRY)) { + result = PostSubmenu(menuPtr->interp, menuPtr, mePtr); + } + Tk_Release((ClientData) mePtr); + } else if ((c == 'p') && (strncmp(argv[1], "post", length) == 0) + && (length == 4)) { + Tk_Window tkwin = menuPtr->tkwin; + int tmp; + char *placeArgv[9]; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " post x y\"", (char *) NULL); + goto error; + } + if ((Tcl_GetInt(interp, argv[2], &tmp) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &tmp) != TCL_OK)) { + goto error; + } + + /* + * 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) { + result = TkCopyAndGlobalEval(menuPtr->interp, + menuPtr->postCommand); + if (result != TCL_OK) { + return result; + } + if (menuPtr->flags & RESIZE_PENDING) { + Tcl_CancelIdleCall(ComputeMenuGeometry, (ClientData) menuPtr); + ComputeMenuGeometry((ClientData) menuPtr); + } + } + + Tk_RestackWindow(tkwin, Above, (Tk_Window) NULL); + placeArgv[0] = "place"; + placeArgv[1] = Tk_PathName(tkwin); + placeArgv[2] = "-x"; + placeArgv[3] = argv[2]; + placeArgv[4] = "-y"; + placeArgv[5] = argv[3]; + placeArgv[6] = "-anchor"; + placeArgv[7] = "nw"; + placeArgv[8] = NULL; + result = Tk_PlaceCmd((ClientData) tkwin, interp, 8, placeArgv); + } 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: + Tcl_SetResult(interp,"command",TCL_STATIC); + break; + case SEPARATOR_ENTRY: + Tcl_SetResult(interp,"separator",TCL_STATIC); + break; + case CHECK_BUTTON_ENTRY: + Tcl_SetResult(interp,"checkbutton",TCL_STATIC); + break; + case RADIO_BUTTON_ENTRY: + Tcl_SetResult(interp,"radiobutton",TCL_STATIC); + break; + case CASCADE_ENTRY: + Tcl_SetResult(interp,"cascade",TCL_STATIC); + break; + case TEAROFF_ENTRY: + Tcl_SetResult(interp,"tearoff",TCL_STATIC); + break; + } + } else if ((c == 'u') && (strncmp(argv[1], "unpost", length) == 0)) { + char *placeArgv[4]; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " unpost\"", (char *) NULL); + goto error; + } + placeArgv[0] = "place"; + placeArgv[1] = "forget"; + placeArgv[2] = Tk_PathName(menuPtr->tkwin); + placeArgv[3] = NULL; + result = Tk_PlaceCmd((ClientData) menuPtr->tkwin, interp, 3, placeArgv); + if (result == TCL_OK) { + result = PostSubmenu(interp, menuPtr, (MenuEntry *) NULL); + } + } else if ((c == 'y') && (strncmp(argv[1], "yposition", length) == 0)) { + int index; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " yposition index\"", (char *) NULL); + goto error; + } + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + if (index < 0 || menuPtr->numRows == 0) { + Tcl_SetResult(interp,"0",TCL_STATIC); + } else { + char buffer[20]; + sprintf(buffer, "%d", + (index%menuPtr->numRows) + menuPtr->borderWidth); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": 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); + return result; + + error: + Tk_Release((ClientData) menuPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyMenu -- + * + * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * to clean up the internal structure of a menu at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the menu is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyMenu(clientData) + ClientData clientData; /* Info about menu widget. */ +{ + register Menu *menuPtr = (Menu *) clientData; + int i; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + for (i = 0; i < menuPtr->numEntries; i++) { + DestroyMenuEntry((ClientData) menuPtr->entries[i]); + } + if (menuPtr->entries != NULL) { + ckfree((char *) menuPtr->entries); + } + Tk_FreeOptions(configSpecs, (char *) menuPtr, 0); + ckfree((char *) menuPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DestroyMenuEntry -- + * + * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * to clean up the internal structure of a menu entry at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the menu entry is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyMenuEntry(clientData) + ClientData clientData; /* Pointer to entry to be freed. */ +{ + register MenuEntry *mePtr = (MenuEntry *) clientData; + Menu *menuPtr = mePtr->menuPtr; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + if (menuPtr->postedCascade == mePtr) { + /* + * Ignore errors while unposting the menu, since it's possible + * that the menu has already been deleted and the unpost will + * generate an error. + */ + + PostSubmenu(menuPtr->interp, menuPtr, (MenuEntry *) NULL); + } + 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, + (COMMAND_MASK << mePtr->type)); + ckfree((char *) mePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureMenu -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a menu 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, font, etc. get set + * for menuPtr; old resources get freed, if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureMenu(interp, menuPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Menu *menuPtr; /* 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 i; + + if (Tk_ConfigureWidget(interp, menuPtr->tkwin, configSpecs, + argc, argv, (char *) menuPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * After reconfiguring a menu, we need to reconfigure all of the + * entries in the menu, since some of the things in the children + * (such as graphics contexts) may have to change to reflect changes + * in the parent. + */ + + for (i = 0; i < menuPtr->numEntries; i++) { + MenuEntry *mePtr; + + mePtr = menuPtr->entries[i]; + ConfigureMenuEntry(interp, menuPtr, mePtr, i, 0, (char **) NULL, + 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)) { + Tk_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; + Tcl_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); + } + + Tk_SetInternalBorder(menuPtr->tkwin, menuPtr->borderWidth); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureMenuEntry -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) one entry in a menu. + * + * 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 label and accelerator get + * set for mePtr; old resources get freed, if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Menu *menuPtr; /* Information about whole menu. */ + register MenuEntry *mePtr; /* Information about menu entry; may + * or may not already have values for + * some fields. */ + int index; /* Index of mePtr within menuPtr's + * entries. */ + int argc; /* Number of valid entries in argv. */ + char **argv; /* Arguments. */ + int flags; /* Additional flags to pass to + * Tk_ConfigureWidget. */ +{ + /* + * If this entry is a cascade and the cascade is posted, then unpost + * it before reconfiguring the entry (otherwise the reconfigure might + * change the name of the cascaded entry, leaving a posted menu + * high and dry). + */ + + if (menuPtr->postedCascade == mePtr) { + if (PostSubmenu(menuPtr->interp, menuPtr, (MenuEntry *) NULL) + != TCL_OK) { + Tcl_BackgroundError(menuPtr->interp); + } + } + + /* + * If this entry is a check button or radio button, then remove + * its old trace procedure. + */ + + if ((mePtr->name != NULL) && + ((mePtr->type == CHECK_BUTTON_ENTRY) + || (mePtr->type == RADIO_BUTTON_ENTRY))) { + Tcl_UntraceVar(menuPtr->interp, mePtr->name, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuVarProc, (ClientData) mePtr); + } + + if (Tk_ConfigureWidget(interp, menuPtr->tkwin, entryConfigSpecs, + argc, argv, (char *) mePtr, + flags | (COMMAND_MASK << mePtr->type)) != TCL_OK) { + return TCL_ERROR; + } + + /* + * The code below handles special configuration stuff not taken + * care of by Tk_ConfigureWidget, such as special processing for + * defaults, sizing strings, graphics contexts, etc. + */ + + if (mePtr->label == NULL) { + mePtr->labelLength = 0; + } else { + mePtr->labelLength = strlen(mePtr->label); + } + if (mePtr->accel == NULL) { + mePtr->accelLength = 0; + } else { + mePtr->accelLength = strlen(mePtr->accel); + } + + if (mePtr->state == tkActiveUid) { + if (index != menuPtr->active) { + ActivateMenuEntry(menuPtr, index); + } + } else { + if (index == menuPtr->active) { + ActivateMenuEntry(menuPtr, -1); + } + if ((mePtr->state != tkNormalUid) && (mePtr->state != tkDisabledUid)) { + Tcl_AppendResult(interp, "bad state value \"", mePtr->state, + "\": must be normal, active, or disabled", (char *) NULL); + mePtr->state = tkNormalUid; + return TCL_ERROR; + } + } + + if ((mePtr->type == CHECK_BUTTON_ENTRY) + || (mePtr->type == RADIO_BUTTON_ENTRY)) { + char *value; + + if (mePtr->name == NULL) { + mePtr->name = (char *) ckalloc((unsigned) (mePtr->labelLength + 1)); + strcpy(mePtr->name, (mePtr->label == NULL) ? "" : mePtr->label); + } + if (mePtr->onValue == NULL) { + mePtr->onValue = (char *) ckalloc((unsigned) + (mePtr->labelLength + 1)); + strcpy(mePtr->onValue, (mePtr->label == NULL) ? "" : mePtr->label); + } + + /* + * Select the entry if the associated variable has the + * appropriate value, initialize the variable if it doesn't + * exist, then set a trace on the variable to monitor future + * changes to its value. + */ + + value = Tcl_GetVar(interp, mePtr->name, TCL_GLOBAL_ONLY); + mePtr->flags &= ~ENTRY_SELECTED; + if (value != NULL) { + if (strcmp(value, mePtr->onValue) == 0) { + mePtr->flags |= ENTRY_SELECTED; + } + } else { + Tcl_SetVar(interp, mePtr->name, + (mePtr->type == CHECK_BUTTON_ENTRY) ? mePtr->offValue : "", + TCL_GLOBAL_ONLY); + } + Tcl_TraceVar(interp, mePtr->name, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuVarProc, (ClientData) mePtr); + } + + if (!(menuPtr->flags & RESIZE_PENDING)) { + menuPtr->flags |= RESIZE_PENDING; + Tcl_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ComputeMenuGeometry -- + * + * This procedure is invoked to recompute the size and + * layout of a menu. It is called as a when-idle handler so + * that it only gets done once, even if a group of changes is + * made to the menu. + * + * Results: + * None. + * + * Side effects: + * Fields of menu entries are changed to reflect their + * current positions, and the size of the menu window + * itself may be changed. + * + *-------------------------------------------------------------- + */ + +static void +ComputeMenuGeometry(clientData) + ClientData clientData; /* Structure describing menu. */ +{ + Menu *menuPtr = (Menu *) clientData; + register MenuEntry *mePtr; + int maxLabelWidth, maxAccelWidth; + int numColumns, width, height; + int i; + + if (menuPtr->tkwin == NULL) { + return; + } + + maxLabelWidth = maxAccelWidth = 0; + + for (i = 0; i < menuPtr->numEntries; i++) { + /* + * For each entry, compute the label and accelerator width. + */ + + mePtr = menuPtr->entries[i]; + + if (mePtr->label != NULL) { + (void) TkMeasureChars(mePtr->label, + mePtr->labelLength, 0, (int) 100000, 0, + TK_NEWLINES_NOT_SPECIAL, &width); + if (width > maxLabelWidth) { + maxLabelWidth = width; + } + } + + if (mePtr->accel != NULL) { + (void) TkMeasureChars(mePtr->accel, mePtr->accelLength, + 0, (int) 100000, 0, TK_NEWLINES_NOT_SPECIAL, &width); + if (width > maxAccelWidth) { + maxAccelWidth = width; + } + } + } + + /* + * Got all the sizes. Update fields in the menu structure, then + * resize the window if necessary. + * + * Column width is max. label and accelerator widths + 2 spaces + * for selection and cascade indicators. + */ + + menuPtr->labelWidth = maxLabelWidth; + menuPtr->columnWidth = maxLabelWidth + maxAccelWidth + 2; + numColumns = 1 + (menuPtr->numEntries - 1) + / (Ctk_DisplayHeight(Tk_Display(menuPtr->tkwin)) + - 2*menuPtr->borderWidth); + if (numColumns <= 0) { + menuPtr->numRows = numColumns = 0; + } else { + menuPtr->numRows = 1 + (menuPtr->numEntries - 1)/numColumns; + } + width = menuPtr->columnWidth * numColumns + 2*menuPtr->borderWidth; + height = menuPtr->numRows + 2*menuPtr->borderWidth; + + if ((width != Tk_ReqWidth(menuPtr->tkwin)) || + (height != Tk_ReqHeight(menuPtr->tkwin))) { + Tk_GeometryRequest(menuPtr->tkwin, width, height); + } else { + /* + * Must always force a redisplay here if the window is mapped + * (even if the size didn't change, something else might have + * changed in the menu, such as a label or accelerator). The + * resize will force a redisplay above. + */ + + EventuallyRedrawMenu(menuPtr, (MenuEntry *) NULL); + } + + menuPtr->flags &= ~RESIZE_PENDING; +} + +/* + *---------------------------------------------------------------------- + * + * DisplayMenu -- + * + * This procedure is invoked to display a menu widget. + * + * Results: + * None. + * + * Side effects: + * Commands are output to X to display the menu in its + * current mode. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayMenu(clientData) + ClientData clientData; /* Information about widget. */ +{ + register Menu *menuPtr = (Menu *) clientData; + register MenuEntry *mePtr; + register Tk_Window tkwin = menuPtr->tkwin; + int index; + int x, y, underlineX; + Ctk_Style style; + int fillChar; + + if ((menuPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + goto done; + } + + /* + * Loop through all of the entries, drawing them one at a time. + */ + + x = y = menuPtr->borderWidth; + for (index = 0; index < menuPtr->numEntries; index++) { + mePtr = menuPtr->entries[index]; + if ((mePtr->flags & ENTRY_NEEDS_REDISPLAY)) { + mePtr->flags &= ~ENTRY_NEEDS_REDISPLAY; + + /* + * Fill Background. + */ + + style = (mePtr->state == tkDisabledUid) + ? CTK_DISABLED_STYLE : CTK_PLAIN_STYLE; + if (mePtr->type == SEPARATOR_ENTRY) { + fillChar = '-'; + } else if (mePtr->type == TEAROFF_ENTRY) { + fillChar = '='; + } else { + fillChar = ' '; + } + Ctk_FillRect(tkwin, x, y, x + menuPtr->columnWidth, y + 1, + style, fillChar); + + if (mePtr->flags & ENTRY_SELECTED) { + /* + * Draw check/radio-button indicator. + */ + + Ctk_DrawCharacter(tkwin, x, y, style, '*'); + } + + /* + * Draw label for entry. + */ + + if (mePtr->label != NULL) { + TkDisplayChars(tkwin, style, mePtr->label, mePtr->labelLength, + x + 1, y, x + 1, TK_NEWLINES_NOT_SPECIAL); + if (mePtr->underline >= 0) { + + (void) TkMeasureChars(mePtr->label, mePtr->underline, + x + 1, x + menuPtr->columnWidth, x + 1, + TK_WHOLE_WORDS|TK_AT_LEAST_ONE, &underlineX); + TkDisplayChars(tkwin, CTK_UNDERLINE_STYLE, + mePtr->label + mePtr->underline, 1, + underlineX, y, x + 1, + TK_NEWLINES_NOT_SPECIAL); + } + } + + /* + * Draw accelerator. + */ + + if (mePtr->accel != NULL) { + TkDisplayChars(tkwin, style, + mePtr->accel, mePtr->accelLength, + x + 1 + menuPtr->labelWidth, y, + x + 1 + menuPtr->labelWidth, TK_NEWLINES_NOT_SPECIAL); + } + + if (mePtr->type == CASCADE_ENTRY) { + /* + * Draw cascade arrow. + */ + + Ctk_DrawCharacter(tkwin, x + menuPtr->columnWidth - 1, y, + style, '>'); + } + + if (index == menuPtr->active && menuPtr->flags & GOT_FOCUS) { + /* + * Place cursor. + */ + + Ctk_SetCursor(tkwin, x + 1, y); + } + } + + y += 1; + if (y == Tk_Height(tkwin) - menuPtr->borderWidth) { + y = menuPtr->borderWidth; + x += menuPtr->columnWidth; + } + } + + /* + * Draw border, if necessary. + */ + if (menuPtr->flags & BORDER_NEEDED) { + Ctk_DrawBorder(tkwin, CTK_PLAIN_STYLE, (char *)NULL); + } + + done: + menuPtr->flags &= ~(BORDER_NEEDED|REDRAW_PENDING); +} + +/* + *-------------------------------------------------------------- + * + * GetMenuIndex -- + * + * Parse a textual index into a menu and return the numerical + * index of the indicated entry. + * + * Results: + * A standard Tcl result. If all went well, then *indexPtr is + * filled in with the entry index corresponding to string + * (ranges from -1 to the number of entries in the menu minus + * one). Otherwise an error message is left in interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +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; + + if ((string[0] == 'a') && (strcmp(string, "active") == 0)) { + *indexPtr = menuPtr->active; + return TCL_OK; + } + + if (((string[0] == 'l') && (strcmp(string, "last") == 0)) + || ((string[0] == 'e') && (strcmp(string, "end") == 0))) { + *indexPtr = menuPtr->numEntries - ((lastOK) ? 0 : 1); + return TCL_OK; + } + + if ((string[0] == 'n') && (strcmp(string, "none") == 0)) { + *indexPtr = -1; + return TCL_OK; + } + + if (string[0] == '@') { + /* + * With multi-column menus I really need both the x and y + * coordinates here - but I don't think any CTk specific + * apps need to specify indexes this way and Tk only uses + * one coordinate. + */ + + if (Tcl_GetInt(interp, string+1, &y) == TCL_OK) { + i = y - menuPtr->borderWidth; + if (i < 0) { + i = 0; + } else if (i >= menuPtr->numEntries) { + i = menuPtr->numEntries-1; + } + *indexPtr = i; + return TCL_OK; + } else { + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + } + } + + if (isdigit(UCHAR(string[0]))) { + if (Tcl_GetInt(interp, string, &i) == TCL_OK) { + if (i >= menuPtr->numEntries) { + if (lastOK) { + i = menuPtr->numEntries; + } else { + i = menuPtr->numEntries - 1; + } + } else if (i < 0) { + i = -1; + } + *indexPtr = i; + return TCL_OK; + } + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + } + + for (i = 0; i < menuPtr->numEntries; i++) { + char *label; + + label = menuPtr->entries[i]->label; + if ((label != NULL) + && (Tcl_StringMatch(menuPtr->entries[i]->label, string))) { + *indexPtr = i; + return TCL_OK; + } + } + + Tcl_AppendResult(interp, "bad menu entry index \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * MenuEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on menus. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +MenuEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Menu *menuPtr = (Menu *) clientData; + if (eventPtr->type == CTK_EXPOSE_EVENT) { + EventuallyRedrawMenu(menuPtr, (MenuEntry *) NULL); + menuPtr->flags |= BORDER_NEEDED; + } else if (eventPtr->type == CTK_DESTROY_EVENT) { + if (menuPtr->tkwin != NULL) { + menuPtr->tkwin = NULL; + Tcl_DeleteCommand(menuPtr->interp, + Tcl_GetCommandName(menuPtr->interp, menuPtr->widgetCmd)); + } + if (menuPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayMenu, (ClientData) menuPtr); + } + if (menuPtr->flags & RESIZE_PENDING) { + Tcl_CancelIdleCall(ComputeMenuGeometry, (ClientData) menuPtr); + } + Tk_EventuallyFree((ClientData) menuPtr, DestroyMenu); + } else if (eventPtr->type == CTK_FOCUS_EVENT) { + menuPtr->flags |= GOT_FOCUS; + if (menuPtr->active != -1) { + EventuallyRedrawMenu(menuPtr, menuPtr->entries[menuPtr->active]); + } + } else if (eventPtr->type == CTK_UNFOCUS_EVENT) { + menuPtr->flags &= ~GOT_FOCUS; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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->accel = NULL; + mePtr->accelLength = 0; + mePtr->state = tkNormalUid; + mePtr->indicatorOn = 1; + 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; +} + +/* + *-------------------------------------------------------------- + * + * MenuVarProc -- + * + * This procedure is invoked when someone changes the + * state variable associated with a radiobutton or checkbutton + * menu entry. The entry's selected state is set to match + * the value of the variable. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The menu entry may become selected or deselected. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +MenuVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about menu entry. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* First part of variable's name. */ + char *name2; /* Second part of variable's name. */ + int flags; /* Describes what just happened. */ +{ + MenuEntry *mePtr = (MenuEntry *) clientData; + Menu *menuPtr; + char *value; + + menuPtr = mePtr->menuPtr; + + /* + * If the variable is being unset, then re-establish the + * trace unless the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + mePtr->flags &= ~ENTRY_SELECTED; + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar(interp, mePtr->name, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuVarProc, clientData); + } + EventuallyRedrawMenu(menuPtr, (MenuEntry *) NULL); + return (char *) NULL; + } + + /* + * Use the value of the variable to update the selected status of + * the menu entry. + */ + + 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; + } + mePtr->flags |= ENTRY_SELECTED; + } else if (mePtr->flags & ENTRY_SELECTED) { + mePtr->flags &= ~ENTRY_SELECTED; + } else { + return (char *) NULL; + } + EventuallyRedrawMenu(menuPtr, (MenuEntry *) NULL); + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * EventuallyRedrawMenu -- + * + * Arrange for an entry of a menu, or the whole menu, to be + * redisplayed at some point in the future. + * + * Results: + * None. + * + * Side effects: + * A when-idle hander is scheduled to do the redisplay, if there + * isn't one already scheduled. + * + *---------------------------------------------------------------------- + */ + +static void +EventuallyRedrawMenu(menuPtr, mePtr) + register Menu *menuPtr; /* Information about menu to redraw. */ + register MenuEntry *mePtr; /* Entry to redraw. NULL means redraw + * all the entries in the menu. */ +{ + int i; + if (menuPtr->tkwin == NULL) { + return; + } + if (mePtr != NULL) { + mePtr->flags |= ENTRY_NEEDS_REDISPLAY; + } else { + for (i = 0; i < menuPtr->numEntries; i++) { + menuPtr->entries[i]->flags |= ENTRY_NEEDS_REDISPLAY; + } + } + if ((menuPtr->tkwin == NULL) || !Tk_IsMapped(menuPtr->tkwin) + || (menuPtr->flags & REDRAW_PENDING)) { + return; + } + Tcl_DoWhenIdle(DisplayMenu, (ClientData) menuPtr); + menuPtr->flags |= REDRAW_PENDING; +} + +/* + *-------------------------------------------------------------- + * + * PostSubmenu -- + * + * This procedure arranges for a particular submenu (i.e. the + * menu corresponding to a given cascade entry) to be + * posted. + * + * Results: + * A standard Tcl return result. Errors may occur in the + * Tcl commands generated to post and unpost submenus. + * + * Side effects: + * If there is already a submenu posted, it is unposted. + * The new submenu is then posted. + * + *-------------------------------------------------------------- + */ + +static int +PostSubmenu(interp, menuPtr, mePtr) + Tcl_Interp *interp; /* Used for invoking sub-commands and + * reporting errors. */ + register Menu *menuPtr; /* Information about menu as a whole. */ + register MenuEntry *mePtr; /* Info about submenu that is to be + * posted. NULL means make sure that + * no submenu is posted. */ +{ + char string[30]; + int result, x, y, i; + + if (mePtr == menuPtr->postedCascade) { + return TCL_OK; + } + + if (menuPtr->postedCascade != NULL) { + EventuallyRedrawMenu(menuPtr, menuPtr->postedCascade); + result = Tcl_VarEval(interp, menuPtr->postedCascade->name, + " unpost", (char *) NULL); + menuPtr->postedCascade = NULL; + if (result != TCL_OK) { + return result; + } + } + + if ((mePtr != NULL) && (mePtr->name != NULL) + && Tk_IsMapped(menuPtr->tkwin)) { + /* + * Make sure that the cascaded submenu is a child of the + * parent menu. + */ + + if (Ctk_ParentByName(interp, mePtr->name, menuPtr->tkwin) + != menuPtr->tkwin) { + Tcl_AppendResult(interp, "cascaded sub-menu ", + mePtr->name, " 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). + */ + + for (i = 0; i < menuPtr->numEntries; i++) { + if (menuPtr->entries[i] == mePtr) break; + } + x = Ctk_AbsLeft(menuPtr->tkwin) + + (i/menuPtr->numRows + 1)*menuPtr->columnWidth + + menuPtr->borderWidth; + y = Ctk_AbsTop(menuPtr->tkwin) + (i%menuPtr->numRows) + + menuPtr->borderWidth; + sprintf(string, "%d %d", x, y); + result = Tcl_VarEval(interp, mePtr->name, " post ", string, + (char *) NULL); + if (result != TCL_OK) { + return result; + } + menuPtr->postedCascade = mePtr; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ActivateMenuEntry -- + * + * This procedure is invoked to make a particular menu entry + * the active one, deactivating any other entry that might + * currently be active. + * + * Results: + * The return value is a standard Tcl result (errors can occur + * while posting and unposting submenus). + * + * Side effects: + * Menu entries get redisplayed, and the active entry changes. + * Submenus may get posted and unposted. + * + *---------------------------------------------------------------------- + */ + +static int +ActivateMenuEntry(menuPtr, index) + register Menu *menuPtr; /* Menu in which to activate. */ + int index; /* Index of entry to activate, or + * -1 to deactivate all entries. */ +{ + register MenuEntry *mePtr; + int result = TCL_OK; + + if (menuPtr->active >= 0) { + mePtr = menuPtr->entries[menuPtr->active]; + + /* + * Don't change the state unless it's currently active (state + * might already have been changed to disabled). + */ + + if (mePtr->state == tkActiveUid) { + mePtr->state = tkNormalUid; + } + EventuallyRedrawMenu(menuPtr, menuPtr->entries[menuPtr->active]); + } + menuPtr->active = index; + if (index >= 0) { + mePtr = menuPtr->entries[index]; + mePtr->state = tkActiveUid; + EventuallyRedrawMenu(menuPtr, mePtr); + } + return result; +} ADDED tkMenubutton.c Index: tkMenubutton.c ================================================================== --- tkMenubutton.c +++ tkMenubutton.c @@ -0,0 +1,770 @@ +/* + * tkMenubutton.c (CTk) -- + * + * This module implements button-like widgets that are used + * to invoke pull-down menus. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "default.h" +#include "tkInt.h" + +/* + * A data structure of the following type is kept for each + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the widget. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + 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. */ + + /* + * Information about what's displayed in the menu button: + */ + + char *text; /* Text to display in button (malloc'ed) + * or NULL. */ + 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 + * of this variable. */ + + /* + * Information used when displaying widget: + */ + + Tk_Uid state; /* State of button for display purposes: + * normal, active, or disabled. */ + int borderWidth; /* Width of border. */ + 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. */ + + /* + * Miscellaneous 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. */ + int flags; /* Various flags; see below for + * definitions. */ +} MenuButton; + +/* + * Flag bits for buttons: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * 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 pixels (characters). + */ + +#define INDICATOR_WIDTH 1 + +/* + * Information used for parsing configuration specs: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_ANCHOR, "-anchor", "anchor", "Anchor", + DEF_MENUBUTTON_ANCHOR, Tk_Offset(MenuButton, anchor), 0}, + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_MENUBUTTON_BORDER_WIDTH, Tk_Offset(MenuButton, borderWidth), 0}, + {TK_CONFIG_INT, "-height", "height", "Height", + DEF_MENUBUTTON_HEIGHT, Tk_Offset(MenuButton, height), 0}, + {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}, + {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", + DEF_MENUBUTTON_PADX, Tk_Offset(MenuButton, padX), 0}, + {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", + DEF_MENUBUTTON_PADY, Tk_Offset(MenuButton, padY), 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", + DEF_MENUBUTTON_TEXT_VARIABLE, Tk_Offset(MenuButton, textVarName), + 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_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} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void ComputeMenuButtonGeometry _ANSI_ARGS_(( + MenuButton *mbPtr)); +static void MenuButtonCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void MenuButtonEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static char * MenuButtonTextVarProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + char *name1, char *name2, int flags)); +static int MenuButtonWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +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 DisplayMenuButton _ANSI_ARGS_((ClientData clientData)); + +/* + *-------------------------------------------------------------- + * + * Tk_MenubuttonCmd -- + * + * This procedure is invoked to process 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. + * + *-------------------------------------------------------------- + */ + +int +Tk_MenubuttonCmd(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. */ +{ + register MenuButton *mbPtr; + Tk_Window tkwin = (Tk_Window) clientData; + Tk_Window new; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Create the new window. + */ + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + /* + * Initialize the data structure for the button. + */ + + mbPtr = (MenuButton *) ckalloc(sizeof(MenuButton)); + mbPtr->tkwin = new; + mbPtr->interp = interp; + mbPtr->widgetCmd = Tcl_CreateCommand(interp, Tk_PathName(mbPtr->tkwin), + MenuButtonWidgetCmd, (ClientData) mbPtr, MenuButtonCmdDeletedProc); + mbPtr->menuName = NULL; + mbPtr->text = NULL; + mbPtr->numChars = 0; + mbPtr->underline = -1; + mbPtr->textVarName = NULL; + mbPtr->state = tkNormalUid; + mbPtr->borderWidth = 0; + mbPtr->width = 0; + mbPtr->height = 0; + mbPtr->wrapLength = 0; + mbPtr->padX = 0; + mbPtr->padY = 0; + mbPtr->anchor = TK_ANCHOR_CENTER; + mbPtr->justify = TK_JUSTIFY_CENTER; + mbPtr->indicatorOn = 0; + mbPtr->takeFocus = NULL; + mbPtr->flags = 0; + + Tk_SetClass(mbPtr->tkwin, "Menubutton"); + Tk_CreateEventHandler(mbPtr->tkwin, + CTK_EXPOSE_EVENT_MASK|CTK_DESTROY_EVENT_MASK|CTK_FOCUS_EVENT_MASK, + MenuButtonEventProc, (ClientData) mbPtr); + if (ConfigureMenuButton(interp, mbPtr, argc-2, argv+2, 0) != TCL_OK) { + Tk_DestroyWindow(mbPtr->tkwin); + return TCL_ERROR; + } + + Tcl_SetResult(interp,Tk_PathName(mbPtr->tkwin),TCL_VOLATILE); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * MenuButtonWidgetCmd -- + * + * 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 +MenuButtonWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about button widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register MenuButton *mbPtr = (MenuButton *) 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; + } + Tk_Preserve((ClientData) mbPtr); + 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, 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); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, mbPtr->tkwin, configSpecs, + (char *) mbPtr, argv[2], 0); + } else { + result = ConfigureMenuButton(interp, mbPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cget or configure", + (char *) NULL); + goto error; + } + Tk_Release((ClientData) mbPtr); + return result; + + error: + Tk_Release((ClientData) mbPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyMenuButton -- + * + * This procedure is invoked to recycle all of the resources + * associated with a button widget. It is invoked as a + * when-idle handler in order to make sure that there is no + * other use of the button pending at the time of the deletion. + * + * Results: + * None. + * + * Side effects: + * Everything associated with the widget is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyMenuButton(clientData) + ClientData clientData; /* Info about button widget. */ +{ + register MenuButton *mbPtr = (MenuButton *) clientData; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + if (mbPtr->textVarName != NULL) { + Tcl_UntraceVar(mbPtr->interp, mbPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuButtonTextVarProc, (ClientData) mbPtr); + } + Tk_FreeOptions(configSpecs, (char *) mbPtr, 0); + ckfree((char *) mbPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureMenuButton -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a menubutton 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 mbPtr; old resources get freed, if there + * were any. The menubutton is redisplayed. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureMenuButton(interp, mbPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register MenuButton *mbPtr; /* 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 result; + + /* + * Eliminate any existing trace on variables monitored by the menubutton. + */ + + if (mbPtr->textVarName != NULL) { + Tcl_UntraceVar(interp, mbPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuButtonTextVarProc, (ClientData) mbPtr); + } + + result = Tk_ConfigureWidget(interp, mbPtr->tkwin, configSpecs, + argc, argv, (char *) mbPtr, flags); + if (result != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few options need special processing. + */ + + 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); + mbPtr->state = tkNormalUid; + return TCL_ERROR; + } + + if (mbPtr->padX < 0) { + mbPtr->padX = 0; + } + if (mbPtr->padY < 0) { + mbPtr->padY = 0; + } + + if (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); + if (value == NULL) { + Tcl_SetVar(interp, mbPtr->textVarName, mbPtr->text, + TCL_GLOBAL_ONLY); + } else { + if (mbPtr->text != NULL) { + ckfree(mbPtr->text); + } + mbPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(mbPtr->text, value); + } + Tcl_TraceVar(interp, mbPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuButtonTextVarProc, (ClientData) mbPtr); + } + + /* + * Recompute the geometry for the button. + */ + ComputeMenuButtonGeometry(mbPtr); + + /* + * Lastly, arrange for the button to be redisplayed. + */ + + if (Tk_IsMapped(mbPtr->tkwin) && !(mbPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); + mbPtr->flags |= REDRAW_PENDING; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DisplayMenuButton -- + * + * This procedure is invoked to display a menubutton widget. + * + * Results: + * None. + * + * Side effects: + * Commands are output to X to display the menubutton in its + * current mode. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayMenuButton(clientData) + ClientData clientData; /* Information about widget. */ +{ + register MenuButton *mbPtr = (MenuButton *) clientData; + register Tk_Window tkwin = mbPtr->tkwin; + Ctk_Style style; + int x, y; + unsigned int width = Tk_Width(tkwin); + unsigned int height = Tk_Height(tkwin); + int indicatorSpace = (mbPtr->indicatorOn) ? INDICATOR_WIDTH : 0; + + mbPtr->flags &= ~REDRAW_PENDING; + if ((tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + + style = (mbPtr->state == tkDisabledUid) + ? CTK_DISABLED_STYLE : CTK_BUTTON_STYLE; + + 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 = (width - indicatorSpace - mbPtr->textWidth)/2; + break; + default: + x = width - mbPtr->borderWidth - mbPtr->padX - indicatorSpace + - mbPtr->textWidth; + 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 = (height - mbPtr->textHeight)/2; + break; + default: + y = height - mbPtr->borderWidth - mbPtr->padY - mbPtr->textHeight; + break; + } + + /* + * Clear rect. + */ + Ctk_FillRect(tkwin, 0, 0, width, height, style, ' '); + + /* + * Draw text. + */ + TkDisplayText(tkwin, style, mbPtr->text, mbPtr->numChars, + x, y, mbPtr->textWidth, mbPtr->justify, mbPtr->underline); + + /* + * Draw Indicator. + */ + if (indicatorSpace) { + x = width - mbPtr->borderWidth - mbPtr->padX - indicatorSpace; + y += mbPtr->textHeight/2; + Ctk_DrawCharacter(tkwin, x, y, style, '^'); + } + + /* + * Draw border. + */ + Ctk_DrawBorder(tkwin, style, (char *)NULL); + + /* + * Position cursor. + */ + if (mbPtr->flags & GOT_FOCUS) { + Ctk_SetCursor(tkwin, mbPtr->borderWidth, mbPtr->borderWidth); + } +} + +/* + *-------------------------------------------------------------- + * + * MenuButtonEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on buttons. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +MenuButtonEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + MenuButton *mbPtr = (MenuButton *) clientData; + if (eventPtr->type == CTK_EXPOSE_EVENT) { + if ((mbPtr->tkwin != NULL) && !(mbPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); + mbPtr->flags |= REDRAW_PENDING; + } + } else if (eventPtr->type == CTK_DESTROY_EVENT) { + if (mbPtr->tkwin != NULL) { + mbPtr->tkwin = NULL; + Tcl_DeleteCommand(mbPtr->interp, + Tcl_GetCommandName(mbPtr->interp, mbPtr->widgetCmd)); + } + if (mbPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayMenuButton, (ClientData) mbPtr); + } + Tk_EventuallyFree((ClientData) mbPtr, DestroyMenuButton); + } else if (eventPtr->type == CTK_FOCUS_EVENT) { + mbPtr->flags |= GOT_FOCUS; + Ctk_SetCursor(mbPtr->tkwin, mbPtr->borderWidth, mbPtr->borderWidth); + } else if (eventPtr->type == CTK_UNFOCUS_EVENT) { + mbPtr->flags &= ~GOT_FOCUS; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * ComputeMenuButtonGeometry -- + * + * After changes in a menu button's text or bitmap, this procedure + * recomputes the menu button's geometry and passes this information + * along to the geometry manager for the window. + * + * Results: + * None. + * + * Side effects: + * The menu button's window may change size. + * + *---------------------------------------------------------------------- + */ + +static void +ComputeMenuButtonGeometry(mbPtr) + register MenuButton *mbPtr; /* Widget record for menu button. */ +{ + int width, height; + int indicatorSpace = (mbPtr->indicatorOn) ? INDICATOR_WIDTH : 0; + + mbPtr->numChars = strlen(mbPtr->text); + TkComputeTextGeometry(mbPtr->text, mbPtr->numChars, + mbPtr->wrapLength, + &mbPtr->textWidth, &mbPtr->textHeight); + width = mbPtr->width; + if (width < 0) { + width = mbPtr->textWidth; + } + height = mbPtr->height; + if (height < 0) { + height = mbPtr->textHeight; + } + width += 2*mbPtr->padX; + height += 2*mbPtr->padY; + + Tk_GeometryRequest(mbPtr->tkwin, + width + indicatorSpace + 2*mbPtr->borderWidth, + height + 2*mbPtr->borderWidth); +} + +/* + *-------------------------------------------------------------- + * + * MenuButtonTextVarProc -- + * + * This procedure is invoked when someone changes the variable + * whose contents are to be displayed in a menu button. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The text displayed in the menu button will change to match the + * variable. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +MenuButtonTextVarProc(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 MenuButton *mbPtr = (MenuButton *) clientData; + char *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_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_GetVar(interp, mbPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + if (mbPtr->text != NULL) { + ckfree(mbPtr->text); + } + 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)) { + Tcl_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); + mbPtr->flags |= REDRAW_PENDING; + } + return (char *) NULL; +} ADDED tkOption.c Index: tkOption.c ================================================================== --- tkOption.c +++ tkOption.c @@ -0,0 +1,1369 @@ +/* + * tkOption.c (Ctk) -- + * + * This module contains procedures to manage the option + * database, which allows various strings to be associated + * with windows either by name or by class or both. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1995 Cleveland Clinic Foundation + * adapted from tk4.2b1 by JuanJo + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * The option database is stored as one tree for each main window. + * Each name or class field in an option is associated with a node or + * leaf of the tree. For example, the options "x.y.z" and "x.y*a" + * each correspond to three nodes in the tree; they share the nodes + * "x" and "x.y", but have different leaf nodes. One of the following + * structures exists for each node or leaf in the option tree. It is + * actually stored as part of the parent node, and describes a particular + * child of the parent. + */ + +typedef struct Element { + Tk_Uid nameUid; /* Name or class from one element of + * an option spec. */ + union { + struct ElArray *arrayPtr; /* If this is an intermediate node, + * a pointer to a structure describing + * the remaining elements of all + * options whose prefixes are the + * same up through this element. */ + Tk_Uid valueUid; /* For leaf nodes, this is the string + * value of the option. */ + } child; + int priority; /* Used to select among matching + * options. Includes both the + * priority level and a serial #. + * Greater value means higher + * priority. Irrelevant except in + * leaf nodes. */ + int flags; /* OR-ed combination of bits. See + * below for values. */ +} Element; + +/* + * Flags in Element structures: + * + * CLASS - Non-zero means this element refers to a class, + * Zero means this element refers to a name. + * NODE - Zero means this is a leaf element (the child + * field is a value, not a pointer to another node). + * One means this is a node element. + * WILDCARD - Non-zero means this there was a star in the + * original specification just before this element. + * Zero means there was a dot. + */ + +#define TYPE_MASK 0x7 + +#define CLASS 0x1 +#define NODE 0x2 +#define WILDCARD 0x4 + +#define EXACT_LEAF_NAME 0x0 +#define EXACT_LEAF_CLASS 0x1 +#define EXACT_NODE_NAME 0x2 +#define EXACT_NODE_CLASS 0x3 +#define WILDCARD_LEAF_NAME 0x4 +#define WILDCARD_LEAF_CLASS 0x5 +#define WILDCARD_NODE_NAME 0x6 +#define WILDCARD_NODE_CLASS 0x7 + +/* + * The following structure is used to manage a dynamic array of + * Elements. These structures are used for two purposes: to store + * the contents of a node in the option tree, and for the option + * stacks described below. + */ + +typedef struct ElArray { + int arraySize; /* Number of elements actually + * allocated in the "els" array. */ + int numUsed; /* Number of elements currently in + * use out of els. */ + Element *nextToUse; /* Pointer to &els[numUsed]. */ + Element els[1]; /* Array of structures describing + * children of this node. The + * array will actually contain enough + * elements for all of the children + * (and even a few extras, perhaps). + * This must be the last field in + * the structure. */ +} ElArray; + +#define EL_ARRAY_SIZE(numEls) ((unsigned) (sizeof(ElArray) \ + + ((numEls)-1)*sizeof(Element))) +#define INITIAL_SIZE 5 + +/* + * In addition to the option tree, which is a relatively static structure, + * there are eight additional structures called "stacks", which are used + * to speed up queries into the option database. The stack structures + * are designed for the situation where an individual widget makes repeated + * requests for its particular options. The requests differ only in + * their last name/class, so during the first request we extract all + * the options pertaining to the particular widget and save them in a + * stack-like cache; subsequent requests for the same widget can search + * the cache relatively quickly. In fact, the cache is a hierarchical + * one, storing a list of relevant options for this widget and all of + * its ancestors up to the application root; hence the name "stack". + * + * Each of the eight stacks consists of an array of Elements, ordered in + * terms of levels in the window hierarchy. All the elements relevant + * for the top-level widget appear first in the array, followed by all + * those from the next-level widget on the path to the current widget, + * etc. down to those for the current widget. + * + * Cached information is divided into eight stacks according to the + * CLASS, NODE, and WILDCARD flags. Leaf and non-leaf information is + * kept separate to speed up individual probes (non-leaf information is + * only relevant when building the stacks, but isn't relevant when + * making probes; similarly, only non-leaf information is relevant + * when the stacks are being extended to the next widget down in the + * widget hierarchy). Wildcard elements are handled separately from + * "exact" elements because once they appear at a particular level in + * the stack they remain active for all deeper levels; exact elements + * are only relevant at a particular level. For example, when searching + * for options relevant in a particular window, the entire wildcard + * stacks get checked, but only the portions of the exact stacks that + * pertain to the window's parent. Lastly, name and class stacks are + * kept separate because different search keys are used when searching + * them; keeping them separate speeds up the searches. + */ + +#define NUM_STACKS 8 +static ElArray *stacks[NUM_STACKS]; +static TkWindow *cachedWindow = NULL; /* Lowest-level window currently + * loaded in stacks at present. + * NULL means stacks have never + * been used, or have been + * invalidated because of a change + * to the database. */ + +/* + * One of the following structures is used to keep track of each + * level in the stacks. + */ + +typedef struct StackLevel { + TkWindow *winPtr; /* Window corresponding to this stack + * level. */ + int bases[NUM_STACKS]; /* For each stack, index of first + * element on stack corresponding to + * this level (used to restore "numUsed" + * fields when popping out of a level. */ +} StackLevel; + +/* + * Information about all of the stack levels that are currently + * active. This array grows dynamically to become as large as needed. + */ + +static StackLevel *levels = NULL; + /* Array describing current stack. */ +static int numLevels = 0; /* Total space allocated. */ +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 + * the database so far. It increments on each addition to the option + * database. It is used in computing option priorities, so that the + * most recent entry wins when choosing between options at the same + * priority level. + */ + +static int serial = 0; + +/* + * Special "no match" Element to use as default for searches. + */ + +static Element defaultMatch; + +/* + * Forward declarations for procedures defined in this file: + */ + +static int AddFromString _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string, int priority)); +static void ClearOptionTree _ANSI_ARGS_((ElArray *arrayPtr)); +static ElArray * ExtendArray _ANSI_ARGS_((ElArray *arrayPtr, + Element *elPtr)); +static void ExtendStacks _ANSI_ARGS_((ElArray *arrayPtr, + int leaf)); +static int GetDefaultOptions _ANSI_ARGS_((Tcl_Interp *interp, + TkWindow *winPtr)); +static ElArray * NewArray _ANSI_ARGS_((int numEls)); +static void OptionInit _ANSI_ARGS_((TkMainInfo *mainPtr)); +static int ParsePriority _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +static int ReadOptionFile _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *fileName, int priority)); +static void SetupStacks _ANSI_ARGS_((TkWindow *winPtr, int leaf)); + +/* + *-------------------------------------------------------------- + * + * Tk_AddOption -- + * + * Add a new option to the option database. + * + * Results: + * None. + * + * Side effects: + * Information is added to the option database. + * + *-------------------------------------------------------------- + */ + +void +Tk_AddOption(tkwin, name, value, priority) + Tk_Window tkwin; /* Window token; option will be associated + * with main window for this window. */ + char *name; /* Multi-element name of option. */ + char *value; /* String value for option. */ + int priority; /* Overall priority level to use for + * this option, such as TK_USER_DEFAULT_PRIO + * or TK_INTERACTIVE_PRIO. Must be between + * 0 and TK_MAX_PRIO. */ +{ + TkWindow *winPtr = ((TkWindow *) tkwin)->mainPtr->winPtr; + register ElArray **arrayPtrPtr; + register Element *elPtr; + Element newEl; + register char *p; + char *field; + int count, firstField, length; +#define TMP_SIZE 100 + char tmp[TMP_SIZE+1]; + + if (winPtr->mainPtr->optionRootPtr == NULL) { + OptionInit(winPtr->mainPtr); + } + cachedWindow = NULL; /* Invalidate the cache. */ + + /* + * Compute the priority for the new element, including both the + * overall level and the serial number (to disambiguate with the + * level). + */ + + if (priority < 0) { + priority = 0; + } else if (priority > TK_MAX_PRIO) { + priority = TK_MAX_PRIO; + } + newEl.priority = (priority << 24) + serial; + serial++; + + /* + * Parse the option one field at a time. + */ + + arrayPtrPtr = &(((TkWindow *) tkwin)->mainPtr->optionRootPtr); + p = name; + for (firstField = 1; ; firstField = 0) { + + /* + * Scan the next field from the name and convert it to a Tk_Uid. + * Must copy the field before calling Tk_Uid, so that a terminating + * NULL may be added without modifying the source string. + */ + + if (*p == '*') { + newEl.flags = WILDCARD; + p++; + } else { + newEl.flags = 0; + } + field = p; + while ((*p != 0) && (*p != '.') && (*p != '*')) { + p++; + } + length = p - field; + if (length > TMP_SIZE) { + length = TMP_SIZE; + } + strncpy(tmp, field, (size_t) length); + tmp[length] = 0; + newEl.nameUid = Tk_GetUid(tmp); + if (isupper(UCHAR(*field))) { + newEl.flags |= CLASS; + } + + if (*p != 0) { + + /* + * New element will be a node. If this option can't possibly + * apply to this main window, then just skip it. Otherwise, + * add it to the parent, if it isn't already there, and descend + * into it. + */ + + newEl.flags |= NODE; + if (firstField && !(newEl.flags & WILDCARD) + && (newEl.nameUid != winPtr->nameUid) + && (newEl.nameUid != winPtr->classUid)) { + return; + } + for (elPtr = (*arrayPtrPtr)->els, count = (*arrayPtrPtr)->numUsed; + ; elPtr++, count--) { + if (count == 0) { + newEl.child.arrayPtr = NewArray(5); + *arrayPtrPtr = ExtendArray(*arrayPtrPtr, &newEl); + arrayPtrPtr = &((*arrayPtrPtr)->nextToUse[-1].child.arrayPtr); + break; + } + if ((elPtr->nameUid == newEl.nameUid) + && (elPtr->flags == newEl.flags)) { + arrayPtrPtr = &(elPtr->child.arrayPtr); + break; + } + } + if (*p == '.') { + p++; + } + } else { + + /* + * New element is a leaf. Add it to the parent, if it isn't + * already there. If it exists already, keep whichever value + * has highest priority. + */ + + newEl.child.valueUid = Tk_GetUid(value); + for (elPtr = (*arrayPtrPtr)->els, count = (*arrayPtrPtr)->numUsed; + ; elPtr++, count--) { + if (count == 0) { + *arrayPtrPtr = ExtendArray(*arrayPtrPtr, &newEl); + return; + } + if ((elPtr->nameUid == newEl.nameUid) + && (elPtr->flags == newEl.flags)) { + if (elPtr->priority < newEl.priority) { + elPtr->priority = newEl.priority; + elPtr->child.valueUid = newEl.child.valueUid; + } + return; + } + } + } + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetOption -- + * + * Retrieve an option from the option database. + * + * Results: + * The return value is the value specified in the option + * database for the given name and class on the given + * window. If there is nothing specified in the database + * for that option, then NULL is returned. + * + * Side effects: + * The internal caches used to speed up option mapping + * may be modified, if this tkwin is different from the + * last tkwin used for option retrieval. + * + *-------------------------------------------------------------- + */ + +Tk_Uid +Tk_GetOption(tkwin, name, className) + Tk_Window tkwin; /* Token for window that option is + * associated with. */ + char *name; /* Name of option. */ + char *className; /* Class of option. NULL means there + * is no class for this option: just + * check for name. */ +{ + Tk_Uid nameId, classId; + register Element *elPtr, *bestPtr; + register int count; + + /* + * Note: no need to call OptionInit here: it will be done by + * the SetupStacks call below (squeeze out those nanoseconds). + */ + + if (tkwin != (Tk_Window) cachedWindow) { + SetupStacks((TkWindow *) tkwin, 1); + } + + nameId = Tk_GetUid(name); + bestPtr = &defaultMatch; + for (elPtr = stacks[EXACT_LEAF_NAME]->els, + count = stacks[EXACT_LEAF_NAME]->numUsed; count > 0; + elPtr++, count--) { + if ((elPtr->nameUid == nameId) + && (elPtr->priority > bestPtr->priority)) { + bestPtr = elPtr; + } + } + for (elPtr = stacks[WILDCARD_LEAF_NAME]->els, + count = stacks[WILDCARD_LEAF_NAME]->numUsed; count > 0; + elPtr++, count--) { + if ((elPtr->nameUid == nameId) + && (elPtr->priority > bestPtr->priority)) { + bestPtr = elPtr; + } + } + if (className != NULL) { + classId = Tk_GetUid(className); + for (elPtr = stacks[EXACT_LEAF_CLASS]->els, + count = stacks[EXACT_LEAF_CLASS]->numUsed; count > 0; + elPtr++, count--) { + if ((elPtr->nameUid == classId) + && (elPtr->priority > bestPtr->priority)) { + bestPtr = elPtr; + } + } + for (elPtr = stacks[WILDCARD_LEAF_CLASS]->els, + count = stacks[WILDCARD_LEAF_CLASS]->numUsed; count > 0; + elPtr++, count--) { + if ((elPtr->nameUid == classId) + && (elPtr->priority > bestPtr->priority)) { + bestPtr = elPtr; + } + } + } + return bestPtr->child.valueUid; +} + +/* + *-------------------------------------------------------------- + * + * Tk_OptionCmd -- + * + * This procedure is invoked to process the "option" 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_OptionCmd(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; + size_t length; + char c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "add", length) == 0)) { + int priority; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " add pattern value ?priority?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + priority = TK_INTERACTIVE_PRIO; + } else { + priority = ParsePriority(interp, argv[4]); + if (priority < 0) { + return TCL_ERROR; + } + } + Tk_AddOption(tkwin, argv[2], argv[3], priority); + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "clear", length) == 0)) { + TkMainInfo *mainPtr; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " clear\"", (char *) NULL); + return TCL_ERROR; + } + mainPtr = ((TkWindow *) tkwin)->mainPtr; + if (mainPtr->optionRootPtr != NULL) { + ClearOptionTree(mainPtr->optionRootPtr); + mainPtr->optionRootPtr = NULL; + } + cachedWindow = NULL; + return TCL_OK; + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + Tk_Window window; + Tk_Uid value; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get window name class\"", (char *) NULL); + return TCL_ERROR; + } + window = Tk_NameToWindow(interp, argv[2], tkwin); + if (window == NULL) { + return TCL_ERROR; + } + value = Tk_GetOption(window, argv[3], argv[4]); + if (value != NULL) { + Tcl_SetResult(interp,value,TCL_VOLATILE); + } + return TCL_OK; + } else if ((c == 'r') && (strncmp(argv[1], "readfile", length) == 0)) { + int priority; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " readfile fileName ?priority?\"", + (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + priority = ParsePriority(interp, argv[3]); + if (priority < 0) { + return TCL_ERROR; + } + } else { + priority = TK_INTERACTIVE_PRIO; + } + return ReadOptionFile(interp, tkwin, argv[2], priority); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be add, clear, get, or readfile", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *-------------------------------------------------------------- + * + * TkOptionDeadWindow -- + * + * This procedure is called whenever a window is deleted. + * It cleans up any option-related stuff associated with + * the window. + * + * Results: + * None. + * + * Side effects: + * Option-related resources are freed. See code below + * for details. + * + *-------------------------------------------------------------- + */ + +void +TkOptionDeadWindow(winPtr) + register TkWindow *winPtr; /* Window to be cleaned up. */ +{ + /* + * If this window is in the option stacks, then clear the stacks. + */ + + if (winPtr->optionLevel != -1) { + int i; + + for (i = 1; i <= curLevel; i++) { + levels[i].winPtr->optionLevel = -1; + } + curLevel = -1; + cachedWindow = NULL; + } + + /* + * If this window was a main window, then delete its option + * database. + */ + + if ((winPtr->mainPtr->winPtr == winPtr) + && (winPtr->mainPtr->optionRootPtr != NULL)) { + ClearOptionTree(winPtr->mainPtr->optionRootPtr); + winPtr->mainPtr->optionRootPtr = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ParsePriority -- + * + * Parse a string priority value. + * + * Results: + * The return value is the integer priority level corresponding + * to string, or -1 if string doesn't point to a valid priority level. + * In this case, an error message is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParsePriority(interp, string) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *string; /* Describes a priority level, either + * symbolically or numerically. */ +{ + int priority, c; + size_t length; + + c = string[0]; + length = strlen(string); + if ((c == 'w') + && (strncmp(string, "widgetDefault", length) == 0)) { + return TK_WIDGET_DEFAULT_PRIO; + } else if ((c == 's') + && (strncmp(string, "startupFile", length) == 0)) { + return TK_STARTUP_FILE_PRIO; + } else if ((c == 'u') + && (strncmp(string, "userDefault", length) == 0)) { + return TK_USER_DEFAULT_PRIO; + } else if ((c == 'i') + && (strncmp(string, "interactive", length) == 0)) { + return TK_INTERACTIVE_PRIO; + } else { + char *end; + + priority = strtoul(string, &end, 0); + if ((end == string) || (*end != 0) || (priority < 0) + || (priority > 100)) { + Tcl_AppendResult(interp, "bad priority level \"", string, + "\": must be widgetDefault, startupFile, userDefault, ", + "interactive, or a number between 0 and 100", + (char *) NULL); + return -1; + } + } + return priority; +} + +/* + *---------------------------------------------------------------------- + * + * AddFromString -- + * + * Given a string containing lines in the standard format for + * X resources (see other documentation for details on what this + * is), parse the resource specifications and enter them as options + * for tkwin's main window. + * + * Results: + * The return value is a standard Tcl return code. In the case of + * an error in parsing string, TCL_ERROR will be returned and an + * error message will be left in interp->result. The memory at + * string is totally trashed by this procedure. If you care about + * its contents, make a copy before calling here. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +AddFromString(interp, tkwin, string, priority) + Tcl_Interp *interp; /* Interpreter to use for reporting results. */ + Tk_Window tkwin; /* Token for window: options are entered + * for this window's main window. */ + char *string; /* String containing option specifiers. */ + int priority; /* Priority level to use for options in + * this string, such as TK_USER_DEFAULT_PRIO + * or TK_INTERACTIVE_PRIO. Must be between + * 0 and TK_MAX_PRIO. */ +{ + register char *src, *dst; + char *name, *value; + int lineNum; + + src = string; + lineNum = 1; + while (1) { + + /* + * Skip leading white space and empty lines and comment lines, and + * check for the end of the spec. + */ + + while ((*src == ' ') || (*src == '\t')) { + src++; + } + if ((*src == '#') || (*src == '!')) { + do { + src++; + if ((src[0] == '\\') && (src[1] == '\n')) { + src += 2; + lineNum++; + } + } while ((*src != '\n') && (*src != 0)); + } + if (*src == '\n') { + src++; + lineNum++; + continue; + } + if (*src == '\0') { + break; + } + + /* + * Parse off the option name, collapsing out backslash-newline + * sequences of course. + */ + + dst = name = src; + while (*src != ':') { + if ((*src == '\0') || (*src == '\n')) { + char buffer[100]; + sprintf(buffer, "missing colon on line %d", + lineNum); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + return TCL_ERROR; + } + if ((src[0] == '\\') && (src[1] == '\n')) { + src += 2; + lineNum++; + } else { + *dst = *src; + dst++; + src++; + } + } + + /* + * Eliminate trailing white space on the name, and null-terminate + * it. + */ + + while ((dst != name) && ((dst[-1] == ' ') || (dst[-1] == '\t'))) { + dst--; + } + *dst = '\0'; + + /* + * Skip white space between the name and the value. + */ + + src++; + while ((*src == ' ') || (*src == '\t')) { + src++; + } + if (*src == '\0') { + char buffer[100]; + sprintf(buffer, "missing value on line %d", lineNum); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + return TCL_ERROR; + } + + /* + * Parse off the value, squeezing out backslash-newline sequences + * along the way. + */ + + dst = value = src; + while (*src != '\n') { + if (*src == '\0') { + char buffer[100]; + sprintf(buffer, "missing newline on line %d", + lineNum); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + return TCL_ERROR; + } + if ((src[0] == '\\') && (src[1] == '\n')) { + src += 2; + lineNum++; + } else { + *dst = *src; + dst++; + src++; + } + } + *dst = 0; + + /* + * Enter the option into the database. + */ + + Tk_AddOption(tkwin, name, value, priority); + src++; + lineNum++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ReadOptionFile -- + * + * Read a file of options ("resources" in the old X terminology) + * and load them into the option database. + * + * Results: + * The return value is a standard Tcl return code. In the case of + * an error in parsing string, TCL_ERROR will be returned and an + * error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ReadOptionFile(interp, tkwin, fileName, priority) + Tcl_Interp *interp; /* Interpreter to use for reporting results. */ + Tk_Window tkwin; /* Token for window: options are entered + * for this window's main window. */ + char *fileName; /* Name of file containing options. */ + int priority; /* Priority level to use for options in + * this file, such as TK_USER_DEFAULT_PRIO + * or TK_INTERACTIVE_PRIO. Must be between + * 0 and TK_MAX_PRIO. */ +{ + char *realName, *buffer; + int result, bufferSize; + Tcl_Channel chan; + Tcl_DString newName; + + Tcl_DStringInit(&newName); + realName = Tcl_TranslateFileName(interp, fileName, &newName); + if (realName == NULL) { + return TCL_ERROR; + } + chan = Tcl_OpenFileChannel(interp, realName, "r", 0); + Tcl_DStringFree(&newName); + if (chan == NULL) { + return TCL_ERROR; + } + + /* + * 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; + } + Tcl_Close(NULL, chan); + buffer[bufferSize] = 0; + + result = AddFromString(interp, tkwin, buffer, priority); + ckfree(buffer); + return result; +} + +/* + *-------------------------------------------------------------- + * + * NewArray -- + * + * Create a new ElArray structure of a given size. + * + * Results: + * The return value is a pointer to a properly initialized + * element array with "numEls" space. The array is marked + * as having no active elements. + * + * Side effects: + * Memory is allocated. + * + *-------------------------------------------------------------- + */ + +static ElArray * +NewArray(numEls) + int numEls; /* How many elements of space to allocate. */ +{ + register ElArray *arrayPtr; + + arrayPtr = (ElArray *) ckalloc(EL_ARRAY_SIZE(numEls)); + arrayPtr->arraySize = numEls; + arrayPtr->numUsed = 0; + arrayPtr->nextToUse = arrayPtr->els; + return arrayPtr; +} + +/* + *-------------------------------------------------------------- + * + * ExtendArray -- + * + * Add a new element to an array, extending the array if + * necessary. + * + * Results: + * The return value is a pointer to the new array, which + * will be different from arrayPtr if the array got expanded. + * + * Side effects: + * Memory may be allocated or freed. + * + *-------------------------------------------------------------- + */ + +static ElArray * +ExtendArray(arrayPtr, elPtr) + register ElArray *arrayPtr; /* Array to be extended. */ + register Element *elPtr; /* Element to be copied into array. */ +{ + /* + * If the current array has filled up, make it bigger. + */ + + if (arrayPtr->numUsed >= arrayPtr->arraySize) { + register ElArray *newPtr; + + newPtr = (ElArray *) ckalloc(EL_ARRAY_SIZE(2*arrayPtr->arraySize)); + newPtr->arraySize = 2*arrayPtr->arraySize; + newPtr->numUsed = arrayPtr->numUsed; + newPtr->nextToUse = &newPtr->els[newPtr->numUsed]; + memcpy((VOID *) newPtr->els, (VOID *) arrayPtr->els, + (arrayPtr->arraySize*sizeof(Element))); + ckfree((char *) arrayPtr); + arrayPtr = newPtr; + } + + *arrayPtr->nextToUse = *elPtr; + arrayPtr->nextToUse++; + arrayPtr->numUsed++; + return arrayPtr; +} + +/* + *-------------------------------------------------------------- + * + * SetupStacks -- + * + * Arrange the stacks so that they cache all the option + * information for a particular window. + * + * Results: + * None. + * + * Side effects: + * The stacks are modified to hold information for tkwin + * and all its ancestors in the window hierarchy. + * + *-------------------------------------------------------------- + */ + +static void +SetupStacks(winPtr, leaf) + TkWindow *winPtr; /* Window for which information is to + * be cached. */ + int leaf; /* Non-zero means this is the leaf + * window being probed. Zero means this + * is an ancestor of the desired leaf. */ +{ + int level, i, *iPtr; + register StackLevel *levelPtr; + register ElArray *arrayPtr; + + /* + * The following array defines the order in which the current + * stacks are searched to find matching entries to add to the + * stacks. Given the current priority-based scheme, the order + * below is no longer relevant; all that matters is that an + * element is on the list *somewhere*. The ordering is a relic + * of the old days when priorities were determined differently. + */ + + static int searchOrder[] = {WILDCARD_NODE_CLASS, WILDCARD_NODE_NAME, + EXACT_NODE_CLASS, EXACT_NODE_NAME, -1}; + + if (winPtr->mainPtr->optionRootPtr == NULL) { + OptionInit(winPtr->mainPtr); + } + + /* + * Step 1: make sure that options are cached for this window's + * parent. + */ + + if (winPtr->parentPtr && winPtr->parentPtr->parentPtr) { + level = winPtr->parentPtr->optionLevel; + if ((level == -1) || (cachedWindow == NULL)) { + SetupStacks(winPtr->parentPtr, 0); + level = winPtr->parentPtr->optionLevel; + } + level++; + } else { + level = 1; + } + + /* + * Step 2: pop extra unneeded information off the stacks and + * mark those windows as no longer having cached information. + */ + + if (curLevel >= level) { + while (curLevel >= level) { + levels[curLevel].winPtr->optionLevel = -1; + curLevel--; + } + levelPtr = &levels[level]; + for (i = 0; i < NUM_STACKS; i++) { + arrayPtr = stacks[i]; + arrayPtr->numUsed = levelPtr->bases[i]; + arrayPtr->nextToUse = &arrayPtr->els[arrayPtr->numUsed]; + } + } + curLevel = winPtr->optionLevel = level; + + /* + * Step 3: if the root database information isn't loaded or + * isn't valid, initialize level 0 of the stack from the + * database root (this only happens if winPtr is a main window). + */ + + if ((curLevel == 1) + && ((cachedWindow == NULL) + || (cachedWindow->mainPtr != winPtr->mainPtr))) { + for (i = 0; i < NUM_STACKS; i++) { + arrayPtr = stacks[i]; + arrayPtr->numUsed = 0; + arrayPtr->nextToUse = arrayPtr->els; + } + ExtendStacks(winPtr->mainPtr->optionRootPtr, 0); + } + + /* + * Step 4: create a new stack level; grow the level array if + * we've run out of levels. Clear the stacks for EXACT_LEAF_NAME + * and EXACT_LEAF_CLASS (anything that was there is of no use + * any more). + */ + + if (curLevel >= numLevels) { + StackLevel *newLevels; + + newLevels = (StackLevel *) ckalloc((unsigned) + (numLevels*2*sizeof(StackLevel))); + memcpy((VOID *) newLevels, (VOID *) levels, + (numLevels*sizeof(StackLevel))); + ckfree((char *) levels); + numLevels *= 2; + levels = newLevels; + } + levelPtr = &levels[curLevel]; + levelPtr->winPtr = winPtr; + arrayPtr = stacks[EXACT_LEAF_NAME]; + arrayPtr->numUsed = 0; + arrayPtr->nextToUse = arrayPtr->els; + arrayPtr = stacks[EXACT_LEAF_CLASS]; + arrayPtr->numUsed = 0; + arrayPtr->nextToUse = arrayPtr->els; + levelPtr->bases[EXACT_LEAF_NAME] = stacks[EXACT_LEAF_NAME]->numUsed; + levelPtr->bases[EXACT_LEAF_CLASS] = stacks[EXACT_LEAF_CLASS]->numUsed; + levelPtr->bases[EXACT_NODE_NAME] = stacks[EXACT_NODE_NAME]->numUsed; + levelPtr->bases[EXACT_NODE_CLASS] = stacks[EXACT_NODE_CLASS]->numUsed; + levelPtr->bases[WILDCARD_LEAF_NAME] = stacks[WILDCARD_LEAF_NAME]->numUsed; + levelPtr->bases[WILDCARD_LEAF_CLASS] = stacks[WILDCARD_LEAF_CLASS]->numUsed; + levelPtr->bases[WILDCARD_NODE_NAME] = stacks[WILDCARD_NODE_NAME]->numUsed; + levelPtr->bases[WILDCARD_NODE_CLASS] = stacks[WILDCARD_NODE_CLASS]->numUsed; + + + /* + * Step 5: scan the current stack level looking for matches to this + * window's name or class; where found, add new information to the + * stacks. + */ + + for (iPtr = searchOrder; *iPtr != -1; iPtr++) { + register Element *elPtr; + int count; + Tk_Uid id; + + i = *iPtr; + if (i & CLASS) { + id = winPtr->classUid; + } else { + id = winPtr->nameUid; + } + elPtr = stacks[i]->els; + count = levelPtr->bases[i]; + + /* + * For wildcard stacks, check all entries; for non-wildcard + * stacks, only check things that matched in the parent. + */ + + if (!(i & WILDCARD)) { + elPtr += levelPtr[-1].bases[i]; + count -= levelPtr[-1].bases[i]; + } + for ( ; count > 0; elPtr++, count--) { + if (elPtr->nameUid != id) { + continue; + } + ExtendStacks(elPtr->child.arrayPtr, leaf); + } + } + cachedWindow = winPtr; +} + +/* + *-------------------------------------------------------------- + * + * ExtendStacks -- + * + * Given an element array, copy all the elements from the + * array onto the system stacks (except for irrelevant leaf + * elements). + * + * Results: + * None. + * + * Side effects: + * The option stacks are extended. + * + *-------------------------------------------------------------- + */ + +static void +ExtendStacks(arrayPtr, leaf) + ElArray *arrayPtr; /* Array of elements to copy onto stacks. */ + int leaf; /* If zero, then don't copy exact leaf + * elements. */ +{ + register int count; + register Element *elPtr; + + for (elPtr = arrayPtr->els, count = arrayPtr->numUsed; + count > 0; elPtr++, count--) { + if (!(elPtr->flags & (NODE|WILDCARD)) && !leaf) { + continue; + } + stacks[elPtr->flags] = ExtendArray(stacks[elPtr->flags], elPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * OptionInit -- + * + * Initialize data structures for option handling. + * + * Results: + * None. + * + * Side effects: + * Option-related data structures get initialized. + * + *-------------------------------------------------------------- + */ + +static void +OptionInit(mainPtr) + register TkMainInfo *mainPtr; /* Top-level information about + * window that isn't initialized + * yet. */ +{ + int i; + Tcl_Interp *interp; + + /* + * First, once-only initialization. + */ + + if (numLevels == 0) { + + numLevels = 5; + levels = (StackLevel *) ckalloc((unsigned) (5*sizeof(StackLevel))); + for (i = 0; i < NUM_STACKS; i++) { + stacks[i] = NewArray(10); + levels[0].bases[i] = 0; + } + + defaultMatch.nameUid = NULL; + defaultMatch.child.valueUid = NULL; + defaultMatch.priority = -1; + defaultMatch.flags = 0; + } + + /* + * Then, per-main-window initialization. Create and delete dummy + * interpreter for message logging. + */ + + mainPtr->optionRootPtr = NewArray(20); + interp = Tcl_CreateInterp(); + (void) GetDefaultOptions(interp, mainPtr->winPtr); + Tcl_DeleteInterp(interp); +} + +/* + *-------------------------------------------------------------- + * + * ClearOptionTree -- + * + * This procedure is called to erase everything in a + * hierarchical option database. + * + * Results: + * None. + * + * Side effects: + * All the options associated with arrayPtr are deleted, + * along with all option subtrees. The space pointed to + * by arrayPtr is freed. + * + *-------------------------------------------------------------- + */ + +static void +ClearOptionTree(arrayPtr) + ElArray *arrayPtr; /* Array of options; delete everything + * referred to recursively by this. */ +{ + register Element *elPtr; + int count; + + for (count = arrayPtr->numUsed, elPtr = arrayPtr->els; count > 0; + count--, elPtr++) { + if (elPtr->flags & NODE) { + ClearOptionTree(elPtr->child.arrayPtr); + } + } + ckfree((char *) arrayPtr); +} + +/* + *-------------------------------------------------------------- + * + * GetDefaultOptions -- + * + * This procedure is invoked to load the default set of options + * for a window. + * + * Results: + * None. + * + * Side effects: + * Options are added to those for winPtr's main window. If + * there exists a RESOURCE_MANAGER proprety for winPtr's + * display, that is used. Otherwise, the .ctkdefaults file in + * the user's home directory is used. + * + *-------------------------------------------------------------- + */ + +static int +GetDefaultOptions(interp, winPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + TkWindow *winPtr; /* Fetch option defaults for main window + * associated with this. */ +{ + int result; + + /* + * Try a .ctkdefaults file in the user's home + * directory. + */ + + result = ReadOptionFile(interp, (Tk_Window) winPtr, "~/.ctkdefaults", + TK_USER_DEFAULT_PRIO); + return result; +} ADDED tkPack.c Index: tkPack.c ================================================================== --- tkPack.c +++ tkPack.c @@ -0,0 +1,1729 @@ +/* + * tkPack.c -- + * + * This file contains code to implement the "packer" + * geometry manager 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. + */ + +static char sccsid[] = "@(#) tkPack.c 1.56 95/11/24 17:52:11"; + +#include "tkPort.h" +#include "tkInt.h" + +typedef enum {TOP, BOTTOM, LEFT, RIGHT} Side; + +/* For each window that the packer cares about (either because + * the window is managed by the packer or because the window + * has slaves that are managed by the packer), there is a + * structure of the following type: + */ + +typedef struct Packer { + Tk_Window tkwin; /* Tk token for window. NULL means that + * the window has been deleted, but the + * packet hasn't had a chance to clean up + * yet because the structure is still in + * use. */ + struct Packer *masterPtr; /* Master window within which this window + * is packed (NULL means this window + * isn't managed by the packer). */ + struct Packer *nextPtr; /* Next window packed within same + * parent. List is priority-ordered: + * first on list gets packed first. */ + struct Packer *slavePtr; /* First in list of slaves packed + * inside this window (NULL means + * no packed slaves). */ + Side side; /* Side of parent against which + * this window is packed. */ + Tk_Anchor anchor; /* If frame allocated for window is larger + * than window needs, this indicates how + * where to position window in frame. */ + 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 doubleBw; /* Twice the window's last known border + * width. If this changes, the window + * must be repacked within its parent. */ + int *abortPtr; /* If non-NULL, it means that there is a nested + * call to ArrangePacking 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. */ +} Packer; + +/* + * Flag values for Packer structures: + * + * 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 + * is wider than window needs, expand window + * to fill frame. 0 means don't make window + * any larger than needed. + * FILLY: Same as FILLX, except for height. + * EXPAND: 1 means this window's frame will absorb any + * extra space in the parent window. + * OLD_STYLE: 1 means this window is being managed with + * the old-style packer algorithms (before + * Tk version 3.3). The main difference is + * that padding and filling are done differently. + * 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_REPACK 1 +#define FILLX 2 +#define FILLY 4 +#define EXPAND 8 +#define OLD_STYLE 16 +#define DONT_PROPAGATE 32 + +/* + * Hash table used to map from Tk_Window tokens to corresponding + * Packer structures: + */ + +static Tcl_HashTable packerHashTable; + +/* + * Have statics in this module been initialized? + */ + +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: + */ + +static void ArrangePacking _ANSI_ARGS_((ClientData clientData)); +static int ConfigureSlaves _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int argc, char *argv[])); +static Packer * GetPacker _ANSI_ARGS_((Tk_Window tkwin)); +static int PackAfter _ANSI_ARGS_((Tcl_Interp *interp, + Packer *prevPtr, Packer *masterPtr, int argc, + char **argv)); +static void PackReqProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void PackStructureProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void Unlink _ANSI_ARGS_((Packer *packPtr)); +static int XExpansion _ANSI_ARGS_((Packer *slavePtr, + int cavityWidth)); +static int YExpansion _ANSI_ARGS_((Packer *slavePtr, + int cavityHeight)); + +/* + *-------------------------------------------------------------- + * + * Tk_PackCmd -- + * + * This procedure is invoked to process the "pack" 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_PackCmd(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; + size_t length; + int c; + + if ((argc >= 2) && (argv[1][0] == '.')) { + 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 == 'a') && (length >= 2) + && (strncmp(argv[1], "after", length) == 0)) { + Packer *prevPtr; + Tk_Window tkwin2; + + tkwin2 = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + prevPtr = GetPacker(tkwin2); + if (prevPtr->masterPtr == NULL) { + Tcl_AppendResult(interp, "window \"", argv[2], + "\" isn't packed", (char *) NULL); + return TCL_ERROR; + } + return PackAfter(interp, prevPtr, prevPtr->masterPtr, argc-3, argv+3); + } else if ((c == 'a') && (length >= 2) + && (strncmp(argv[1], "append", length) == 0)) { + Packer *masterPtr; + register Packer *prevPtr; + Tk_Window tkwin2; + + tkwin2 = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + masterPtr = GetPacker(tkwin2); + prevPtr = masterPtr->slavePtr; + if (prevPtr != NULL) { + while (prevPtr->nextPtr != NULL) { + prevPtr = prevPtr->nextPtr; + } + } + return PackAfter(interp, prevPtr, masterPtr, argc-3, argv+3); + } else if ((c == 'b') && (strncmp(argv[1], "before", length) == 0)) { + Packer *packPtr, *masterPtr; + register Packer *prevPtr; + Tk_Window tkwin2; + + tkwin2 = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + packPtr = GetPacker(tkwin2); + if (packPtr->masterPtr == NULL) { + Tcl_AppendResult(interp, "window \"", argv[2], + "\" isn't packed", (char *) NULL); + return TCL_ERROR; + } + masterPtr = packPtr->masterPtr; + prevPtr = masterPtr->slavePtr; + if (prevPtr == packPtr) { + prevPtr = NULL; + } else { + for ( ; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr == NULL) { + panic("\"pack before\" couldn't find predecessor"); + } + if (prevPtr->nextPtr == packPtr) { + break; + } + } + } + return PackAfter(interp, prevPtr, masterPtr, argc-3, argv+3); + } 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)) { + Tk_Window slave; + Packer *slavePtr; + int i; + + for (i = 2; i < argc; i++) { + slave = Tk_NameToWindow(interp, argv[i], tkwin); + if (slave == NULL) { + continue; + } + slavePtr = GetPacker(slave); + if ((slavePtr != NULL) && (slavePtr->masterPtr != 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)) { + register Packer *slavePtr; + Tk_Window slave; + char buffer[300]; + static char *sideNames[] = {"top", "bottom", "left", "right"}; + + 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 = GetPacker(slave); + if (slavePtr->masterPtr == NULL) { + Tcl_AppendResult(interp, "window \"", argv[2], + "\" isn't packed", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, "-in"); + Tcl_AppendElement(interp, Tk_PathName(slavePtr->masterPtr->tkwin)); + Tcl_AppendElement(interp, "-anchor"); + Tcl_AppendElement(interp, Tk_NameOfAnchor(slavePtr->anchor)); + Tcl_AppendResult(interp, " -expand ", + (slavePtr->flags & EXPAND) ? "1" : "0", " -fill ", + (char *) NULL); + switch (slavePtr->flags & (FILLX|FILLY)) { + case 0: + Tcl_AppendResult(interp, "none", (char *) NULL); + break; + case FILLX: + Tcl_AppendResult(interp, "x", (char *) NULL); + break; + case FILLY: + Tcl_AppendResult(interp, "y", (char *) NULL); + break; + case FILLX|FILLY: + Tcl_AppendResult(interp, "both", (char *) NULL); + break; + } + 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, " -side ", sideNames[slavePtr->side], + (char *) NULL); + } else if ((c == 'p') && (strncmp(argv[1], "propagate", length) == 0)) { + Tk_Window master; + Packer *masterPtr; + 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 = GetPacker(master); + if (argc == 3) { + if (masterPtr->flags & DONT_PROPAGATE) { + Tcl_SetResult(interp,"0",TCL_STATIC); + } else { + Tcl_SetResult(interp,"1",TCL_STATIC); + } + return TCL_OK; + } + if (Tcl_GetBoolean(interp, argv[3], &propagate) != TCL_OK) { + return TCL_ERROR; + } + if (propagate) { + masterPtr->flags &= ~DONT_PROPAGATE; + + /* + * Repack 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_REPACK)) { + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + } + } else { + masterPtr->flags |= DONT_PROPAGATE; + } + } else if ((c == 's') && (strncmp(argv[1], "slaves", length) == 0)) { + Tk_Window master; + Packer *masterPtr, *slavePtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " slaves window\"", (char *) NULL); + return TCL_ERROR; + } + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + masterPtr = GetPacker(master); + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + Tcl_AppendElement(interp, Tk_PathName(slavePtr->tkwin)); + } + } else if ((c == 'u') && (strncmp(argv[1], "unpack", length) == 0)) { + Tk_Window tkwin2; + Packer *packPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " unpack window\"", (char *) NULL); + return TCL_ERROR; + } + tkwin2 = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + packPtr = GetPacker(tkwin2); + if ((packPtr != NULL) && (packPtr->masterPtr != 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, ", + "propagate, or slaves", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * PackReqProc -- + * + * This procedure is invoked by Tk_GeometryRequest for + * windows managed by the packer. + * + * Results: + * None. + * + * Side effects: + * Arranges for tkwin, and all its managed siblings, to + * be re-packed at the next idle point. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PackReqProc(clientData, tkwin) + ClientData clientData; /* Packer's information about + * window that got new preferred + * geometry. */ + Tk_Window tkwin; /* Other Tk-related information + * about the window. */ +{ + register Packer *packPtr = (Packer *) clientData; + + packPtr = packPtr->masterPtr; + if (!(packPtr->flags & REQUESTED_REPACK)) { + packPtr->flags |= REQUESTED_REPACK; + 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 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 + * layout operation. + * + * Results: + * None. + * + * Side effects: + * The packed slaves of masterPtr may get resized or + * moved. + * + *-------------------------------------------------------------- + */ + +static void +ArrangePacking(clientData) + ClientData clientData; /* Structure describing parent whose slaves + * are to be re-layed out. */ +{ + register Packer *masterPtr = (Packer *) clientData; + register Packer *slavePtr; + int cavityX, cavityY, cavityWidth, cavityHeight; + /* These variables keep track of the + * as-yet-unallocated space remaining in + * the middle of the parent window. */ + int frameX, frameY, frameWidth, frameHeight; + /* These variables keep track of the frame + * allocated to the current window. */ + int x, y, width, height; /* These variables are used to hold the + * actual geometry of the current window. */ + int intBWidth; /* Width of internal border in parent window, + * if any. */ + int abort; /* May get set to non-zero to abort this + * repacking operation. */ + int borderX, borderY; + int maxWidth, maxHeight, tmp; + + masterPtr->flags &= ~REQUESTED_REPACK; + + /* + * If the parent has no slaves anymore, then don't do anything + * at all: just leave the parent's size as-is. + */ + + if (masterPtr->slavePtr == NULL) { + return; + } + + /* + * Abort any nested call to ArrangePacking 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; + Tk_Preserve((ClientData) masterPtr); + + /* + * Pass #1: scan all the slaves to figure out the total amount + * of space needed. Two separate width and height values are + * computed: + * + * width - Holds the sum of the widths (plus padding) of + * all the slaves seen so far that were packed LEFT + * or RIGHT. + * height - Holds the sum of the heights (plus padding) of + * all the slaves seen so far that were packed TOP + * or BOTTOM. + * + * maxWidth - Gradually builds up the width needed by the master + * to just barely satisfy all the slave's needs. For + * each slave, the code computes the width needed for + * all the slaves so far and updates maxWidth if the + * new value is greater. + * maxHeight - Same as maxWidth, except keeps height info. + */ + + intBWidth = Tk_InternalBorderWidth(masterPtr->tkwin); + width = height = maxWidth = maxHeight = 2*intBWidth; + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + if ((slavePtr->side == TOP) || (slavePtr->side == BOTTOM)) { + tmp = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padX + slavePtr->iPadX + width; + if (tmp > maxWidth) { + maxWidth = tmp; + } + height += Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padY + slavePtr->iPadY; + } else { + tmp = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padY + slavePtr->iPadY + height; + if (tmp > maxHeight) { + maxHeight = tmp; + } + width += Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padX + slavePtr->iPadX; + } + } + if (width > maxWidth) { + maxWidth = width; + } + if (height > maxHeight) { + maxHeight = height; + } + + /* + * If the total amount of space needed in the parent window has + * changed, and if we're propagating geometry information, then + * notify the next geometry manager up and requeue ourselves to + * start again after the parent has had a chance to + * resize us. + */ + + if (((maxWidth != Tk_ReqWidth(masterPtr->tkwin)) + || (maxHeight != Tk_ReqHeight(masterPtr->tkwin))) + && !(masterPtr->flags & DONT_PROPAGATE)) { + Tk_GeometryRequest(masterPtr->tkwin, maxWidth, maxHeight); + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + goto done; + } + + /* + * Pass #2: scan the slaves a second time assigning + * new sizes. The "cavity" variables keep track of the + * unclaimed space in the cavity of the window; this + * shrinks inward as we allocate windows around the + * edges. The "frame" variables keep track of the space + * allocated to the current window and its frame. The + * current window is then placed somewhere inside the + * frame, depending on anchor. + */ + + cavityX = cavityY = x = y = intBWidth; + cavityWidth = Tk_Width(masterPtr->tkwin) - 2*intBWidth; + cavityHeight = Tk_Height(masterPtr->tkwin) - 2*intBWidth; + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + if ((slavePtr->side == TOP) || (slavePtr->side == BOTTOM)) { + frameWidth = cavityWidth; + frameHeight = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padY + slavePtr->iPadY; + if (slavePtr->flags & EXPAND) { + frameHeight += YExpansion(slavePtr, cavityHeight); + } + cavityHeight -= frameHeight; + if (cavityHeight < 0) { + frameHeight += cavityHeight; + cavityHeight = 0; + } + frameX = cavityX; + if (slavePtr->side == TOP) { + frameY = cavityY; + cavityY += frameHeight; + } else { + frameY = cavityY + cavityHeight; + } + } else { + frameHeight = cavityHeight; + frameWidth = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padX + slavePtr->iPadX; + if (slavePtr->flags & EXPAND) { + frameWidth += XExpansion(slavePtr, cavityWidth); + } + cavityWidth -= frameWidth; + if (cavityWidth < 0) { + frameWidth += cavityWidth; + cavityWidth = 0; + } + frameY = cavityY; + if (slavePtr->side == LEFT) { + frameX = cavityX; + cavityX += frameWidth; + } else { + frameX = cavityX + cavityWidth; + } + } + + /* + * Now that we've got the size of the frame for the window, + * compute the window's actual size and location using the + * fill, padding, and frame factors. The variables "borderX" + * and "borderY" are used to handle the differences between + * old-style packing and the new style (in old-style, iPadX + * and iPadY are always zero and padding is completely ignored + * except when computing frame size). + */ + + if (slavePtr->flags & OLD_STYLE) { + borderX = borderY = 0; + } else { + borderX = slavePtr->padX; + borderY = slavePtr->padY; + } + width = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->iPadX; + if ((slavePtr->flags & FILLX) + || (width > (frameWidth - borderX))) { + width = frameWidth - borderX; + } + height = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->iPadY; + if ((slavePtr->flags & FILLY) + || (height > (frameHeight - borderY))) { + height = frameHeight - borderY; + } + borderX /= 2; + borderY /= 2; + switch (slavePtr->anchor) { + case TK_ANCHOR_N: + x = frameX + (frameWidth - width)/2; + y = frameY + borderY; + break; + case TK_ANCHOR_NE: + x = frameX + frameWidth - width - borderX; + y = frameY + borderY; + break; + case TK_ANCHOR_E: + x = frameX + frameWidth - width - borderX; + y = frameY + (frameHeight - height)/2; + break; + case TK_ANCHOR_SE: + x = frameX + frameWidth - width - borderX; + y = frameY + frameHeight - height - borderY; + break; + case TK_ANCHOR_S: + x = frameX + (frameWidth - width)/2; + y = frameY + frameHeight - height - borderY; + break; + case TK_ANCHOR_SW: + x = frameX + borderX; + y = frameY + frameHeight - height - borderY; + break; + case TK_ANCHOR_W: + x = frameX + borderX; + y = frameY + (frameHeight - height)/2; + break; + case TK_ANCHOR_NW: + x = frameX + borderX; + y = frameY + borderY; + break; + case TK_ANCHOR_CENTER: + x = frameX + (frameWidth - width)/2; + y = frameY + (frameHeight - height)/2; + break; + default: + panic("bad frame factor in ArrangePacking"); + } + width -= slavePtr->doubleBw; + height -= slavePtr->doubleBw; + + /* + * 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. + */ + + 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; + } + + /* + * 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); + } + } + + /* + * Changes to the window's structure could cause almost anything + * to happen, including deleting the parent or child. If this + * happens, we'll be told to abort. + */ + + if (abort) { + goto done; + } + } + + done: + masterPtr->abortPtr = NULL; + Tk_Release((ClientData) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * XExpansion -- + * + * Given a list of packed slaves, the first of which is packed + * on the left or right and is expandable, compute how much to + * expand the child. + * + * Results: + * The return value is the number of additional pixels to give to + * the child. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +XExpansion(slavePtr, cavityWidth) + register Packer *slavePtr; /* First in list of remaining + * slaves. */ + int cavityWidth; /* Horizontal space left for all + * remaining slaves. */ +{ + int numExpand, minExpand, curExpand; + int childWidth; + + /* + * This procedure is tricky because windows packed top or bottom can + * be interspersed among expandable windows packed left or right. + * Scan through the list, keeping a running sum of the widths of + * all left and right windows (actually, count the cavity space not + * allocated) and a running count of all expandable left and right + * windows. At each top or bottom window, and at the end of the + * list, compute the expansion factor that seems reasonable at that + * point. Return the smallest factor seen at any of these points. + */ + + minExpand = cavityWidth; + numExpand = 0; + for ( ; slavePtr != NULL; slavePtr = slavePtr->nextPtr) { + childWidth = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padX + slavePtr->iPadX; + if ((slavePtr->side == TOP) || (slavePtr->side == BOTTOM)) { + curExpand = (cavityWidth - childWidth)/numExpand; + if (curExpand < minExpand) { + minExpand = curExpand; + } + } else { + cavityWidth -= childWidth; + if (slavePtr->flags & EXPAND) { + numExpand++; + } + } + } + curExpand = cavityWidth/numExpand; + if (curExpand < minExpand) { + minExpand = curExpand; + } + return (minExpand < 0) ? 0 : minExpand; +} + +/* + *---------------------------------------------------------------------- + * + * YExpansion -- + * + * Given a list of packed slaves, the first of which is packed + * on the top or bottom and is expandable, compute how much to + * expand the child. + * + * Results: + * The return value is the number of additional pixels to give to + * the child. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +YExpansion(slavePtr, cavityHeight) + register Packer *slavePtr; /* First in list of remaining + * slaves. */ + int cavityHeight; /* Vertical space left for all + * remaining slaves. */ +{ + int numExpand, minExpand, curExpand; + int childHeight; + + /* + * See comments for XExpansion. + */ + + minExpand = cavityHeight; + numExpand = 0; + for ( ; slavePtr != NULL; slavePtr = slavePtr->nextPtr) { + childHeight = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padY + slavePtr->iPadY; + if ((slavePtr->side == LEFT) || (slavePtr->side == RIGHT)) { + curExpand = (cavityHeight - childHeight)/numExpand; + if (curExpand < minExpand) { + minExpand = curExpand; + } + } else { + cavityHeight -= childHeight; + if (slavePtr->flags & EXPAND) { + numExpand++; + } + } + } + curExpand = cavityHeight/numExpand; + if (curExpand < minExpand) { + minExpand = curExpand; + } + return (minExpand < 0) ? 0 : minExpand; +} + +/* + *-------------------------------------------------------------- + * + * GetPacker -- + * + * This internal procedure is used to locate a Packer + * structure for a given window, creating one if one + * doesn't exist already. + * + * Results: + * The return value is a pointer to the Packer structure + * corresponding to tkwin. + * + * Side effects: + * A new packer structure may be created. If so, then + * a callback is set up to clean things up when the + * window is deleted. + * + *-------------------------------------------------------------- + */ + +static Packer * +GetPacker(tkwin) + Tk_Window tkwin; /* Token for window for which + * packer structure is desired. */ +{ + register Packer *packPtr; + Tcl_HashEntry *hPtr; + int new; + + if (!initialized) { + initialized = 1; + Tcl_InitHashTable(&packerHashTable, TCL_ONE_WORD_KEYS); + } + + /* + * See if there's already packer for this window. If not, + * then create a new one. + */ + + hPtr = Tcl_CreateHashEntry(&packerHashTable, (char *) tkwin, &new); + if (!new) { + return (Packer *) Tcl_GetHashValue(hPtr); + } + packPtr = (Packer *) ckalloc(sizeof(Packer)); + packPtr->tkwin = tkwin; + packPtr->masterPtr = NULL; + packPtr->nextPtr = NULL; + packPtr->slavePtr = NULL; + packPtr->side = TOP; + packPtr->anchor = TK_ANCHOR_CENTER; + packPtr->padX = 1; + packPtr->padY = 0; + packPtr->iPadX = packPtr->iPadY = 0; + packPtr->doubleBw = 2*Tk_BorderWidth(tkwin); + packPtr->abortPtr = NULL; + packPtr->flags = 0; + Tcl_SetHashValue(hPtr, packPtr); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + PackStructureProc, (ClientData) packPtr); + return packPtr; +} + +/* + *-------------------------------------------------------------- + * + * PackAfter -- + * + * This procedure does most of the real work of adding + * one or more windows into the packing order for its parent. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * The geometry of the specified windows may change, both now and + * again in the future. + * + *-------------------------------------------------------------- + */ + +static int +PackAfter(interp, prevPtr, masterPtr, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Packer *prevPtr; /* Pack windows in argv just after this + * window; NULL means pack as first + * child of masterPtr. */ + Packer *masterPtr; /* Master in which to pack windows. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Array of lists, each containing 2 + * elements: window name and side + * against which to pack. */ +{ + register Packer *packPtr; + Tk_Window tkwin, ancestor, parent; + size_t length; + char **options; + int index, tmp, optionCount, c; + + /* + * Iterate over all of the window specifiers, each consisting of + * two arguments. The first argument contains the window name and + * the additional arguments contain options such as "top" or + * "padx 20". + */ + + for ( ; argc > 0; argc -= 2, argv += 2, prevPtr = packPtr) { + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: window \"", + argv[0], "\" should be followed by options", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the packer for the window to be packed, and make sure + * that the window in which it will be packed is either its + * or a descendant of its parent. + */ + + tkwin = Tk_NameToWindow(interp, argv[0], masterPtr->tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + + parent = Tk_Parent(tkwin); + for (ancestor = masterPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) { + if (ancestor == parent) { + break; + } + if (((Tk_FakeWin *) (ancestor))->flags & TK_TOP_LEVEL) { + badWindow: + Tcl_AppendResult(interp, "can't pack ", argv[0], + " inside ", Tk_PathName(masterPtr->tkwin), + (char *) NULL); + return TCL_ERROR; + } + } + if (((Tk_FakeWin *) (tkwin))->flags & TK_TOP_LEVEL) { + goto badWindow; + } + if (tkwin == masterPtr->tkwin) { + goto badWindow; + } + packPtr = GetPacker(tkwin); + + /* + * Process options for this window. + */ + + if (Tcl_SplitList(interp, argv[1], &optionCount, &options) != TCL_OK) { + return TCL_ERROR; + } + packPtr->side = TOP; + packPtr->anchor = TK_ANCHOR_CENTER; + packPtr->padX = 1; + packPtr->padY = 0; + packPtr->iPadX = packPtr->iPadY = 0; + packPtr->flags &= ~(FILLX|FILLY|EXPAND); + packPtr->flags |= OLD_STYLE; + for (index = 0 ; index < optionCount; index++) { + char *curOpt = options[index]; + + c = curOpt[0]; + length = strlen(curOpt); + + if ((c == 't') + && (strncmp(curOpt, "top", length)) == 0) { + packPtr->side = TOP; + } else if ((c == 'b') + && (strncmp(curOpt, "bottom", length)) == 0) { + packPtr->side = BOTTOM; + } else if ((c == 'l') + && (strncmp(curOpt, "left", length)) == 0) { + packPtr->side = LEFT; + } else if ((c == 'r') + && (strncmp(curOpt, "right", length)) == 0) { + packPtr->side = RIGHT; + } else if ((c == 'e') + && (strncmp(curOpt, "expand", length)) == 0) { + packPtr->flags |= EXPAND; + } else if ((c == 'f') + && (strcmp(curOpt, "fill")) == 0) { + packPtr->flags |= FILLX|FILLY; + } else if ((length == 5) && (strcmp(curOpt, "fillx")) == 0) { + packPtr->flags |= FILLX; + } else if ((length == 5) && (strcmp(curOpt, "filly")) == 0) { + packPtr->flags |= FILLY; + } else if ((c == 'p') && (strcmp(curOpt, "padx")) == 0) { + if (optionCount < (index+2)) { + missingPad: + Tcl_AppendResult(interp, "wrong # args: \"", curOpt, + "\" option must be followed by screen distance", + (char *) NULL); + goto error; + } + if ((Tk_GetPixels(interp, tkwin, options[index+1], &tmp) + != TCL_OK) || (tmp < 0)) { + badPad: + Tcl_AppendResult(interp, "bad pad value \"", + options[index+1], + "\": must be positive screen distance", + (char *) NULL); + goto error; + } + packPtr->padX = tmp; + packPtr->iPadX = 0; + index++; + } else if ((c == 'p') && (strcmp(curOpt, "pady")) == 0) { + if (optionCount < (index+2)) { + goto missingPad; + } + if ((Tk_GetPixels(interp, tkwin, options[index+1], &tmp) + != TCL_OK) || (tmp < 0)) { + goto badPad; + } + packPtr->padY = tmp; + packPtr->iPadY = 0; + index++; + } else if ((c == 'f') && (length > 1) + && (strncmp(curOpt, "frame", length) == 0)) { + if (optionCount < (index+2)) { + Tcl_AppendResult(interp, "wrong # args: \"frame\" ", + "option must be followed by anchor point", + (char *) NULL); + goto error; + } + if (Tk_GetAnchor(interp, options[index+1], + &packPtr->anchor) != TCL_OK) { + goto error; + } + index++; + } else { + Tcl_AppendResult(interp, "bad option \"", curOpt, + "\": should be top, bottom, left, right, ", + "expand, fill, fillx, filly, padx, pady, or frame", + (char *) NULL); + goto error; + } + } + + if (packPtr != prevPtr) { + + /* + * 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); + } + + /* + * Add the window in the correct place in its parent's + * packing order, then make sure that the window is + * managed by us. + */ + + packPtr->masterPtr = masterPtr; + if (prevPtr == NULL) { + packPtr->nextPtr = masterPtr->slavePtr; + masterPtr->slavePtr = packPtr; + } else { + packPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = packPtr; + } + Tk_ManageGeometry(tkwin, &packerType, (ClientData) packPtr); + } + ckfree((char *) options); + } + + /* + * Arrange for the parent to be re-packed at the first + * idle moment. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_REPACK)) { + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + } + return TCL_OK; + + error: + ckfree((char *) options); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Unlink -- + * + * Remove a packer from its parent's list of slaves. + * + * Results: + * None. + * + * Side effects: + * The parent will be scheduled for repacking. + * + *---------------------------------------------------------------------- + */ + +static void +Unlink(packPtr) + register Packer *packPtr; /* Window to unlink. */ +{ + register Packer *masterPtr, *packPtr2; + + masterPtr = packPtr->masterPtr; + if (masterPtr == NULL) { + return; + } + if (masterPtr->slavePtr == packPtr) { + masterPtr->slavePtr = packPtr->nextPtr; + } else { + for (packPtr2 = masterPtr->slavePtr; ; packPtr2 = packPtr2->nextPtr) { + if (packPtr2 == NULL) { + panic("Unlink couldn't find previous window"); + } + if (packPtr2->nextPtr == packPtr) { + packPtr2->nextPtr = packPtr->nextPtr; + break; + } + } + } + if (!(masterPtr->flags & REQUESTED_REPACK)) { + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + } + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + + packPtr->masterPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyPacker -- + * + * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * to clean up the internal structure of a packer at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the packer is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyPacker(clientData) + ClientData clientData; /* Info about packed window that + * is now dead. */ +{ + register Packer *packPtr = (Packer *) clientData; + ckfree((char *) packPtr); +} + +/* + *---------------------------------------------------------------------- + * + * PackStructureProc -- + * + * 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 packer-related + * information. If it was just resized, repack its slaves, if + * any. + * + *---------------------------------------------------------------------- + */ + +static void +PackStructureProc(clientData, eventPtr) + ClientData clientData; /* Our information about window + * referred to by eventPtr. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register Packer *packPtr = (Packer *) clientData; + if (eventPtr->type == ConfigureNotify) { + if ((packPtr->slavePtr != NULL) + && !(packPtr->flags & REQUESTED_REPACK)) { + packPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr); + } + if (packPtr->doubleBw != 2*Tk_BorderWidth(packPtr->tkwin)) { + if ((packPtr->masterPtr != NULL) + && !(packPtr->masterPtr->flags & REQUESTED_REPACK)) { + packPtr->doubleBw = 2*Tk_BorderWidth(packPtr->tkwin); + packPtr->masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr->masterPtr); + } + } + } else if (eventPtr->type == DestroyNotify) { + register Packer *slavePtr, *nextPtr; + + if (packPtr->masterPtr != NULL) { + Unlink(packPtr); + } + 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) { + Tcl_CancelIdleCall(ArrangePacking, (ClientData) packPtr); + } + packPtr->tkwin = NULL; + Tk_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; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr); + } + } else if (eventPtr->type == UnmapNotify) { + 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) { + Tk_UnmapWindow(packPtr2->tkwin); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureSlaves -- + * + * This implements the guts of the "pack configure" command. Given + * a list of slaves and configuration options, it arranges for the + * packer to manage the slaves and sets the specified options. + * + * 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 packer. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + Packer *masterPtr, *slavePtr, *prevPtr, *otherPtr; + Tk_Window other, slave, parent, ancestor; + int i, j, numWindows, c, tmp, positionGiven; + size_t length; + + /* + * Find out how many windows are specified. + */ + + for (numWindows = 0; numWindows < argc; numWindows++) { + if (argv[numWindows][0] != '.') { + break; + } + } + + /* + * Iterate over all of the slave windows, parsing the configuration + * 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 packed we want to just change a few + * existing values without resetting everything. If there are + * multiple windows, the -after, -before, and -in options only + * get processed for the first window. + */ + + masterPtr = NULL; + prevPtr = NULL; + positionGiven = 0; + for (j = 0; j < numWindows; j++) { + slave = Tk_NameToWindow(interp, argv[j], tkwin); + if (slave == NULL) { + return TCL_ERROR; + } + if (Tk_IsTopLevel(slave)) { + Tcl_AppendResult(interp, "can't pack \"", argv[j], + "\": it's a top-level window", (char *) NULL); + return TCL_ERROR; + } + slavePtr = GetPacker(slave); + slavePtr->flags &= ~OLD_STYLE; + + /* + * If the slave isn't currently packed, reset all of its + * configuration information to default values (there could + * be old values left from a previous packing). + */ + + if (slavePtr->masterPtr == NULL) { + slavePtr->side = TOP; + slavePtr->anchor = TK_ANCHOR_CENTER; + slavePtr->padX = 1; + slavePtr->padY = 0; + slavePtr->iPadX = slavePtr->iPadY = 0; + slavePtr->flags &= ~(FILLX|FILLY|EXPAND); + } + + for (i = numWindows; i < argc; i+=2) { + if ((i+2) > argc) { + Tcl_AppendResult(interp, "extra option \"", argv[i], + "\" (option with no value?)", (char *) NULL); + return TCL_ERROR; + } + length = strlen(argv[i]); + if (length < 2) { + goto badOption; + } + c = argv[i][1]; + if ((c == 'a') && (strncmp(argv[i], "-after", length) == 0) + && (length >= 2)) { + if (j == 0) { + other = Tk_NameToWindow(interp, argv[i+1], tkwin); + if (other == NULL) { + return TCL_ERROR; + } + prevPtr = GetPacker(other); + if (prevPtr->masterPtr == NULL) { + notPacked: + Tcl_AppendResult(interp, "window \"", argv[i+1], + "\" isn't packed", (char *) NULL); + return TCL_ERROR; + } + masterPtr = prevPtr->masterPtr; + positionGiven = 1; + } + } else if ((c == 'a') && (strncmp(argv[i], "-anchor", length) == 0) + && (length >= 2)) { + if (Tk_GetAnchor(interp, argv[i+1], &slavePtr->anchor) + != TCL_OK) { + return TCL_ERROR; + } + } else if ((c == 'b') + && (strncmp(argv[i], "-before", length) == 0)) { + if (j == 0) { + other = Tk_NameToWindow(interp, argv[i+1], tkwin); + if (other == NULL) { + return TCL_ERROR; + } + otherPtr = GetPacker(other); + if (otherPtr->masterPtr == NULL) { + goto notPacked; + } + masterPtr = otherPtr->masterPtr; + prevPtr = masterPtr->slavePtr; + if (prevPtr == otherPtr) { + prevPtr = NULL; + } else { + while (prevPtr->nextPtr != otherPtr) { + prevPtr = prevPtr->nextPtr; + } + } + positionGiven = 1; + } + } else if ((c == 'e') + && (strncmp(argv[i], "-expand", length) == 0)) { + if (Tcl_GetBoolean(interp, argv[i+1], &tmp) != TCL_OK) { + return TCL_ERROR; + } + slavePtr->flags &= ~EXPAND; + if (tmp) { + slavePtr->flags |= EXPAND; + } + } else if ((c == 'f') && (strncmp(argv[i], "-fill", length) == 0)) { + if (strcmp(argv[i+1], "none") == 0) { + slavePtr->flags &= ~(FILLX|FILLY); + } else if (strcmp(argv[i+1], "x") == 0) { + slavePtr->flags = (slavePtr->flags & ~FILLY) | FILLX; + } else if (strcmp(argv[i+1], "y") == 0) { + slavePtr->flags = (slavePtr->flags & ~FILLX) | FILLY; + } else if (strcmp(argv[i+1], "both") == 0) { + slavePtr->flags |= FILLX|FILLY; + } else { + Tcl_AppendResult(interp, "bad fill style \"", argv[i+1], + "\": must be none, x, y, or both", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'i') && (strcmp(argv[i], "-in") == 0)) { + if (j == 0) { + other = Tk_NameToWindow(interp, argv[i+1], tkwin); + if (other == NULL) { + return TCL_ERROR; + } + masterPtr = GetPacker(other); + prevPtr = masterPtr->slavePtr; + if (prevPtr != NULL) { + while (prevPtr->nextPtr != NULL) { + prevPtr = prevPtr->nextPtr; + } + } + positionGiven = 1; + } + } else if ((c == 'i') && (strcmp(argv[i], "-ipadx") == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp < 0)) { + badPad: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad pad 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)) { + goto badPad; + } + 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)) { + goto badPad; + } + 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)) { + goto badPad; + } + slavePtr->padY = tmp*2; + } else if ((c == 's') && (strncmp(argv[i], "-side", length) == 0)) { + c = argv[i+1][0]; + if ((c == 't') && (strcmp(argv[i+1], "top") == 0)) { + slavePtr->side = TOP; + } else if ((c == 'b') && (strcmp(argv[i+1], "bottom") == 0)) { + slavePtr->side = BOTTOM; + } else if ((c == 'l') && (strcmp(argv[i+1], "left") == 0)) { + slavePtr->side = LEFT; + } else if ((c == 'r') && (strcmp(argv[i+1], "right") == 0)) { + slavePtr->side = RIGHT; + } else { + Tcl_AppendResult(interp, "bad side \"", argv[i+1], + "\": must be top, bottom, left, or right", + (char *) NULL); + return TCL_ERROR; + } + } else { + badOption: + Tcl_AppendResult(interp, "unknown or ambiguous option \"", + argv[i], "\": must be -after, -anchor, -before, ", + "-expand, -fill, -in, -ipadx, -ipady, -padx, ", + "-pady, or -side", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * If no position in a packing list was specified and the slave + * is already packed, then leave it in its current location in + * its current packing list. + */ + + if (!positionGiven && (slavePtr->masterPtr != NULL)) { + masterPtr = slavePtr->masterPtr; + goto scheduleLayout; + } + + /* + * If the slave is going to be put back after itself then + * skip the whole operation, since it won't work anyway. + */ + + if (prevPtr == slavePtr) { + masterPtr = slavePtr->masterPtr; + goto scheduleLayout; + } + + /* + * If none of the "-in", "-before", or "-after" options has + * been specified, arrange for the slave to go at the end of + * the order for its parent. + */ + + if (!positionGiven) { + masterPtr = GetPacker(Tk_Parent(slave)); + prevPtr = masterPtr->slavePtr; + if (prevPtr != NULL) { + while (prevPtr->nextPtr != NULL) { + prevPtr = prevPtr->nextPtr; + } + } + } + + /* + * 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. + */ + + parent = Tk_Parent(slave); + for (ancestor = masterPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) { + if (ancestor == parent) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + Tcl_AppendResult(interp, "can't pack ", argv[j], + " inside ", Tk_PathName(masterPtr->tkwin), + (char *) NULL); + 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 + * after prevPtr. + */ + + 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; + if (prevPtr == NULL) { + slavePtr->nextPtr = masterPtr->slavePtr; + masterPtr->slavePtr = slavePtr; + } else { + slavePtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = slavePtr; + } + Tk_ManageGeometry(slave, &packerType, (ClientData) slavePtr); + prevPtr = slavePtr; + + /* + * Arrange for the parent to be re-packed at the first + * idle moment. + */ + + scheduleLayout: + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_REPACK)) { + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + } + } + return TCL_OK; +} ADDED tkPlace.c Index: tkPlace.c ================================================================== --- tkPlace.c +++ tkPlace.c @@ -0,0 +1,1054 @@ +/* + * tkPlace.c -- + * + * This file contains code to implement a simple geometry manager + * for Tk based on absolute placement or "rubber-sheet" placement. + * + * 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. + */ + +static char sccsid[] = "%Z% %M% %I% %E% %U%"; + +#include "tkPort.h" +#include "tkInt.h" + +/* + * Border modes for relative placement: + * + * BM_INSIDE: relative distances computed using area inside + * all borders of master window. + * BM_OUTSIDE: relative distances computed using outside area + * that includes all borders of master. + * BM_IGNORE: border issues are ignored: place relative to + * master's actual window size. + */ + +typedef enum {BM_INSIDE, BM_OUTSIDE, BM_IGNORE} BorderMode; + +/* + * For each window whose geometry is managed by the placer there is + * a structure of the following type: + */ + +typedef struct Slave { + Tk_Window tkwin; /* Tk's token for window. */ + struct Master *masterPtr; /* Pointer to information for window + * relative to which tkwin is placed. + * This isn't necessarily the logical + * parent of tkwin. NULL means the + * master was deleted or never assigned. */ + struct Slave *nextPtr; /* Next in list of windows placed relative + * to same master (NULL for end of list). */ + + /* + * Geometry information for window; where there are both relative + * and absolute values for the same attribute (e.g. x and relX) only + * one of them is actually used, depending on flags. + */ + + int x, y; /* X and Y pixel coordinates for tkwin. */ + float relX, relY; /* X and Y coordinates relative to size of + * master. */ + int width, height; /* Absolute dimensions for tkwin. */ + float relWidth, relHeight; /* Dimensions for tkwin relative to size of + * master. */ + Tk_Anchor anchor; /* Which point on tkwin is placed at the + * given position. */ + BorderMode borderMode; /* How to treat borders of master window. */ + int flags; /* Various flags; see below for bit + * definitions. */ +} Slave; + +/* + * Flag definitions for Slave structures: + * + * 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_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 + * is a structure of the following form: + */ + +typedef struct Master { + Tk_Window tkwin; /* Tk's token for master window. */ + struct Slave *slavePtr; /* First in linked list of slaves + * placed relative to this master. */ + int flags; /* See below for bit definitions. */ +} Master; + +/* + * Flag definitions for masters: + * + * PARENT_RECONFIG_PENDING - 1 means that a call to RecomputePlacement + * is already pending via a Do_When_Idle handler. + */ + +#define PARENT_RECONFIG_PENDING 1 + +/* + * The hash tables below both use Tk_Window tokens as keys. They map + * from Tk_Windows to Slave and Master structures for windows, if they + * exist. + */ + +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: + */ + +static void SlaveStructureProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int ConfigureSlave _ANSI_ARGS_((Tcl_Interp *interp, + Slave *slavePtr, int argc, char **argv)); +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 RecomputePlacement _ANSI_ARGS_((ClientData clientData)); +static void UnlinkSlave _ANSI_ARGS_((Slave *slavePtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_PlaceCmd -- + * + * This procedure is invoked to process the "place" 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_PlaceCmd(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; + Slave *slavePtr; + Tcl_HashEntry *hPtr; + size_t length; + int c; + + /* + * Initialize, if that hasn't been done yet. + */ + + if (!initialized) { + Tcl_InitHashTable(&masterTable, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&slaveTable, TCL_ONE_WORD_KEYS); + initialized = 1; + } + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option|pathName args", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + + /* + * Handle special shortcut where window name is first argument. + */ + + if (c == '.') { + tkwin = Tk_NameToWindow(interp, argv[1], (Tk_Window) clientData); + if (tkwin == NULL) { + return TCL_ERROR; + } + slavePtr = FindSlave(tkwin); + return ConfigureSlave(interp, slavePtr, argc-2, argv+2); + } + + /* + * Handle more general case of option followed by window name followed + * by possible additional arguments. + */ + + tkwin = Tk_NameToWindow(interp, argv[2], (Tk_Window) clientData); + if (tkwin == NULL) { + return TCL_ERROR; + } + if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + if (argc < 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], + " configure pathName option value ?option value ...?\"", + (char *) NULL); + return TCL_ERROR; + } + slavePtr = FindSlave(tkwin); + return ConfigureSlave(interp, slavePtr, argc-3, argv+3); + } else if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " forget pathName\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&slaveTable, (char *) tkwin); + if (hPtr == NULL) { + 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_GeomMgr *) NULL, (ClientData) NULL); + Tk_UnmapWindow(tkwin); + ckfree((char *) slavePtr); + } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { + char buffer[50]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " info pathName\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&slaveTable, (char *) tkwin); + if (hPtr == NULL) { + return TCL_OK; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + sprintf(buffer, "-x %d", slavePtr->x); + Tcl_AppendResult(interp, buffer, (char *) NULL); + 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 { + 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 { + Tcl_AppendResult(interp, " -relheight {}", (char *) NULL); + } + + Tcl_AppendResult(interp, " -anchor ", Tk_NameOfAnchor(slavePtr->anchor), + (char *) NULL); + if (slavePtr->borderMode == BM_OUTSIDE) { + Tcl_AppendResult(interp, " -bordermode outside", (char *) NULL); + } else if (slavePtr->borderMode == BM_IGNORE) { + Tcl_AppendResult(interp, " -bordermode ignore", (char *) NULL); + } + if ((slavePtr->masterPtr != NULL) + && (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin))) { + Tcl_AppendResult(interp, " -in ", + Tk_PathName(slavePtr->masterPtr->tkwin), (char *) NULL); + } + } else if ((c == 's') && (strncmp(argv[1], "slaves", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " slaves pathName\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&masterTable, (char *) tkwin); + if (hPtr != NULL) { + Master *masterPtr; + masterPtr = (Master *) Tcl_GetHashValue(hPtr); + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + Tcl_AppendElement(interp, Tk_PathName(slavePtr->tkwin)); + } + } + } else { + Tcl_AppendResult(interp, "unknown or ambiguous option \"", argv[1], + "\": must be configure, forget, info, or slaves", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FindSlave -- + * + * Given a Tk_Window token, find the Slave structure corresponding + * to that token (making a new one if necessary). + * + * Results: + * None. + * + * Side effects: + * A new Slave structure may be created. + * + *---------------------------------------------------------------------- + */ + +static Slave * +FindSlave(tkwin) + Tk_Window tkwin; /* Token for desired slave. */ +{ + Tcl_HashEntry *hPtr; + register Slave *slavePtr; + int new; + + hPtr = Tcl_CreateHashEntry(&slaveTable, (char *) tkwin, &new); + if (new) { + slavePtr = (Slave *) ckalloc(sizeof(Slave)); + slavePtr->tkwin = tkwin; + slavePtr->masterPtr = NULL; + slavePtr->nextPtr = NULL; + slavePtr->x = slavePtr->y = 0; + slavePtr->relX = slavePtr->relY = 0.0; + slavePtr->width = slavePtr->height = 0; + slavePtr->relWidth = slavePtr->relHeight = 0.0; + slavePtr->anchor = TK_ANCHOR_NW; + slavePtr->borderMode = BM_INSIDE; + slavePtr->flags = 0; + Tcl_SetHashValue(hPtr, slavePtr); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, SlaveStructureProc, + (ClientData) slavePtr); + Tk_ManageGeometry(tkwin, &placerType, (ClientData) slavePtr); + } else { + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + } + return slavePtr; +} + +/* + *---------------------------------------------------------------------- + * + * UnlinkSlave -- + * + * This procedure removes a slave window from the chain of slaves + * in its master. + * + * Results: + * None. + * + * Side effects: + * The slave list of slavePtr's master changes. + * + *---------------------------------------------------------------------- + */ + +static void +UnlinkSlave(slavePtr) + Slave *slavePtr; /* Slave structure to be unlinked. */ +{ + register Master *masterPtr; + register Slave *prevPtr; + + masterPtr = slavePtr->masterPtr; + if (masterPtr == NULL) { + return; + } + if (masterPtr->slavePtr == slavePtr) { + masterPtr->slavePtr = slavePtr->nextPtr; + } else { + for (prevPtr = masterPtr->slavePtr; ; + prevPtr = prevPtr->nextPtr) { + if (prevPtr == NULL) { + panic("UnlinkSlave couldn't find slave to unlink"); + } + if (prevPtr->nextPtr == slavePtr) { + prevPtr->nextPtr = slavePtr->nextPtr; + break; + } + } + } + slavePtr->masterPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FindMaster -- + * + * Given a Tk_Window token, find the Master structure corresponding + * to that token (making a new one if necessary). + * + * Results: + * None. + * + * Side effects: + * A new Master structure may be created. + * + *---------------------------------------------------------------------- + */ + +static Master * +FindMaster(tkwin) + Tk_Window tkwin; /* Token for desired master. */ +{ + Tcl_HashEntry *hPtr; + register Master *masterPtr; + int new; + + hPtr = Tcl_CreateHashEntry(&masterTable, (char *) tkwin, &new); + if (new) { + masterPtr = (Master *) ckalloc(sizeof(Master)); + masterPtr->tkwin = tkwin; + masterPtr->slavePtr = NULL; + masterPtr->flags = 0; + Tcl_SetHashValue(hPtr, masterPtr); + Tk_CreateEventHandler(masterPtr->tkwin, StructureNotifyMask, + MasterStructureProc, (ClientData) masterPtr); + } else { + masterPtr = (Master *) Tcl_GetHashValue(hPtr); + } + return masterPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureSlave -- + * + * This procedure is called to process an argv/argc list to + * reconfigure the placement of a window. + * + * Results: + * A standard Tcl result. If an error occurs then a message is + * left in interp->result. + * + * Side effects: + * Information in slavePtr may change, and slavePtr's master is + * scheduled for reconfiguration. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureSlave(interp, slavePtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Slave *slavePtr; /* Pointer to current information + * about slave. */ + int argc; /* Number of config arguments. */ + char **argv; /* String values for arguments. */ +{ + register Master *masterPtr; + int c, result; + size_t length; + double d; + + result = TCL_OK; + for ( ; argc > 0; argc -= 2, argv += 2) { + if (argc < 2) { + Tcl_AppendResult(interp, "extra option \"", argv[0], + "\" (option with no value?)", (char *) NULL); + result = TCL_ERROR; + goto done; + } + length = strlen(argv[0]); + c = argv[0][1]; + if ((c == 'a') && (strncmp(argv[0], "-anchor", length) == 0)) { + if (Tk_GetAnchor(interp, argv[1], &slavePtr->anchor) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + } else if ((c == 'b') + && (strncmp(argv[0], "-bordermode", length) == 0)) { + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'i') && (strncmp(argv[1], "ignore", length) == 0) + && (length >= 2)) { + slavePtr->borderMode = BM_IGNORE; + } else if ((c == 'i') && (strncmp(argv[1], "inside", length) == 0) + && (length >= 2)) { + slavePtr->borderMode = BM_INSIDE; + } else if ((c == 'o') + && (strncmp(argv[1], "outside", length) == 0)) { + slavePtr->borderMode = BM_OUTSIDE; + } else { + Tcl_AppendResult(interp, "bad border mode \"", argv[1], + "\": must be ignore, inside, or outside", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else if ((c == 'h') && (strncmp(argv[0], "-height", length) == 0)) { + if (argv[1][0] == 0) { + 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_HEIGHT; + } + } else if ((c == 'i') && (strncmp(argv[0], "-in", length) == 0)) { + Tk_Window tkwin; + Tk_Window ancestor; + + tkwin = Tk_NameToWindow(interp, argv[1], slavePtr->tkwin); + if (tkwin == NULL) { + result = TCL_ERROR; + goto done; + } + + /* + * Make sure that the new master is either the logical parent + * 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)) { + if (ancestor == Tk_Parent(slavePtr->tkwin)) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + Tcl_AppendResult(interp, "can't place ", + Tk_PathName(slavePtr->tkwin), " relative to ", + Tk_PathName(tkwin), (char *) NULL); + result = TCL_ERROR; + goto done; + } + } + 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 (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; + } + } else if ((c == 'r') && (strncmp(argv[0], "-relwidth", length) == 0) + && (length >= 5)) { + 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; + } + } else if ((c == 'r') && (strncmp(argv[0], "-relx", length) == 0) + && (length >= 5)) { + if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->relX = d; + } else if ((c == 'r') && (strncmp(argv[0], "-rely", length) == 0) + && (length >= 5)) { + if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->relY = d; + } else if ((c == 'w') && (strncmp(argv[0], "-width", length) == 0)) { + if (argv[1][0] == 0) { + 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_WIDTH; + } + } else if ((c == 'x') && (strncmp(argv[0], "-x", length) == 0)) { + if (Tk_GetPixels(interp, slavePtr->tkwin, argv[1], + &slavePtr->x) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + } 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; + } + } else { + Tcl_AppendResult(interp, "unknown or ambiguous option \"", + argv[0], "\": must be -anchor, -bordermode, -height, ", + "-in, -relheight, -relwidth, -relx, -rely, -width, ", + "-x, or -y", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } + + /* + * If there's no master specified for this slave, use its Tk_Parent. + * Then arrange for a placement recalculation in the master. + */ + + done: + masterPtr = slavePtr->masterPtr; + if (masterPtr == NULL) { + masterPtr = FindMaster(Tk_Parent(slavePtr->tkwin)); + slavePtr->masterPtr = masterPtr; + slavePtr->nextPtr = masterPtr->slavePtr; + masterPtr->slavePtr = slavePtr; + } + if (!(masterPtr->flags & PARENT_RECONFIG_PENDING)) { + masterPtr->flags |= PARENT_RECONFIG_PENDING; + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * RecomputePlacement -- + * + * This procedure is called as a when-idle handler. It recomputes + * the geometries of all the slaves of a given master. + * + * Results: + * None. + * + * Side effects: + * Windows may change size or shape. + * + *---------------------------------------------------------------------- + */ + +static void +RecomputePlacement(clientData) + ClientData clientData; /* Pointer to Master record. */ +{ + register Master *masterPtr = (Master *) clientData; + register Slave *slavePtr; + int x, y, width, height, tmp; + int masterWidth, masterHeight, masterBW; + double x1, y1, x2, y2; + + masterPtr->flags &= ~PARENT_RECONFIG_PENDING; + + /* + * Iterate over all the slaves for the master. Each slave's + * geometry can be computed independently of the other slaves. + */ + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + /* + * Step 1: compute size and borderwidth of master, taking into + * account desired border mode. + */ + + masterBW = 0; + masterWidth = Tk_Width(masterPtr->tkwin); + masterHeight = Tk_Height(masterPtr->tkwin); + if (slavePtr->borderMode == BM_INSIDE) { + masterBW = Tk_InternalBorderWidth(masterPtr->tkwin); + } else if (slavePtr->borderMode == BM_OUTSIDE) { + masterBW = -Tk_BorderWidth(masterPtr->tkwin); + } + masterWidth -= 2*masterBW; + masterHeight -= 2*masterBW; + + /* + * Step 2: compute size of slave (outside dimensions including + * border) and location of anchor point within master. + */ + + 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_BorderWidth(slavePtr->tkwin); + } + 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_BorderWidth(slavePtr->tkwin); + } + + /* + * Step 3: adjust the x and y positions so that the desired + * anchor point on the slave appears at that position. Also + * adjust for the border mode and master's border. + */ + + switch (slavePtr->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; + } + + /* + * 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. + */ + + width -= 2*Tk_BorderWidth(slavePtr->tkwin); + height -= 2*Tk_BorderWidth(slavePtr->tkwin); + if (width <= 0) { + width = 1; + } + if (height <= 0) { + height = 1; + } + + /* + * 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 (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); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * MasterStructureProc -- + * + * This procedure is invoked by the Tk event handler when + * StructureNotify events occur for a master window. + * + * Results: + * None. + * + * Side effects: + * Structures get cleaned up if the window was deleted. If the + * window was resized then slave geometries get recomputed. + * + *---------------------------------------------------------------------- + */ + +static void +MasterStructureProc(clientData, eventPtr) + ClientData clientData; /* Pointer to Master structure for window + * referred to by eventPtr. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register Master *masterPtr = (Master *) clientData; + register Slave *slavePtr, *nextPtr; + + if (eventPtr->type == ConfigureNotify) { + if ((masterPtr->slavePtr != NULL) + && !(masterPtr->flags & PARENT_RECONFIG_PENDING)) { + masterPtr->flags |= PARENT_RECONFIG_PENDING; + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + } + } else if (eventPtr->type == DestroyNotify) { + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = nextPtr) { + slavePtr->masterPtr = NULL; + nextPtr = slavePtr->nextPtr; + slavePtr->nextPtr = NULL; + } + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&masterTable, + (char *) masterPtr->tkwin)); + if (masterPtr->flags & PARENT_RECONFIG_PENDING) { + 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); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * SlaveStructureProc -- + * + * This procedure is invoked by the Tk event handler when + * StructureNotify events occur for a slave window. + * + * Results: + * None. + * + * Side effects: + * Structures get cleaned up if the window was deleted. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveStructureProc(clientData, eventPtr) + ClientData clientData; /* Pointer to Slave structure for window + * referred to by eventPtr. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register Slave *slavePtr = (Slave *) clientData; + + if (eventPtr->type == DestroyNotify) { + UnlinkSlave(slavePtr); + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&slaveTable, + (char *) slavePtr->tkwin)); + ckfree((char *) slavePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * PlaceRequestProc -- + * + * This procedure is invoked by Tk whenever a slave managed by us + * changes its requested geometry. + * + * Results: + * None. + * + * Side effects: + * The window will get relayed out, if its requested size has + * anything to do with its actual size. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PlaceRequestProc(clientData, tkwin) + ClientData clientData; /* Pointer to our record for slave. */ + Tk_Window tkwin; /* Window that changed its desired + * size. */ +{ + Slave *slavePtr = (Slave *) clientData; + Master *masterPtr; + + if (((slavePtr->flags & (CHILD_WIDTH|CHILD_REL_WIDTH)) != 0) + && ((slavePtr->flags & (CHILD_HEIGHT|CHILD_REL_HEIGHT)) != 0)) { + return; + } + masterPtr = slavePtr->masterPtr; + if (masterPtr == NULL) { + return; + } + if (!(masterPtr->flags & PARENT_RECONFIG_PENDING)) { + masterPtr->flags |= PARENT_RECONFIG_PENDING; + 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); +} ADDED tkPort.h Index: tkPort.h ================================================================== --- tkPort.h +++ tkPort.h @@ -0,0 +1,185 @@ +/* + * tkPort.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. + * 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. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#ifndef _TKPORT +#define _TKPORT + +/* + * 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 +#ifdef HAVE_LIMITS_H +# include +#else +# include "compat/limits.h" +#endif +#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 + +/* + * Not all systems declare the errno variable in errno.h. so this + * file does it explicitly. + */ + +extern int errno; + +/* + * 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 macro checks to see whether there is buffered + * input data available for a stdio FILE. This has to be done + * in different ways on different systems. TK_FILE_GPTR and + * TK_FILE_COUNT are #defined by autoconf. + */ + +#ifdef TK_FILE_COUNT +# define TK_READ_DATA_PENDING(f) ((f)->TK_FILE_COUNT > 0) +#else +# ifdef TK_FILE_GPTR +# define TK_READ_DATA_PENDING(f) ((f)->_gptr < (f)->_egptr) +# else +# ifdef TK_FILE_READ_PTR +# define TK_READ_DATA_PENDING(f) ((f)->_IO_read_ptr != (f)->_IO_read_end) +# else + /* + * Don't know what to do for this system; whoever installs + * Tk will have to write a function TkReadDataPending to do + * the job. + */ + EXTERN int TkReadDataPending _ANSI_ARGS_((FILE *f)); +# define TK_READ_DATA_PENDING(f) TkReadDataPending(f) +# endif +# endif +#endif + +/* + * Substitute Tcl's own versions for several system calls. The + * Tcl versions retry automatically if interrupted by signals. + */ + +#ifdef OLDTCL +#define open(a,b,c) TclOpen(a,b,c) +#define read(a,b,c) TclRead(a,b,c) +#endif +#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)); + +/* + * If this system has a BSDgettimeofday function (e.g. IRIX) use it + * instead of gettimeofday; the gettimeofday function has a different + * interface than the BSD one that this code expects. + */ + +#ifdef HAVE_BSDGETTIMEOFDAY +# define gettimeofday BSDgettimeofday +#endif +#ifdef GETTOD_NOT_DECLARED +EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp, + struct timezone *tzp)); +#endif + +/* + * Declarations for various library procedures that may not be declared + * in any other header file. + */ + +//extern void panic(); + +#endif /* _TKPORT */ ADDED tkPreserve.c Index: tkPreserve.c ================================================================== --- tkPreserve.c +++ tkPreserve.c @@ -0,0 +1,231 @@ +/* + * tkPreserve.c (CTk) -- + * + * 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-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "tk.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 + * 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 + * for block. */ + int mustFree; /* Non-zero means Tk_EventuallyFree was + * called while a Tk_Preserve call was in + * effect, so the structure must be freed + * when refCount becomes zero. */ + Tk_FreeProc *freeProc; /* Procedure to call to free. */ +} Reference; + +static Reference *refArray; /* First in array of references. */ +static int spaceAvl = 0; /* Total number of structures available + * at *firstRefPtr. */ +static int inUse = 0; /* Count of structures currently in use + * in refArray. */ +#define INITIAL_SIZE 2 + +/* + *---------------------------------------------------------------------- + * + * Tk_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. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +void +Tk_Preserve(clientData) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ +{ + register Reference *refPtr; + int i; + + /* + * See if there is already a reference for this pointer. If so, + * just increment its reference count. + */ + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData == clientData) { + refPtr->refCount++; + return; + } + } + + /* + * Make a reference array if it doesn't already exist, or make it + * bigger if it is full. + */ + + if (inUse == spaceAvl) { + if (spaceAvl == 0) { + refArray = (Reference *) ckalloc((unsigned) + (INITIAL_SIZE*sizeof(Reference))); + spaceAvl = INITIAL_SIZE; + } else { + Reference *new; + + new = (Reference *) ckalloc((unsigned) + (2*spaceAvl*sizeof(Reference))); + memcpy((VOID *) new, (VOID *) refArray, spaceAvl*sizeof(Reference)); + ckfree((char *) refArray); + refArray = new; + spaceAvl *= 2; + } + } + + /* + * Make a new entry for the new reference. + */ + + refPtr = &refArray[inUse]; + refPtr->clientData = clientData; + refPtr->refCount = 1; + refPtr->mustFree = 0; + inUse += 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_Release -- + * + * This procedure is called to cancel a previous call to + * Tk_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 + * memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_Release(clientData) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ +{ + register Reference *refPtr; + int i; + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData != clientData) { + continue; + } + 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. + */ + + inUse--; + if (i < inUse) { + refArray[i] = refArray[inUse]; + } + } + return; + } + + /* + * Reference not found. This is a bug in the caller. + */ + + panic("Tk_Release couldn't find reference for 0x%x", clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_EventuallyFree -- + * + * Free up a block of memory, unless a call to Tk_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. + * + * Results: + * None. + * + * Side effects: + * Ptr may be released by calling free(). + * + *---------------------------------------------------------------------- + */ + +void +Tk_EventuallyFree(clientData, freeProc) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ + Tk_FreeProc *freeProc; /* Procedure to actually do free. */ +{ + register Reference *refPtr; + int i; + + /* + * See if there is a reference for this pointer. If so, set its + * "mustFree" flag (the flag had better not be set already!). + */ + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData != clientData) { + continue; + } + if (refPtr->mustFree) { + panic("Tk_EventuallyFree called twice for 0x%x\n", clientData); + } + refPtr->mustFree = 1; + refPtr->freeProc = freeProc; + return; + } + + /* + * No reference for this block. Free it now. + */ + + if (freeProc == (Tk_FreeProc *) free) { + ckfree((char *) clientData); + } else { + (*freeProc)(clientData); + } +} ADDED tkScrollbar.c Index: tkScrollbar.c ================================================================== --- tkScrollbar.c +++ tkScrollbar.c @@ -0,0 +1,865 @@ +/* + * tkScrollbar.c (CTk) -- + * + * This module implements a scrollbar widgets for the CTk + * toolkit. A scrollbar displays a slider and two arrows; + * mouse clicks on features within the scrollbar cause + * scrolling commands to be invoked. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tkPort.h" +#include "default.h" +#include "tkInt.h" + +/* + * A data structure of the following type is kept for each scrollbar + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the scrollbar. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + 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 + * requested, zero means horizontal. */ + int width; /* Desired narrow dimension of scrollbar, + * in pixels. */ + char *command; /* Command prefix to use when invoking + * scrolling commands. NULL means don't + * invoke commands. Malloc'ed. */ + int commandSize; /* Number of non-NULL bytes in command. */ + + /* + * Information used when displaying widget: + */ + + int borderWidth; /* Width of border in pixels. */ + int sliderFirst; /* Character coordinate of top or left edge + * of slider area, including border. */ + int sliderLast; /* Coordinate of character just after bottom + * or right edge of slider area, including + * border. */ + + /* + * Information describing the application related to the scrollbar. + * This information is provided by the application by invoking the + * "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. 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. 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: + */ + + 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; + +/* + * Flag bits for scrollbars: + * + * 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 and (fixed) arrow length, in characters. + */ +#define MIN_SLIDER_LENGTH 1 +#define ARROW_LENGTH 1 + +/* + * Information used for argv parsing. + */ +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_SCROLLBAR_BORDER_WIDTH, Tk_Offset(Scrollbar, borderWidth), 0}, + {TK_CONFIG_STRING, "-command", "command", "Command", + DEF_SCROLLBAR_COMMAND, Tk_Offset(Scrollbar, command), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_UID, "-orient", "orient", "Orient", + DEF_SCROLLBAR_ORIENT, Tk_Offset(Scrollbar, orientUid), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_SCROLLBAR_TAKE_FOCUS, Tk_Offset(Scrollbar, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-width", "width", "Width", + DEF_SCROLLBAR_WIDTH, Tk_Offset(Scrollbar, 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 ComputeScrollbarGeometry _ANSI_ARGS_(( + Scrollbar *scrollPtr)); +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 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, + Ctk_Event *eventPtr)); +static int ScrollbarWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *, int argc, char **argv)); + +/* + *-------------------------------------------------------------- + * + * Tk_ScrollbarCmd -- + * + * This procedure is invoked to process the "scrollbar" 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_ScrollbarCmd(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 Scrollbar *scrollPtr; + 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 ConfigureScrollbar, + * or which ConfigureScrollbar expects to have reasonable values + * (e.g. resource pointers). + */ + + scrollPtr = (Scrollbar *) ckalloc(sizeof(Scrollbar)); + scrollPtr->tkwin = 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; + scrollPtr->command = NULL; + scrollPtr->commandSize = 0; + scrollPtr->borderWidth = 0; + scrollPtr->sliderFirst = 0; + scrollPtr->sliderLast = 0; + scrollPtr->totalUnits = 0; + scrollPtr->windowUnits = 0; + scrollPtr->firstUnit = 0; + scrollPtr->lastUnit = 0; + scrollPtr->firstFraction = 0.0; + scrollPtr->lastFraction = 0.0; + scrollPtr->takeFocus = NULL; + scrollPtr->flags = 0; + + Tk_SetClass(scrollPtr->tkwin, "Scrollbar"); + Tk_CreateEventHandler(scrollPtr->tkwin, + CTK_EXPOSE_EVENT_MASK|CTK_FOCUS_EVENT_MASK|CTK_MAP_EVENT_MASK + |CTK_DESTROY_EVENT_MASK, + ScrollbarEventProc, (ClientData) scrollPtr); + if (ConfigureScrollbar(interp, scrollPtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + Tcl_SetResult(interp,Tk_PathName(scrollPtr->tkwin),TCL_VOLATILE); + return TCL_OK; + + error: + Tk_DestroyWindow(scrollPtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * ScrollbarWidgetCmd -- + * + * 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 +ScrollbarWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about scrollbar + * widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Scrollbar *scrollPtr = (Scrollbar *) 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; + } + Tk_Preserve((ClientData) scrollPtr); + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0)) { + result = Ctk_Unsupported(interp, "scrollbar activate"); + } 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); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, scrollPtr->tkwin, configSpecs, + (char *) scrollPtr, argv[2], 0); + } else { + 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*(ARROW_LENGTH + scrollPtr->borderWidth); + } else { + pixels = xDelta; + length = Tk_Width(scrollPtr->tkwin) - 1 + - 2*(ARROW_LENGTH + scrollPtr->borderWidth); + } + if (length == 0) { + fraction = 0.0; + } else { + fraction = ((double) pixels / (double) length); + } + { + char buffer[30]; + sprintf(buffer, "%g", fraction); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } 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 - (ARROW_LENGTH + scrollPtr->borderWidth); + length = Tk_Height(scrollPtr->tkwin) - 1 + - 2*(ARROW_LENGTH + scrollPtr->borderWidth); + } else { + pos = x - (ARROW_LENGTH + scrollPtr->borderWidth); + length = Tk_Width(scrollPtr->tkwin) - 1 + - 2*(ARROW_LENGTH + scrollPtr->borderWidth); + } + 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; + } + { + char buffer[30]; + sprintf(buffer, "%g", fraction); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } 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; + } + 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 { + char buffer[100]; + sprintf(buffer, "%d %d %d %d", scrollPtr->totalUnits, + scrollPtr->windowUnits, scrollPtr->firstUnit, + scrollPtr->lastUnit); + Tcl_SetResult(interp, buffer, TCL_VOLATILE); + } + } else if ((c == 'i') && (strncmp(argv[1], "identify", length) == 0)) { + result = Ctk_Unsupported(interp, "scrollbar identify"); + } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)) { + int totalUnits, windowUnits, firstUnit, lastUnit; + + 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; + } + ComputeScrollbarGeometry(scrollPtr); + EventuallyRedraw(scrollPtr); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be activate, cget, configure, delta, fraction, ", + "get, identify, or set", (char *) NULL); + goto error; + } + Tk_Release((ClientData) scrollPtr); + return result; + + error: + Tk_Release((ClientData) scrollPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyScrollbar -- + * + * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * to clean up the internal structure of a scrollbar at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the scrollbar is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyScrollbar(clientData) + ClientData clientData; /* Info about scrollbar widget. */ +{ + register Scrollbar *scrollPtr = (Scrollbar *) clientData; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + Tk_FreeOptions(configSpecs, (char *) scrollPtr, 0); + ckfree((char *) scrollPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureScrollbar -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a scrollbar 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 scrollPtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureScrollbar(interp, scrollPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Scrollbar *scrollPtr; /* 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. */ +{ + size_t length; + + if (Tk_ConfigureWidget(interp, scrollPtr->tkwin, configSpecs, + argc, argv, (char *) scrollPtr, 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. + */ + + if (scrollPtr->width < 1) { + scrollPtr->width = 1; + } + length = strlen(scrollPtr->orientUid); + if (strncmp(scrollPtr->orientUid, "vertical", length) == 0) { + scrollPtr->vertical = 1; + } else if (strncmp(scrollPtr->orientUid, "horizontal", length) == 0) { + scrollPtr->vertical = 0; + } else { + Tcl_AppendResult(interp, "bad orientation \"", scrollPtr->orientUid, + "\": must be vertical or horizontal", (char *) NULL); + return TCL_ERROR; + } + + if (scrollPtr->command != NULL) { + scrollPtr->commandSize = strlen(scrollPtr->command); + } else { + scrollPtr->commandSize = 0; + } + + /* + * Register the desired geometry for the window (leave enough space + * for the two arrows plus a minimum-size slider, plus border around + * the whole window, if any). Then arrange for the window to be + * redisplayed. + */ + + Tk_SetInternalBorder(scrollPtr->tkwin, scrollPtr->borderWidth); + ComputeScrollbarGeometry(scrollPtr); + EventuallyRedraw(scrollPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DisplayScrollbar -- + * + * This procedure redraws the contents of a scrollbar 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 +DisplayScrollbar(clientData) + ClientData clientData; /* Information about window. */ +{ + register Scrollbar *scrollPtr = (Scrollbar *) clientData; + register Tk_Window tkwin = scrollPtr->tkwin; + int bd = scrollPtr->borderWidth; + int xBound = Tk_Width(tkwin) - bd; + int yBound = Tk_Height(tkwin) - bd; + int middle; + + if ((scrollPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + goto done; + } + + if (scrollPtr->vertical) { + if (Tk_Width(tkwin) > 1 + 2*bd) { + Ctk_FillRect(tkwin, bd, bd, xBound, yBound, CTK_PLAIN_STYLE, ' '); + } + middle = Tk_Width(tkwin)/2; + Ctk_DrawCharacter(tkwin, middle, bd, CTK_PLAIN_STYLE, '^'); + Ctk_FillRect(tkwin, middle, bd+1, middle+1, yBound-1, + CTK_PLAIN_STYLE, '|'); + Ctk_DrawCharacter(tkwin, middle, yBound-1, CTK_PLAIN_STYLE, 'V'); + Ctk_FillRect(scrollPtr->tkwin, + middle, scrollPtr->sliderFirst, middle+1, scrollPtr->sliderLast, + CTK_PLAIN_STYLE, '#'); + if (scrollPtr->flags & GOT_FOCUS) { + Ctk_SetCursor(tkwin, middle, scrollPtr->sliderFirst); + } + } else { + if (Tk_Height(tkwin) > 1 + 2*bd) { + Ctk_FillRect(tkwin, bd, bd, xBound, yBound, CTK_PLAIN_STYLE, ' '); + } + middle = Tk_Height(tkwin)/2; + Ctk_DrawCharacter(tkwin, bd, middle, CTK_PLAIN_STYLE, '<'); + Ctk_FillRect(tkwin, bd+1, middle, xBound-1, middle+1, + CTK_PLAIN_STYLE, '-'); + Ctk_DrawCharacter(tkwin, xBound-1, middle, CTK_PLAIN_STYLE, '>'); + Ctk_FillRect(scrollPtr->tkwin, + scrollPtr->sliderFirst, middle, scrollPtr->sliderLast, middle+1, + CTK_PLAIN_STYLE, '#'); + if (scrollPtr->flags & GOT_FOCUS) { + Ctk_SetCursor(tkwin, scrollPtr->sliderFirst, middle); + } + } + Ctk_DrawBorder(tkwin, CTK_PLAIN_STYLE, (char *)NULL); + + done: + scrollPtr->flags &= ~REDRAW_PENDING; +} + +/* + *-------------------------------------------------------------- + * + * ScrollbarEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on scrollbars. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +ScrollbarEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + Ctk_Event *eventPtr; /* Information about event. */ +{ + Scrollbar *scrollPtr = (Scrollbar *) clientData; + + if (eventPtr->type == CTK_EXPOSE_EVENT) { + EventuallyRedraw(scrollPtr); + } else if (eventPtr->type == CTK_DESTROY_EVENT) { + if (scrollPtr->tkwin != NULL) { + scrollPtr->tkwin = NULL; + Tcl_DeleteCommand(scrollPtr->interp, + Tcl_GetCommandName(scrollPtr->interp, + scrollPtr->widgetCmd)); + } + if (scrollPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayScrollbar, (ClientData) scrollPtr); + } + Tk_EventuallyFree((ClientData) scrollPtr, DestroyScrollbar); + } else if (eventPtr->type == CTK_FOCUS_EVENT) { + scrollPtr->flags |= GOT_FOCUS; + } else if (eventPtr->type == CTK_UNFOCUS_EVENT) { + scrollPtr->flags &= ~GOT_FOCUS; + } else if (eventPtr->type == CTK_MAP_EVENT) { + ComputeScrollbarGeometry(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); + } +} + +/* + *---------------------------------------------------------------------- + * + * ComputeScrollbarGeometry -- + * + * After changes in a scrollbar's size or configuration, this + * procedure recomputes various geometry information used in + * displaying the scrollbar. + * + * Results: + * None. + * + * Side effects: + * The scrollbar will be displayed differently. + * + *---------------------------------------------------------------------- + */ + +static void +ComputeScrollbarGeometry(scrollPtr) + register Scrollbar *scrollPtr; /* Scrollbar whose geometry may + * have changed. */ +{ + int width, fieldLength; + + width = (scrollPtr->vertical) + ? Tk_Width(scrollPtr->tkwin) : Tk_Height(scrollPtr->tkwin); + fieldLength = ( scrollPtr->vertical + ? (Tk_Height(scrollPtr->tkwin) - 2*scrollPtr->borderWidth) + : (Tk_Width(scrollPtr->tkwin) - 2*scrollPtr->borderWidth) ) + - 2*ARROW_LENGTH; + if (fieldLength < 0) { + fieldLength = 0; + } + 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). + */ + if (scrollPtr->sliderFirst > (fieldLength - 1)) { + scrollPtr->sliderFirst = fieldLength - 1; + } + 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->vertical) { + scrollPtr->sliderFirst += ARROW_LENGTH + scrollPtr->borderWidth; + scrollPtr->sliderLast += ARROW_LENGTH + scrollPtr->borderWidth; + } else { + scrollPtr->sliderFirst += ARROW_LENGTH + scrollPtr->borderWidth; + scrollPtr->sliderLast += ARROW_LENGTH + scrollPtr->borderWidth; + } + + /* + * Register the desired geometry for the window (leave enough space + * for the two arrows plus a minimum-size slider, plus border around + * the whole window, if any). Then arrange for the window to be + * redisplayed. + */ + if (scrollPtr->vertical) { + Tk_GeometryRequest(scrollPtr->tkwin, + scrollPtr->width + 2*scrollPtr->borderWidth, + MIN_SLIDER_LENGTH + 2*(ARROW_LENGTH + scrollPtr->borderWidth)); + } else { + Tk_GeometryRequest(scrollPtr->tkwin, + MIN_SLIDER_LENGTH + 2*(ARROW_LENGTH + scrollPtr->borderWidth), + scrollPtr->width + 2*scrollPtr->borderWidth); + } +} + +/* + *-------------------------------------------------------------- + * + * EventuallyRedraw -- + * + * Arrange for one or more of the fields of a scrollbar + * to be redrawn. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +EventuallyRedraw(scrollPtr) + register Scrollbar *scrollPtr; /* Information about widget. */ +{ + if ((scrollPtr->tkwin == NULL) || (!Tk_IsMapped(scrollPtr->tkwin))) { + return; + } + if ((scrollPtr->flags & REDRAW_PENDING) == 0) { + Tcl_DoWhenIdle(DisplayScrollbar, (ClientData) scrollPtr); + scrollPtr->flags |= REDRAW_PENDING; + } +} ADDED tkText.c Index: tkText.c ================================================================== --- tkText.c +++ tkText.c @@ -0,0 +1,1491 @@ +/* + * tkText.c (CTk) -- + * + * 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-1995 Sun Microsystems, Inc. + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + + +#include "default.h" +#include "tkPort.h" +#include "tkInt.h" +#include "tkText.h" + +/* + * Information used to parse text configuration options: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_TEXT_BORDER_WIDTH, Tk_Offset(TkText, borderWidth), 0}, + {TK_CONFIG_PIXELS, "-height", "height", "Height", + DEF_TEXT_HEIGHT, Tk_Offset(TkText, height), 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_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_((ClientData clientData)); +static void InsertChars _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, char *string)); +static void TextCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void TextEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +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)); + +/* + *-------------------------------------------------------------- + * + * 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->interp = interp; + textPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(textPtr->tkwin), TextWidgetCmd, + (ClientData) textPtr, TextCmdDeletedProc); + textPtr->tree = TkBTreeCreate(); + 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->borderWidth = 0; + textPtr->padX = 0; + textPtr->padY = 0; + 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->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->insertMarkPtr = NULL; + textPtr->takeFocus = NULL; + textPtr->xScrollCmd = NULL; + textPtr->yScrollCmd = NULL; + textPtr->flags = 0; + + /* + * Create the "sel" tag and the "insert" mark. + */ + + textPtr->selTagPtr = TkTextCreateTag(textPtr, "sel"); + /* + * Should set "sel" tag to REVERSE style here (when I support + * setting arbitrary styles for tags). + */ + textPtr->insertMarkPtr = TkTextSetMark(textPtr, "insert", &startIndex); + + Tk_SetClass(new, "Text"); + Tk_CreateEventHandler(textPtr->tkwin, + CTK_EXPOSE_EVENT_MASK|CTK_DESTROY_EVENT_MASK|CTK_MAP_EVENT_MASK + |CTK_FOCUS_EVENT_MASK, + TextEventProc, (ClientData) textPtr); + if (ConfigureText(interp, textPtr, argc-2, argv+2, 0) != TCL_OK) { + Tk_DestroyWindow(textPtr->tkwin); + return TCL_ERROR; + } + Tcl_SetResult(interp,Tk_PathName(textPtr->tkwin),TCL_VOLATILE); + + 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; + } + Tk_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) { + char buffer[80]; + sprintf(buffer, "%d %d %d %d", x, y, width, height); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } 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; + } + Tcl_SetResult(interp,(value) ? "1" : "0",TCL_STATIC); + } 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) { + Tcl_SetResult(interp,(tkBTreeDebug) ? "1" : "0",TCL_STATIC); + } 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) { + char buffer[100]; + sprintf(buffer, "%d %d %d %d %d", + x, y, width, height, base); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + } + } 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 == '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 = Ctk_Unsupported(interp, "scan"); + } 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); */ + result = Ctk_Unsupported(interp, "window"); + } 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: + 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. 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); + } + + Tk_FreeOptions(configSpecs, (char *) textPtr, 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. */ +{ + 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; + } + + /* + * 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->affectsDisplay = 0; + if ((textPtr->selTagPtr->justifyString != NULL) + || (textPtr->selTagPtr->lMargin1String != NULL) + || (textPtr->selTagPtr->lMargin2String != NULL) + || (textPtr->selTagPtr->offsetString != 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); + + /* + * 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; + } + Tk_GeometryRequest(textPtr->tkwin, + textPtr->width + 2*textPtr->borderWidth + 2*textPtr->padX, + textPtr->height + 2*textPtr->borderWidth + 2*textPtr->padY); + Tk_SetInternalBorder(textPtr->tkwin, textPtr->borderWidth); + 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 == CTK_EXPOSE_EVENT) { + TkTextRedrawRegion(textPtr, + eventPtr->u.expose.left, eventPtr->u.expose.top, + eventPtr->u.expose.right - eventPtr->u.expose.left, + eventPtr->u.expose.bottom - eventPtr->u.expose.top); + } else if (eventPtr->type == CTK_MAP_EVENT) { + 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 == CTK_DESTROY_EVENT) { + if (textPtr->tkwin != NULL) { + textPtr->tkwin = NULL; + Tcl_DeleteCommand(textPtr->interp, + Tcl_GetCommandName(textPtr->interp, + textPtr->widgetCmd)); + } + Tk_EventuallyFree((ClientData) textPtr, DestroyText); + } else if (eventPtr->type == CTK_FOCUS_EVENT) { + textPtr->flags |= GOT_FOCUS; + TkTextMarkSegToIndex(textPtr, textPtr->insertMarkPtr, &index); + TkTextIndexForwChars(&index, 1, &index2); + TkTextChanged(textPtr, &index, &index2); + } else if (eventPtr->type == CTK_UNFOCUS_EVENT) { + textPtr->flags &= ~GOT_FOCUS; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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) { + 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; + + /* + * 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. + */ + + TkTextChanged(textPtr, indexPtr, indexPtr); + TkBTreeInsertChars(indexPtr, string); +} + +/* + *---------------------------------------------------------------------- + * + * 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); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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)) { + Tcl_SetResult(interp,"no value given for \"-count\" option",TCL_STATIC); + 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; +} ADDED tkText.h Index: tkText.h ================================================================== --- tkText.h +++ tkText.h @@ -0,0 +1,680 @@ +/* + * tkText.h (CTk.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. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#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, + Tk_Window win)); +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 *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 Style *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 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. */ + + /* + * 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. + */ + + 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 *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.*/ + 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). + */ + + int borderWidth; /* Width of 3-D border to draw around entire + * widget. */ + int padX, padY; /* Padding between text and window border. */ + 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 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 DInfo *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. */ + TkTextIndex selIndex; /* Used during multi-pass selection retrievals. + * This index identifies the next character + * to be returned from the selection. */ + + /* + * Information related to insertion cursor: + */ + + TkTextSegment *insertMarkPtr; + /* Points to segment for "insert" mark. */ + + /* + * 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_FOCUS: Non-zero means this window has the input + * focus. + * UPDATE_SCROLLBARS: Non-zero means scrollbar(s) should be updated + * during next redisplay operation. + */ + +#define GOT_FOCUS 4 +#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_((void)); +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 void TkBTreeStartSearch _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 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 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 */ ADDED tkTextBTree.c Index: tkTextBTree.c ================================================================== --- tkTextBTree.c +++ tkTextBTree.c @@ -0,0 +1,2789 @@ +/* + * tkTextBTree.c (CTk) -- + * + * 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. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + + +#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. */ +} 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)); + +/* + * 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() +{ + 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; + + 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; + + /* + * 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; + } + 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; + } + } + 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. + * + * 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; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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(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; + + 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. + */ + + if (index1Ptr->charIndex >= index2Ptr->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; + } + + /* + * 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) { + 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; + } + } + } + } + + /* + * 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; + + /* + * Make sure that overall there is an even count of tag transitions + * for the whole tree. + */ + + 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 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) { + 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) { + 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. + */ + + 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; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * 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 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; + + if (segPtr->size != 0) { + panic("ToggleCheckProc: segment had non-zero size"); + } + if (!segPtr->body.toggle.inNodeCounts) { + panic("ToggleCheckProc: toggle counts not updated in nodes"); + } + for (summaryPtr = linePtr->parentPtr->summaryPtr; ; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr == NULL) { + panic("ToggleCheckProc: tag not present in node"); + } + if (summaryPtr->tagPtr == segPtr->body.toggle.tagPtr) { + 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; +} ADDED tkTextDisp.c Index: tkTextDisp.c ================================================================== --- tkTextDisp.c +++ tkTextDisp.c @@ -0,0 +1,3758 @@ +/* + * tkTextDisp.c (CTk) -- + * + * 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. + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + + +#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 { + 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 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 + * the CTk style 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. */ + Ctk_Style ctkStyle; + 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 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 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: + * + * 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 NEW_LAYOUT 2 +#define TOP_LINE 4 +#define BOTTOM_LINE 8 + +/* + * 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. */ + 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. */ + + /* + * 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. */ +} DInfo; + +/* + * 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 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. + */ + +#define DINFO_OUT_OF_DATE 1 +#define REDRAW_PENDING 2 +#define REDRAW_BORDERS 4 + +/* + * 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. */ + +/* + * 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 *xPtr, int *yPtr, int *widthPtr, + int *heightPtr)); +static void CharDisplayProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int x, int y, Tk_Window win)); +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)); +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, + Style *stylePtr)); +static Style * 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)); + +/* + *---------------------------------------------------------------------- + * + * 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; + + dInfoPtr = (DInfo *) ckalloc(sizeof(DInfo)); + Tcl_InitHashTable(&dInfoPtr->styleTable, sizeof(StyleValues)/sizeof(int)); + dInfoPtr->dLinePtr = NULL; + 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->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 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); + 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 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, 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; + Style *stylePtr; + Tcl_HashEntry *hPtr; + int numTags, new, i; + + /* + * The variables below keep track of the highest-priority specification + * that has occurred for each of the various fields of the StyleValues. + */ + + int underlinePrio, justifyPrio, offsetPrio; + int lMargin1Prio, lMargin2Prio, rMarginPrio; + int spacing1Prio, spacing2Prio, spacing3Prio; + int 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); + underlinePrio = justifyPrio = offsetPrio = -1; + lMargin1Prio = lMargin2Prio = rMarginPrio = -1; + spacing1Prio = spacing2Prio = spacing3Prio = -1; + tabPrio = wrapPrio = -1; + memset((VOID *) &styleValues, 0, sizeof(StyleValues)); + 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->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->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 = (Style *) Tcl_GetHashValue(hPtr); + stylePtr->refCount++; + return stylePtr; + } + + /* + * No existing style matched. Make a new one. + */ + + stylePtr = (Style *) ckalloc(sizeof(Style)); + stylePtr->refCount = 1; + stylePtr->ctkStyle = styleValues.underline ? + CTK_UNDERLINE_STYLE : CTK_PLAIN_STYLE; + 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) { + 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, 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->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; + } + 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; + } + for (chunkPtr = dlPtr->chunkPtr; chunkPtr != NULL; + chunkPtr = chunkPtr->nextPtr) { + chunkPtr->x += jIndent; + dlPtr->count += chunkPtr->numChars; + if (chunkPtr->minHeight > dlPtr->height) { + dlPtr->height = chunkPtr->minHeight; + } + } + 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 = 1 + dlPtr->spaceAbove + dlPtr->spaceBelow; + + /* + * 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 DInfo *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; + } + 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. + */ + + 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; + while (1) { + if (dlPtr->nextPtr == NULL) { + 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); + if (dInfoPtr->newCharOffset > maxOffset) { + dInfoPtr->newCharOffset = maxOffset; + } + if (dInfoPtr->newCharOffset < 0) { + dInfoPtr->newCharOffset = 0; + } + pixelOffset = dInfoPtr->newCharOffset; + 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) + 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. */ +{ + register Tk_Window win = textPtr->tkwin; + register TkTextDispChunk *chunkPtr; + DInfo *dInfoPtr = textPtr->dInfoPtr; + int height, x; + + /* + * First, clear the area of the line to the background color for the + * text widget. + */ + + height = dlPtr->height; + if ((height + dlPtr->y) > dInfoPtr->maxY) { + height = dInfoPtr->maxY - dlPtr->y; + } + Ctk_FillRect(win, dInfoPtr->x, dlPtr->y, dInfoPtr->maxX, dlPtr->y+height, + CTK_PLAIN_STYLE, ' '); + + /* + * 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) { + 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->y + dlPtr->spaceAbove, win); + } else { + (*chunkPtr->displayProc)(chunkPtr, x, dlPtr->y + dlPtr->spaceAbove, + win); + } + if (dInfoPtr->dLinesInvalidated) { + return; + } + } + + 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; + register DLine *dlPtr; + DLine *prevPtr; + int bottomY = 0; /* Initialization needed only to stop + * compiler warnings. */ + + if (textPtr->tkwin == NULL) { + /* + * The widget has been deleted. Don't do anything. + */ + + return; + } + + if (tkTextDebug) { + Tcl_SetVar2(textPtr->interp, "tk_textRelayout", (char *) NULL, + "", TCL_GLOBAL_ONLY); + } + + 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(textPtr->interp, "tk_textRedraw", (char *) NULL, + "", TCL_GLOBAL_ONLY); + } + + /* + * First recompute what's supposed to be displayed. + */ + + UpdateDisplayInfo(textPtr); + dInfoPtr->dLinesInvalidated = 0; + + /* + * 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(textPtr->interp, "tk_textRedraw", + (char *) NULL, "borders", + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + Ctk_DrawBorder(textPtr->tkwin, CTK_PLAIN_STYLE, (char *) NULL); + dInfoPtr->flags &= ~REDRAW_BORDERS; + } + + /* + * Now redraw the lines. + */ + + 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); + if (dInfoPtr->dLinesInvalidated) { + return; + } + dlPtr->oldY = dlPtr->y; + dlPtr->flags &= ~NEW_LAYOUT; + } + bottomY = dlPtr->y + dlPtr->height; + } + for ( ; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { + bottomY = dlPtr->y + dlPtr->height; + } + + /* + * See if we need to refresh the part of the window below the + * last line of text (if there is any such area). + */ + + 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); + } + Ctk_FillRect(textPtr->tkwin, + dInfoPtr->x, bottomY, dInfoPtr->maxX, dInfoPtr->topOfEof, + CTK_PLAIN_STYLE, ' '); + } + 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); + } + + /* + * Update the horizontal scrollbar, if any. + */ + + if (textPtr->xScrollCmd != NULL) { + GetXView(textPtr->interp, textPtr, 1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * 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, inset; + + /* + * 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; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + inset = textPtr->borderWidth; + if ((x < inset) || (y < inset) + || ((x + 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. */ +{ + DInfo *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; + + /* + * 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; + DInfo *dInfoPtr = textPtr->dInfoPtr; + 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); + tagOn = TkBTreeCharTagged(index1Ptr, tagPtr); + if (tagOn != withTag) { + if (!TkBTreeNextTag(&search)) { + return; + } + } + + /* + * 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; + + /* + * 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 (search.curIndex.charIndex == 0) { + dlPtr = FindDLine(dlPtr, &search.curIndex); + } else { + TkTextIndex tmp; + + tmp = search.curIndex; + 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 { + endIndexPtr = &search.curIndex; + } + 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. */ +{ + DInfo *dInfoPtr = textPtr->dInfoPtr; + + /* + * 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; + + /* + * 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. + */ + + dInfoPtr->x = textPtr->borderWidth + textPtr->padX; + dInfoPtr->y = textPtr->borderWidth + textPtr->padY; + dInfoPtr->maxX = Tk_Width(textPtr->tkwin) + - textPtr->borderWidth - textPtr->padX; + if (dInfoPtr->maxX <= dInfoPtr->x) { + dInfoPtr->maxX = dInfoPtr->x + 1; + } + dInfoPtr->maxY = Tk_Height(textPtr->tkwin) + - 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + DInfo *dInfoPtr = textPtr->dInfoPtr; + register DLine *dlPtr; + int bottomY, close, lineIndex; + 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. + * 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. + */ + + bottomY = (dInfoPtr->y + dInfoPtr->maxY + 1)/2; + close = (dInfoPtr->maxY - dInfoPtr->y)/3; + if (close < 3) { + close = 3; + } + close += 1; + 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; +} + +/* + *-------------------------------------------------------------- + * + * 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". */ +{ + DInfo *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, + &x, &y, &width, &height); + delta = x - dInfoPtr->curPixelOffset; + oneThird = lineWidth/3; + if (delta < 0) { + if (delta < -oneThird) { + dInfoPtr->newCharOffset = x - lineWidth/2; + } else { + dInfoPtr->newCharOffset -= -delta; + } + } else { + delta -= (lineWidth - width); + if (delta > 0) { + if (delta > oneThird) { + dInfoPtr->newCharOffset = x - lineWidth/2; + } else { + dInfoPtr->newCharOffset += delta ; + } + } 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". */ +{ + DInfo *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) + 0.5; + newOffset = fraction * dInfoPtr->maxLength; + break; + case TK_SCROLL_PAGES: + charsPerPage = (dInfoPtr->maxX - dInfoPtr->x) - 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; + DInfo *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; +} + +/* + *-------------------------------------------------------------- + * + * 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". */ +{ + DInfo *dInfoPtr = textPtr->dInfoPtr; + int pickPlace, lineNum, type, lineHeight; + 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); + index.charIndex = TkBTreeCharsInLine(index.linePtr) + * (fraction-lineNum) + 0.5; + 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 = 1; + 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; + break; + case TK_SCROLL_UNITS: + scrollByLines: + ScrollByLines(textPtr, count); + break; + } + 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. */ +{ + DInfo *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) { + char buffer[60]; + sprintf(buffer, "%g %g", first, last); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + 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. */ +{ + DInfo *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) { + char buffer[60]; + sprintf(buffer, "%g %g", first, last); + Tcl_SetResult(interp,buffer,TCL_VOLATILE); + 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). */ +{ + DInfo *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. */ +{ + DInfo *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, + 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. */ +{ + DInfo *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->spaceAbove; + 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. */ +{ + 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; + charsThatFit = TkMeasureChars(p, maxChars, chunkPtr->x, + maxX, 0, TK_IGNORE_TABS, &nextX); + if (charsThatFit < maxChars) { + if ((charsThatFit == 0) && noCharsYet) { + charsThatFit = 1; + TkMeasureChars(p, 1, chunkPtr->x, INT_MAX, 0, + TK_IGNORE_TABS, &nextX); + } + if (p[charsThatFit] == '\n') { + /* + * A newline character takes up no space, so if the previous + * character fits then so does the newline. + */ + + charsThatFit++; + } else if ((nextX < maxX) && (isspace(UCHAR(p[charsThatFit])))) { + /* + * 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 (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->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') { + 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, win) + TkTextDispChunk *chunkPtr; /* Chunk that is to be drawn. */ + int x; /* X-position in win 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 win. */ + Tk_Window win; /* Window in which to draw + * chunk. */ +{ + CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; + Style *stylePtr; + StyleValues *sValuePtr; + + if ((x + chunkPtr->width) <= 0) { + /* + * The chunk is off-screen. + */ + + return; + } + + stylePtr = chunkPtr->stylePtr; + sValuePtr = stylePtr->sValuePtr; + + /* + * Draw the text and underline for this chunk. + */ + + if (ciPtr->numChars > 0) { + TkDisplayChars(win, stylePtr->ctkStyle, + ciPtr->chars, ciPtr->numChars, x, + y + - sValuePtr->offset, x - chunkPtr->x, + TK_IGNORE_TABS); + } +} + +/* + *-------------------------------------------------------------- + * + * 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(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, 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 *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(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(ciPtr->chars + index, 1, + *xPtr, 1000000, 0, TK_IGNORE_TABS, widthPtr); + if (*widthPtr > maxX) { + *widthPtr = maxX - *xPtr; + } else { + *widthPtr -= *xPtr; + } + } + *yPtr = y; + *heightPtr = 1; +} + +/* + *---------------------------------------------------------------------- + * + * 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; + 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("\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(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 containin the + * tab. Be sure that the tab occupies at least the width of a + * space character. + */ + + update: + delta = desired - x; + if (delta < 1) { + delta = 1; + } + 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; + TkTextTabAlign alignment; + + if ((tabArrayPtr == NULL) || (tabArrayPtr->numTabs == 0)) { + TkMeasureChars("\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: + if (result < 1) { + result = 1; + } + return result; +} ADDED tkTextIndex.c Index: tkTextIndex.c ================================================================== --- tkTextIndex.c +++ tkTextIndex.c @@ -0,0 +1,831 @@ +/* + * tkTextIndex.c (CTk) -- + * + * 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. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + + +#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 0 + 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; + } + } +#endif + 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; +} ADDED tkTextMark.c Index: tkTextMark.c ================================================================== --- tkTextMark.c +++ tkTextMark.c @@ -0,0 +1,577 @@ +/* + * tkTextMark.c (CTk) -- + * + * 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. + * Copyright (c) 1995 Martin Andrews + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + + +#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 void InsertDisplayProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int x, int y, + Tk_Window win)); + +/* + * 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) { + Tcl_SetResult(interp,"right",TCL_STATIC); + } else { + Tcl_SetResult(interp,"left",TCL_STATIC); + } + 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 == '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)) { + 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, 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 = InsertDisplayProc; + chunkPtr->undisplayProc = InsertUndisplayProc; + chunkPtr->measureProc = (Tk_ChunkMeasureProc *) NULL; + chunkPtr->bboxProc = (Tk_ChunkBboxProc *) NULL; + chunkPtr->numChars = 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; +} + +/* + *-------------------------------------------------------------- + * + * InsertDisplayProc -- + * + * This procedure is called to display the insertion + * cursor. + * + * Results: + * None. + * + * Side effects: + * Graphics are drawn. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +InsertDisplayProc(chunkPtr, x, y, win) + 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). */ + Tk_Window win; /* Window in which to draw chunk. */ +{ + TkText *textPtr = (TkText *) chunkPtr->clientData; + if (textPtr->flags & GOT_FOCUS) { + Ctk_SetCursor(win, x, y); + } +} + +/* + *-------------------------------------------------------------- + * + * 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"); + } + } +} ADDED tkTextTag.c Index: tkTextTag.c ================================================================== --- tkTextTag.c +++ tkTextTag.c @@ -0,0 +1,846 @@ +/* + * tkTextTag.c (CTk) -- + * + * This module implements the "tag" subcommand of the widget command + * for text widgets, plus most of the other high-level functions + * related to tags. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "default.h" +#include "tkPort.h" +#include "tk.h" +#include "tkText.h" + +/* + * Information used for parsing tag configuration information: + */ + +static Tk_ConfigSpec tagConfigSpecs[] = { + {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, "-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} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void ChangeTagPriority _ANSI_ARGS_((TkText *textPtr, + TkTextTag *tagPtr, int prio)); +static TkTextTag * FindTag _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, char *tagName)); +static void SortTags _ANSI_ARGS_((int numTags, + TkTextTag **tagArrayPtr)); +static int TagSortProc _ANSI_ARGS_((CONST VOID *first, + CONST VOID *second)); + +/* + *-------------------------------------------------------------- + * + * TkTextTagCmd -- + * + * This procedure is invoked to process the "tag" 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 +TkTextTagCmd(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 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 \"", + argv[0], " tag option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'a') && (strncmp(argv[2], "add", length) == 0)) { + fullOption = "add"; + addTag = 1; + + addAndRemove: + if (argc < 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag ", fullOption, + " tagName index1 ?index2 index1 index2 ...?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = TkTextCreateTag(textPtr, argv[3]); + for (i = 4; i < argc; i += 2) { + if (TkTextGetIndex(interp, textPtr, argv[i], &index1) != TCL_OK) { + return TCL_ERROR; + } + 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); + } + TkBTreeTag(&index1, &index2, tagPtr, addTag); + } + } else if ((c == 'b') && (strncmp(argv[2], "bind", length) == 0)) { + return Ctk_Unsupported(interp, "textWidget bind"); + } 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? ", + "?option value ...?\"", (char *) NULL); + return TCL_ERROR; + } + tagPtr = TkTextCreateTag(textPtr, argv[3]); + if (argc == 4) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, tagConfigSpecs, + (char *) tagPtr, (char *) NULL, 0); + } else if (argc == 5) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, tagConfigSpecs, + (char *) tagPtr, argv[4], 0); + } else { + int result; + + 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->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->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; + } + + tagPtr->affectsDisplay = 0; + if ((tagPtr->justifyString != NULL) + || (tagPtr->lMargin1String != NULL) + || (tagPtr->lMargin2String != NULL) + || (tagPtr->offsetString != 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)) { + Tcl_HashEntry *hPtr; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag delete tagName tagName ...\"", + (char *) NULL); + return TCL_ERROR; + } + for (i = 3; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&textPtr->tagTable, argv[i]); + if (hPtr == NULL) { + continue; + } + tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); + if (tagPtr == textPtr->selTagPtr) { + continue; + } + if (tagPtr->affectsDisplay) { + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, + (TkTextIndex *) NULL, tagPtr, 1); + } + TkBTreeTag(TkTextMakeIndex(textPtr->tree, 0, 0, &first), + TkTextMakeIndex(textPtr->tree, + TkBTreeNumLines(textPtr->tree), 0, &last), + tagPtr, 0); + Tcl_DeleteHashEntry(hPtr); + + /* + * Update the tag priorities to reflect the deletion of this tag. + */ + + ChangeTagPriority(textPtr, tagPtr, textPtr->numTags-1); + textPtr->numTags -= 1; + TkTextFreeTag(textPtr, tagPtr); + } + } else if ((c == 'l') && (strncmp(argv[2], "lower", length) == 0)) { + TkTextTag *tagPtr2; + int prio; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag lower tagName ?belowThis?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag(interp, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_ERROR; + } + if (argc == 5) { + tagPtr2 = FindTag(interp, textPtr, argv[4]); + if (tagPtr2 == NULL) { + return TCL_ERROR; + } + if (tagPtr->priority < tagPtr2->priority) { + prio = tagPtr2->priority - 1; + } else { + prio = tagPtr2->priority; + } + } else { + prio = 0; + } + ChangeTagPriority(textPtr, tagPtr, prio); + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, (TkTextIndex *) NULL, + tagPtr, 1); + } else if ((c == 'n') && (strncmp(argv[2], "names", length) == 0) + && (length >= 2)) { + TkTextTag **arrayPtr; + int arraySize; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag names ?index?\"", + (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + arrayPtr = (TkTextTag **) ckalloc((unsigned) + (textPtr->numTags * sizeof(TkTextTag *))); + for (i = 0, hPtr = Tcl_FirstHashEntry(&textPtr->tagTable, &search); + hPtr != NULL; i++, hPtr = Tcl_NextHashEntry(&search)) { + arrayPtr[i] = (TkTextTag *) Tcl_GetHashValue(hPtr); + } + arraySize = textPtr->numTags; + } else { + if (TkTextGetIndex(interp, textPtr, argv[3], &index1) + != TCL_OK) { + return TCL_ERROR; + } + arrayPtr = TkBTreeGetTags(&index1, &arraySize); + if (arrayPtr == NULL) { + return TCL_OK; + } + } + SortTags(arraySize, arrayPtr); + for (i = 0; i < arraySize; i++) { + tagPtr = arrayPtr[i]; + Tcl_AppendElement(interp, tagPtr->name); + } + ckfree((char *) arrayPtr); + } else if ((c == 'n') && (strncmp(argv[2], "nextrange", length) == 0) + && (length >= 2)) { + TkTextSearch tSearch; + char position[TK_POS_CHARS]; + + if ((argc != 5) && (argc != 6)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag nextrange 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; + } + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, &last); + if (argc == 5) { + 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 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 index2; once + * we find the start, we don't want TkBTreeNextTag to abort the + * search because the end of the range is after index2. + */ + + 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; + } + } + + /* + * Find the start of the tagged range. + */ + + if (!TkBTreeNextTag(&tSearch)) { + return TCL_OK; + } + gotStart: + if (TkTextIndexCmp(&tSearch.curIndex, &index2) >= 0) { + return TCL_OK; + } + TkTextPrintIndex(&tSearch.curIndex, position); + Tcl_AppendElement(interp, position); + TkBTreeNextTag(&tSearch); + TkTextPrintIndex(&tSearch.curIndex, position); + Tcl_AppendElement(interp, position); + } else if ((c == 'r') && (strncmp(argv[2], "raise", length) == 0) + && (length >= 3)) { + TkTextTag *tagPtr2; + int prio; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag raise tagName ?aboveThis?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag(interp, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_ERROR; + } + if (argc == 5) { + tagPtr2 = FindTag(interp, textPtr, argv[4]); + if (tagPtr2 == NULL) { + return TCL_ERROR; + } + if (tagPtr->priority <= tagPtr2->priority) { + prio = tagPtr2->priority; + } else { + prio = tagPtr2->priority + 1; + } + } else { + prio = textPtr->numTags-1; + } + ChangeTagPriority(textPtr, tagPtr, prio); + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, (TkTextIndex *) NULL, + tagPtr, 1); + } else if ((c == 'r') && (strncmp(argv[2], "ranges", length) == 0) + && (length >= 3)) { + TkTextSearch tSearch; + char position[TK_POS_CHARS]; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag ranges tagName\"", (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag((Tcl_Interp *) NULL, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_OK; + } + 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.curIndex, position); + Tcl_AppendElement(interp, position); + } + } else if ((c == 'r') && (strncmp(argv[2], "remove", length) == 0) + && (length >= 2)) { + fullOption = "remove"; + addTag = 0; + goto addAndRemove; + } else { + Tcl_AppendResult(interp, "bad tag option \"", argv[2], + "\": must be add, bind, cget, configure, delete, lower, ", + "names, nextrange, raise, ranges, or remove", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextCreateTag -- + * + * Find the record describing a tag within a given text widget, + * creating a new record if one doesn't already exist. + * + * Results: + * The return value is a pointer to the TkTextTag record for tagName. + * + * Side effects: + * A new tag record is created if there isn't one already defined + * for tagName. + * + *---------------------------------------------------------------------- + */ + +TkTextTag * +TkTextCreateTag(textPtr, tagName) + TkText *textPtr; /* Widget in which tag is being used. */ + char *tagName; /* Name of desired tag. */ +{ + register TkTextTag *tagPtr; + Tcl_HashEntry *hPtr; + int new; + + hPtr = Tcl_CreateHashEntry(&textPtr->tagTable, tagName, &new); + if (!new) { + return (TkTextTag *) Tcl_GetHashValue(hPtr); + } + + /* + * No existing entry. Create a new one, initialize it, and add a + * pointer to it to the hash table entry. + */ + + tagPtr = (TkTextTag *) ckalloc(sizeof(TkTextTag)); + tagPtr->name = Tcl_GetHashKey(&textPtr->tagTable, hPtr); + tagPtr->priority = textPtr->numTags; + 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->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; +} + +/* + *---------------------------------------------------------------------- + * + * FindTag -- + * + * See if tag is defined for a given widget. + * + * Results: + * If tagName is defined in textPtr, a pointer to its TkTextTag + * structure is returned. Otherwise NULL is returned and an + * error message is recorded in interp->result unless interp + * is NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkTextTag * +FindTag(interp, textPtr, tagName) + Tcl_Interp *interp; /* Interpreter to use for error message; + * if NULL, then don't record an error + * message. */ + TkText *textPtr; /* Widget in which tag is being used. */ + char *tagName; /* Name of desired tag. */ +{ + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&textPtr->tagTable, tagName); + if (hPtr != NULL) { + return (TkTextTag *) Tcl_GetHashValue(hPtr); + } + if (interp != NULL) { + Tcl_AppendResult(interp, "tag \"", tagName, + "\" isn't defined in text widget", (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextFreeTag -- + * + * This procedure is called when a tag is deleted to free up the + * memory and other resources associated with the tag. + * + * Results: + * None. + * + * Side effects: + * Memory and other resources are freed. + * + *---------------------------------------------------------------------- + */ + +void +TkTextFreeTag(textPtr, tagPtr) + TkText *textPtr; /* Info about overall widget. */ + register TkTextTag *tagPtr; /* Tag being deleted. */ +{ + 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->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); +} + +/* + *---------------------------------------------------------------------- + * + * SortTags -- + * + * This procedure sorts an array of tag pointers in increasing + * order of priority, optimizing for the common case where the + * array is small. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SortTags(numTags, tagArrayPtr) + int numTags; /* Number of tag pointers at *tagArrayPtr. */ + TkTextTag **tagArrayPtr; /* Pointer to array of pointers. */ +{ + int i, j, prio; + register TkTextTag **tagPtrPtr; + TkTextTag **maxPtrPtr, *tmp; + + if (numTags < 2) { + return; + } + if (numTags < 20) { + for (i = numTags-1; i > 0; i--, tagArrayPtr++) { + maxPtrPtr = tagPtrPtr = tagArrayPtr; + prio = tagPtrPtr[0]->priority; + for (j = i, tagPtrPtr++; j > 0; j--, tagPtrPtr++) { + if (tagPtrPtr[0]->priority < prio) { + prio = tagPtrPtr[0]->priority; + maxPtrPtr = tagPtrPtr; + } + } + tmp = *maxPtrPtr; + *maxPtrPtr = *tagArrayPtr; + *tagArrayPtr = tmp; + } + } else { + qsort((VOID *) tagArrayPtr, (unsigned) numTags, sizeof (TkTextTag *), + TagSortProc); + } +} + +/* + *---------------------------------------------------------------------- + * + * TagSortProc -- + * + * This procedure is called by qsort when sorting an array of + * tags in priority order. + * + * Results: + * The return value is -1 if the first argument should be before + * the second element (i.e. it has lower priority), 0 if it's + * equivalent (this should never happen!), and 1 if it should be + * after the second element. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TagSortProc(first, second) + CONST VOID *first, *second; /* Elements to be compared. */ +{ + TkTextTag *tagPtr1, *tagPtr2; + + tagPtr1 = * (TkTextTag **) first; + tagPtr2 = * (TkTextTag **) second; + return tagPtr1->priority - tagPtr2->priority; +} + +/* + *---------------------------------------------------------------------- + * + * ChangeTagPriority -- + * + * This procedure changes the priority of a tag by modifying + * its priority and the priorities of other tags that are affected + * by the change. + * + * Results: + * None. + * + * Side effects: + * Priorities may be changed for some or all of the tags in + * textPtr. The tags will be arranged so that there is exactly + * one tag at each priority level between 0 and textPtr->numTags-1, + * with tagPtr at priority "prio". + * + *---------------------------------------------------------------------- + */ + +static void +ChangeTagPriority(textPtr, tagPtr, prio) + TkText *textPtr; /* Information about text widget. */ + TkTextTag *tagPtr; /* Tag whose priority is to be + * changed. */ + int prio; /* New priority for tag. */ +{ + int low, high, delta; + register TkTextTag *tagPtr2; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + if (prio < 0) { + prio = 0; + } + if (prio >= textPtr->numTags) { + prio = textPtr->numTags-1; + } + if (prio == tagPtr->priority) { + return; + } else if (prio < tagPtr->priority) { + low = prio; + high = tagPtr->priority-1; + delta = 1; + } else { + low = tagPtr->priority+1; + high = prio; + delta = -1; + } + for (hPtr = Tcl_FirstHashEntry(&textPtr->tagTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + tagPtr2 = (TkTextTag *) Tcl_GetHashValue(hPtr); + if ((tagPtr2->priority >= low) && (tagPtr2->priority <= high)) { + tagPtr2->priority += delta; + } + } + tagPtr->priority = prio; +} ADDED tkUtil.c Index: tkUtil.c ================================================================== --- tkUtil.c +++ tkUtil.c @@ -0,0 +1,98 @@ +/* + * tkUtil.c (CTk) -- + * + * 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. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#include "tk.h" +#include "tkPort.h" + +/* + *---------------------------------------------------------------------- + * + * 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; +} ADDED tkWindow.c Index: tkWindow.c ================================================================== --- tkWindow.c +++ tkWindow.c @@ -0,0 +1,1762 @@ +/* + * tkWindow.c (CTk) -- + * + * CTk window manipulation functions. + * + * Copyright (c) 1989-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +static char rcsid[] = "@(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $"; + + +#include "tkPort.h" +#include "tkInt.h" +#include "patchlevel.h" + + +#define HEAD_CHILD(winPtr) ((TkWindow *) &((winPtr)->childList)) +#define TOP_CHILD(winPtr) ((winPtr)->childList.priorPtr) +#define BOTTOM_CHILD(winPtr) ((winPtr)->childList.nextPtr) + +/* + * Count of number of main windows currently open in this process. + */ + +int tk_NumMainWindows; + +/* + * First in list of all main windows managed by this process. + */ + +TkMainInfo *tkMainWindowList = NULL; + +/* + * List of all displays currently in use. + */ + +TkDisplay *tkDisplayList = NULL; + +/* + * Have statics in this module been initialized? + */ + +static int initialized = 0; + +/* + * The variables below hold several uid's that are used in many places + * in the toolkit. + */ + +Tk_Uid tkDisabledUid = NULL; +Tk_Uid tkActiveUid = NULL; +Tk_Uid tkNormalUid = NULL; + +/* + * The following structure defines all of the commands supported by + * CTk, and the C procedures that execute them. + */ + +typedef struct { + char *name; /* Name of command. */ + int (*cmdProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); + /* Command procedure. */ +} TkCmd; + +static TkCmd commands[] = { + /* + * Commands that are part of the intrinsics: + */ + + {"bell", Tk_BellCmd}, + {"bind", Tk_BindCmd}, + {"bindtags", Tk_BindtagsCmd}, + /* {"clipboard", Tk_ClipboardCmd}, */ + {"ctk", Ctk_CtkCmd}, + {"ctk_event", Ctk_CtkEventCmd}, + {"destroy", Tk_DestroyCmd}, + {"exit", Tk_ExitCmd}, + {"focus", Tk_FocusCmd}, + /* {"grab", Tk_GrabCmd}, */ + /* {"image", Tk_ImageCmd}, */ + {"lower", Tk_LowerCmd}, + {"option", Tk_OptionCmd}, + {"pack", Tk_PackCmd}, + {"place", Tk_PlaceCmd}, + {"raise", Tk_RaiseCmd}, + /* {"selection", Tk_SelectionCmd}, */ + {"tk", Tk_TkCmd}, + {"tk_focusNext", Ctk_TkFocusNextCmd}, + {"tk_focusPrev", Ctk_TkFocusPrevCmd}, + {"tkEntryInsert", Ctk_TkEntryInsertCmd}, + {"tkEntrySeeInsert", Ctk_TkEntrySeeInsertCmd}, + {"tkwait", Tk_TkwaitCmd}, + {"update", Tk_UpdateCmd}, + {"winfo", Tk_WinfoCmd}, + /* {"wm", Tk_WmCmd}, */ + + /* + * Widget-creation commands. + */ + {"button", Tk_ButtonCmd}, + /* {"canvas", Tk_CanvasCmd}, */ + {"checkbutton", Tk_CheckbuttonCmd}, + {"entry", Tk_EntryCmd}, + {"frame", Tk_FrameCmd}, + {"label", Tk_LabelCmd}, + {"listbox", Tk_ListboxCmd}, + {"menu", Tk_MenuCmd}, + {"menubutton", Tk_MenubuttonCmd}, + /* {"message", Tk_MessageCmd}, */ + {"radiobutton", Tk_RadiobuttonCmd}, + /* {"scale", Tk_ScaleCmd}, */ + {"scrollbar", Tk_ScrollbarCmd}, + {"text", Tk_TextCmd}, + {"toplevel", Tk_FrameCmd}, + {(char *) NULL, (int (*)()) NULL} +}; + +/* + * Forward declarations to procedures defined later in this file: + */ + +static TkDisplay * GetScreen _ANSI_ARGS_((Tcl_Interp *interp, + char *screenName)); +static TkWindow * CreateRoot _ANSI_ARGS_((Tcl_Interp *interp, + TkDisplay *dispPtr)); +static TkWindow * NewWindow _ANSI_ARGS_((TkDisplay *dispPtr)); +static void DisplayWindow _ANSI_ARGS_((TkWindow *winPtr)); +static void UndisplayWindow _ANSI_ARGS_((TkWindow *winPtr)); +static void InsertWindow _ANSI_ARGS_((TkWindow *winPtr, + TkWindow *sibling)); +static void UnlinkWindow _ANSI_ARGS_((TkWindow *winPtr)); +static void Unoverlap _ANSI_ARGS_((TkWindow *underPtr, + TkWindow *overPtr)); +static void UnoverlapHierarchy _ANSI_ARGS_((TkWindow *underPtr, + TkWindow * overPtr)); +static void ExposeWindow _ANSI_ARGS_((TkWindow *winPtr, + CtkRegion *rgn)); +static void ComputeClipRect _ANSI_ARGS_((TkWindow *winPtr)); + + + +/* + *---------------------------------------------------------------------- + * + * Tk_Init -- + * + * This procedure is typically invoked by Tcl_AppInit procedures + * to perform additional Tk initialization for a Tcl interpreter, + * such as sourcing the "ctk.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 ctk.tcl script. + * + *---------------------------------------------------------------------- + */ + +int +Tk_Init(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ +#ifdef USE_TCL_STUBS + Tk_Window winPtr; +#endif + static char initCmd[] = + "if [file exists $tk_library/ctk.tcl] {\n\ + source $tk_library/ctk.tcl\n\ + } else {\n\ + set msg \"can't find $tk_library/ctk.tcl; perhaps you \"\n\ + append msg \"need to\\ninstall CTk or set your CTK_LIBRARY \"\n\ + append msg \"environment variable?\"\n\ + error $msg\n\ + }"; + int retval; + +#ifdef USE_TCL_STUBS + winPtr = Tk_CreateMainWindow(interp, NULL, "ctk", "ctk"); + if (winPtr == NULL) { + return(TCL_ERROR); + } +#endif + + retval = Tcl_Eval(interp, initCmd); + if (retval != TCL_OK) { + return(retval); + } + +#ifdef USE_TCL_STUBS + Tcl_SetMainLoop(Tk_MainLoop); +#endif + + return(retval); +} + +/* + *---------------------------------------------------------------------- + * + * GetScreen -- + * + * Given a string name for a terminal device-plus-type, find the + * TkDisplay structure for the display. + * + * Results: + * The return value is a pointer to information about the display, + * or NULL if the display couldn't be opened. In this case, an + * error message is left in interp->result. + * + * Side effects: + * A new stream is opened to the device if there is no + * connection already. A new TkDisplay data structure is also + * setup, if necessary. + * + *---------------------------------------------------------------------- + */ + +static TkDisplay * +GetScreen(interp, screenName) + Tcl_Interp *interp; /* Place to leave error message. */ + char *screenName; /* Name for screen. NULL or empty means + * use CTK_DISPLAY environment variable. */ +{ + register TkDisplay *dispPtr; + char *p; + size_t length; + + /* + * Separate the terminal type from the rest of the display + * name. ScreenName is assumed to have the syntax + * : with the colon and the type being + * optional. + */ + + if (screenName == NULL || screenName[0] == '\0') { + screenName = Tcl_GetVar2(interp, "env", "CTK_DISPLAY", TCL_GLOBAL_ONLY); + if (screenName == NULL) { + /* + * For backwards compatibility, check CWISH_DISPLAY - + * this feature will eventually be removed. + */ + screenName = Tcl_GetVar2(interp, "env", "CWISH_DISPLAY", + TCL_GLOBAL_ONLY); + } + if (screenName == NULL) { + screenName = "tty"; + } + } + p = strchr(screenName, ':'); + if (p == NULL) { + length = strlen(screenName); + } else { + length = p - screenName; + } + + /* + * See if we already have a connection to this display. + */ + + for (dispPtr = tkDisplayList; dispPtr != NULL; dispPtr = dispPtr->nextPtr) { + if ((strncmp(dispPtr->name, screenName, length) == 0) + && (dispPtr->name[length] == '\0')) { + return dispPtr; + } + } + + /* + * Create entry for new display. + */ + + dispPtr = (TkDisplay *) ckalloc(sizeof(TkDisplay)); + if (CtkDisplayInit(interp, dispPtr, screenName) != TCL_OK) { + return (TkDisplay *) NULL; + } + dispPtr->numWindows = 0; + dispPtr->rootPtr = CreateRoot(interp, dispPtr); + if (dispPtr->rootPtr == NULL) { + CtkDisplayEnd(dispPtr); + return (TkDisplay *) NULL; + } + dispPtr->focusPtr = dispPtr->rootPtr; + dispPtr->cursorPtr = dispPtr->rootPtr; + dispPtr->cursorX = 0; + dispPtr->cursorY = 0; + dispPtr->nextPtr = tkDisplayList; + tkDisplayList = dispPtr; + + return dispPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CreateMainWindow -- + * + * Make a new main window. A main window is a special kind of + * top-level window used as the outermost window in an + * application. + * + * Results: + * The return value is a token for the new window, or NULL if + * an error prevented the new window from being created. If + * NULL is returned, an error message will be left in + * interp->result. + * + * Side effects: + * A new window structure is allocated locally; "interp" is + * 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. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_CreateMainWindow(interp, screenName, baseName, className) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *screenName; /* "device:term-type" on which to create + * window. Empty or NULL string means + * use stdin/stdout. */ + 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). */ +{ + int dummy; + Tcl_HashEntry *hPtr; + register TkMainInfo *mainPtr; + register TkWindow *winPtr; + register TkDisplay *dispPtr; + register TkCmd *cmdPtr; + char *libDir; + char *argv[1]; + + if (!initialized) { + initialized = 1; + tkNormalUid = Tk_GetUid("normal"); + tkDisabledUid = Tk_GetUid("disabled"); + tkActiveUid = Tk_GetUid("active"); + } + + /* + * Create the TkMainInfo structure for this application. + */ + + mainPtr = (TkMainInfo *) ckalloc(sizeof(TkMainInfo)); + mainPtr->winPtr = NULL; + mainPtr->refCount = 0; + mainPtr->interp = interp; + Tcl_InitHashTable(&mainPtr->nameTable, TCL_STRING_KEYS); + mainPtr->bindingTable = Tk_CreateBindingTable(interp); + mainPtr->curDispPtr = NULL; + mainPtr->bindingDepth = 0; + mainPtr->optionRootPtr = NULL; + mainPtr->nextPtr = tkMainWindowList; + tkMainWindowList = mainPtr; + + /* + * Create the basic TkWindow structure. + * + * Temporarily put root window into the application's name table + * and set root windows mainPtr to the new main structure, + * so that Tk_TopLevelCmd() will use the new main structure for + * the window it creates. + */ + + if (screenName == (char *) NULL) { + screenName = ""; + } + dispPtr = GetScreen(interp, screenName); + if (dispPtr == NULL) { + return (Tk_Window) NULL; + } + dispPtr->rootPtr->mainPtr = mainPtr; + hPtr = Tcl_CreateHashEntry(&mainPtr->nameTable, "", &dummy); + Tcl_SetHashValue(hPtr, dispPtr->rootPtr); + winPtr = Tk_CreateWindowFromPath(interp, dispPtr->rootPtr, ".", screenName); + Tcl_DeleteHashEntry(hPtr); + dispPtr->rootPtr->mainPtr = NULL; + if (winPtr == NULL) { + return (Tk_Window) NULL; + } + mainPtr->winPtr = winPtr; + + /* + * Bind in Tk's commands. + */ + + for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) { + Tcl_CreateCommand(interp, cmdPtr->name, cmdPtr->cmdProc, + (ClientData) winPtr, (void (*)()) NULL); + } + + /* + * Set variables for the intepreter. + */ + + if (Tcl_GetVar(interp, "tk_library", TCL_GLOBAL_ONLY) == NULL) { + /* + * A library directory hasn't already been set, so figure out + * which one to use. + */ + + libDir = getenv("CTK_LIBRARY"); + if (libDir == NULL) { + libDir = CTK_LIBRARY; + } + Tcl_SetVar(interp, "tk_library", libDir, TCL_GLOBAL_ONLY); + } + Tcl_SetVar(interp, "ctk_patchLevel", CTK_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tk_version", TK_VERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tk_port", "curses", TCL_GLOBAL_ONLY); + + /* + * Make the main window into a toplevel widget, and give it an initial + * requested size. + */ + + Tk_SetClass(winPtr, className); + argv[0] = NULL; + if (TkInitFrame(interp, winPtr, 1, 0, argv) == NULL) { + return NULL; + } + Tk_GeometryRequest(winPtr, 20, 10); + + CtkSetFocus(winPtr); + tk_NumMainWindows++; + return winPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Ctk_Unsupported -- + * + * This procedure is invoked when a Tk feature that is not + * supported by CTk is requested. + * + * Results: + * A standard TCL result. + * + * Side effects: + * Sets the interpreter result, if "ctk_unsupported" is defined, + * could do anything. + * + *---------------------------------------------------------------------- + */ + +int +Ctk_Unsupported(interp, feature) + Tcl_Interp *interp; /* Interpreter in which unsupported + * feature has been requested. */ + char *feature; /* Description of requested feature. */ +{ + Tcl_CmdInfo info; + char *argv[3]; + + Tcl_ResetResult(interp); + if (Tcl_GetCommandInfo(interp, "ctk_unsupported", &info)) { + argv[0] = "ctk_unsupported"; + argv[1] = feature; + argv[2] = NULL; + return (*info.proc)(info.clientData, interp, 2, argv); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CreateWindowFromPath -- + * + * This procedure is similar to Tk_CreateWindow except that + * it uses a path name to create the window, rather than a + * parent and a child name. + * + * Results: + * The return value is a token for the new window. If an error + * occurred in creating the window (e.g. no such display or + * screen), then an error message is left in interp->result and + * NULL is returned. + * + * Side effects: + * A new window structure is allocated. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_CreateWindowFromPath(interp, winPtr, pathName, screenName) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * Interp->result is assumed to be + * initialized by the caller. */ + TkWindow *winPtr; /* Token for any window in application + * that is to contain new window. */ + char *pathName; /* Path name for new window within the + * application of tkwin. The parent of + * this window must already exist, but + * the window itself must not exist. */ + char *screenName; /* If NULL, new window will be on same + * screen as its parent. If non-NULL, + * gives name of screen on which to create + * new window; window will be a top-level + * window. */ +{ + TkWindow *parentPtr; + TkDisplay *dispPtr; + Tcl_HashEntry *hPtr; + int new; + char *name; + + name = strrchr(pathName, '.'); + if (name) { + name++; + } + parentPtr = Ctk_ParentByName(interp, pathName, winPtr); + if (parentPtr == (TkWindow *) NULL) { + return (TkWindow *) NULL; + } + if (screenName == NULL) { + dispPtr = parentPtr->dispPtr; + } else { + dispPtr = GetScreen(interp, screenName); + } + + /* + * Get entry for new name. + */ + hPtr = Tcl_CreateHashEntry(&winPtr->mainPtr->nameTable, pathName, &new); + if (!new) { + Tcl_AppendResult(interp, "window name \"", pathName, + "\" already exists", (char *) NULL); + return NULL; + } + + /* + * Create the window. + */ + winPtr = NewWindow(dispPtr); + if (screenName) { + winPtr->parentPtr = dispPtr->rootPtr; + winPtr->flags |= TK_TOP_LEVEL; + parentPtr->flags |= CTK_HAS_TOPLEVEL_CHILD; + } else { + winPtr->parentPtr = parentPtr; + } + winPtr->mainPtr = parentPtr->mainPtr; + winPtr->mainPtr->refCount++; + InsertWindow(winPtr, HEAD_CHILD(winPtr->parentPtr)); + Tcl_SetHashValue(hPtr, winPtr); + winPtr->pathName = Tcl_GetHashKey(&winPtr->mainPtr->nameTable, hPtr); + winPtr->nameUid = Tk_GetUid(name); + return winPtr; +} + +/* + *---------------------------------------------------------------------- + * Ctk_ParentByName -- + * Determine parent of window based on path name. This is necessary + * for top level windows because Ctk_Parent() will always return + * the root window for them. + * + * Results: + * Returns pointer to new window if successful. Returns + * NULL if the parent can't be found, and stores an error + * message in interp->result. + * + * Side Effects: + *---------------------------------------------------------------------- + */ + +TkWindow * +Ctk_ParentByName(interp, pathName, tkwin) + Tcl_Interp *interp; + char *pathName; + Tk_Window tkwin; +{ +#define FIXED_SPACE 50 + char fixedSpace[FIXED_SPACE+1]; + char *p; + int numChars; + Tk_Window parent; + + /* + * Strip the parent's name out of pathName (it's everything up + * to the last dot). There are two tricky parts: (a) must + * copy the parent's name somewhere else to avoid modifying + * the pathName string (for large names, space for the copy + * will have to be malloc'ed); (b) must special-case the + * situations where the parent is "" or ".". + */ + p = strrchr(pathName, '.'); + if (p == NULL) { + Tcl_AppendResult(interp, "bad window path name \"", pathName, + "\"", (char *) NULL); + return NULL; + } + numChars = p-pathName; + if (numChars > FIXED_SPACE) { + p = (char *) ckalloc((unsigned) (numChars+1)); + } else { + p = fixedSpace; + } + if (pathName[1] == '\0') { + /* + * Parent is root: "" + */ + *p = '\0'; + } else if (numChars == 0) { + /* + * Parent is main: "." + */ + *p = '.'; + p[1] = '\0'; + } else { + strncpy(p, pathName, numChars); + p[numChars] = '\0'; + } + + /* + * Find the parent window. + */ + parent = Tk_NameToWindow(interp, p, tkwin); + if (p != fixedSpace) { + ckfree(p); + } + return parent; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_SetClass -- + * + * This procedure is used to give a window a class. + * + * Results: + * None. + * + * Side effects: + * A new class is stored for tkwin, replacing any existing + * class for it. + * + *---------------------------------------------------------------------- + */ + +void +Tk_SetClass(tkwin, className) + Tk_Window tkwin; /* Token for window to assign class. */ + char *className; /* New class for tkwin. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->classUid = Tk_GetUid(className); + TkOptionClassChanged(winPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_NameToWindow -- + * + * Given a string name for a window, this procedure + * returns the token for the window, if there exists a + * window corresponding to the given name. + * + * Results: + * The return result is either a token for the window corresponding + * to "name", or else NULL to indicate that there is no such + * window. In this case, an error message is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tk_Window +Tk_NameToWindow(interp, pathName, winPtr) + Tcl_Interp *interp; /* Where to report errors. */ + char *pathName; /* Path name of window. */ + TkWindow *winPtr; /* Token for window, name is assumed to + * belong to the same main window as winPtr. */ +{ + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->nameTable, pathName); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "bad window path name \"", + pathName, "\"", (char *) NULL); + return NULL; + } + return (Tk_Window) Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * CreateRoot -- + * + * Creates the root window (whole screen, no parent). The window + * is mapped and displayed. + * + * Results: + * A new window pointer. + * + * Side Effects: + * Screen is cleared. + * + *---------------------------------------------------------------------- + */ +static TkWindow * +CreateRoot(interp, dispPtr) + Tcl_Interp *interp; + TkDisplay *dispPtr; +{ + TkWindow *winPtr = NewWindow(dispPtr); + + winPtr->mainPtr = NULL; + winPtr->parentPtr = NULL; + winPtr->nextPtr = NULL; + winPtr->priorPtr = NULL; + CtkSetRect(&winPtr->rect, 0, 0, + Ctk_DisplayWidth(dispPtr), Ctk_DisplayHeight(dispPtr)); + CtkCopyRect(&winPtr->maskRect, &winPtr->rect); + CtkCopyRect(&winPtr->clipRect, &winPtr->rect); + winPtr->clipRgn = CtkCreateRegion(&(winPtr->maskRect)); + winPtr->absLeft = 0; + winPtr->absTop = 0; + winPtr->flags |= TK_MAPPED|CTK_DISPLAYED|TK_TOP_LEVEL; + winPtr->classUid = Tk_GetUid("Root"); + Ctk_ClearWindow(winPtr); + + return winPtr; +} + +/* + *---------------------------------------------------------------------- + * NewWindow -- + * Allocate a window structure and initialize contents. + * + * Results: + * Returns pointer to window. + * + * Side Effects: + * + *---------------------------------------------------------------------- + */ +static TkWindow * +NewWindow(dispPtr) + TkDisplay *dispPtr; +{ + TkWindow *winPtr = (TkWindow *) ckalloc(sizeof(TkWindow)); + + winPtr->dispPtr = dispPtr; + winPtr->pathName = NULL; + winPtr->classUid = NULL; + winPtr->mainPtr = NULL; + winPtr->flags = 0; + winPtr->handlerList = NULL; + winPtr->numTags = 0; + winPtr->optionLevel = -1; + winPtr->tagPtr = NULL; + winPtr->childList.nextPtr = HEAD_CHILD(winPtr); + winPtr->childList.priorPtr = HEAD_CHILD(winPtr); + winPtr->borderWidth = 0; + winPtr->fillChar = ' '; + winPtr->fillStyle = CTK_PLAIN_STYLE; + winPtr->clipRgn = NULL; + winPtr->reqWidth = 1; + winPtr->reqHeight = 1; + winPtr->geomMgrPtr = NULL; + winPtr->geomData = NULL; + + dispPtr->numWindows++; + return winPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tk_DestroyWindow -- + * + * Destroy an existing window. After this call, the caller + * should never again use the token. + * + * Results: + * None. + * + * Side effects: + * The window is deleted, along with all of its children. + * Relevant callback procedures are invoked. + * + *-------------------------------------------------------------- + */ + +void +Tk_DestroyWindow(winPtr) + TkWindow *winPtr; +{ + TkWindow *child; + TkWindow *nextPtr; + Ctk_Event event; + + if (winPtr->flags & TK_ALREADY_DEAD) { + /* + * A destroy event binding caused the window to be destroyed + * again. Ignore the request. + */ + + return; + } + winPtr->flags |= TK_ALREADY_DEAD; + + Ctk_Unmap(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; + } + tk_NumMainWindows--; + } + + /* + * Recursively destroy children. + */ + + for (child = BOTTOM_CHILD(winPtr); + child != HEAD_CHILD(winPtr); + child = nextPtr) { + nextPtr = child->nextPtr; + Tk_DestroyWindow(child); + } + if (winPtr->flags & CTK_HAS_TOPLEVEL_CHILD) { + /* + * This window has toplevel children, which are not stored + * in the child list. Check all the children of all root + * windows to see if their name is an extension of this + * windows name - if so destroy the top level window. + */ + char *path = Tk_PathName(winPtr); + char *childPath; + int length = strlen(path); + TkWindow *priorPtr; + TkDisplay *dispPtr; + + for (dispPtr = tkDisplayList; + dispPtr != NULL; + dispPtr = dispPtr->nextPtr) { + priorPtr = HEAD_CHILD(dispPtr->rootPtr); + child = BOTTOM_CHILD(dispPtr->rootPtr); + while (child != HEAD_CHILD(dispPtr->rootPtr)) { + childPath = Tk_PathName(child); + if (strncmp(childPath, path, length) == 0 + && (childPath[length] == '.' + || (length == 1 && childPath[1] != '\0'))) { + Tk_DestroyWindow(child); + } else { + priorPtr = child; + } + child = priorPtr->nextPtr; + } + } + } + + /* + * Generate a Destroy event. + * + * 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->pathName != NULL) { + event.type = CTK_DESTROY_EVENT; + event.window = winPtr; + Tk_HandleEvent(&event); + } + + UnlinkWindow(winPtr); + TkEventDeadWindow(winPtr); + if (winPtr->tagPtr != NULL) { + TkFreeBindingTags(winPtr); + } + TkOptionDeadWindow(winPtr); + TkFocusDeadWindow(winPtr); + + if (winPtr->mainPtr != NULL) { + if (winPtr->pathName != NULL) { + Tk_DeleteAllBindings(winPtr->mainPtr->bindingTable, + (ClientData) winPtr->pathName); + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&winPtr->mainPtr->nameTable, + winPtr->pathName)); + } + winPtr->mainPtr->refCount--; + if (winPtr->mainPtr->refCount == 0) { + register TkCmd *cmdPtr; + + /* + * 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 (except don't replace + * the "exit" command, since it may be needed for the application + * to exit). + */ + + for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) { + if (cmdPtr->cmdProc != Tk_ExitCmd) { + Tcl_CreateCommand(winPtr->mainPtr->interp, cmdPtr->name, + TkDeadAppCmd, (ClientData) NULL, + (void (*)()) NULL); + } + } + if (winPtr->mainPtr->bindingDepth == 0) { + TkDeleteMain(winPtr->mainPtr); + } + } + } + + if ((--(winPtr->dispPtr->numWindows)) == 1) { + TkDisplay *dispPtr = winPtr->dispPtr; + + CtkDisplayEnd(dispPtr); + if (tkDisplayList == dispPtr) { + tkDisplayList = dispPtr->nextPtr; + } else { + TkDisplay *prevDispPtr; + for (prevDispPtr = tkDisplayList; + prevDispPtr != NULL; + prevDispPtr = prevDispPtr->nextPtr) { + if (prevDispPtr->nextPtr == dispPtr) { + prevDispPtr->nextPtr = dispPtr->nextPtr; + break; + } + } + } + ckfree((char *) dispPtr->rootPtr); + ckfree((char *) dispPtr); + } + + ckfree((char *) winPtr); +} + +/* + *------------------------------------------------------------ + * TkDeleteMain -- + * + * Release resources for a TkMainInfo structure. + * All windows for this main should already have + * been destroyed. The pointer should no be referenced + * again. + * + * Results: + * None. + * + * Side Effects: + * None. + * + *------------------------------------------------------------ + */ + +void +TkDeleteMain(mainPtr) + TkMainInfo *mainPtr; +{ + Tcl_DeleteHashTable(&mainPtr->nameTable); + Tk_DeleteBindingTable(mainPtr->bindingTable); + ckfree((char *) mainPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RestackWindow -- + * + * Change a window's position in the stacking order. + * + * Results: + * TCL_OK is normally returned. If other is not a descendant + * of tkwin's parent then TCL_ERROR is returned and tkwin is + * not repositioned. + * + * Side effects: + * Tkwin is repositioned in the stacking order. + * + *---------------------------------------------------------------------- + */ + +int +Tk_RestackWindow(winPtr, aboveBelow, otherPtr) + TkWindow *winPtr; + int aboveBelow; + TkWindow *otherPtr; +{ + int redisplay = 0; + + if (otherPtr) { + /* + * Find ancestor of otherPtr (or otherPtr itself) that is a + * sibling of winPtr. + */ + while (otherPtr->parentPtr != winPtr->parentPtr) { + otherPtr = otherPtr->parentPtr; + if (!otherPtr) { + return TCL_ERROR; + } + } + } + if (otherPtr == winPtr) { + return TCL_OK; + } + + if (CtkIsDisplayed(winPtr)) { + UndisplayWindow(winPtr); + redisplay = 1; + } + UnlinkWindow(winPtr); + if (aboveBelow == Above) { + if (otherPtr) { + otherPtr = otherPtr->nextPtr; + } else { + otherPtr = HEAD_CHILD(winPtr->parentPtr); + } + } else { + if (!otherPtr) { + otherPtr = BOTTOM_CHILD(winPtr->parentPtr); + } + } + InsertWindow(winPtr, otherPtr); + if (redisplay) { + DisplayWindow(winPtr); + } + return TCL_OK; +} + +/* + *------------------------------------------------------------ + * Ctk_Map -- + * + * Position a window within its parent. + * + * Results: + * None. + * + * Side Effects: + * Generates a map event for the window. + * If parent is displayed, then the window will be displayed. + * + *------------------------------------------------------------ + */ + +void +Ctk_Map(winPtr, left, top, right, bottom) + TkWindow *winPtr; + int left; + int top; + int right; + int bottom; +{ + TkWindow *parentPtr = winPtr->parentPtr; + Ctk_Event event; + + /* + * Keep top-levels within the bounds of the screen. + */ + if (winPtr->flags & TK_TOP_LEVEL) { + int width = right - left; + int height = bottom - top; + int screenWidth = Tk_Width(parentPtr); + int screenHeight = Tk_Height(parentPtr); + + if (width > screenWidth) { + width = screenWidth; + } + if (height > screenHeight) { + height = screenHeight; + } + if (left < 0) { + left = 0; + } else if (left + width > screenWidth) { + left = screenWidth - width ; + } + if (top < 0) { + top = 0; + } else if (top + height > screenHeight) { + top = screenHeight - height; + } + right = left + width; + bottom = top + height; + } + + if ( !Tk_IsMapped(winPtr) + || (winPtr->rect.left != left) + || (winPtr->rect.top != top) + || (winPtr->rect.right != right) + || (winPtr->rect.bottom != bottom)) { + /* + * Window position changed (or window was not mapped + * before). Undisplay window, re-position it, and then + * display it if parent is displayed. + */ + + if (CtkIsDisplayed(winPtr)) { + UndisplayWindow(winPtr); + } + CtkSetRect(&(winPtr->rect), left, top, right, bottom); + winPtr->flags |= TK_MAPPED; + if (CtkIsDisplayed(parentPtr)) { + DisplayWindow(winPtr); + } + } + event.type = CTK_MAP_EVENT; + event.window = winPtr; + Tk_HandleEvent(&event); +} + +/* + *------------------------------------------------------------ + * Ctk_Unmap -- + * + * Remove positioning for a window. + * + * Results: + * None. + * + * Side Effects: + * If window is displayed, it and all its descendants are + * undisplayed. + * + *------------------------------------------------------------ + */ + +void +Ctk_Unmap(winPtr) + TkWindow *winPtr; +{ + Ctk_Event event; + + if (Tk_IsMapped(winPtr)) { + /* + * Window is mapped, unmap it. + */ + if (CtkIsDisplayed(winPtr)) { + UndisplayWindow(winPtr); + } + winPtr->flags &= ~TK_MAPPED; + event.type = CTK_UNMAP_EVENT; + event.window = winPtr; + Tk_HandleEvent(&event); + } +} + +/* + *------------------------------------------------------------ + * Ctk_BottomChild -- + * Ctk_TopChild -- + * Ctk_PriorSibling -- + * Ctk_NextSibling -- + * Ctk_TopLevel -- + * + * Get window relative. + * + * Results: + * Pointer to window, or NULL if window has no such relative. + * + * Side Effects: + * None. + * + *------------------------------------------------------------ + */ + +TkWindow * +Ctk_BottomChild(winPtr) + TkWindow *winPtr; +{ + TkWindow * child = BOTTOM_CHILD(winPtr); + + if (child == HEAD_CHILD(winPtr)) { + return (TkWindow *) NULL; + } + else { + return child; + } +} + +TkWindow * +Ctk_TopChild(winPtr) + TkWindow *winPtr; +{ + TkWindow * child = TOP_CHILD(winPtr); + + if (child == HEAD_CHILD(winPtr)) { + return (TkWindow *) NULL; + } + else { + return child; + } +} + +TkWindow * +Ctk_NextSibling(winPtr) + TkWindow *winPtr; +{ + TkWindow * sibling = winPtr->nextPtr; + + if (sibling == HEAD_CHILD(winPtr->parentPtr)) { + return (TkWindow *) NULL; + } + else { + return sibling; + } +} + +TkWindow * +Ctk_PriorSibling(winPtr) + TkWindow *winPtr; +{ + TkWindow * sibling = winPtr->priorPtr; + + if (sibling == HEAD_CHILD(winPtr->parentPtr)) { + return (TkWindow *) NULL; + } + else { + return sibling; + } +} + +TkWindow * +Ctk_TopLevel(winPtr) + TkWindow *winPtr; +{ + while (!Tk_IsTopLevel(winPtr)) { + winPtr = winPtr->parentPtr; + } + return winPtr; +} + +/* + *------------------------------------------------------------ + * Tk_SetInternalBorder -- + * + * Set window's internal border width. The standard drawing + * routines will not draw on the internal border (only + * Ctk_DrawBorder() will) and the geometry managers should + * not place child windows there. + * + * Results: + * None. + * + * Side Effects: + * The border width is recorded for the window, and a map + * event is synthesized so that all geometry managers of all + * children are notified to re-layout, if necessary. + * + *------------------------------------------------------------ + */ + +void +Tk_SetInternalBorder(winPtr, width) + TkWindow *winPtr; + int width; +{ + Ctk_Event event; + + if (winPtr->borderWidth != width) { + winPtr->borderWidth = width; + ComputeClipRect(winPtr); + event.type = CTK_MAP_EVENT; + event.window = winPtr; + Tk_HandleEvent(&event); + } +} + +/* + *-------------------------------------------------------------- + * + * Ctk_DrawBorder -- + * + * Draw border for a window in specified style. + * + * Results: + * None. + * + * Side effects: + * Characters are output to the terminal. + * + *-------------------------------------------------------------- + */ + +void +Ctk_DrawBorder(winPtr, style, title) + TkWindow *winPtr; + Ctk_Style style; + char *title; +{ + int borderWidth = winPtr->borderWidth; + + if (borderWidth > 0) { + Ctk_Rect saveClip; + + /* + * Temporarily set clipRect to maskRect so that we can + * draw within the border area. + */ + CtkCopyRect(&saveClip, &winPtr->clipRect); + CtkCopyRect(&winPtr->clipRect, &winPtr->maskRect); + Ctk_DrawRect(winPtr, 0, 0, Tk_Width(winPtr)-1, Tk_Height(winPtr)-1, + style); + if (title) { + Ctk_DrawString(winPtr, 1, 0, style, title, -1); + } + CtkCopyRect(&winPtr->clipRect, &saveClip); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_MainWindow -- + * + * Returns the main window for an application. + * + * Results: + * If interp has a Tk application associated with it, the main + * window for the application is returned. Otherwise NULL is + * returned and an error message is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_MainWindow(interp) + Tcl_Interp *interp; /* Interpreter that embodies the + * application. Used for error + * reporting also. */ +{ + TkMainInfo *mainPtr; + for (mainPtr = tkMainWindowList; mainPtr != NULL; + mainPtr = mainPtr->nextPtr) { + if (mainPtr->interp == interp) { + return (Tk_Window) mainPtr->winPtr; + } + } + Tcl_SetResult(interp,"this isn't a Tk application",TCL_STATIC); + return NULL; +} + +/* + *------------------------------------------------------------ + * DisplayWindow -- + * + * Display window and all its mapped descendants. + * + * Results: + * None. + * + * Side Effects: + * + *------------------------------------------------------------ + */ + +static void +DisplayWindow(winPtr) + TkWindow *winPtr; +{ + TkWindow *parentPtr = winPtr->parentPtr; + TkWindow *sibling; + TkWindow *child; + + if (CtkIsDisplayed(winPtr)) { + panic("Attempt to display already displayed window"); + } + + winPtr->flags |= CTK_DISPLAYED; + + winPtr->absLeft = parentPtr->absLeft + winPtr->rect.left; + winPtr->absTop = parentPtr->absTop + winPtr->rect.top; + winPtr->maskRect.top = winPtr->absTop; + winPtr->maskRect.left = winPtr->absLeft; + winPtr->maskRect.bottom = parentPtr->absTop + winPtr->rect.bottom; + winPtr->maskRect.right = parentPtr->absLeft + winPtr->rect.right; + CtkIntersectRects(&(winPtr->maskRect), &(parentPtr->clipRect)); + ComputeClipRect(winPtr); + + if (winPtr->flags & TK_TOP_LEVEL) { + /* + * This is a top level window, compute clipping by siblings. + * Start with a clipping region equal to `maskRect', then + * remove overlaps with siblings above this window. + */ + winPtr->clipRgn = CtkCreateRegion(&(winPtr->maskRect)); + for (sibling = winPtr->nextPtr; + sibling != HEAD_CHILD(parentPtr); + sibling = sibling->nextPtr) + { + if (CtkIsDisplayed(sibling)) { + CtkRegionMinusRect(winPtr->clipRgn, &(sibling->maskRect), 0); + } + } + + /* + * For each sibling below this window (and the root), + * subtract the overlap between this window and the sibling + * from the sibling's clipping region. + */ + for (sibling = winPtr->priorPtr; + sibling != HEAD_CHILD(parentPtr); + sibling = sibling->priorPtr) + { + if (CtkIsDisplayed(sibling)) { + CtkRegionMinusRect(sibling->clipRgn, &(winPtr->maskRect), 0); + } + } + CtkRegionMinusRect(parentPtr->clipRgn, &(winPtr->maskRect), 0); + } else { + winPtr->clipRgn = parentPtr->clipRgn; + } + + Ctk_ClearWindow(winPtr); + ExposeWindow(winPtr, winPtr->clipRgn); + + for (child = BOTTOM_CHILD(winPtr); + child != HEAD_CHILD(winPtr); + child = child->nextPtr) { + if (Tk_IsMapped(child)) { + DisplayWindow(child); + } + } +} + +/* + *------------------------------------------------------------ + * ComputeClipRect -- + * + * Set the clipping rectangle for a window according + * to it's position, border-width, and parent's clipping + * rectangle. + * + * Results: + * None. + * + * Side Effects: + * Stores new values in winPtr->clipRect. + * + *------------------------------------------------------------ + */ + +static void +ComputeClipRect(winPtr) + register TkWindow *winPtr; +{ + register TkWindow *parentPtr = winPtr->parentPtr; + + winPtr->clipRect.top = winPtr->absTop + winPtr->borderWidth; + winPtr->clipRect.left = winPtr->absLeft + winPtr->borderWidth; + winPtr->clipRect.bottom = + parentPtr->absTop + winPtr->rect.bottom - winPtr->borderWidth; + winPtr->clipRect.right = + parentPtr->absLeft + winPtr->rect.right - winPtr->borderWidth; + CtkIntersectRects(&(winPtr->clipRect), &(parentPtr->clipRect)); +} + +/* + *------------------------------------------------------------ + * ExposeWindow -- + * + * Send expose event(s) to window for specified region + * + * Results: + * Pointer to sibling window, or NULL if window + * does not have a sibling that is displayed and enabled. + * + * Side Effects: + * None. + * + *------------------------------------------------------------ + */ + +static void +ExposeWindow(winPtr, rgnPtr) + TkWindow *winPtr; + CtkRegion *rgnPtr; +{ + Ctk_Event event; + + /* + * Compute intersection of rgnPtr and winPtr->maskRect. + */ + CtkRegionGetRect(rgnPtr, &event.u.expose); + CtkIntersectRects(&event.u.expose, &(winPtr->maskRect)); + CtkMoveRect(&event.u.expose, -winPtr->absLeft, -winPtr->absTop); + + event.type = CTK_EXPOSE_EVENT; + event.window = winPtr; + Tk_HandleEvent(&event); +} + +/* + *------------------------------------------------------------ + * UndisplayWindow -- + * + * Stop displaying window and all its descendants. + * Window must currently be displayed. + * + * Results: + * None. + * + * Side Effects: + * + *------------------------------------------------------------ + */ + +static void +UndisplayWindow(winPtr) + TkWindow *winPtr; +{ + TkWindow *child; + TkWindow *sibling; + TkWindow *parentPtr = winPtr->parentPtr; + Ctk_Event event; + + if (!CtkIsDisplayed(winPtr)) { + panic("Attempt to undisplay window that isn't displayed"); + } + + /* + * Stop displaying the descendants of `winPtr'. + */ + for (child = BOTTOM_CHILD(winPtr); + child != HEAD_CHILD(winPtr); + child = child->nextPtr) + { + if (CtkIsDisplayed(child)) { + UndisplayWindow(child); + } + } + + winPtr->flags &= ~CTK_DISPLAYED; + + if (parentPtr == NULL) { + CtkDestroyRegion(winPtr->clipRgn); + } else if (winPtr->flags & TK_TOP_LEVEL) { + /* + * This is a top level window, + * maintain the clipping regions. + */ + + /* + * For each (displayed) sibling below this window + * (and the root) add the overlap between the window and the + * sibling to the siblings clipping region. + */ + for (sibling = winPtr->priorPtr; + sibling != HEAD_CHILD(parentPtr); + sibling = sibling->priorPtr) { + if (CtkIsDisplayed(sibling)) { + UnoverlapHierarchy(sibling, winPtr); + } + } + Unoverlap(parentPtr, winPtr); + CtkDestroyRegion(winPtr->clipRgn); + } else if (winPtr->fillStyle != CTK_INVISIBLE_STYLE) { + Ctk_FillRect(parentPtr, + winPtr->rect.left, winPtr->rect.top, + winPtr->rect.right, winPtr->rect.bottom, + parentPtr->fillStyle, parentPtr->fillChar); + event.type = CTK_EXPOSE_EVENT; + event.window = parentPtr; + CtkCopyRect(&event.u.expose, &parentPtr->rect); + Tk_HandleEvent(&event); + } else if (winPtr->borderWidth) { + int borderWidth = winPtr->borderWidth; + + /* + * Blank out the border area. + * This would be much easier if we could pass a character to + * Ctk_DrawRect(). + */ + Ctk_FillRect(parentPtr, + winPtr->rect.left, winPtr->rect.top, + winPtr->rect.right, winPtr->rect.top+borderWidth, + parentPtr->fillStyle, parentPtr->fillChar); + Ctk_FillRect(parentPtr, + winPtr->rect.left, winPtr->rect.bottom-borderWidth, + winPtr->rect.right, winPtr->rect.bottom, + parentPtr->fillStyle, parentPtr->fillChar); + Ctk_FillRect(parentPtr, + winPtr->rect.left, winPtr->rect.top+borderWidth, + winPtr->rect.left+borderWidth, winPtr->rect.bottom-borderWidth, + parentPtr->fillStyle, parentPtr->fillChar); + Ctk_FillRect(parentPtr, + winPtr->rect.right-borderWidth, winPtr->rect.top+borderWidth, + winPtr->rect.right, winPtr->rect.bottom-borderWidth, + parentPtr->fillStyle, parentPtr->fillChar); + } + + winPtr->clipRgn = NULL; +} + +/* + *------------------------------------------------------------ + * UnoverlapHierarchy -- + * + * Restore overlapping region to underlying window tree. + * + * Results: + * None. + * + * Side Effects: + * + *------------------------------------------------------------ + */ + +static void +UnoverlapHierarchy(underWinPtr, overWinPtr) + TkWindow *underWinPtr; + TkWindow *overWinPtr; +{ + TkWindow *child; + + for (child = TOP_CHILD(underWinPtr); + child != HEAD_CHILD(underWinPtr); + child = child->priorPtr) { + if (CtkIsDisplayed(child)) { + UnoverlapHierarchy(child, overWinPtr); + } + } + Unoverlap(underWinPtr, overWinPtr); +} + +/* + *------------------------------------------------------------ + * Unoverlap -- + * + * Restore overlapping region to underlying window. + * + * Results: + * None. + * + * Side Effects: + * + *------------------------------------------------------------ + */ + +static void +Unoverlap(underWinPtr, overWinPtr) + TkWindow *underWinPtr; + TkWindow *overWinPtr; +{ + CtkRegion *overlap; + + if (underWinPtr->fillStyle != CTK_INVISIBLE_STYLE) { + overlap = CtkRegionMinusRect( + overWinPtr->clipRgn, + &(underWinPtr->maskRect), + 1); + CtkUnionRegions(underWinPtr->clipRgn, overlap); + CtkFillRegion(underWinPtr->dispPtr, overlap, + underWinPtr->fillStyle, underWinPtr->fillChar); + ExposeWindow(underWinPtr, overlap); + CtkDestroyRegion(overlap); + } else { + if (underWinPtr->borderWidth) { + /* + * Ok - this is a hack: + * Invisible windows can have (visible) borders, so + * must send an expose event to the window. Ideally, + * I would remove the border area from the overlying + * clip region, but that would take a lot of work. + * Since I know that the window will not redraw until + * idle time, I can send expose now, and let the parent + * clear the border area. Later, at idle, the invisible + * window will draw the border. + */ + ExposeWindow(underWinPtr, overWinPtr->clipRgn); + } + } +} + +/* + *------------------------------------------------------------ + * InsertWindow -- + * + * Insert window into list in front of `sibling'. + * + * Results: + * None. + * + * Side Effects: + * + *------------------------------------------------------------ + */ + +static void +InsertWindow(winPtr, sibling) + TkWindow *winPtr; + TkWindow *sibling; +{ + winPtr->nextPtr = sibling; + winPtr->priorPtr = sibling->priorPtr; + sibling->priorPtr->nextPtr = winPtr; + sibling->priorPtr = winPtr; +} + +/* + *------------------------------------------------------------ + * UnlinkWindow -- + * + * Detachs the window from its parent's list of children. + * + * Results: + * None. + * + * Side Effects: + * + *------------------------------------------------------------ + */ + +static void +UnlinkWindow(winPtr) + TkWindow *winPtr; +{ + winPtr->nextPtr->priorPtr = winPtr->priorPtr; + winPtr->priorPtr->nextPtr = winPtr->nextPtr; +} + ADDED tkXEvent.c Index: tkXEvent.c ================================================================== --- tkXEvent.c +++ tkXEvent.c @@ -0,0 +1,533 @@ +/* + * tkXEvent.c (CTk) -- + * + * This file provides basic low-level facilities for managing + * X events. It builds on the facilities provided in tkEvent.c. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright (c) 1995 Cleveland Clinic Foundation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $ + */ + +#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; + +/* + * Array of event masks corresponding to each X event: + */ + +static unsigned long eventMasks[] = { + CTK_MAP_EVENT_MASK, /* CTK_MAP_EVENT */ + CTK_MAP_EVENT_MASK, /* CTK_UNMAP_EVENT */ + CTK_EXPOSE_EVENT_MASK, /* CTK_EXPOSE_EVENT */ + CTK_FOCUS_EVENT_MASK, /* CTK_FOCUS_EVENT */ + CTK_FOCUS_EVENT_MASK, /* CTK_UNFOCUS_EVENT */ + CTK_KEY_EVENT_MASK, /* CTK_KEY_EVENT */ + CTK_DESTROY_EVENT_MASK, /* CTK_DESTROY_EVENT */ + 0 /* CTK_UNSUPPORTED_EVENT */ +}; + + +/* + *-------------------------------------------------------------- + * + * 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 = eventPtr->window; + unsigned long mask = eventMasks[eventPtr->type]; + InProgress ip; + static int lastSerial = 0; + + /* + * Assign the event serial number. + */ + lastSerial++; + eventPtr->serial = lastSerial; + + /* + * 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; + } + + /* + * 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; + 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. + */ + + if (ip.winPtr) { + TkBindEventProc(winPtr, eventPtr); + } + pendingPtr = ip.nextPtr; +} + + /* + *-------------------------------------------------------------- + * + * Tk_DoOneEvent -- + * + * Flushes displays and the calls Tcl_DoOneEvent. + * + * Results: + * See Tcl_DoOneEvent(). + * + * Side effects: + * Displays get flushed. + * + *-------------------------------------------------------------- + */ + +int Tk_DoOneEvent(int flags) +{ + int retval; + Ctk_DisplayFlush(NULL); + retval = Tcl_DoOneEvent(flags); + Ctk_DisplayFlush(NULL); + + return(retval); +} + + +/* + *-------------------------------------------------------------- + * + * 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); + } +} + +/* + *-------------------------------------------------------------- + * + * 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 = NULL; + } + } + ckfree((char *) handlerPtr); + } +}