# Copyright (c) 1998-2000 by Ajuba Solutions.

# All rights reserved.

#

option add *ErrorDialog.function.text [::msgcat::mc "Save To Log"] \

widgetDefault

}

}

# This is the default version of bgerror.

# It tries to execute tkerror, if that fails it posts a dialog box containing

# the error message and gives the user a chance to ask to see a stack

# Arguments:

# err - The error message.

global errorInfo tcl_platform

set butvar ::tk::dialog::error::button

# may take the focus away so we can't redirect it. Finally,

# restore any grab that was in effect.

set button $::tk::dialog::error::button; # Save a copy...

catch {focus $oldFocus}

catch {destroy .bgerrorDialog}

# checkbutton, and radiobutton widgets and provides procedures

# that help in implementing those bindings.

#

#

# Copyright (c) 1992-1994 The Regents of the University of California.

# Copyright (c) 1994-1996 Sun Microsystems, Inc.

if {[string match "macintosh" $tcl_platform(platform)]} {

bind Radiobutton <Enter> {

}

bind Radiobutton <1> {

}

bind Radiobutton <ButtonRelease-1> {

}

bind Checkbutton <Enter> {

}

bind Checkbutton <1> {

}

bind Checkbutton <ButtonRelease-1> {

}

}

if {[string match "windows" $tcl_platform(platform)]} {

bind Checkbutton <equal> {

}

bind Checkbutton <plus> {

}

bind Checkbutton <minus> {

}

bind Checkbutton <1> {

}

bind Checkbutton <ButtonRelease-1> {

}

bind Checkbutton <Enter> {

}

bind Radiobutton <1> {

}

bind Radiobutton <ButtonRelease-1> {

}

bind Radiobutton <Enter> {

}

}

if {[string match "unix" $tcl_platform(platform)]} {

bind Checkbutton <Return> {

if {!$tk_strictMotif} {

}

}

bind Radiobutton <Return> {

if {!$tk_strictMotif} {

}

}

bind Checkbutton <1> {

}

bind Radiobutton <1> {

}

bind Checkbutton <Enter> {

}

bind Radiobutton <Enter> {

}

}

bind Button <space> {

}

bind Checkbutton <space> {

}

bind Radiobutton <space> {

}

bind Button <FocusIn> {}

bind Button <Enter> {

}

bind Button <Leave> {

}

bind Button <1> {

}

bind Button <ButtonRelease-1> {

}

bind Checkbutton <FocusIn> {}

bind Checkbutton <Leave> {

}

bind Radiobutton <FocusIn> {}

bind Radiobutton <Leave> {

}

if {[string match "windows" $tcl_platform(platform)]} {

# Windows implementation

#########################

# The procedure below is invoked when the mouse pointer enters a

# button widget. It records the button we're in and changes the

# state of the button to active unless the button is disabled.

# Arguments:

# w - The name of the widget.

if {[string compare [$w cget -state] "disabled"] } {

# If the mouse button is down, set the relief to sunken on entry.

# Overwise, if there's an -overrelief value, set the relief to that.

$w configure -state active -relief sunken

} elseif { [string compare [$w cget -overrelief] ""] } {

$w configure -relief [$w cget -overrelief]

}

}

}

# The procedure below is invoked when the mouse pointer leaves a

# button widget. It changes the state of the button back to

# inactive. If we're leaving the button window with a mouse button

# button too.

#

# Arguments:

# w - The name of the widget.

if {[string compare [$w cget -state] "disabled"]} {

$w configure -state normal

}

# Restore the original button relief if the mouse button is down

# or there is an -overrelief value.

[string compare [$w cget -overrelief] ""] } {

}

}

# The procedure below is invoked when the mouse pointer enters a

# checkbutton or radiobutton widget. It records the button we're in

# and changes the state of the button to active unless the button is

# Arguments:

# w - The name of the widget.

if {[string compare [$w cget -state] "disabled"]} {

$w configure -state active

}

if { [string compare [$w cget -overrelief] ""] } {

$w configure -relief [$w cget -overrelief]

}

}

}

# The procedure below is invoked when the mouse button is pressed in

# a button widget. It records the fact that the mouse is in the button,

# saves the button's relief so it can be restored later, and changes

# Arguments:

# w - The name of the widget.

# Only save the button's relief if it has no -overrelief value. If there

# the current value of the -relief option will be incorrect.

if { [string equal [$w cget -overrelief] ""] } {

}

if {[string compare [$w cget -state] "disabled"]} {

$w configure -relief sunken -state active

# If this button has a repeatdelay set up, get it going with an after

set delay [$w cget -repeatdelay]

if {$delay > 0} {

}

}

}

# The procedure below is invoked when the mouse button is pressed in

# a button widget. It records the fact that the mouse is in the button,

# saves the button's relief so it can be restored later, and changes

# Arguments:

# w - The name of the widget.

if { [string equal [$w cget -overrelief] ""] } {

}

if {[string compare [$w cget -state] "disabled"]} {

$w configure -state active

}

}

# The procedure below is invoked when the mouse button is released

# in a button widget. It restores the button's relief and invokes

# the command as long as the mouse hasn't left the button.

# Arguments:

# w - The name of the widget.

# Restore the button's relief. If there is no overrelief, the

# button relief goes back to its original value. If there is an

# overrelief, the relief goes to the overrelief (since the cursor is

set relief [$w cget -overrelief]

if { [string equal $relief ""] } {

}

$w configure -relief $relief

# Clean up the after event from the auto-repeater

&& [string compare [$w cget -state] "disabled"]} {

$w configure -state normal

# Only invoke the command if it wasn't already invoked by the

# auto-repeater functionality

uplevel #0 [list $w invoke]

}

}

# Unix implementation

#####################

# The procedure below is invoked when the mouse pointer enters a

# button widget. It records the button we're in and changes the

# state of the button to active unless the button is disabled.

# Arguments:

# w - The name of the widget.

if {[string compare [$w cget -state] "disabled"]} {

$w configure -state active

# If the mouse button is down, set the relief to sunken on entry.

# Overwise, if there's an -overrelief value, set the relief to that.

$w configure -state active -relief sunken

} elseif { [string compare [$w cget -overrelief] ""] } {

$w configure -relief [$w cget -overrelief]

}

}

}

# The procedure below is invoked when the mouse pointer leaves a

# button widget. It changes the state of the button back to

# inactive. If we're leaving the button window with a mouse button

# button too.

#

# Arguments:

# w - The name of the widget.

if {[string compare [$w cget -state] "disabled"]} {

$w configure -state normal

}

# Restore the original button relief if the mouse button is down

# or there is an -overrelief value.

[string compare [$w cget -overrelief] ""] } {

}

}

# The procedure below is invoked when the mouse button is pressed in

# a button widget. It records the fact that the mouse is in the button,

# saves the button's relief so it can be restored later, and changes

# Arguments:

# w - The name of the widget.

# Only save the button's relief if it has no -overrelief value. If there

# the current value of the -relief option will be incorrect.

if { [string equal [$w cget -overrelief] ""] } {

}

if {[string compare [$w cget -state] "disabled"]} {

$w configure -relief sunken

# If this button has a repeatdelay set up, get it going with an after

set delay [$w cget -repeatdelay]

if {$delay > 0} {

}

}

}

# The procedure below is invoked when the mouse button is released

# in a button widget. It restores the button's relief and invokes

# the command as long as the mouse hasn't left the button.

# Arguments:

# w - The name of the widget.

# Restore the button's relief. If there is no overrelief, the

# button relief goes back to its original value. If there is an

set relief [$w cget -overrelief]

if { [string equal $relief ""] } {

}

$w configure -relief $relief

# Clean up the after event from the auto-repeater

&& [string compare [$w cget -state] "disabled"]} {

# Only invoke the command if it wasn't already invoked by the

# auto-repeater functionality

uplevel #0 [list $w invoke]

}

}

# Mac implementation

####################

# The procedure below is invoked when the mouse pointer enters a

# button widget. It records the button we're in and changes the

# state of the button to active unless the button is disabled.

# Arguments:

# w - The name of the widget.

if {[string compare [$w cget -state] "disabled"]} {

$w configure -state active

} elseif { [string compare [$w cget -overrelief] ""] } {

$w configure -relief [$w cget -overrelief]

}

}

}

# The procedure below is invoked when the mouse pointer leaves a

# button widget. It changes the state of the button back to

# inactive. If we're leaving the button window with a mouse button

# button too.

#

# Arguments:

# w - The name of the widget.

$w configure -state normal

}

if { [string compare [$w cget -overrelief] ""] } {

}

}

# The procedure below is invoked when the mouse button is pressed in

# a button widget. It records the fact that the mouse is in the button,

# saves the button's relief so it can be restored later, and changes

# Arguments:

# w - The name of the widget.

if {[string compare [$w cget -state] "disabled"]} {

$w configure -state active

# If this button has a repeatdelay set up, get it going with an after

if { ![catch {$w cget -repeatdelay} delay] } {

set delay [$w cget -repeatdelay]

if {$delay > 0} {

}

}

}

}

# The procedure below is invoked when the mouse button is released

# in a button widget. It restores the button's relief and invokes

# the command as long as the mouse hasn't left the button.

# Arguments:

# w - The name of the widget.

$w configure -state normal

if { [string compare [$w cget -overrelief] ""] } {

$w configure -relief [$w cget -overrelief]

}

# Clean up the after event from the auto-repeater

&& [string compare [$w cget -state] "disabled"]} {

# Only invoke the command if it wasn't already invoked by the

# auto-repeater functionality

uplevel #0 [list $w invoke]

}

}

# Shared routines

##################

# The procedure below is called when a button is invoked through

# the keyboard. It simulate a press of the button via the mouse.

#

# Arguments:

# w - The name of the widget.

if {[string compare [$w cget -state] "disabled"]} {

set oldRelief [$w cget -relief]

set oldState [$w cget -state]

}

}

#

# Invoke an auto-repeating button, and set it up to continue to repeat.

#

# None.

#

# Side effects:

set delay [$w cget -repeatinterval]

uplevel #0 [list $w invoke]

}

if {$delay > 0} {

}

}

# The procedure below is invoked when the mouse button is pressed in

# a checkbutton or radiobutton widget, or when the widget is invoked

# through the keyboard. It invokes the widget if it

# w - The name of the widget.

# cmd - The subcommand to invoke (one of invoke, select, or deselect).

if {[string compare [$w cget -state] "disabled"]} {

uplevel #0 [list $w $cmd]

}

# Copyright (c) 1998-2000 by Scriptics Corporation.

# All rights reserved.

#

# Make sure the tk::dialog namespace, in which all dialogs should live, exists

namespace eval ::tk::dialog {}

namespace eval ::tk::dialog::file::chooseDir {

}

#

# Implements the TK directory selection dialog.

#

# Arguments:

# args Options parsed by the procedure.

#

set dataName __tk_choosedir

upvar ::tk::dialog::file::$dataName data

::tk::dialog::file::chooseDir::Config $dataName $args

# may take the focus away so we can't redirect it. Finally,

# restore any grab that was in effect.

::tk::RestoreFocusGrab $w $data(ent) withdraw

# Return value to user

#

}

# ::tk::dialog::file::chooseDir::Config --

# 4b. If the value is different from the current directory, change to

# that directory.

if { [llength $selection] != 0 } {

set iconText [file join $data(selectPath) $iconText]

::tk::dialog::file::chooseDir::Done $w $iconText

} else {

proc ::tk::dialog::file::chooseDir::DblClick {w} {

upvar ::tk::dialog::file::[winfo name $w] data

if { [llength $selection] != 0 } {

set file $data(selectPath)

if {[file isdirectory $file]} {

::tk::dialog::file::ListInvoke $w $text

#

# Gets called when user has input a valid filename. Pops up a

# dialog box to confirm selection when necessary. Sets the

# loop in tk_chooseDirectory and return the selected filename to the

# script that calls tk_getOpenFile or tk_getSaveFile

#

proc ::tk::dialog::file::chooseDir::Done {w {selectFilePath ""}} {

upvar ::tk::dialog::file::[winfo name $w] data

if {[string equal $selectFilePath ""]} {

set selectFilePath $data(selectPath)

return

}

}

}

# Color selection dialog for platforms that do not support a

# standard color selection dialog.

#

#

# Copyright (c) 1996 Sun Microsystems, Inc.

#

# (2): Implement HSV color selection.

#

#

# Create a color dialog and let the user choose a color. This function

# should not be called directly. It is called by the tk_chooseColor

# function when a native color selector widget does not exist

#

# The lines variables track the start and end indices of the line

# elements in the colorbar canvases.

# selection rectangle at the bottom of the color bar. No restrictions.

set data(PLGN_WIDTH) 10

set sc [winfo screen $data(-parent)]

set winExists [winfo exists $w]

if {$winExists} {

destroy $w

}

}

wm transient $w $data(-parent)

# may take the focus away so we can't redirect it. Finally,

# restore any grab that was in effect.

::tk::RestoreFocusGrab $w $data(okBtn)

unset data

}

#

# Get called during initialization or when user resets NUM_COLORBARS

#

# IntensityIncr is the difference in color intensity between a colorbar

# and its neighbors.

set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}]

}

#

# Parses the command line arguments to tk_chooseColor

#

# 1: the configuration specs

#

} else {

set defaultColor [. cget -background]

}

# 2: parse the arguments

#

if {[string equal $data(-title) ""]} {

set data(-title) " "

}

}

#

# Build the dialog.

#

# TopFrame contains the color strips and the color selection

#

set box [frame $f.box]

label $box.label -text $l: -width $maxWidth -under 0 -anchor ne

pack $box.label -side left -fill y -padx 2 -pady 3

pack $box.entry -side left -anchor n -pady 0

pack $box -side left -fill both

set data($color,sel) $f.sel

bind $data($color,col) <Configure> \

bind $data($color,col) <Enter> \

bind $data($color,col) <Leave> \

bind $data($color,sel) <Enter> \

bind $data($color,sel) <Leave> \

}

pack $stripsFrame -side left -fill both -padx 4 -pady 10

set selFrame [frame $topFrame.sel]

set lab [label $selFrame.lab -text [::msgcat::mc "Selection:"] \

-under 0 -anchor sw]

-width 16]

set f1 [frame $selFrame.f1 -relief sunken -bd 2]

set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70]

pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10

pack $data(finalCanvas) -expand yes -fill both

pack $selFrame -side left -fill none -anchor nw

pack $topFrame -side top -expand yes -fill both -anchor nw

set maxWidth [expr {$maxWidth<8?8:$maxWidth}]

button $botFrame.ok -text [::msgcat::mc "OK"] \

-width $maxWidth -under 0 \

button $botFrame.cancel -text [::msgcat::mc "Cancel"] \

-width $maxWidth -under 0 \

set data(okBtn) $botFrame.ok

set data(cancelBtn) $botFrame.cancel

bind $w <Alt-g> [list focus $data(green,entry)]

bind $w <Alt-b> [list focus $data(blue,entry)]

bind $w <Alt-s> [list focus $ent]

}

#

# Sets the current selection of the dialog box

#

set data(red,intensity) [lindex $color 0]

set data(green,intensity) [lindex $color 1]

set data(blue,intensity) [lindex $color 2]

# Now compute the new x value of each colorbars pointer polygon

foreach color [list red green blue ] {

}

}

#

# Converts a screen coordinate to intensity

#

return [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}]

}

#

# Converts an intensity to screen coordinate.

#

return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}]

}

#

# Draw color scale is called whenever the size of one of the color

# scale canvases is changed.

#

# col: color bar canvas

# sel: selector canvas

}

# Draw the selection polygons

$sel bind $data($c,index) <ButtonPress-1> \

$sel bind $data($c,index) <B1-Motion> \

$sel bind $data($c,index) <ButtonRelease-1> \

set height [winfo height $col]

# Create an invisible region under the colorstrip to catch mouse clicks

$data(canvasWidth) $height -fill {} -outline {}]

bind $col <ButtonPress-1> \

bind $col <B1-Motion> \

bind $col <ButtonRelease-1> \

$sel bind $data($c,clickRegion) <ButtonPress-1> \

$sel bind $data($c,clickRegion) <B1-Motion> \

$sel bind $data($c,clickRegion) <ButtonRelease-1> \

} else {

# l is the canvas index of the first colorbar.

set l $data(lines,$c,start)

set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}]

}

}

#

# Creates and draws the selector polygon at the position

# $data($c,intensity).

#

set data($c,index) [$sel create polygon \

0 $data(PLGN_HEIGHT) \

$data(PLGN_WIDTH) $data(PLGN_HEIGHT) \

$data(indent) 0]

$sel move $data($c,index) $data($c,x) 0

}

#

# Combines the intensities of the three colors into the final color

#

set color [format "#%02x%02x%02x" $data(red,intensity) \

$data(green,intensity) $data(blue,intensity)]

$data(blue,intensity)]

}

#

# Only redraws the colors on the color strips that were not manipulated.

# Params: color of colorstrip that changed. If color is not [red|green|blue]

# Then all colorstrips will be updated

#

switch $colorChanged {

red {

}

green {

}

blue {

}

default {

}

}

}

#----------------------------------------------------------------------

# Event handlers

#----------------------------------------------------------------------

#

# Handles a mousedown button event over the selector polygon.

# Adds the bindings for moving the mouse while the button is

#

# Params: sel is the selector canvas window, color is the color of the strip.

#

if {!$dontMove} {

}

}

#

# Moves the polygon selector so that its middle point has the same

# x value as the specified x. If x is outside the bounds [0,255],

# Params: sel is the selector canvas, c is [red|green|blue]

# x is a x-coordinate.

#

incr x -$delta

return $x

}

#

# Removes mouse tracking bindings, updates the colorbars.

#

# Params: sel is the selector canvas, color is the color of the strip,

# x is the x-coord of the mouse.

#

# Determine exactly what color we are looking at.

}

#

# Completely redraws the colorbars, including resizing the

# colorstrips

#

if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) ||

(($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} {

set data(BARS_WIDTH) $data(NUM_COLORBARS)

}

foreach color [list red green blue ] {

$data($color,col) configure -width $data(canvasWidth)

}

}

#

# Handles the return keypress event in the "Selection:" entry

#

set text [string trim $data(selection)]

# Check to make sure that the color is valid

set G [expr {[lindex $color 1]/0x100}]

set B [expr {[lindex $color 2]/0x100}]

set data(selection) $text

}

#

# Handles the return keypress event in the R, G or B entry

#

foreach c [list red green blue] {

if {[catch {

}

}

$data(green,intensity) $data(blue,intensity)"

}

# mouse cursor enters a color bar

#

$data($color,sel) itemconfig $data($color,index) -fill red

}

# mouse leaves enters a color bar

#

$data($color,sel) itemconfig $data($color,index) -fill black

}

# user hits OK button

#

}

# user hits Cancel button

#

}

# Some functions needed for the common dialog boxes. Probably need to go

# in a different file.

#

#

# Copyright (c) 1996 Sun Microsystems, Inc.

#

#----------------------------------------------------------------------

#

# Create a focus group. All the widgets in a focus group must be

# within the same focus toplevel. Each toplevel can have only

# one focus group, which is identified by the name of the

# toplevel widget.

#

if {[string compare [winfo toplevel $t] $t]} {

error "$t is not a toplevel window"

}

}

}

#

# Add a widget into the "FocusIn" list of the focus group. The $cmd will be

# called when the widget is focused on by the user.

#

error "focus group \"$t\" doesn't exist"

}

}

#

# Add a widget into the "FocusOut" list of the focus group. The

# $cmd will be called when the widget loses the focus (User

# types Tab or click on another widget).

#

error "focus group \"$t\" doesn't exist"

}

}

#

# Cleans up when members of the focus group is deleted, or when the

# toplevel itself gets deleted.

#

if {[string equal $t $w]} {

}

}

} else {

}

catch {

}

catch {

}

}

}

#

# Handles the <FocusIn> event. Calls the FocusIn command for the newly

# focused widget in the focus group.

#

if {[string compare $detail NotifyNonlinear] && \

[string compare $detail NotifyNonlinearVirtual]} {

# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).

return

}

return

}

return

}

# This is already in focus

#

return

} else {

}

}

#

# Handles the <FocusOut> event. Checks if this is really a lose

# focus event, not one generated by the mouse moving out of the

# toplevel window. Calls the FocusOut command for the widget

# who loses its focus.

#

if {[string compare $detail NotifyNonlinear] && \

[string compare $detail NotifyNonlinearVirtual]} {

# This is caused by mouse moving out of the window

return

}

return

}

return

} else {

}

}

#

# Process the string given by the -filetypes option of the file

# dialogs. Similar to the C function TkGetFileFilters() on the Mac

# and Windows platform.

#

foreach t $string {

if {[llength $t] < 2 || [llength $t] > 3} {

error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""

# can be used by non-unix systems that do not have built-in support

# for shells.

#

#

# Copyright (c) 1995-1997 Sun Microsystems, Inc.

# Copyright (c) 1998-2000 Ajuba Solutions.

# TODO: history - remember partially written command

# This procedure constructs and configures the console windows.

#

# Arguments:

# None.

global tcl_platform

if {![consoleinterp eval {set tcl_interactive}]} {

menu .menubar.file -tearoff 0

.menubar.file add command -label [::msgcat::mc "Source..."] \

.menubar.file add command -label [::msgcat::mc "Hide Console"] \

-underline 0 -command {wm withdraw .}

if {[string compare $tcl_platform(platform) "macintosh"]} {

.menubar add cascade -label Help -menu .menubar.help -underline 0

menu .menubar.help -tearoff 0

.menubar.help add command -label [::msgcat::mc "About..."] \

}

. configure -menu .menubar

}

}

.console tag configure stderr -foreground red

.console tag configure stdin -foreground blue

wm title . [::msgcat::mc "Console"]

flush stdout

.console mark set output [.console index "end - 1 char"]

.console mark set promptEnd insert

.console mark gravity promptEnd left

}

#

# Prompts the user for a file to source in the main interpreter.

#

# Arguments:

# None.

set filename [tk_getOpenFile -defaultextension .tcl -parent . \

-title [::msgcat::mc "Select a file to source"] \

-filetypes [list \

if {[string compare $filename ""]} {

set cmd [list source $filename]

if {[catch {consoleinterp eval $cmd} result]} {

}

}

}

# Processes the command line input. If the command is complete it

# is evaled in the main interpreter. Otherwise, the continuation

# prompt is added and more input may be added.

# Arguments:

# None.

set ranges [.console tag ranges input]

set cmd ""

if {[llength $ranges]} {

}

}

if {[string equal $cmd ""]} {

} elseif {[info complete $cmd]} {

.console mark set output end

.console tag delete input

if {[string compare $result ""]} {

puts $result

}

} else {

}

.console yview -pickplace insert

}

# This procedure implements command line history for the

# console. In general is evals the history command in the

#

# Arguments:

# cmd - Which action to take: prev, next, reset.

switch $cmd {

prev {

set cmd {history event [expr {[history nextid] -1}]}

} else {

}

if {[catch {consoleinterp eval $cmd} cmd]} {

return

}

.console delete promptEnd end

.console insert promptEnd $cmd {input stdin}

}

next {

set cmd {history event [expr {[history nextid] -1}]}

set cmd ""

} else {

}

if {[string compare $cmd ""]} {

catch {consoleinterp eval $cmd} cmd

.console insert promptEnd $cmd {input stdin}

}

reset {

}

}

}

# This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2

# exists in the main interpreter it will be called to generate the

# prompt. Otherwise, a hard coded default prompt is printed.

# Arguments:

# partial - Flag to specify which prompt to print.

if {[string equal $partial "normal"]} {

set temp [.console index "end - 1 char"]

.console mark set output end

}

flush stdout

.console mark set output $temp

.console mark set promptEnd insert

.console mark gravity promptEnd left

}

# This procedure first ensures that the default bindings for the Text

# class have been defined. Then certain bindings are overridden for

# the class.

# Arguments:

# None.

bindtags $win "$win Text . all"

# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.

bind $win <KP_Enter> {# nothing}

bind $win <Tab> {

focus %W

break

}

bind $win <Return> {

%W mark set insert {end - 1c}

break

}

bind $win <Delete> {

foreach left {Control-a Home} {

bind $win <$left> {

if {[%W compare insert < promptEnd]} {

} else {

}

break

}

}

foreach right {Control-e End} {

bind $win <$right> {

break

}

}

}

foreach prev {Control-p Up} {

bind $win <$prev> {

break

}

}

foreach prev {Control-n Down} {

bind $win <$prev> {

break

}

}

bind $win <Insert> {

break

}

bind $win <KeyPress> {

break

}

foreach left {Control-b Left} {

if {[%W compare insert == promptEnd]} {

break

}

break

}

}

foreach right {Control-f Right} {

bind $win <$right> {

break

}

}

catch {

set clip [::tk::GetSelection %W CLIPBOARD]

set list [split $clip \n\r]

foreach x [lrange $list 1 end] {

%W mark set insert {end - 1c}

}

}

break

}

}

# Insert a string into a text at the point of the insertion cursor.

# If there is a selection in the text, and it covers the point of the

# insertion cursor, then delete the selection before inserting. Insertion

# w - The text window in which to insert the string

# s - The string to insert (usually just a single character)

if {[string equal $s ""]} {

return

}

$w see insert

}

#

# This routine is called directly by ConsolePutsCmd to cause a string

# to be displayed in the console.

# dest - The output tag to be used: either "stderr" or "stdout".

# string - The string to be displayed.

.console insert output $string $dest

.console see insert

}

#

# This routine is called by ConsoleEventProc when the main window of

# the application is destroyed. Don't call exit - that probably already

# Arguments:

# None.

destroy .

}

#

# This routine displays an About box to show Tcl/Tk version info.

#

# Arguments:

# None.

global tk_patchLevel

tk_messageBox -type ok -message "[::msgcat::mc {Tcl for Windows}]

Copyright \251 2000 Ajuba Solutions

# now initialize the console

# This file defines the procedure tk_dialog, which creates a dialog

# box containing a bitmap, a message, and one or more buttons.

#

#

# Copyright (c) 1992-1993 The Regents of the University of California.

# Copyright (c) 1994-1997 Sun Microsystems, Inc.

#

#

#

# This procedure displays a dialog box, waits for a button in the dialog

# to be invoked, then returns the index of the selected button. If the

# args - One or more strings to display in buttons across the

# bottom of the dialog box.

# Check that $default was properly given

if {[string is int $default]} {

set i 0

foreach but $args {

if {$i == $default} {

$w.button$i configure -default active

} else {

[list $w.button$default] configure -state active -relief sunken

update idletasks

after 100

"

}

# button variable to -1; this is needed in case something happens

# that destroys the window, such as its parent window being destroyed.

# 6. Withdraw the window, then update all the geometry information

# so we know how big it wants to be, then center the window in the

# may take the focus away so we can't redirect it. Finally,

# restore any grab that was in effect.

catch {focus $oldFocus}

catch {

# It's possible that the window has already been destroyed,

# hence this "catch". Delete the Destroy handler so that

bind $w <Destroy> {}

destroy $w

grab -global $oldGrab

}

}

}

# This file defines the default bindings for Tk entry widgets and provides

# procedures that help in implementing those bindings.

#

#

# Copyright (c) 1992-1994 The Regents of the University of California.

# Copyright (c) 1994-1997 Sun Microsystems, Inc.

#

#-------------------------------------------------------------------------

#

# afterId - If non-null, it means that auto-scanning is underway

# and it gives the "after" id for the next auto-scan

# The code below creates the default class bindings for entries.

#-------------------------------------------------------------------------

bind Entry <<Cut>> {

clipboard clear -displayof %W

%W delete sel.first sel.last

}

}

bind Entry <<Copy>> {

clipboard clear -displayof %W

}

}

bind Entry <<Paste>> {

}

}

%W insert insert [::tk::GetSelection %W CLIPBOARD]

}

}

bind Entry <<Clear>> {

%W delete sel.first sel.last

}

bind Entry <<PasteSelection>> {

}

}

# Standard Motif bindings:

bind Entry <1> {

%W selection clear

}

bind Entry <B1-Motion> {

}

bind Entry <Double-1> {

catch {%W icursor sel.first}

}

bind Entry <Triple-1> {

%W icursor 0

}

bind Entry <Shift-1> {

%W selection adjust @%x

}

bind Entry <Double-Shift-1> {

}

bind Entry <Triple-Shift-1> {

}

bind Entry <B1-Leave> {

}

bind Entry <B1-Enter> {

}

bind Entry <ButtonRelease-1> {

}

bind Entry <Control-1> {

%W icursor @%x

}

bind Entry <Left> {

}

bind Entry <Right> {

}

bind Entry <Shift-Left> {

}

bind Entry <Shift-Right> {

}

bind Entry <Control-Left> {

}

bind Entry <Control-Right> {

}

bind Entry <Shift-Control-Left> {

}

bind Entry <Shift-Control-Right> {

}

bind Entry <Home> {

}

bind Entry <Shift-Home> {

}

bind Entry <End> {

}

bind Entry <Shift-End> {

}

bind Entry <Delete> {

}

}

bind Entry <BackSpace> {

}

bind Entry <Control-space> {

%W selection clear

}

bind Entry <KeyPress> {

}

# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.

# generates the <<Paste>> event, so we don't need to do anything here.

if {[string compare $tcl_platform(platform) "windows"]} {

bind Entry <Insert> {

}

}

bind Entry <Control-a> {

if {!$tk_strictMotif} {

}

}

bind Entry <Control-b> {

if {!$tk_strictMotif} {

}

}

bind Entry <Control-d> {

}

bind Entry <Control-e> {

if {!$tk_strictMotif} {

}

}

bind Entry <Control-f> {

if {!$tk_strictMotif} {

}

}

bind Entry <Control-h> {

if {!$tk_strictMotif} {

}

}

bind Entry <Control-k> {

}

bind Entry <Control-t> {

if {!$tk_strictMotif} {

}

}

bind Entry <Meta-b> {

if {!$tk_strictMotif} {

}

}

bind Entry <Meta-d> {

if {!$tk_strictMotif} {

}

}

bind Entry <Meta-f> {

if {!$tk_strictMotif} {

}

}

bind Entry <Meta-BackSpace> {

if {!$tk_strictMotif} {

}

}

bind Entry <Meta-Delete> {

if {!$tk_strictMotif} {

}

}

bind Entry <2> {

if {!$tk_strictMotif} {

%W scan mark %x

}

}

bind Entry <B2-Motion> {

if {!$tk_strictMotif} {

}

%W scan dragto %x

}

}

# Given x and y coordinates, this procedure finds the closest boundary

# between characters to the given coordinates and returns the index

# of the character just after the boundary.

# w - The entry window.

# x - X-coordinate within the window.

set pos [$w index @$x]

set bbox [$w bbox $pos]

if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {

incr pos

}

# This procedure is invoked to handle button-1 presses in entry

# widgets. It moves the insertion cursor, sets the selection anchor,

# and claims the input focus.

# w - The entry window in which the button was pressed.

# x - The x-coordinate of the button press.

$w selection from insert

if {[string compare "disabled" [$w cget -state]]} {focus $w}

}

# This procedure is invoked when dragging out a selection with

# the mouse. Depending on the selection mode (character, word,

# line) it selects in different-sized units. This procedure

# w - The entry window in which the button was pressed.

# x - The x-coordinate of the mouse.

set anchor [$w index anchor]

}

char {

if {$cur < $anchor} {

$w selection range $cur $anchor

} elseif {$cur > $anchor} {

$w selection range 0 end

}

}

$w icursor $cur

}

update idletasks

}

# This procedure sets the insertion cursor to the current mouse position,

# pastes the selection there, and sets the focus to the window.

#

# w - The entry window.

# x - X position of the mouse.

catch {$w insert insert [::tk::GetSelection $w PRIMARY]}

if {[string compare "disabled" [$w cget -state]]} {focus $w}

}

# This procedure is invoked when the mouse leaves an entry window

# with button 1 down. It scrolls the window left or right,

# depending on where the mouse is, and reschedules itself as an

# Arguments:

# w - The entry window.

if {![winfo exists $w]} return

if {$x >= [winfo width $w]} {

$w xview scroll 2 units

} elseif {$x < 0} {

$w xview scroll -2 units

}

}

# 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.

# new - A new position for the insertion cursor (the cursor hasn't

# actually been moved to this position yet).

if {![$w selection present]} {

$w selection from insert

$w selection to $new

$w icursor $new

}

# 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.

# w - The entry window in which to insert the string

# s - The string to insert (usually just a single character)

if {[string equal $s ""]} {

return

}

}

}

$w insert insert $s

}

# 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.

if {[$w selection present]} {

$w delete sel.first sel.last

} else {

}

}

# 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.

set c [$w index insert]

if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {

$w xview $c

}

}

# 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.

# w - The entry window.

# pos - The desired new position for the cursor in the window.

$w icursor $pos

$w selection clear

}

# 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

# Arguments:

# w - The entry window.

set i [$w index insert]

if {$i < [$w index end]} {

incr i

set new [string index [$w get] [expr {$i-1}]][string index [$w get] $first]

$w delete $first $i

$w insert insert $new

}

# Returns the index of the next word position after a given position in the

# entry. The next word is platform dependent and may be either the next

# end-of-word position or the next start-of-word position after the next

# start - Position at which to start search.

if {[string equal $tcl_platform(platform) "windows"]} {

set pos [tcl_endOfWord [$w get] [$w index $start]]

if {$pos >= 0} {

set pos [tcl_startOfNextWord [$w get] $pos]

return $pos

}

} else {

set pos [tcl_endOfWord [$w get] [$w index $start]]

if {$pos < 0} {

return end

}

}

#

# Returns the index of the previous word position before a given

# position in the entry.

# w - The entry window in which the cursor is to move.

# start - Position at which to start search.

set pos [tcl_startOfPreviousWord [$w get] [$w index $start]]

if {$pos < 0} {

return 0

}

return $pos

}

#

# Returns the selected text of the entry with respect to the -show option.

#

# Arguments:

# w - The entry window from which the text to get

set entryString [string range [$w get] [$w index sel.first] \

[expr {[$w index sel.last] - 1}]]

if {[string compare [$w cget -show] ""]} {

# This file defines several procedures for managing the input

# focus.

#

#

# Copyright (c) 1994-1995 Sun Microsystems, Inc.

#

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

# This procedure returns the name of the next window after "w" in

# "focus order" (the window that should receive the focus next if

# Tab is typed in w). "Next" is defined by a pre-order search

# Arguments:

# w - Name of a window.

set cur $w

while {1} {

set children [winfo children $parent]

set i [lsearch -exact $children $cur]

}

return $cur

}

}

}

# This procedure returns the name of the previous window before "w" in

# "focus order" (the window that should receive the focus next if

# Shift-Tab is typed in w). "Next" is defined by a pre-order search

# Arguments:

# w - Name of a window.

set cur $w

while {1} {

set i [llength $children]

}

set cur $parent

return $cur

}

}

}

#

# This procedure is invoked to decide whether or not to focus on

# a given window. It returns 1 if it's OK to focus on the window,

# Arguments:

# w - Name of a window.

set code [catch {$w cget -takefocus} value]

if {($code == 0) && ($value != "")} {

if {$value == 0} {

regexp Key|Focus "[bind $w] [bind [winfo class $w]]"

}

#

# If this procedure is invoked, Tk will enter "focus-follows-mouse"

# mode, where the focus is always on whatever window contains the

# Arguments:

# None.

set old [bind all <Enter>]

set script {

if {[string equal "%d" "NotifyAncestor"] \

|| [string equal "%d" "NotifyNonlinear"] \

|| [string equal "%d" "NotifyInferior"]} {

focus %W

}

}

# This file defines the default bindings for Tk listbox widgets

# and provides procedures that help in implementing those bindings.

#

#

# Copyright (c) 1994 The Regents of the University of California.

# Copyright (c) 1994-1995 Sun Microsystems, Inc.

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#--------------------------------------------------------------------------

#

# afterId - Token returned by "after" for autoscanning.

# listboxPrev - The last element to be selected or deselected

bind Listbox <1> {

if {[winfo exists %W]} {

}

}

}

bind Listbox <B1-Motion> {

}

bind Listbox <ButtonRelease-1> {

%W activate @%x,%y

}

bind Listbox <Shift-1> {

}

bind Listbox <Control-1> {

}

bind Listbox <B1-Leave> {

}

bind Listbox <B1-Enter> {

}

bind Listbox <Up> {

}

bind Listbox <Shift-Up> {

}

bind Listbox <Down> {

}

bind Listbox <Shift-Down> {

}

bind Listbox <Left> {

%W xview scroll -1 units

event generate %W <<ListboxSelect>>

}

bind Listbox <Shift-Control-Home> {

}

bind Listbox <Control-End> {

%W activate end

event generate %W <<ListboxSelect>>

}

bind Listbox <Shift-Control-End> {

}

bind Listbox <<Copy>> {

if {[string equal [selection own -displayof %W] "%W"]} {

}

}

bind Listbox <space> {

}

bind Listbox <Select> {

}

bind Listbox <Control-Shift-space> {

}

bind Listbox <Shift-Select> {

}

bind Listbox <Escape> {

}

bind Listbox <Control-slash> {

}

bind Listbox <Control-backslash> {

if {[string compare [%W cget -selectmode] "browse"]} {

}

}

#

# This procedure is typically invoked on button-1 presses. It begins

# the process of making a selection in the listbox. Its exact behavior

# el - The element for the selection operation (typically the

# one under the pointer). Must be in numerical form.

if {[string equal [$w cget -selectmode] "multiple"]} {

if {[$w selection includes $el]} {

$w selection clear $el

$w selection clear 0 end

$w selection set $el

$w selection anchor $el

}

event generate $w <<ListboxSelect>>

}

#

# This procedure is called to process mouse motion events while

# button 1 is down. It may move or extend the selection, depending

# w - The listbox widget.

# el - The element under the pointer (must be a number).

return

}

set anchor [$w index anchor]

browse {

$w selection clear 0 end

$w selection set $el

event generate $w <<ListboxSelect>>

}

extended {

if {[string equal {} $i]} {

set i $el

$w selection set $el

$w selection clear $i $el

$w selection clear anchor $el

}

}

while {($i < $el) && ($i < $anchor)} {

$w selection set $i

}

incr i

}

while {($i > $el) && ($i > $anchor)} {

$w selection set $i

}

incr i -1

}

event generate $w <<ListboxSelect>>

}

}

}

#

# This procedure is typically invoked on shift-button-1 presses. It

# begins the process of extending a selection in the listbox. Its

# el - The element for the selection operation (typically the

# one under the pointer). Must be in numerical form.

if {[string equal [$w cget -selectmode] "extended"]} {

if {[$w selection includes anchor]} {

} else {

# No selection yet; simulate the begin-select operation.

}

}

}

#

# This procedure is typically invoked on control-button-1 presses. It

# begins the process of toggling a selection in the listbox. Its

# el - The element for the selection operation (typically the

# one under the pointer). Must be in numerical form.

if {[string equal [$w cget -selectmode] "extended"]} {

$w selection anchor $el

if {[$w selection includes $el]} {

$w selection clear $el

}

}

# This procedure is invoked when the mouse leaves an entry window

# with button 1 down. It scrolls the window up, down, left, or

# right, depending on where the mouse left the window, and reschedules

# Arguments:

# w - The entry window.

if {![winfo exists $w]} return

if {$y >= [winfo height $w]} {

$w yview scroll 1 units

} elseif {$y < 0} {

} else {

return

}

}

#

# Moves the location cursor (active element) up or down by one element,

# and changes the selection if we're in browse or extended selection

# w - The listbox widget.

# amount - +1 to move down one item, -1 to move back one item.

$w activate [expr {[$w index active] + $amount}]

$w see active

switch [$w cget -selectmode] {

$w selection clear 0 end

$w selection set active

$w selection anchor active

event generate $w <<ListboxSelect>>

}

}

}

#

# Does nothing unless we're in extended selection mode; in this

# case it moves the location cursor (active element) up or down by

# w - The listbox widget.

# amount - +1 to move down one item, -1 to move back one item.

if {[string compare [$w cget -selectmode] "extended"]} {

return

}

set active [$w index active]

$w selection set $active

}

$w activate [expr {$active + $amount}]

$w see active

}

#

# This procedure is called for key-presses such as Shift-KEndData.

# If the selection mode isn't multiple or extend then it does nothing.

# w - The listbox widget.

# el - An integer element number.

set mode [$w cget -selectmode]

if {[string equal $mode "extended"]} {

$w activate $el

$w see $el

if {[$w selection includes anchor]} {

}

} elseif {[string equal $mode "multiple"]} {

$w activate $el

}

}

#

# This procedure is invoked to cancel an extended selection in

# progress. If there is an extended selection in progress, it

# Arguments:

# w - The listbox widget.

if {[string compare [$w cget -selectmode] "extended"]} {

return

}

set first [$w index anchor]

if { [string equal $last ""] } {

# Not actually doing any selection right now

return

}

$w selection clear $first $last

while {$first <= $last} {

$w selection set $first

}

incr first

event generate $w <<ListboxSelect>>

}

#

# This procedure is invoked to handle the "select all" operation.

# For single and browse mode, it just selects the active element.

# Arguments:

# w - The listbox widget.

set mode [$w cget -selectmode]

if {[string equal $mode "single"] || [string equal $mode "browse"]} {

$w selection clear 0 end

# It also implements keyboard traversal of menus and implements a few

# other utility procedures related to menus.

#

#

# Copyright (c) 1992-1994 The Regents of the University of California.

# Copyright (c) 1994-1997 Sun Microsystems, Inc.

#

#-------------------------------------------------------------------------

#

# cursor - Saves the -cursor option for the posted menubutton.

# focus - Saves the focus during a menu selection operation.

# Focus gets restored here when the menu is unposted.

# contains either an empty string or "-global" to

# indicate whether the old grab was a local one or

# a global one.

# can be used:

#

# 1. As a pulldown from a menubutton. In this style, the variable

# 2. As a torn-off menu copied from some other menu. In this style

# 3. As an option menu, triggered from an option menubutton. In this

# the top-level menu's type is "normal".

# the owning menubar, and the menu itself is of type "normal".

#

# The various binding procedures use the state described above to

bind Menubutton <FocusIn> {}

bind Menubutton <Enter> {

}

bind Menubutton <Leave> {

}

bind Menubutton <1> {

}

}

bind Menubutton <Motion> {

}

bind Menubutton <B1-Motion> {

}

bind Menubutton <ButtonRelease-1> {

}

bind Menubutton <space> {

}

# Must set focus when mouse enters a menu, in order to allow

bind Menu <FocusIn> {}

bind Menu <Enter> {

if {[string equal [%W cget -type] "tearoff"]} {

if {[string compare "%m" "NotifyUngrab"]} {

if {[string equal $tcl_platform(platform) "unix"]} {

}

}

}

}

bind Menu <Leave> {

}

bind Menu <Motion> {

}

bind Menu <ButtonPress> {

}

bind Menu <ButtonRelease> {

}

bind Menu <space> {

}

bind Menu <Return> {

}

bind Menu <Escape> {

}

bind Menu <Left> {

}

bind Menu <Right> {

}

bind Menu <Up> {

}

bind Menu <Down> {

}

bind Menu <KeyPress> {

}

# The following bindings apply to all windows, and are used to

if {[string equal $tcl_platform(platform) "unix"]} {

bind all <Alt-KeyPress> {

}

bind all <F10> {

}

} else {

bind Menubutton <Alt-KeyPress> {

}

bind Menubutton <F10> {

}

}

# This procedure is invoked when the mouse enters a menubutton

# widget. It activates the widget unless it is disabled. Note:

# this procedure is only invoked when mouse button 1 is *not* down.

#

# Arguments:

# w - The name of the widget.

}

if {[string compare [$w cget -state] "disabled"]} {

$w configure -state active

}

}

# This procedure is invoked when the mouse leaves a menubutton widget.

# It de-activates the widget, if the widget still exists.

#

# Arguments:

# w - The name of the widget.

if {![winfo exists $w]} {

return

}

}

}

# Given a menubutton, this procedure does all the work of posting

# its associated menu and unposting any other menu that is currently

# posted.

# option menus. If not specified, then the center

# of the menubutton is used for an option menu.

global tcl_platform

if {[string equal [$w cget -state] "disabled"] || \

return

}

set menu [$w cget -menu]

if {[string first $w $menu] != 0} {

error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"

}

if {[string compare $cur ""]} {

}

$w configure -cursor arrow

$w configure -relief raised

$menu activate none

# If this looks like an option menubutton then post the menu so

# that the current entry is on top of the mouse. Otherwise post

left {

set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]

set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]

if {[$w cget -indicatoron]} {

if {$entry == [$menu index last]} {

incr y [expr {-([$menu yposition $entry] \

$menu post $x $y

if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] "disabled"]} {

$menu activate $entry

}

}

right {

set x [expr {[winfo rootx $w] + [winfo width $w]}]

set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]

if {[$w cget -indicatoron]} {

if {$entry == [$menu index last]} {

incr y [expr {-([$menu yposition $entry] \

$menu post $x $y

if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] "disabled"]} {

$menu activate $entry

}

}

default {

set x [expr {[winfo rootx $w] + [winfo width $w]/2}]

set y [expr {[winfo rooty $w] + [winfo height $w]/2}]

}

} else {

$menu post [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]

}

# reflect the error.

set savedInfo $errorInfo

error $msg $savedInfo

}

if {$tearoff != 0} {

focus $menu

if {[winfo viewable $w]} {

grab -global $w

}

}

}

# This procedure unposts a given menu, plus all of its ancestors up

# to (and including) a menubutton, if any. It also restores various

# values to what they were before the menu was posted, and releases

# menu - Name of a menu to unpost. Ignored if there

# is a posted menubutton.

global tcl_platform

# Restore focus right away (otherwise X will take focus away when

# the menu is unmapped and under some window managers (e.g. olvwm)

# we'll lose the focus completely).

# Unpost menu(s) and restore some stuff that's dependent on

# what was posted.

if {[string compare $mb ""]} {

set menu [$mb cget -menu]

$menu unpost

} elseif {[string compare [$menu cget -type] "menubar"] \

&& [string compare [$menu cget -type] "tearoff"]} {

# We're in a cascaded sub-menu from a torn-off menu or popup.

}

$parent activate none

$parent postcascade none

set type [$parent cget -type]

if {[string equal $type "menubar"] || \

[string equal $type "tearoff"]} {

}

}

# Release grab, if any, and restore the previous grab, if there

# was one.

if {[string compare $menu ""]} {

grab release $grab

}

}

}

if {[string compare $tcl_platform(platform) "unix"]} {

}

}

}

# This procedure handles mouse motion events inside menubuttons, and

# also outside menubuttons when a menubutton has a grab (e.g. when a

# menu selection operation is in progress).

# it isn't.

# rootx, rooty - Coordinates of mouse, in (virtual?) root window.

return

}

set new [winfo containing $rootx $rooty]

&& ([string equal $new ""] \

|| [string equal [winfo toplevel $new] [winfo toplevel $w]])} {

}

if {[string compare $new ""] \

&& [string equal [winfo class $new] "Menubutton"] \

&& ([$new cget -indicatoron] == 0) \

&& ([$w cget -indicatoron] == 0)} {

if {[string equal $upDown "down"]} {

} else {

}

}

}

}

# This procedure is invoked to handle button 1 releases for menubuttons.

# If the release happens inside the menubutton then leave its menu

# posted with element 0 activated. Otherwise, unpost the menu.

# Arguments:

# w - The name of the menubutton widget.

global tcl_platform

set menu [$w cget -menu]

set tearoff [expr {[string equal $tcl_platform(platform) "unix"] || \

([string compare $menu {}] && \

[string equal [$menu cget -type] "tearoff"])}]

} else {

}

}

# This procedure is called to handle mouse motion events for menus.

# It does two things. First, it resets the active element in the

# menu, if the mouse is over the menu. Second, if a mouse button

# y - The y position of the mouse.

# state - Modifier state (tells whether buttons are down).

if {[string equal [$menu cget -type] "menubar"]} {

$menu activate @$x,$y

}

} else {

$menu activate @$x,$y

}

}

if {($state & 0x1f00) != 0} {

}

}

# Handles button presses in menus. There are a couple of tricky things

# here:

# 1. Change the posted cascade entry (if any) to match the mouse position.

# Arguments:

# menu - The menu window.

global tcl_platform

if {![winfo viewable $menu]} {

return

}

$menu postcascade active

} else {

while {[string equal [$menu cget -type] "normal"] \

&& [string equal [winfo class [winfo parent $menu]] "Menu"] \

set menu [winfo parent $menu]

}

$menu configure -cursor arrow

}

# anymore.

if {[string compare $menu [grab current $menu]]} {

}

# Must re-grab even if the grab window hasn't changed, in order

}

}

# This procedure is invoked to handle Leave events for a menu. It

# deactivates everything unless the active element is a cascade element

# and the mouse is now over the submenu.

# rootx, rooty - Root coordinates of mouse.

# state - Modifier state.

if {[string equal [$menu index active] "none"]} {

return

}

return

}

$menu activate none

}

# This procedure is invoked when button 1 is released over a menu.

# It invokes the appropriate menu action and unposts the menu if

# it came from a menubutton.

# buttonRelease - 1 means this procedure is called because of

# a button release; 0 means because of keystroke.

# Mouse was pressed over a menu without a menu button, then

# dragged off the menu (possibly with a cascade posted) and

# released. Unpost everything and quit.

$w postcascade none

$w activate none

event generate $w <<MenuSelect>>

return

}

if {[string equal [$w type active] "cascade"]} {

$w postcascade active

set menu [$w entrycget active -menu]

} elseif {[string equal [$w type active] "tearoff"]} {

} elseif {[string equal [$w cget -type] "menubar"]} {

$w postcascade none

set active [$w index active]

event generate $w <<MenuSelect>>

}

# If the active item is not a cascade, invoke it. This enables

# the use of checkbuttons/commands/etc. on menubars (which is legal,

uplevel #0 [list $w invoke $active]

}

} else {

uplevel #0 [list $w invoke active]

}

}

# This procedure is invoked for the Cancel (or Escape) key. It unposts

# the given menu and, if it is the top-level menu for a menu button,

# unposts the menu button as well.

# Arguments:

# menu - Name of the menu window.

set parent [winfo parent $menu]

if {[string compare [winfo class $parent] "Menu"]} {

} elseif {[string equal [$parent cget -type] "menubar"]} {

} else {

}

}

# The following routines handle arrow keys. Arrow keys behave

# differently depending on whether the menu is a menu bar or not.

if {[string equal [$menu cget -type] "menubar"]} {

} else {

}

}

if {[string equal [$menu cget -type] "menubar"]} {

} else {

}

}

if {[string equal [$menu cget -type] "menubar"]} {

} else {

}

}

if {[string equal [$menu cget -type] "menubar"]} {

} else {

}

}

# This procedure is invoked to handle "left" and "right" traversal

# motions in menus. It traverses to the next menu in a menu bar,

# or into or out of a cascaded menu.

# event.

# direction - Direction in which to move: "left" or "right"

# First handle traversals into and out of cascaded menus.

$menu postcascade active

set m2 [$menu entrycget active -menu]

if {[string compare $m2 ""]} {

}

return

} else {

if {[string equal [winfo class $parent] "Menu"] \

&& [string equal [$parent cget -type] "menubar"]} {

tk_menuSetFocus $parent

return

}

set parent [winfo parent $parent]

if {[string equal [winfo class $m2] "Menu"]} {

if {[string compare [$m2 cget -type] "menubar"]} {

$menu activate none

tk_menuSetFocus $m2

# This code unposts any posted submenu in the parent.

if {[string equal [winfo class $m2] "Menu"]} {

if {[string equal [$m2 cget -type] "menubar"]} {

tk_menuSetFocus $m2

return

}

}

if {[string equal $w ""]} {

return

}

}

incr i $count

}

}

# Activate the next higher or lower entry in the posted menu,

# wrapping around at the ends. Disabled entries are skipped.

#

# count - 1 means go to the next lower entry,

# -1 means go to the next higher entry.

if {[string equal [$menu index last] "none"]} {

return

incr quitAfter -1

}

$menu activate $i

if {[string equal [$menu type $i] "cascade"]} {

set cascade [$menu entrycget $i -menu]

if {[string compare $cascade ""]} {

# we traverse left/right in the menubar, but undesirable when

# we traverse up/down in a menu.

$menu postcascade $i

}

}

}

# This procedure searches the entire window hierarchy under w for

# a menubutton that isn't disabled and whose underlined character

# is "char" or an entry in a menubar that isn't disabled and whose

# may be either upper or lower case, and

# will match either upper or lower case.

set char [string tolower $char]

set windowlist [winfo child $w]

}

default {

if {[string compare $match ""]} {

return $match

}

return {}

}

# This procedure implements keyboard traversal of menus. Given an

# ASCII character "char", it looks for a menubutton with that character

# underlined. If one is found, it posts the menubutton's menu

# is ignored. If an empty string, nothing

# happens.

if {[string equal $char ""]} {

return

}

while {[string equal [winfo class $w] "Menu"]} {

if {[string compare [$w cget -type] "menubar"] \

return

}

if {[string equal [$w cget -type] "menubar"]} {

}

set w [winfo parent $w]

}

if {[string compare $w ""]} {

if {[string equal [winfo class $w] "Menu"]} {

tk_menuSetFocus $w

grab -global $w

} else {

}

}

}

# This procedure traverses to the first menubutton in the toplevel

# for a given window, and posts that menubutton's menu.

#

# w - Name of a window. Selects which toplevel

# to search for menubuttons.

if {[string compare $w ""]} {

if {[string equal [winfo class $w] "Menu"]} {

tk_menuSetFocus $w

grab -global $w

} else {

}

}

}

# This procedure implements keyboard traversal within a menu. It

# searches for an entry in the menu that has "char" underlined. If

# such an entry is found, it is invoked and the menu is unposted.

# ignored. If the string is empty then

# nothing happens.

if {[string equal $char ""]} {

return

}

event generate $w <<MenuSelect>>

set m2 [$w entrycget $i -menu]

if {[string compare $m2 ""]} {

}

} else {

uplevel #0 [list $w invoke $i]

}

return

}

}

# Given a menu, this procedure finds the first entry that isn't

# disabled or a tear-off or separator, and activates that entry.

# However, if there is already an active entry in the menu (e.g.,

# entry isn't changed. This procedure also sets the input focus

# to the menu.

#

# Arguments:

# menu - Name of the menu window (possibly empty).

if {[string equal $menu ""]} {

return

}

&& [string compare $state "disabled"] \

&& [string compare [$menu type $i] "tearoff"]} {

$menu activate $i

# Only post the cascade if the current menu is a menubar;

# otherwise, if the first entry of the cascade is a cascade,

# we can get an annoying cascading effect resulting in a bunch of

set cascade [$menu entrycget $i -menu]

if {[string compare $cascade ""]} {

$menu postcascade $i

}

}

return

}

}

# Given a menu and a text string, return the index of the menu entry

# that displays the string as its label. If there is no such entry,

# return an empty string. This procedure is tricky because some names

# menu - Name of the menu widget.

# s - String to look for.

set i ""

if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {

catch {set i [$menu index $s]}

return ""

}

# This procedure posts a given menu such that a given entry in the

# menu is centered over a given point in the root window. It also

# activates the given entry.

# If omitted or specified as {}, then the menu's

# upper-left corner goes at (x,y).

global tcl_platform

if {[string compare $entry {}]} {

if {[string compare $entry {}] \

&& [string compare [$menu entrycget $entry -state] "disabled"]} {

$menu activate $entry

}

}

# the state of any existing grab on the w's display.

#

# Arguments:

# w - Name of a window; used to select the display

# whose grab information is to be recorded.

}

}

# Restores the grab to what it was before TkSaveGrabInfo was called.

#

# Be careful restoring the old grab, since it's window may not

# be visible anymore.

catch {

} else {

}

}

}

}

}

focus $menu

}

return

}

event generate $menu <<MenuSelect>>

}

# This procedure pops up a menu and sets things up for traversing

# the menu and its submenus.

#

# If omitted or specified as {}, then menu's

# upper-left corner goes at (x,y).

global tcl_platform

}

if {[string equal $tcl_platform(platform) "unix"] \

&& [winfo viewable $menu]} {

grab -global $menu

tk_menuSetFocus $menu

}

}

# Implements messageboxes for platforms that do not have native

# messagebox support.

#

#

# Copyright (c) 1994-1997 Sun Microsystems, Inc.

#

0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,

0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"

#

# Pops up a messagebox with an application-supplied message with

# an icon and a list of buttons. This procedure will be called

#

# See the user documentation for details on what tk_messageBox does.

#

#

# The default value of the title is space (" ") not the empty string

set opts [list -text $capName]

}

if {[string equal $name $data(-default)]} {

$w.$name configure -default active

bind $w <Return> {

if {[string equal Button [winfo class %W]]} {

}

}

# may take the focus away so we can't redirect it. Finally,

# restore any grab that was in effect.

::tk::RestoreFocusGrab $w $focus

}

# This file defines the procedure tk_optionMenu, which creates

# an option button and its associated menu.

#

#

# Copyright (c) 1994 The Regents of the University of California.

# Copyright (c) 1994 Sun Microsystems, Inc.

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

# This procedure creates an option button named $w and an associated

# menu. Together they provide the functionality of Motif option menus:

# they can be used to select one of many values, and the current value

# firstValue - First of legal values for option (must be >= 1).

# args - Any number of additional values.

upvar #0 $varName var

if {![info exists var]} {

# This file contains procedures that change the color palette used

# by Tk.

#

#

# Copyright (c) 1995-1997 Sun Microsystems, Inc.

#

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

# Changes the default color scheme for a Tk application by setting

# default colors in the option database and by modifying all of the

# color options for existing widgets that have the default value.

# option names and values. The name for an option is the one used

# for the option database, such as activeForeground, not -activeforeground.

if {[winfo depth .] == 1} {

# Just return on monochrome displays, otherwise errors will occur

return

}

# Create an array that has the complete new palette. If some colors

# aren't specified, compute them from other colors that are specified.

# Walk the widget hierarchy, recoloring all existing windows.

# The option database must be set according to what we do here,

# but it breaks things if we set things in the database while

# option database changes that need to be made, and they

# need to be evalled here to take effect.

# We have to walk the whole widget tree instead of just

# of widgets that we don't currently know about, so we'll

# walk the whole hierarchy just in case.

catch {destroy .___tk_set_palette}

option add *$option $new($option) widgetDefault

}

# next time we change the options.

}

# This procedure changes the colors in a window and all of its

# descendants, according to information provided by the colors

# argument. This looks at the defaults provided by the option

# is named after a widget configuration option, and

# each value is the value for that option.

upvar $colors c

set result {}

foreach dbOption [array names c] {

}

}

foreach child [winfo children $w] {

}

return $result

}

# Given a color name, computes a new color value that darkens (or

# brightens) the given color by a given percent.

#

# percent: 50 means darken by 50%, 110 means brighten

# by 10%.

foreach {red green blue} [winfo rgb . $color] {

set red [expr {($red/256)*$percent/100}]

set green [expr {($green/256)*$percent/100}]

return [format "#%02x%02x%02x" $red $green $blue]

}

# Reset the Tk color palette to the old "bisque" colors.

#

# Arguments:

# None.

tk_setPalette activeBackground #e6ceb1 activeForeground black \

background #ffe4c4 disabledForeground #b0b0b0 foreground black \

highlightBackground #ffe4c4 highlightColor black \

# This file defines the default bindings for Tk scale widgets and provides

# procedures that help in implementing the bindings.

#

#

# Copyright (c) 1994 The Regents of the University of California.

# Copyright (c) 1994-1995 Sun Microsystems, Inc.

bind Scale <Enter> {

if {$tk_strictMotif} {

%W config -activebackground [%W cget -background]

}

}

bind Scale <Motion> {

}

bind Scale <Leave> {

if {$tk_strictMotif} {

}

if {[string equal [%W cget -state] "active"]} {

%W configure -state normal

}

}

bind Scale <1> {

}

bind Scale <B1-Motion> {

}

bind Scale <B1-Leave> { }

bind Scale <B1-Enter> { }

bind Scale <ButtonRelease-1> {

}

bind Scale <2> {

}

bind Scale <B2-Motion> {

}

bind Scale <B2-Leave> { }

bind Scale <B2-Enter> { }

bind Scale <ButtonRelease-2> {

}

bind Scale <Control-1> {

}

bind Scale <Up> {

}

bind Scale <Down> {

}

bind Scale <Left> {

}

bind Scale <Right> {

}

bind Scale <Control-Up> {

}

bind Scale <Control-Down> {

}

bind Scale <Control-Left> {

}

bind Scale <Control-Right> {

}

bind Scale <Home> {

%W set [%W cget -from]

%W set [%W cget -to]

}

# This procedure is invoked to check a given x-y position in the

# scale and activate the slider if the x-y position falls within

# the slider.

# w - The scale widget.

# x, y - Mouse coordinates.

if {[string equal [$w cget -state] "disabled"]} {

return

}

}

}

# This procedure is invoked when a button is pressed in a scale. It

# takes different actions depending on where the button was pressed.

#

# w - The scale widget.

# x, y - Mouse coordinates of button press.

set el [$w identify $x $y]

if {[string equal $el "trough1"]} {

} elseif {[string equal $el "trough2"]} {

} elseif {[string equal $el "slider"]} {

set coords [$w coords]

$w configure -sliderrelief sunken

}

}

# This procedure is called when the mouse is dragged with

# mouse button 1 down. If the drag started inside the slider

# (i.e. the scale is active) then the scale's value is adjusted

# w - The scale widget.

# x, y - Mouse coordinates.

return

}

}

# This procedure is called to end an interactive drag of the

# slider. It just marks the drag as over.

#

# Arguments:

# w - The scale widget.

$w configure -sliderrelief raised

}

# This procedure is invoked to increment the value of a scale and

# to set up auto-repeating of the action if that is desired. The

# way the value is incremented depends on the "dir" and "big"

# first action in an auto-repeat sequence, and "again"

# means this is the second repetition or later.

if {![winfo exists $w]} return

if {[string equal $big "big"]} {

set inc [$w cget -bigincrement]

$w set [expr {[$w get] + $inc}]

if {[string equal $repeat "again"]} {

} elseif {[string equal $repeat "initial"]} {

set delay [$w cget -repeatdelay]

if {$delay > 0} {

}

}

}

# This procedure handles button presses that are made with the Control

# key down. Depending on the mouse position, it adjusts the scale

# value to one end of the range or the other.

# w - The scale widget.

# x, y - Mouse coordinates where the button was pressed.

set el [$w identify $x $y]

if {[string equal $el "trough1"]} {

$w set [$w cget -from]

}

}

# This procedure is invoked when button 2 is pressed over a scale.

# It sets the value to correspond to the mouse position and starts

# a slider drag.

# w - The scrollbar widget.

# x, y - Mouse coordinates within the widget.

if {[string equal [$w cget -state] "disabled"]} {

return

}

$w configure -state active

$w set [$w get $x $y]

set coords "$x $y"

}

# This file defines the default bindings for Tk scrollbar widgets.

# It also provides procedures that help in implementing the bindings.

#

#

# Copyright (c) 1994 The Regents of the University of California.

# Copyright (c) 1994-1996 Sun Microsystems, Inc.

bind Scrollbar <Enter> {

if {$tk_strictMotif} {

%W config -activebackground [%W cget -background]

}

%W activate [%W identify %x %y]

# unknown reasons.

bind Scrollbar <Leave> {

}

%W activate {}

}

bind Scrollbar <1> {

}

bind Scrollbar <B1-Motion> {

}

bind Scrollbar <B1-B2-Motion> {

}

bind Scrollbar <ButtonRelease-1> {

}

bind Scrollbar <B1-Leave> {

# Prevents <Leave> binding from being invoked.

# Prevents <Enter> binding from being invoked.

}

bind Scrollbar <2> {

}

bind Scrollbar <B1-2> {

# Do nothing, since button 1 is already down.

# Do nothing, since button 2 is already down.

}

bind Scrollbar <B2-Motion> {

}

bind Scrollbar <ButtonRelease-2> {

}

bind Scrollbar <B1-ButtonRelease-2> {

# Do nothing: B1 release will handle it.

# Prevents <Enter> binding from being invoked.

}

bind Scrollbar <Control-1> {

}

bind Scrollbar <Control-2> {

}

bind Scrollbar <Up> {

}

bind Scrollbar <Down> {

}

bind Scrollbar <Control-Up> {

}

bind Scrollbar <Control-Down> {

}

bind Scrollbar <Left> {

}

bind Scrollbar <Right> {

}

bind Scrollbar <Control-Left> {

}

bind Scrollbar <Control-Right> {

}

bind Scrollbar <Prior> {

}

bind Scrollbar <Next> {

}

bind Scrollbar <Home> {

}

bind Scrollbar <End> {

}

}

# This procedure is invoked when a button is pressed in a scrollbar.

# It changes the way the scrollbar is displayed and takes actions

# depending on where the mouse is.

# w - The scrollbar widget.

# x, y - Mouse coordinates.

$w configure -activerelief sunken

set element [$w identify $x $y]

if {[string equal $element "slider"]} {

} else {

}

}

# This procedure is invoked when a button is released in a scrollbar.

# It cancels scans and auto-repeats that were in progress, and restores

# the way the active element is displayed.

# w - The scrollbar widget.

# x, y - Mouse coordinates.

# Avoid error due to spurious release events

$w activate [$w identify $x $y]

}

}

# This procedure is invoked when a button is pressed over the scrollbar.

# It invokes one of several scrolling actions depending on where in

# the scrollbar the button was pressed.

# first action in an auto-repeat sequence, and "again"

# means this is the second repetition or later.

if {![winfo exists $w]} return

switch -- $element {

default {return}

}

if {[string equal $repeat "again"]} {

} elseif {[string equal $repeat "initial"]} {

set delay [$w cget -repeatdelay]

if {$delay > 0} {

}

}

}

# This procedure is called to initiate a drag of the slider. It just

# remembers the starting position of the mouse and slider.

#

# w - The scrollbar widget.

# x, y - The mouse position at the start of the drag operation.

if {[string equal [$w cget -command] ""]} {

return

}

} elseif {$iv0 == 0} {

} else {

}

}

# This procedure is called for each mouse motion even when the slider

# is being dragged. It notifies the associated widget if we're not

# jump scrolling, and it just updates the scrollbar if we are jump

# w - The scrollbar widget.

# x, y - The current mouse position.

return

}

if {[$w cget -jump]} {

} else {

}

} else {

}

}

# This procedure is called to end an interactive drag of the slider.

# It scrolls the window if we're in jump mode, otherwise it does nothing.

#

# w - The scrollbar widget.

# x, y - The mouse position at the end of the drag operation.

return

}

if {[$w cget -jump]} {

}

}

# This procedure tells the scrollbar's associated widget to scroll up

# or down by a given number of units. It notifies the associated widget

# in different ways for old and new command syntaxes.

# horizontal, "v" for vertical, "hv" for both.

# amount - How many units to scroll: typically 1 or -1.

set cmd [$w cget -command]

if {[string equal $cmd ""] || ([string first \

[string index [$w cget -orient] 0] $orient] < 0)} {

}

}

# This procedure tells the scrollbar's associated widget to scroll up

# or down by a given number of screenfuls. It notifies the associated

# widget in different ways for old and new command syntaxes.

# horizontal, "v" for vertical, "hv" for both.

# amount - How many screens to scroll: typically 1 or -1.

set cmd [$w cget -command]

if {[string equal $cmd ""] || ([string first \

[string index [$w cget -orient] 0] $orient] < 0)} {

}

}

# This procedure tells the scrollbar's associated widget to scroll to

# a particular location, given by a fraction between 0 and 1. It notifies

# the associated widget in different ways for old and new command syntaxes.

# pos - A fraction between 0 and 1 indicating a desired position

# in the document.

set cmd [$w cget -command]

if {[string equal $cmd ""]} {

return

}

}

# Scroll to the top or bottom of the document, depending on the mouse

# position.

#

# w - The scrollbar widget.

# x, y - Mouse coordinates within the widget.

set element [$w identify $x $y]

if {[string match *1 $element]} {

} elseif {[string match *2 $element]} {

}

}

# This procedure is invoked when button 2 is pressed over a scrollbar.

# If the button is over the trough or slider, it sets the scrollbar to

# the mouse position and starts a slider drag. Otherwise it just

# w - The scrollbar widget.

# x, y - Mouse coordinates within the widget.

set element [$w identify $x $y]

if {[string match {arrow[12]} $element]} {

return

}

# Need the "update idletasks" below so that the widget calls us

# back to reset the actual scrollbar position before we start the

update idletasks

$w configure -activerelief sunken

$w activate slider

}