#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  README Makefile tcl2c init.tcl tk.tcl tkAppInit.c tkMain.c
# Wrapped by sau@ss10 on Wed Oct  6 08:49:28 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'README' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'README'\"
else
echo shar: Extracting \"'README'\" \(1652 characters\)
sed "s/^X//" >'README' <<'END_OF_FILE'
XThis package contains the files needed to build a self-contained
X"wish" application binary, that can be run even if tcl, tk and wish
X(TCL7.0/TK3.3) are not installed on the target system.
X
XThe package consists of:
X  tcl2c        a csh script for turning tcl code into C strings
X  tkAppInit.c  Modified to use "compiled in" initialization files
X  tkMain.c     Modified to use "compiled in" wish script
X  Makefile     For "compiling" your wish scripts
X  README       This file
X
XTo build a stand-alone binary:
X*  Edit Makefile to reflect the locations of TK, TCL and X11 on your system
X*  create a wish script (with a .tcl suffix) that you wish to "compile".
X*  make PROG=foo
X   Where "foo.tcl" is the name of your script, "foo", is the name of the 
X   executable created, as well as the name of the application (e.g. send).
X
XThe binary "foo" accepts the same arguments as standard wish, except for "-f".
X
X
XNotes:
X  The profile.ps file called in tkCanvPs.c is not yet compiled in.
X
X  The included files init.tcl and tk.tcl are the stock initialization
X  files for tcl7.0/tk3.3 minus the checks for valid file version with
X  all of the normally auto-loaded functions included.  If your application
X  auto-loads additional functions, put them here, if you don't need some
X  of the "standard" ones, you may take them out.
X
X  This works with TK3.3 and TCL7.0
X
X  "make wish" builds a wish with the tcl and tk initialization files
X  compiled in.
X
X  tcl2c is a modified version of the script posted to comp.lang.tcl
X  to convert tcl programs to compilable C strings
X
X  This was tested on SunOS 4.1.3
X
Xcomments, suggestions to:
X  Stephen Uhler
X  sau@bellcore.com
END_OF_FILE
if test 1652 -ne `wc -c <'README'`; then
    echo shar: \"'README'\" unpacked with wrong size!
fi
# end of 'README'
fi
if test -f 'Makefile' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'Makefile'\"
else
echo shar: Extracting \"'Makefile'\" \(1686 characters\)
sed "s/^X//" >'Makefile' <<'END_OF_FILE'
X# makefile for building stand-alone wish application binaries
X# Stephen Uhler  sau@bellcore.com 10/1/93
X#
X#  Usage:
X#  To make a stand-alone binary <foo> out of the wish script <foo.tcl>:
X#     make PROG=<foo>
X#  To make a stand-alone version of wish (init files compiled in):
X#     make wish
X
X# tcl and tk initalization and standard auto-loaded files
XTCLFILES=init.tcl tk.tcl
X
X# modified TK source files
XCFILES= tkAppInit.c tkMain.c
X
XOTHER= README Makefile tcl2c
X
X# Where to find tcl/tk libraries
XTCLLIB=../tcl7.0
XTKLIB=../tk3.3
X
X# Where to find X11 include fileS
XXINCL=/usr/local/X11/include
X
X# location of TK sources
XTKINCL=../tk3.3
X
X# compile and link options
XCC=gcc -Wall
XFLAG = -O
XCFLAGS=-I$(XINCL) -I$(TKINCL) $(FLAG) -DNAME=\"$(PROG)\"
XLDFLAGS=$(FLAG) -static
X
X# set a default program that evokes a usage message
XPROG=usage
X
Xall: $(PROG)
X
Xusage::
X	@ echo "To make a self contained binary for a package called <foo>"
X	@ echo "Place the wish script <foo.tcl> in this directory.  Make sure"
X	@ echo "all \"source\" commands are already expanded (if possible)"
X	@ echo "run"
X	@ echo "   make PROG=<foo>"
X	exit 1
X
X$(PROG)::		init.o tk.o tkMain.o tkAppInit.o  $(PROG).o
X	$(CC) $(LDFLAGS) -o $(PROG) tkMain.o init.o tk.o tkAppInit.o $(PROG).o \
X			$(TKLIB)/libtk.a $(TCLLIB)/libtcl.a -lX11 -lnsl -lm   
X
Xinit.c:	init.tcl
X	./tcl2c init.tcl
X
Xtk.c:		tk.tcl
X	./tcl2c tk.tcl
X
X$(PROG).c:	$(PROG).tcl
X	./tcl2c $(PROG).tcl fileName
X
Xwish:		init.o tk.o tkAppInit.o 
X	$(CC) $(LDFLAGS) -o wish init.o tk.o tkAppInit.o \
X			$(TKLIB)/libtk.a $(TCLLIB)/libtcl.a -lX11 -lnsl -lm   
X
Xclean:
X	rm -rf *.o tk.c init.c $(PROG).c
X
Xlist:
X	@for i in $(OTHER) $(TCLFILES) $(CFILES); do \
X		echo $$i; \
X		done
END_OF_FILE
if test 1686 -ne `wc -c <'Makefile'`; then
    echo shar: \"'Makefile'\" unpacked with wrong size!
fi
# end of 'Makefile'
fi
if test -f 'tcl2c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'tcl2c'\"
else
echo shar: Extracting \"'tcl2c'\" \(1134 characters\)
sed "s/^X//" >'tcl2c' <<'END_OF_FILE'
X#!/bin/csh
X# convert a wish script to an initialized C string
X# Modified 10/1/93 by sau@bellcore.com
X
X    if ($#argv < 1) then
X            echo "usage: $0 filename.tcl [c_variable_name]"
X            exit 1
X    endif
X    
X    set root=$1:r
X    set var=$root"_tcl"
X    
X    if ($#argv == 2) then
X		 set var="$2"
X    endif
X    
X    echo "/* this file was machine generated from $1 */" > $root.c
X    echo "/* on `date` by $USER  */" >>  $root.c
X    echo "" >>  $root.c
X    echo 'char '$var'[] = "\' >>$root.c
X    
X    # Transformations applied to each line of the file:
X    #       eliminate blank lines
X    #       eliminate lines that are only comments
X    #       Convert preexisting backslash into double backslash.
X    #       Precede preexisting double quote (") with backslash.
X    #       Add backslash, n, backslash to the end of each line.
X    
X    sed -e '/^$/d'            \
X        -e '/^[ 	]*#/d'            \
X        -e 's/\\/\\\\/g'            \
X        -e 's/"/\\\"/g'              \
X        -e 's/$/\\n\\/'             \
X       $1 >>$root".c"
X    
X    # Final line of transformed file:
X    
X    echo '   ";' >>$root'.c'
END_OF_FILE
if test 1134 -ne `wc -c <'tcl2c'`; then
    echo shar: \"'tcl2c'\" unpacked with wrong size!
fi
chmod +x 'tcl2c'
# end of 'tcl2c'
fi
if test -f 'init.tcl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'init.tcl'\"
else
echo shar: Extracting \"'init.tcl'\" \(9670 characters\)
sed "s/^X//" >'init.tcl' <<'END_OF_FILE'
X# init.tcl --
X#
X# Default system startup file for Tcl-based applications.  Defines
X# "unknown" procedure and auto-load facilities.
X#
X# $Header: /usr/local/src/tk/static/RCS/init.tcl,v 1.1 1993/10/02 22:57:33 sau Exp sau $ SPRITE (Berkeley)
X#
X# Copyright (c) 1991-1993 The Regents of the University of California.
X# All rights reserved.
X#
X# Permission is hereby granted, without written agreement and without
X# license or royalty fees, to use, copy, modify, and distribute this
X# software and its documentation for any purpose, provided that the
X# above copyright notice and the following two paragraphs appear in
X# all copies of this software.
X#
X# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X#
X# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X#
X
Xset auto_path [info library]
X
X# unknown:
X# Invoked when a Tcl command is invoked that doesn't exist in the
X# interpreter:
X#
X#	1. See if the autoload facility can locate the command in a
X#	   Tcl script file.  If so, load it and execute it.
X#	2. See if the command exists as an executable UNIX program.
X#	   If so, "exec" the command.
X#	3. If the command was invoked at top-level:
X#	    (a) see if the command requests csh-like history substitution
X#		in one of the common forms !!, !<number>, or ^old^new.  If
X#		so, emulate csh's history substitution.
X#	    (b) see if the command is a unique abbreviation for another
X#		command.  If so, invoke the command.
X
Xproc unknown args {
X    global auto_noexec auto_noload env unknown_pending tcl_interactive;
X
X    set name [lindex $args 0]
X    if ![info exists auto_noload] {
X	#
X	# Make sure we're not trying to load the same proc twice.
X	#
X	if [info exists unknown_pending($name)] {
X	    unset unknown_pending($name)
X	    if {[array size unknown_pending] == 0} {
X		unset unknown_pending
X	    }
X	    return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
X	}
X	set unknown_pending($name) pending;
X	set ret [catch {auto_load $name} msg]
X	unset unknown_pending($name);
X	if {$ret != 0} {
X	    return -code $ret "error while autoloading \"$name\": $msg"
X	}
X	if ![array size unknown_pending] {
X	    unset unknown_pending
X	}
X	if $msg {
X	    return [uplevel $args]
X	}
X    }
X    if {([info level] == 1) && ([info script] == "") && $tcl_interactive} {
X	if ![info exists auto_noexec] {
X	    if [auto_execok $name] {
X		return [uplevel exec >&@stdout <@stdin $args]
X	    }
X	}
X	if {$name == "!!"} {
X	    return [uplevel {history redo}]
X	}
X	if [regexp {^!(.+)$} $name dummy event] {
X	    return [uplevel [list history redo $event]]
X	}
X	if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
X	    return [uplevel [list history substitute $old $new]]
X	}
X	set cmds [info commands $name*]
X	if {[llength $cmds] == 1} {
X	    return [uplevel [lreplace $args 0 0 $cmds]]
X	}
X	if {[llength $cmds] != 0} {
X	    if {$name == ""} {
X		return -code error "empty command name \"\""
X	    } else {
X		return -code error \
X			"ambiguous command name \"$name\": [lsort $cmds]"
X	    }
X	}
X    }
X    return -code error "invalid command name \"$name\""
X}
X
X# auto_load:
X# Checks a collection of library directories to see if a procedure
X# is defined in one of them.  If so, it sources the appropriate
X# library file to create the procedure.  Returns 1 if it successfully
X# loaded the procedure, 0 otherwise.
X
Xproc auto_load cmd {
X    global auto_index auto_oldpath auto_path env errorInfo errorCode
X
X    if [info exists auto_index($cmd)] {
X	uplevel #0 $auto_index($cmd)
X	return 1
X    }
X    if [catch {set path $auto_path}] {
X	if [catch {set path $env(TCLLIBPATH)}] {
X	    if [catch {set path [info library]}] {
X		return 0
X	    }
X	}
X    }
X    if [info exists auto_oldpath] {
X	if {$auto_oldpath == $path} {
X	    return 0
X	}
X    }
X    set auto_oldpath $path
X    catch {unset auto_index}
X    foreach dir $path {
X	set f ""
X	if [catch {set f [open $dir/tclIndex]}] {
X	    continue
X	}
X	set error [catch {
X	    set id [gets $f]
X	    if {$id == "# Tcl autoload index file, version 2.0"} {
X		eval [read $f]
X	    } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
X		while {[gets $f line] >= 0} {
X		    if {([string index $line 0] == "#")
X			    || ([llength $line] != 2)} {
X			continue
X		    }
X		    set name [lindex $line 0]
X		    if {![info exists auto_index($name)]} {
X			set auto_index($name) "source $dir/[lindex $line 1]"
X		    }
X		}
X	    } else {
X		error "$dir/tclIndex isn't a proper Tcl index file"
X	    }
X	} msg]
X	if {$f != ""} {
X	    close $f
X	}
X	if $error {
X	    error $msg $errorInfo $errorCode
X	}
X    }
X    if [info exists auto_index($cmd)] {
X	uplevel #0 $auto_index($cmd)
X	if {[info commands $cmd] != ""} {
X	    return 1
X	}
X    }
X    return 0
X}
X
X# auto_execok:
X# Returns 1 if there's an executable in the current path for the
X# given name, 0 otherwise.  Builds an associative array auto_execs
X# that caches information about previous checks, for speed.
X
Xproc auto_execok name {
X    global auto_execs env
X
X    if [info exists auto_execs($name)] {
X	return $auto_execs($name)
X    }
X    set auto_execs($name) 0
X    if {[string first / $name] >= 0} {
X	if {[file executable $name] && ![file isdirectory $name]} {
X	    puts "special, ok!"
X	    set auto_execs($name) 1
X	}
X	return $auto_execs($name)
X    }
X    foreach dir [split $env(PATH) :] {
X	if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
X	    set auto_execs($name) 1
X	    return 1
X	}
X    }
X    return 0
X}
X
X# auto_reset:
X# Destroy all cached information for auto-loading and auto-execution,
X# so that the information gets recomputed the next time it's needed.
X# Also delete any procedures that are listed in the auto-load index
X# except those related to auto-loading.
X
Xproc auto_reset {} {
X    global auto_execs auto_index auto_oldpath
X    foreach p [info procs] {
X	if {[info exists auto_index($p)] && ($p != "unknown")
X		&& ![string match auto_* $p]} {
X	    rename $p {}
X	}
X    }
X    catch {unset auto_execs}
X    catch {unset auto_index}
X    catch {unset auto_oldpath}
X}
X
X# auto_mkindex:
X# Regenerate a tclIndex file from Tcl source files.  Takes as argument
X# the name of the directory in which the tclIndex file is to be placed,
X# floowed by any number of glob patterns to use in that directory to
X# locate all of the relevant files.
X
Xproc auto_mkindex {dir args} {
X    global errorCode errorInfo
X    set oldDir [pwd]
X    cd $dir
X    set dir [pwd]
X    append index "# Tcl autoload index file, version 2.0\n"
X    append index "# This file is generated by the \"auto_mkindex\" command\n"
X    append index "# and sourced to set up indexing information for one or\n"
X    append index "# more commands.  Typically each line is a command that\n"
X    append index "# sets an element in the auto_index array, where the\n"
X    append index "# element name is the name of a command and the value is\n"
X    append index "# a script that loads the command.\n\n"
X    foreach file [eval glob $args] {
X	set f ""
X	set error [catch {
X	    set f [open $file]
X	    while {[gets $f line] >= 0} {
X		if [regexp {^proc[ 	]+([^ 	]*)} $line match procName] {
X		    append index "set [list auto_index($procName)]"
X		    append index " \"source \$dir/$file\"\n"
X		}
X	    }
X	    close $f
X	} msg]
X	if $error {
X	    set code $errorCode
X	    set info $errorInfo
X	    catch {close $f}
X	    cd $oldDir
X	    error $msg $info $code
X	}
X    }
X    set f [open tclIndex w]
X    puts $f $index nonewline
X    close $f
X    cd $oldDir
X}
X
X# parray:
X# Print the contents of a global array on stdout.
X#
X# $Header: /user6/ouster/tcl/library/RCS/parray.tcl,v 1.5 93/02/06 16:33:45 ouster Exp $ SPRITE (Berkeley)
X#
X# Copyright (c) 1991-1993 The Regents of the University of California.
X# All rights reserved.
X#
X# Permission is hereby granted, without written agreement and without
X# license or royalty fees, to use, copy, modify, and distribute this
X# software and its documentation for any purpose, provided that the
X# above copyright notice and the following two paragraphs appear in
X# all copies of this software.
X#
X# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X#
X# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X#
X
Xproc parray a {
X    upvar 1 $a array
X    if [catch {array size array}] {
X	error "\"$a\" isn't an array"
X    }
X    set maxl 0
X    foreach name [lsort [array names array]] {
X	if {[string length $name] > $maxl} {
X	    set maxl [string length $name]
X	}
X    }
X    set maxl [expr {$maxl + [string length $a] + 2}]
X    foreach name [lsort [array names array]] {
X	set nameString [format %s(%s) $a $name]
X	puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
X    }
X}
END_OF_FILE
if test 9670 -ne `wc -c <'init.tcl'`; then
    echo shar: \"'init.tcl'\" unpacked with wrong size!
fi
# end of 'init.tcl'
fi
if test -f 'tk.tcl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'tk.tcl'\"
else
echo shar: Extracting \"'tk.tcl'\" \(38872 characters\)
sed "s/^X//" >'tk.tcl' <<'END_OF_FILE'
X# tk.tcl --
X#
X# Initialization script normally executed in the interpreter for each
X# Tk-based application.  Arranges class bindings for widgets.
X#
X# $Header: /usr/local/src/tk/static/RCS/tk.tcl,v 1.1 1993/10/02 11:49:16 sau Exp $ SPRITE (Berkeley)
X#
X# Copyright (c) 1992-1993 The Regents of the University of California.
X# All rights reserved.
X#
X# Permission is hereby granted, without written agreement and without
X# license or royalty fees, to use, copy, modify, and distribute this
X# software and its documentation for any purpose, provided that the
X# above copyright notice and the following two paragraphs appear in
X# all copies of this software.
X#
X# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X#
X# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X
X# Insist on running with compatible versions of Tcl and Tk.
X
X
X# Add Tk's directory to the end of the auto-load search path:
X
Xlappend auto_path $tk_library
X
X# Turn off strict Motif look and feel as a default.
X
Xset tk_strictMotif 0
X
X# normally auto-loaded files
X# button.tcl --
X#
X# This file contains Tcl procedures used to manage Tk buttons.
X#
X# $Header: /user6/ouster/wish/library/RCS/button.tcl,v 1.9 93/07/01 13:41:53 ouster Exp $ SPRITE (Berkeley)
X#
X# Copyright (c) 1992-1993 The Regents of the University of California.
X# All rights reserved.
X#
X# Permission is hereby granted, without written agreement and without
X# license or royalty fees, to use, copy, modify, and distribute this
X# software and its documentation for any purpose, provided that the
X# above copyright notice and the following two paragraphs appear in
X# all copies of this software.
X#
X# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X#
X# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X#
X
X# The procedure below is invoked when the mouse pointer enters a
X# button widget.  It records the button we're in and changes the
X# state of the button to active unless the button is disabled.
X
Xproc tk_butEnter w {
X    global tk_priv tk_strictMotif
X    if {[lindex [$w config -state] 4] != "disabled"} {
X	if {!$tk_strictMotif} {
X	    $w config -state active
X	}
X	set tk_priv(window) $w
X    }
X}
X
X# The procedure below is invoked when the mouse pointer leaves a
X# button widget.  It changes the state of the button back to
X# inactive.
X
Xproc tk_butLeave w {
X    global tk_priv tk_strictMotif
X    if {[lindex [$w config -state] 4] != "disabled"} {
X	if {!$tk_strictMotif} {
X	    $w config -state normal
X	}
X    }
X    set tk_priv(window) ""
X}
X
X# The procedure below is invoked when the mouse button is pressed in
X# a button/radiobutton/checkbutton widget.  It records information
X# (a) to indicate that the mouse is in the button, and
X# (b) to save the button's relief so it can be restored later.
X
Xproc tk_butDown w {
X    global tk_priv
X    set tk_priv(relief) [lindex [$w config -relief] 4]
X    set tk_priv(buttonWindow) $w
X    if {[lindex [$w config -state] 4] != "disabled"} {
X	$w config -relief sunken
X    }
X}
X
X# The procedure below is invoked when the mouse button is released
X# for a button/radiobutton/checkbutton widget.  It restores the
X# button's relief and invokes the command as long as the mouse
X# hasn't left the button.
X
Xproc tk_butUp w {
X    global tk_priv
X    if {$w == $tk_priv(buttonWindow)} {
X	$w config -relief $tk_priv(relief)
X	if {($w == $tk_priv(window))
X		&& ([lindex [$w config -state] 4] != "disabled")} {
X	    uplevel #0 [list $w invoke]
X	}
X	set tk_priv(buttonWindow) ""
X    }
X}
X# dialog.tcl --
X#
X# This file defines the procedure tk_dialog, which creates a dialog
X# box containing a bitmap, a message, and one or more buttons.
X#
X# $Header: /user6/ouster/wish/library/RCS/dialog.tcl,v 1.4 93/08/16 16:59:52 ouster Exp $ SPRITE (Berkeley)
X#
X# Copyright (c) 1992-1993 The Regents of the University of California.
X# All rights reserved.
X#
X# Permission is hereby granted, without written agreement and without
X# license or royalty fees, to use, copy, modify, and distribute this
X# software and its documentation for any purpose, provided that the
X# above copyright notice and the following two paragraphs appear in
X# all copies of this software.
X#
X# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X#
X# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X#
X
X#
X# tk_dialog:
X#
X# This procedure displays a dialog box, waits for a button in the dialog
X# to be invoked, then returns the index of the selected button.
X#
X# Arguments:
X# w -		Window to use for dialog top-level.
X# title -	Title to display in dialog's decorative frame.
X# text -	Message to display in dialog.
X# bitmap -	Bitmap to display in dialog (empty string means none).
X# default -	Index of button that is to display the default ring
X#		(-1 means none).
X# args -	One or more strings to display in buttons across the
X#		bottom of the dialog box.
X
Xproc tk_dialog {w title text bitmap default args} {
X    global tk_priv
X
X    # 1. Create the top-level window and divide it into top
X    # and bottom parts.
X
X    catch {destroy $w}
X    toplevel $w -class Dialog
X    wm title $w $title
X    wm iconname $w Dialog
X    frame $w.top -relief raised -bd 1
X    pack $w.top -side top -fill both
X    frame $w.bot -relief raised -bd 1
X    pack $w.bot -side bottom -fill both
X
X    # 2. Fill the top part with bitmap and message.
X
X    message $w.msg -width 3i -text $text \
X	    -font -Adobe-Times-Medium-R-Normal-*-180-*
X    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 5m -pady 5m
X    if {$bitmap != ""} {
X	label $w.bitmap -bitmap $bitmap
X	pack $w.bitmap -in $w.top -side left -padx 5m -pady 5m
X    }
X
X    # 3. Create a row of buttons at the bottom of the dialog.
X
X    set i 0
X    foreach but $args {
X	button $w.button$i -text $but -command "set tk_priv(button) $i"
X	if {$i == $default} {
X	    frame $w.default -relief sunken -bd 1
X	    raise $w.button$i $w.default
X	    pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m
X	    pack $w.button$i -in $w.default -padx 2m -pady 2m \
X		    -ipadx 2m -ipady 1m
X	    bind $w <Return> "$w.button$i flash; set tk_priv(button) $i"
X	} else {
X	    pack $w.button$i -in $w.bot -side left -expand 1 \
X		    -padx 3m -pady 3m -ipadx 2m -ipady 1m
X	}
X	incr i
X    }
X
X    # 4. Withdraw the window, then update all the geometry information
X    # so we know how big it wants to be, then center the window in the
X    # display and de-iconify it.
X
X    wm withdraw $w
X    update idletasks
X    set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
X	    - [winfo vrootx [winfo parent $w]]]
X    set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
X	    - [winfo vrooty [winfo parent $w]]]
X    wm geom $w +$x+$y
X    wm deiconify $w
X
X    # 5. Set a grab and claim the focus too.
X
X    set oldFocus [focus]
X    grab $w
X    focus $w
X
X    # 6. Wait for the user to respond, then restore the focus and
X    # return the index of the selected button.
X
X    tkwait variable tk_priv(button)
X    destroy $w
X    focus $oldFocus
X    return $tk_priv(button)
X}
X# entry.tcl --
X#
X# This file contains Tcl procedures used to manage Tk entries.
X#
X# $Header: /user6/ouster/wish/library/RCS/entry.tcl,v 1.6 93/07/01 13:42:00 ouster Exp $ SPRITE (Berkeley)
X#
X# Copyright (c) 1992-1993 The Regents of the University of California.
X# All rights reserved.
X#
X# Permission is hereby granted, without written agreement and without
X# license or royalty fees, to use, copy, modify, and distribute this
X# software and its documentation for any purpose, provided that the
X# above copyright notice and the following two paragraphs appear in
X# all copies of this software.
X#
X# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X#
X# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X#
X
X# The procedure below is invoked to backspace over one character
X# in an entry widget.  The name of the widget is passed as argument.
X
Xproc tk_entryBackspace w {
X    set x [expr {[$w index insert] - 1}]
X    if {$x != -1} {$w delete $x}
X}
X
X# The procedure below is invoked to backspace over one word in an
X# entry widget.  The name of the widget is passed as argument.
X
Xproc tk_entryBackword w {
X    set string [$w get]
X    set curs [expr [$w index insert]-1]
X    if {$curs < 0} return
X    for {set x $curs} {$x > 0} {incr x -1} {
X	if {([string first [string index $string $x] " \t"] < 0)
X		&& ([string first [string index $string [expr $x-1]] " \t"]
X		>= 0)} {
X	    break
X	}
X    }
X    $w delete $x $curs
X}
X
X# The procedure below is invoked after insertions.  If the caret is not
X# visible in the window then the procedure adjusts the entry's view to
X# bring the caret back into the window again.  Also, try to keep at
X# least one character visible to the left of the caret.
X
Xproc tk_entrySeeCaret w {
X    set c [$w index insert]
X    set left [$w index @0]
X    if {$left >= $c} {
X	if {$c > 0} {
X	    $w view [expr $c-1]
X	} else {
X	    $w view $c
X	}
X	return
X    }
X    while {([$w index @[expr [winfo width $w]-5]] < $c)
X	    && ($left < $c)} {
X	set left [expr $left+1]
X	$w view $left
X    }
X}
X# listbox.tcl --
X#
X# This file contains Tcl procedures used to manage Tk listboxes.
X#
X# $Header: /user6/ouster/wish/library/RCS/listbox.tcl,v 1.3 93/07/01 13:42:05 ouster Exp $ SPRITE (Berkeley)
X#
X# Copyright (c) 1992-1993 The Regents of the University of California.
X# All rights reserved.
X#
X# Permission is hereby granted, without written agreement and without
X# license or royalty fees, to use, copy, modify, and distribute this
X# software and its documentation for any purpose, provided that the
X# above copyright notice and the following two paragraphs appear in
X# all copies of this software.
X#
X# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X#
X# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X#
X
X# The procedure below may be invoked to change the behavior of
X# listboxes so that only a single item may be selected at once.
X# The arguments give one or more windows whose behavior should
X# be changed;  if one of the arguments is "Listbox" then the default
X# behavior is changed for all listboxes.
X
Xproc tk_listboxSingleSelect args {
X    foreach w $args {
X	bind $w <B1-Motion> {%W select from [%W nearest %y]} 
X	bind $w <Shift-1> {%W select from [%W nearest %y]}
X	bind $w <Shift-B1-Motion> {%W select from [%W nearest %y]}
X    }
X}
X# menu.tcl --
X#
X# This file contains Tcl procedures used to manage Tk menus and
X# menubuttons.  Most of the code here is dedicated to support for
X# pulling down menus and menu traversal via the keyboard.
X#
X# $Header: /user6/ouster/wish/library/RCS/menu.tcl,v 1.23 93/09/17 14:02:28 ouster Exp $ SPRITE (Berkeley)
X#
X# Copyright (c) 1992-1993 The Regents of the University of California.
X# All rights reserved.
X#
X# Permission is hereby granted, without written agreement and without
X# license or royalty fees, to use, copy, modify, and distribute this
X# software and its documentation for any purpose, provided that the
X# above copyright notice and the following two paragraphs appear in
X# all copies of this software.
X#
X# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X#
X# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X#
X
X# The procedure below is publically available.  It is used to identify
X# a frame that serves as a menu bar and the menu buttons that lie inside
X# the menu bar.  This procedure establishes proper "menu bar" behavior
X# for all of the menu buttons, including keyboard menu traversal.  Only
X# one menu bar may exist for a given top-level window at a time.
X# Arguments:
X#	
X# bar -				The path name of the containing frame.  Must
X#				be an ancestor of all of the menu buttons,
X#				since it will be be used in grabs.
X# additional arguments -	One or more menu buttons that are descendants
X#				of bar.  The order of these arguments
X#				determines the order of keyboard traversal.
X#				If no extra arguments are named then all of
X#				the menu bar information for bar is cancelled.
X
Xproc tk_menuBar {w args} {
X    global tk_priv
X    if {$args == ""} {
X	if [catch {set menus $tk_priv(menusFor$w)}] {
X	    return ""
X	}
X	return $menus
X    }
X    if [info exists tk_priv(menusFor$w)] {
X	unset tk_priv(menusFor$w)
X	unset tk_priv(menuBarFor[winfo toplevel $w])
X    }
X    if {$args == "{}"} {
X	return
X    }
X    set tk_priv(menusFor$w) $args
X    set tk_priv(menuBarFor[winfo toplevel $w]) $w
X    bind $w <Any-Alt-KeyPress> {tk_traverseToMenu %W %A}
X    bind $w <F10> {tk_firstMenu %W}
X    bind $w <Any-ButtonRelease-1> tk_mbUnpost
X}
X
Xproc tk_menus {w args} {
X    error "tk_menus is obsolete in Tk versions 3.0 and later; please change your scripts to use tk_menuBar instead"
X}
X
X# The procedure below is publically available.  It takes any number of
X# arguments that are names of widgets or classes.  It sets up bindings
X# for the widgets or classes so that keyboard menu traversal is possible
X# when the input focus is in those widgets or classes.
X
Xproc tk_bindForTraversal args {
X    foreach w $args {
X	bind $w <Any-Alt-KeyPress> {tk_traverseToMenu %W %A}
X	bind $w <F10> {tk_firstMenu %W}
X    }
X}
X
X# The procedure below does all of the work of posting a menu (including
X# unposting any other menu that might currently be posted).  The "w"
X# argument is the name of the menubutton for the menu to be posted.
X# Note:  if $w is disabled then the procedure does nothing.
X
Xproc tk_mbPost {w} {
X    global tk_priv tk_strictMotif
X    if {[lindex [$w config -state] 4] == "disabled"} {
X	return
X    }
X    if {$w == $tk_priv(posted)} {
X	grab -global $tk_priv(grab)
X	return
X    }
X    set menu [lindex [$w config -menu] 4]
X    if {$menu == ""} {
X	return
X    }
X    if ![string match $w* $menu] {
X	error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
X    }
X    set cur $tk_priv(posted)
X    if {$cur != ""} tk_mbUnpost
X    set tk_priv(relief) [lindex [$w config -relief] 4]
X    $w config -relief raised
X    set tk_priv(posted) $w
X    if {$tk_priv(focus) == ""} {
X	set tk_priv(focus) [focus]
X    }
X    set tk_priv(activeBg) [lindex [$menu config -activebackground] 4]
X    set tk_priv(activeFg) [lindex [$menu config -activeforeground] 4]
X    if $tk_strictMotif {
X	$menu config -activebackground [lindex [$menu config -background] 4]
X	$menu config -activeforeground [lindex [$menu config -foreground] 4]
X    }
X    $menu activate none
X    focus $menu
X    $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]]
X    if [catch {set grab $tk_priv(menuBarFor[winfo toplevel $w])}] {
X	set grab $w
X    } else {
X	if [lsearch $tk_priv(menusFor$grab) $w]<0 {
X	    set grab $w
X	}
X    }
X    set tk_priv(cursor) [lindex [$grab config -cursor] 4]
X    $grab config -cursor arrow
X    set tk_priv(grab) $grab
X    grab -global $grab
X}
X
X# The procedure below does all the work of unposting the menubutton that's
X# currently posted.  It takes no arguments.  Special notes:
X# 1. It's important to unpost the menu before releasing the grab, so
X#    that any Enter-Leave events (e.g. from menu back to main
X#    application) have mode NotifyGrab.
X# 2. Be sure to enclose various groups of commands in "catch" so that
X#    the procedure will complete even if the menubutton or the menu
X#    or the grab window has been deleted.
X
Xproc tk_mbUnpost {} {
X    global tk_priv
X    set w $tk_priv(posted)
X    if {$w != ""} {
X	catch {
X	    set menu [lindex [$w config -menu] 4]
X	    $menu unpost
X	    $menu config -activebackground $tk_priv(activeBg)
X	    $menu config -activeforeground $tk_priv(activeFg)
X	    $w config -relief $tk_priv(relief)
X	}
X	catch {$tk_priv(grab) config -cursor $tk_priv(cursor)}
X	catch {focus $tk_priv(focus)}
X	grab release $tk_priv(grab)
X	set tk_priv(grab) ""
X	set tk_priv(focus) ""
X	set tk_priv(posted) {}
X    }
X}
X
X# The procedure below is invoked to implement keyboard traversal to
X# a menu button.  It takes two arguments:  the name of a window where
X# a keystroke originated, and the ascii character that was typed.
X# This procedure finds a menu bar by looking upward for a top-level
X# window, then looking for a window underneath that named "menu".
X# Then it searches through all the subwindows of "menu" for a menubutton
X# with an underlined character matching char.  If one is found, it
X# posts that menu.
X
Xproc tk_traverseToMenu {w char} {
X    global tk_priv
X    if {$char == ""} {
X	return
X    }
X    set char [string tolower $char]
X
X    foreach mb [tk_getMenuButtons $w] {
X	if {[winfo class $mb] == "Menubutton"} {
X	    set char2 [string index [lindex [$mb config -text] 4] \
X		    [lindex [$mb config -underline] 4]]
X	    if {[string compare $char [string tolower $char2]] == 0} {
X		tk_mbPost $mb
X		[lindex [$mb config -menu] 4] activate 0
X		return
X	    }
X	}
X    }
X}
X
X# The procedure below is used to implement keyboard traversal within
X# the posted menu.  It takes two arguments:  the name of the menu to
X# be traversed within, and an ASCII character.  It searches for an
X# entry in the menu that has that character underlined.  If such an
X# entry is found, it is invoked and the menu is unposted.
X
Xproc tk_traverseWithinMenu {w char} {
X    if {$char == ""} {
X	return
X    }
X    set char [string tolower $char]
X    set last [$w index last]
X    if {$last == "none"} {
X	return
X    }
X    for {set i 0} {$i <= $last} {incr i} {
X	if [catch {set char2 [string index \
X		[lindex [$w entryconfig $i -label] 4] \
X		[lindex [$w entryconfig $i -underline] 4]]}] {
X	    continue
X	}
X	if {[string compare $char [string tolower $char2]] == 0} {
X	    tk_mbUnpost
X	    $w invoke $i
X	    return
X	}
X    }
X}
X
X# The procedure below takes a single argument, which is the name of
X# a window.  It returns a list containing path names for all of the
X# menu buttons associated with that window's top-level window, or an
X# empty list if there are none.
X
Xproc tk_getMenuButtons w {
X    global tk_priv
X    set top [winfo toplevel $w]
X    if [catch {set bar [set tk_priv(menuBarFor$top)]}] {
X	return ""
X    }
X    return $tk_priv(menusFor$bar)
X}
X
X# The procedure below is used to traverse to the next or previous
X# menu in a menu bar.  It takes one argument, which is a count of
X# how many menu buttons forward or backward (if negative) to move.
X# If there is no posted menu then this procedure has no effect.
X
Xproc tk_nextMenu count {
X    global tk_priv
X    if {$tk_priv(posted) == ""} {
X	return
X    }
X    set buttons [tk_getMenuButtons $tk_priv(posted)]
X    set length [llength $buttons]
X    for {set i 0} 1 {incr i} {
X	if {$i >= $length} {
X	    return
X	}
X	if {[lindex $buttons $i] == $tk_priv(posted)} {
X	    break
X	}
X    }
X    incr i $count
X    while 1 {
X	while {$i < 0} {
X	    incr i $length
X	}
X	while {$i >= $length} {
X	    incr i -$length
X	}
X	set mb [lindex $buttons $i]
X	if {[lindex [$mb configure -state] 4] != "disabled"} {
X	    break
X	}
X	incr i $count
X    }
X    tk_mbUnpost
X    tk_mbPost $mb
X    [lindex [$mb config -menu] 4] activate 0
X}
X
X# The procedure below is used to traverse to the next or previous entry
X# in the posted menu.  It takes one argument, which is 1 to go to the
X# next entry or -1 to go to the previous entry.  Disabled entries are
X# skipped in this process.
X
Xproc tk_nextMenuEntry count {
X    global tk_priv
X    if {$tk_priv(posted) == ""} {
X	return
X    }
X    set menu [lindex [$tk_priv(posted) config -menu] 4]
X    if {[$menu index last] == "none"} {
X	return
X    }
X    set length [expr [$menu index last]+1]
X    set i [$menu index active]
X    if {$i == "none"} {
X	set i 0
X    } else {
X	incr i $count
X    }
X    while 1 {
X	while {$i < 0} {
X	    incr i $length
X	}
X	while {$i >= $length} {
X	    incr i -$length
X	}
X	if {[catch {$menu entryconfigure $i -state} state] == 0} {
X	    if {[lindex $state 4] != "disabled"} {
X		break
X	    }
X	}
X	incr i $count
X    }
X    $menu activate $i
X}
X
X# The procedure below invokes the active entry in the posted menu,
X# if there is one.  Otherwise it does nothing.
X
Xproc tk_invokeMenu {menu} {
X    set i [$menu index active]
X    if {$i != "none"} {
X	tk_mbUnpost
X	update idletasks
X	$menu invoke $i
X    }
X}
X
X# The procedure below is invoked to keyboard-traverse to the first
X# menu for a given source window.  The source window is passed as
X# parameter.
X
Xproc tk_firstMenu w {
X    set mb [lindex [tk_getMenuButtons $w] 0]
X    if {$mb != ""} {
X	tk_mbPost $mb
X	[lindex [$mb config -menu] 4] activate 0
X    }
X}
X
X# The procedure below is invoked when a button-1-down event is
X# received by a menu button.  If the mouse is in the menu button
X# then it posts the button's menu.  If the mouse isn't in the
X# button's menu, then it deactivates any active entry in the menu.
X# Remember, event-sharing can cause this procedure to be invoked
X# for two different menu buttons on the same event.
X
Xproc tk_mbButtonDown w {
X    global tk_priv
X    if {[lindex [$w config -state] 4] == "disabled"} {
X	return
X    }
X    if {$tk_priv(inMenuButton) == $w} {
X	tk_mbPost $w
X    }
X}
X# text.tcl --
X#
X# This file contains Tcl procedures used to manage Tk entries.
X#
X# $Header: /user6/ouster/wish/library/RCS/text.tcl,v 1.3 93/07/01 13:42:07 ouster Exp $ SPRITE (Berkeley)
X#
X# Copyright (c) 1992-1993 The Regents of the University of California.
X# All rights reserved.
X#
X# Permission is hereby granted, without written agreement and without
X# license or royalty fees, to use, copy, modify, and distribute this
X# software and its documentation for any purpose, provided that the
X# above copyright notice and the following two paragraphs appear in
X# all copies of this software.
X#
X# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X#
X# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X#
X
X# The procedure below is invoked when dragging one end of the selection.
X# The arguments are the text window name and the index of the character
X# that is to be the new end of the selection.
X
Xproc tk_textSelectTo {w index} {
X    global tk_priv
X
X    case $tk_priv(selectMode) {
X	char {
X	    if [$w compare $index < anchor] {
X		set first $index
X		set last anchor
X	    } else {
X		set first anchor
X		set last [$w index $index+1c]
X	    }
X	}
X	word {
X	    if [$w compare $index < anchor] {
X		set first [$w index "$index wordstart"]
X		set last [$w index "anchor wordend"]
X	    } else {
X		set first [$w index "anchor wordstart"]
X		set last [$w index "$index wordend"]
X	    }
X	}
X	line {
X	    if [$w compare $index < anchor] {
X		set first [$w index "$index linestart"]
X		set last [$w index "anchor lineend + 1c"]
X	    } else {
X		set first [$w index "anchor linestart"]
X		set last [$w index "$index lineend + 1c"]
X	    }
X	}
X    }
X    $w tag remove sel 0.0 $first
X    $w tag add sel $first $last
X    $w tag remove sel $last end
X}
X
X# The procedure below is invoked to backspace over one character in
X# a text widget.  The name of the widget is passed as argument.
X
Xproc tk_textBackspace w {
X    $w delete insert-1c insert
X}
X
X# The procedure below compares three indices, a, b, and c.  Index b must
X# be less than c.  The procedure returns 1 if a is closer to b than to c,
X# and 0 otherwise.  The "w" argument is the name of the text widget in
X# which to do the comparison.
X
Xproc tk_textIndexCloser {w a b c} {
X    set a [$w index $a]
X    set b [$w index $b]
X    set c [$w index $c]
X    if [$w compare $a <= $b] {
X	return 1
X    }
X    if [$w compare $a >= $c] {
X	return 0
X    }
X    scan $a "%d.%d" lineA chA
X    scan $b "%d.%d" lineB chB
X    scan $c "%d.%d" lineC chC
X    if {$chC == 0} {
X	incr lineC -1
X	set chC [string length [$w get $lineC.0 $lineC.end]]
X    }
X    if {$lineB != $lineC} {
X	return [expr {($lineA-$lineB) < ($lineC-$lineA)}]
X    }
X    return [expr {($chA-$chB) < ($chC-$chA)}]
X}
X
X# The procedure below is called to reset the selection anchor to
X# whichever end is FARTHEST from the index argument.
X
Xproc tk_textResetAnchor {w index} {
X    global tk_priv
X    if {[$w tag ranges sel] == ""} {
X	set tk_priv(selectMode) char
X	$w mark set anchor $index
X	return
X    }
X    if [tk_textIndexCloser $w $index sel.first sel.last] {
X	if {$tk_priv(selectMode) == "char"} {
X	    $w mark set anchor sel.last
X	} else {
X	    $w mark set anchor sel.last-1c
X	}
X    } else {
X	$w mark set anchor sel.first
X    }
X}
X# This file contains a default version of the tkError procedure.  It
X# posts a dialog box with the error message and gives the user a chance
X# to see a more detailed stack trace.
X
Xproc tkerror err {
X    global errorInfo
X    set info $errorInfo
X    if {[tk_dialog .tkerrorDialog "Error in Tcl Script" \
X	    "Error: $err" error 0 OK "See Stack Trace"] == 0} {
X	return
X    }
X
X    set w .tkerrorTrace
X    catch {destroy $w}
X    toplevel $w -class ErrorTrace
X    wm minsize $w 1 1
X    wm title $w "Stack Trace for Error"
X    wm iconname $w "Stack Trace"
X    button $w.ok -text OK -command "destroy $w"
X    text $w.text -relief raised -bd 2 -yscrollcommand "$w.scroll set" \
X	    -setgrid true -width 40 -height 10
X    scrollbar $w.scroll -relief flat -command "$w.text yview"
X    pack $w.ok -side bottom -padx 3m -pady 3m -ipadx 2m -ipady 1m
X    pack $w.scroll -side right -fill y
X    pack $w.text -side left -expand yes -fill both
X    $w.text insert 0.0 $info
X    $w.text mark set insert 0.0
X
X    # Center the window on the screen.
X
X    wm withdraw $w
X    update idletasks
X    set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
X	    - [winfo vrootx [winfo parent $w]]]
X    set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
X	    - [winfo vrooty [winfo parent $w]]]
X    wm geom $w +$x+$y
X    wm deiconify $w
X}
X# standard TK bindings
X# ----------------------------------------------------------------------
X# Class bindings for various flavors of button widgets.  $tk_priv(window)
X# keeps track of the button containing the mouse $tk_priv(relief) saves
X# the original relief of the button so it can be restored when the mouse
X# button is released, and $tk_priv(buttonWindow) keeps track of the
X# window in which the mouse button was pressed.
X# ----------------------------------------------------------------------
X
Xbind Button <Any-Enter> {tk_butEnter %W}
Xbind Button <Any-Leave> {tk_butLeave %W}
Xbind Button <1> {tk_butDown %W}
Xbind Button <ButtonRelease-1> {tk_butUp %W}
X
Xbind Checkbutton <Any-Enter> {tk_butEnter %W}
Xbind Checkbutton <Any-Leave> {tk_butLeave %W}
Xbind Checkbutton <1> {tk_butDown %W}
Xbind Checkbutton <ButtonRelease-1> {tk_butUp %W}
X
Xbind Radiobutton <Any-Enter> {tk_butEnter %W}
Xbind Radiobutton <Any-Leave> {tk_butLeave %W}
Xbind Radiobutton <1> {tk_butDown %W}
Xbind Radiobutton <ButtonRelease-1> {tk_butUp %W}
X
X# ----------------------------------------------------------------------
X# Class bindings for entry widgets.
X# ----------------------------------------------------------------------
X
Xbind Entry <1> {
X    %W icursor @%x
X    %W select from @%x
X    if {[lindex [%W config -state] 4] == "normal"} {focus %W}
X}
Xbind Entry <B1-Motion> {%W select to @%x}
Xbind Entry <Shift-1> {%W select adjust @%x}
Xbind Entry <Shift-B1-Motion> {%W select to @%x}
Xbind Entry <2> {%W scan mark %x}
Xbind Entry <B2-Motion> {%W scan dragto %x}
Xbind Entry <Any-KeyPress> {
X    if {"%A" != ""} {
X	%W insert insert %A
X	tk_entrySeeCaret %W
X    }
X}
Xbind Entry <Delete> {tk_entryBackspace %W; tk_entrySeeCaret %W}
Xbind Entry <BackSpace> {tk_entryBackspace %W; tk_entrySeeCaret %W}
Xbind Entry <Control-h> {tk_entryBackspace %W; tk_entrySeeCaret %W}
Xbind Entry <Control-d> {%W delete sel.first sel.last; tk_entrySeeCaret %W}
Xbind Entry <Control-u> {%W delete 0 end}
Xbind Entry <Control-v> {%W insert insert [selection get]; tk_entrySeeCaret %W}
Xbind Entry <Control-w> {tk_entryBackword %W; tk_entrySeeCaret %W}
Xtk_bindForTraversal Entry
X
X# ----------------------------------------------------------------------
X# Class bindings for listbox widgets.
X# ----------------------------------------------------------------------
X
Xbind Listbox <1> {%W select from [%W nearest %y]}
Xbind Listbox <B1-Motion> {%W select to [%W nearest %y]}
Xbind Listbox <Shift-1> {%W select adjust [%W nearest %y]}
Xbind Listbox <Shift-B1-Motion> {%W select to [%W nearest %y]}
Xbind Listbox <2> {%W scan mark %x %y}
Xbind Listbox <B2-Motion> {%W scan dragto %x %y}
X
X# ----------------------------------------------------------------------
X# Class bindings for scrollbar widgets.  When strict Motif is requested,
X# the bindings use $tk_priv(buttons) and $tk_priv(activeFg) to set the
X# -activeforeground color to -foreground when the mouse is in the window
X# and restore it when the mouse leaves.
X# ----------------------------------------------------------------------
X
Xbind Scrollbar <Any-Enter> {
X    if $tk_strictMotif {
X	set tk_priv(activeFg) [lindex [%W config -activeforeground] 4]
X	%W config -activeforeground [lindex [%W config -foreground] 4]
X    }
X}
Xbind Scrollbar <Any-Leave> {
X    if {$tk_strictMotif && ($tk_priv(buttons) == 0)} {
X	%W config -activeforeground $tk_priv(activeFg)
X    }
X}
Xbind Scrollbar <Any-ButtonPress> {incr tk_priv(buttons)}
Xbind Scrollbar <Any-ButtonRelease> {incr tk_priv(buttons) -1}
X
X# ----------------------------------------------------------------------
X# Class bindings for scale widgets.  When strict Motif is requested,
X# the bindings use $tk_priv(buttons) and $tk_priv(activeFg) to set the
X# -activeforeground color to -foreground when the mouse is in the window
X# and restore it when the mouse leaves.
X# ----------------------------------------------------------------------
X
Xbind Scale <Any-Enter> {
X    if $tk_strictMotif {
X	set tk_priv(activeFg) [lindex [%W config -activeforeground] 4]
X	%W config -activeforeground [lindex [%W config -sliderforeground] 4]
X    }
X}
Xbind Scale <Any-Leave> {
X    if {$tk_strictMotif && ($tk_priv(buttons) == 0)} {
X	%W config -activeforeground $tk_priv(activeFg)
X    }
X}
Xbind Scale <Any-ButtonPress> {incr tk_priv(buttons)}
Xbind Scale <Any-ButtonRelease> {incr tk_priv(buttons) -1}
X
X# ----------------------------------------------------------------------
X# Class bindings for menubutton widgets.  Variables used:
X# $tk_priv(posted) -		keeps track of the menubutton whose menu is
X#				currently posted (or empty string, if none).
X# $tk_priv(inMenuButton)-	if non-null, identifies menu button
X#				containing mouse pointer.
X# $tk_priv(relief) -		keeps track of original relief of posted
X#				menu button, so it can be restored later.
X# $tk_priv(dragging) -		if non-null, identifies menu button whose
X#				menu is currently being dragged in a tear-off
X#				operation.
X# $tk_priv(focus) -		records old focus window so focus can be
X#				returned there after keyboard traversal
X#				to menu.
X# ----------------------------------------------------------------------
X
Xbind Menubutton <Any-Enter> {
X    set tk_priv(inMenuButton) %W
X    if {[lindex [%W config -state] 4] != "disabled"} {
X	if {!$tk_strictMotif} {
X	    %W config -state active
X	}
X    }
X}
Xbind Menubutton <Any-Leave> {
X    set tk_priv(inMenuButton) {}
X    if {[lindex [%W config -state] 4] == "active"} {
X	%W config -state normal
X    }
X}
Xbind Menubutton <1> {tk_mbButtonDown %W}
Xbind Menubutton <Any-ButtonRelease-1> {
X    if {($tk_priv(posted) == "%W") && ($tk_priv(inMenuButton) == "%W")} {
X	[lindex [$tk_priv(posted) config -menu] 4] activate 0
X    } else {
X	tk_mbUnpost
X    }
X}
X
X# The binding below is trickier than it looks.  It's important to check
X# to see that another menu is posted in the "if" statement below.
X# The check is needed because some window managers (e.g. mwm in
X# click-to-focus mode) cause a button-press event to be preceded by
X# a B1-Enter event;  we don't want to process that B1-Enter event (if
X# we do, the grab may get mis-set so that the menu is non-responsive).
X
Xbind Menubutton <B1-Enter> {
X    set tk_priv(inMenuButton) %W
X    if {([lindex [%W config -state] 4] != "disabled")
X	    && ($tk_priv(posted) != "")} {
X	if {!$tk_strictMotif} {
X	    %W config -state active
X	}
X	tk_mbPost %W
X    }
X}
Xbind Menubutton <2> {
X    if {($tk_priv(posted) == "")
X	    && ([lindex [%W config -state] 4] != "disabled")} {
X	set tk_priv(dragging) %W
X	[lindex [$tk_priv(dragging) config -menu] 4] post %X %Y
X    }
X}
Xbind Menubutton <B2-Motion> {
X    if {$tk_priv(dragging) != ""} {
X	[lindex [$tk_priv(dragging) config -menu] 4] post %X %Y
X    }
X}
Xbind Menubutton <ButtonRelease-2> {set tk_priv(dragging) ""}
X
X# ----------------------------------------------------------------------
X# Class bindings for menu widgets.  $tk_priv(x) and $tk_priv(y) are used
X# to keep track of the position of the mouse cursor in the menu window
X# during dragging of tear-off menus.  $tk_priv(window) keeps track of
X# the menu containing the mouse, if any.
X# ----------------------------------------------------------------------
X
Xbind Menu <Any-Enter> {set tk_priv(window) %W; %W activate @%y}
Xbind Menu <Any-Leave> {set tk_priv(window) {}; %W activate none}
Xbind Menu <Any-Motion> {
X    if {$tk_priv(window) == "%W"} {
X	%W activate @%y
X    }
X}
Xbind Menu <1> {
X    if {$tk_priv(grab) != ""} {
X	grab $tk_priv(grab)
X    }
X}
Xbind Menu <ButtonRelease-1> {tk_invokeMenu %W}
Xbind Menu <2> {set tk_priv(x) %x; set tk_priv(y) %y}
Xbind Menu <B2-Motion> {
X    if {$tk_priv(posted) == ""} {
X	%W post [expr %X-$tk_priv(x)] [expr %Y-$tk_priv(y)]
X    }
X}
Xbind Menu <B2-Leave> { }
Xbind Menu <B2-Enter> { }
Xbind Menu <Escape> {tk_mbUnpost}
Xbind Menu <Any-KeyPress> {tk_traverseWithinMenu %W %A}
Xbind Menu <Left> {tk_nextMenu -1}
Xbind Menu <Right> {tk_nextMenu 1}
Xbind Menu <Up> {tk_nextMenuEntry -1}
Xbind Menu <Down> {tk_nextMenuEntry 1}
Xbind Menu <Return> {tk_invokeMenu %W}
X
X# ----------------------------------------------------------------------
X# Class bindings for text widgets. $tk_priv(selectMode) holds one of
X# "char", "word", or "line" to indicate which selection mode is active.
X# ----------------------------------------------------------------------
X
Xbind Text <1> {
X    set tk_priv(selectMode) char
X    %W mark set insert @%x,%y
X    %W mark set anchor insert
X    if {[lindex [%W config -state] 4] == "normal"} {focus %W}
X}
Xbind Text <Double-1> {
X    set tk_priv(selectMode) word
X    %W mark set insert "@%x,%y wordstart"
X    tk_textSelectTo %W insert
X}
Xbind Text <Triple-1> {
X    set tk_priv(selectMode) line
X    %W mark set insert "@%x,%y linestart"
X    tk_textSelectTo %W insert
X}
Xbind Text <B1-Motion> {tk_textSelectTo %W @%x,%y}
Xbind Text <Shift-1> {
X    tk_textResetAnchor %W @%x,%y
X    tk_textSelectTo %W @%x,%y
X}
Xbind Text <Shift-B1-Motion> {tk_textSelectTo %W @%x,%y}
Xbind Text <2> {%W scan mark %y}
Xbind Text <B2-Motion> {%W scan dragto %y}
Xbind Text <Any-KeyPress> {
X    if {"%A" != ""} {
X	%W insert insert %A
X	%W yview -pickplace insert
X    }
X}
Xbind Text <Return> {%W insert insert \n; %W yview -pickplace insert}
Xbind Text <BackSpace> {tk_textBackspace %W; %W yview -pickplace insert}
Xbind Text <Delete> {tk_textBackspace %W; %W yview -pickplace insert}
Xbind Text <Control-h> {tk_textBackspace %W; %W yview -pickplace insert}
Xbind Text <Control-d> {%W delete sel.first sel.last}
Xbind Text <Control-v> {
X    %W insert insert [selection get]
X    %W yview -pickplace insert
X}
Xtk_bindForTraversal Text
X
X# Initialize the elements of tk_priv that require initialization.
X
Xset tk_priv(buttons) 0
Xset tk_priv(buttonWindow) {}
Xset tk_priv(dragging) {}
Xset tk_priv(focus) {}
Xset tk_priv(grab) {}
Xset tk_priv(inMenuButton) {}
Xset tk_priv(posted) {}
Xset tk_priv(selectMode) char
Xset tk_priv(window) {}
END_OF_FILE
if test 38872 -ne `wc -c <'tk.tcl'`; then
    echo shar: \"'tk.tcl'\" unpacked with wrong size!
fi
# end of 'tk.tcl'
fi
if test -f 'tkAppInit.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'tkAppInit.c'\"
else
echo shar: Extracting \"'tkAppInit.c'\" \(3486 characters\)
sed "s/^X//" >'tkAppInit.c' <<'END_OF_FILE'
X/* 
X * tkAppInit.c --
X *
X * Modified 10/1/93 by sau to incorporate startup files
X *
X *	Provides a default version of the Tcl_AppInit procedure for
X *	use in wish and similar Tk-based applications.
X *
X * Copyright (c) 1993 The Regents of the University of California.
X * All rights reserved.
X *
X * Permission is hereby granted, without written agreement and without
X * license or royalty fees, to use, copy, modify, and distribute this
X * software and its documentation for any purpose, provided that the
X * above copyright notice and the following two paragraphs appear in
X * all copies of this software.
X * 
X * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X *
X * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X */
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: /usr/local/src/tk/static/RCS/tkAppInit.c,v 1.1 1993/10/01 15:01:28 sau Exp sau $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include "tk.h"
X
X/*
X * The following variable is a special hack that allows applications
X * to be linked using the procedure "main" from the Tk library.  The
X * variable generates a reference to "main", which causes main to
X * be brought in from the library (and all of Tk and Tcl with it).
X */
X
Xextern int main();
Xint *tclDummyMainPtr = (int *) main;
Xextern char init_tcl[], tk_tcl[];	/* static initialization files */
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_AppInit --
X *
X *	This procedure performs application-specific initialization.
X *	Most applications, especially those that incorporate additional
X *	packages, will have their own version of this procedure.
X *
X * Results:
X *	Returns a standard Tcl completion code, and leaves an error
X *	message in interp->result if an error occurs.
X *
X * Side effects:
X *	Depends on the startup script.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_AppInit(interp)
X    Tcl_Interp *interp;		/* Interpreter for application. */
X{
X    Tk_Window main;
X    int result;
X
X    main = Tk_MainWindow(interp);
X
X    /*
X     * Call the init procedures for included packages.  Each call should
X     * look like this:
X     *
X     * if (Mod_Init(interp) == TCL_ERROR) {
X     *     return TCL_ERROR;
X     * }
X     *
X     * where "Mod" is the name of the module.
X     */
X
X     if ((result=Tcl_Eval(interp, init_tcl)) != TCL_OK)
X			return(result);
X     return Tcl_Eval(interp, tk_tcl);	/* static TK initialization */
X
X    /*
X     * Call Tcl_CreateCommand for application-specific commands, if
X     * they weren't already created by the init procedures called above.
X     */
X
X    /*
X     * Specify a user-specific startup file to invoke if the application
X     * is run interactively.  Typically the startup file is "~/.apprc"
X     * where "app" is the name of the application.  If this line is deleted
X     * then no user-specific startup file will be run under any conditions.
X     */
X
X    return TCL_OK;
X}
END_OF_FILE
if test 3486 -ne `wc -c <'tkAppInit.c'`; then
    echo shar: \"'tkAppInit.c'\" unpacked with wrong size!
fi
# end of 'tkAppInit.c'
fi
if test -f 'tkMain.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'tkMain.c'\"
else
echo shar: Extracting \"'tkMain.c'\" \(6438 characters\)
sed "s/^X//" >'tkMain.c' <<'END_OF_FILE'
X/* 
X * main.c --
X *
X * Modified 10/3/93 by sau to only run compiled in wish program
X *
X *	This file contains the main program for "wish", a windowing
X *	shell based on Tk and Tcl.  It also provides a template that
X *	can be used as the basis for main programs for other Tk
X *	applications.
X *
X * Copyright (c) 1990-1993 The Regents of the University of California.
X * All rights reserved.
X *
X * Permission is hereby granted, without written agreement and without
X * license or royalty fees, to use, copy, modify, and distribute this
X * software and its documentation for any purpose, provided that the
X * above copyright notice and the following two paragraphs appear in
X * all copies of this software.
X * 
X * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
X * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
X * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
X * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
X *
X * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
X * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
X * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
X * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
X * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
X */
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkMain.c,v 1.96 93/09/17 12:03:05 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X/* #include "tkConfig.h" */
X#include "tkInt.h"
X
X/*
X * Global variables used by the main program:
X */
X
Xstatic Tk_Window mainWindow;	/* The main window for the application.  If
X				 * NULL then the application no longer
X				 * exists. */
Xstatic Tcl_Interp *interp;	/* Interpreter for this application. */
Xchar *tcl_RcFileName = NULL;	/* Name of a user-specific startup script
X				 * to source if the application is being run
X				 * interactively (e.g. "~/.wishrc").  Set
X				 * by Tcl_AppInit.  NULL means don't source
X				 * anything ever. */
Xstatic Tcl_DString command;	/* Used to assemble lines of terminal input
X				 * into Tcl commands. */
Xstatic char errorExitCmd[] = "exit 1";
X
X/*
X * Command-line options:
X */
X
Xint synchronize = 0;
Xextern char fileName[];
Xchar *name = NAME;
Xchar *display = NULL;
Xchar *geometry = NULL;
X
XTk_ArgvInfo argTable[] = {
X    {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry,
X	"Initial geometry for window"},
X    {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display,
X	"Display to use"},
X    {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name,
X	"Name to use for application"},
X    {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize,
X	"Use synchronous mode for display server"},
X    {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL,
X	(char *) NULL}
X};
X
X
X/*
X *----------------------------------------------------------------------
X *
X * main --
X *
X *	Main program for Wish.
X *
X * Results:
X *	None. This procedure never returns (it exits the process when
X *	it's done
X *
X * Side effects:
X *	This procedure initializes the wish world and then starts
X *	interpreting commands;  almost anything could happen, depending
X *	on the script being interpreted.
X *
X *----------------------------------------------------------------------
X */
X
Xint
Xmain(argc, argv)
X    int argc;				/* Number of arguments. */
X    char **argv;			/* Array of argument strings. */
X{
X    char *args, *msg;
X    char buf[20];
X    int code;
X
X    interp = Tcl_CreateInterp();
X#ifdef TCL_MEM_DEBUG
X    Tcl_InitMemory(interp);
X#endif
X
X    /*
X     * Parse command-line arguments.
X     */
X
X    if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0)
X	    != TCL_OK) {
X	fprintf(stderr, "%s\n", interp->result);
X	exit(1);
X    }
X
X    /*
X     * If a display was specified, put it into the DISPLAY
X     * environment variable so that it will be available for
X     * any sub-processes created by us.
X     */
X
X    if (display != NULL) {
X	Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY);
X    }
X
X    /*
X     * Initialize the Tk application.
X     */
X
X    mainWindow = Tk_CreateMainWindow(interp, display, name);
X    if (mainWindow == NULL) {
X	fprintf(stderr, "%s\n", interp->result);
X	exit(1);
X    }
X    Tk_SetClass(mainWindow, "Tk");
X    if (synchronize) {
X	XSynchronize(Tk_Display(mainWindow), True);
X    }
X    Tk_GeometryRequest(mainWindow, 200, 200);
X
X    /*
X     * Make command-line arguments available in the Tcl variables "argc"
X     * and "argv".  Also set the "geometry" variable from the geometry
X     * specified on the command line.
X     */
X
X    args = Tcl_Merge(argc-1, argv+1);
X    Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
X    ckfree(args);
X    sprintf(buf, "%d", argc-1);
X    Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
X    Tcl_SetVar(interp, "argv0", NAME,TCL_GLOBAL_ONLY);
X    if (geometry != NULL) {
X	Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY);
X    }
X
X    /*
X     * Set the "tcl_interactive" variable.
X     */
X
X    Tcl_SetVar(interp, "tcl_interactive","0", TCL_GLOBAL_ONLY);
X
X    /*
X     * Invoke application-specific initialization.
X     */
X
X    if (Tcl_AppInit(interp) != TCL_OK) {
X	fprintf(stderr, "Tcl_AppInit failed: %s\n", interp->result);
X    }
X
X    /*
X     * Set the geometry of the main window, if requested.
X     */
X
X    if (geometry != NULL) {
X	code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL);
X	if (code != TCL_OK) {
X	    fprintf(stderr, "%s\n", interp->result);
X	}
X    }
X
X    /*
X     * Invoke the script specified on the command line, if any.
X     */
X
X     code = Tcl_VarEval(interp, fileName, (char *) NULL);
X     if (code != TCL_OK) {
X	 goto error;
X     }
X    fflush(stdout);
X    Tcl_DStringInit(&command);
X
X    /*
X     * Loop infinitely, waiting for commands to execute.  When there
X     * are no windows left, Tk_MainLoop returns and we exit.
X     */
X
X    Tk_MainLoop();
X
X    /*
X     * Don't exit directly, but rather invoke the Tcl "exit" command.
X     * This gives the application the opportunity to redefine "exit"
X     * to do additional cleanup.
X     */
X
X    Tcl_Eval(interp, "exit");
X    exit(1);
X
Xerror:
X    msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
X    if (msg == NULL) {
X	msg = interp->result;
X    }
X    fprintf(stderr, "%s\n", msg);
X    Tcl_Eval(interp, errorExitCmd);
X    return 1;			/* Needed only to prevent compiler warnings. */
X}
END_OF_FILE
if test 6438 -ne `wc -c <'tkMain.c'`; then
    echo shar: \"'tkMain.c'\" unpacked with wrong size!
fi
# end of 'tkMain.c'
fi
echo shar: End of shell archive.
exit 0
