diff options
Diffstat (limited to 'tcl/library')
124 files changed, 0 insertions, 30175 deletions
diff --git a/tcl/library/bgerror.tcl b/tcl/library/bgerror.tcl deleted file mode 100644 index 1407b55c4bf..00000000000 --- a/tcl/library/bgerror.tcl +++ /dev/null @@ -1,292 +0,0 @@ -# bgerror.tcl -- -# -# Implementation of the bgerror procedure. It posts a dialog box with -# the error message and gives the user a chance to see a more detailed -# stack trace, and possible do something more interesting with that -# trace (like save it to a log). This is adapted from work done by -# Donal K. Fellows. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# All rights reserved. -# -# RCS: @(#) $Id$ -# $Id$ - -namespace eval ::tk { - namespace eval dialog { - namespace eval error { - namespace import ::tk::msgcat::* - namespace export bgerror - option add *ErrorDialog.function.text [mc "Save To Log"] \ - widgetDefault - option add *ErrorDialog.function.command [namespace code SaveToLog] - } - } -} - -proc ::tk::dialog::error::Return {} { - variable button - - .bgerrorDialog.ok configure -state active -relief sunken - update idletasks - after 100 - set button 0 -} - -proc ::tk::dialog::error::Details {} { - set w .bgerrorDialog - set caption [option get $w.function text {}] - set command [option get $w.function command {}] - if { ($caption eq "") || ($command eq "") } { - grid forget $w.function - } - $w.function configure -text $caption -command \ - "$command [list [.bgerrorDialog.top.info.text get 1.0 end]]" - grid $w.top.info - -sticky nsew -padx 3m -pady 3m -} - -proc ::tk::dialog::error::SaveToLog {text} { - if { $::tcl_platform(platform) eq "windows" } { - set allFiles *.* - } else { - set allFiles * - } - set types [list \ - [list [mc "Log Files"] .log] \ - [list [mc "Text Files"] .txt] \ - [list [mc "All Files"] $allFiles] \ - ] - set filename [tk_getSaveFile -title [mc "Select Log File"] \ - -filetypes $types -defaultextension .log -parent .bgerrorDialog] - if {![string length $filename]} { - return - } - set f [open $filename w] - puts -nonewline $f $text - close $f -} - -proc ::tk::dialog::error::Destroy {w} { - if {$w eq ".bgerrorDialog"} { - variable button - set button -1 - } -} - -# ::tk::dialog::error::bgerror -- -# 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 -# trace. -# Arguments: -# err - The error message. - -proc ::tk::dialog::error::bgerror err { - global errorInfo tcl_platform - variable button - - set info $errorInfo - - set ret [catch {::tkerror $err} msg]; - if {$ret != 1} {return -code $ret $msg} - - # Ok the application's tkerror either failed or was not found - # we use the default dialog then : - if {($tcl_platform(platform) eq "macintosh") - || ([tk windowingsystem] eq "aqua")} { - set ok [mc Ok] - set messageFont system - set textRelief flat - set textHilight 0 - } else { - set ok [mc OK] - set messageFont {Times -18} - set textRelief sunken - set textHilight 1 - } - - - # Truncate the message if it is too wide (longer than 30 characacters) or - # too tall (more than 4 newlines). Truncation occurs at the first point at - # which one of those conditions is met. - set displayedErr "" - set lines 0 - foreach line [split $err \n] { - if { [string length $line] > 30 } { - append displayedErr "[string range $line 0 29]..." - break - } - if { $lines > 4 } { - append displayedErr "..." - break - } else { - append displayedErr "${line}\n" - } - incr lines - } - - set w .bgerrorDialog - set title [mc "Application Error"] - set text [mc {Error: %1$s} $err] - set buttons [list ok $ok dismiss [mc "Skip Messages"] \ - function [mc "Details >>"]] - - # 1. Create the top-level window and divide it into top - # and bottom parts. - - catch {destroy .bgerrorDialog} - toplevel .bgerrorDialog -class ErrorDialog - wm title .bgerrorDialog $title - wm iconname .bgerrorDialog ErrorDialog - wm protocol .bgerrorDialog WM_DELETE_WINDOW { } - - if {($tcl_platform(platform) eq "macintosh") - || ([tk windowingsystem] eq "aqua")} { - ::tk::unsupported::MacWindowStyle style .bgerrorDialog dBoxProc - } - - frame .bgerrorDialog.bot - frame .bgerrorDialog.top - if {[tk windowingsystem] eq "x11"} { - .bgerrorDialog.bot configure -relief raised -bd 1 - .bgerrorDialog.top configure -relief raised -bd 1 - } - pack .bgerrorDialog.bot -side bottom -fill both - pack .bgerrorDialog.top -side top -fill both -expand 1 - - set W [frame $w.top.info] - text $W.text \ - -bd 2 \ - -yscrollcommand [list $W.scroll set]\ - -setgrid true \ - -width 40 \ - -height 10 \ - -state normal \ - -relief $textRelief \ - -highlightthickness $textHilight \ - -wrap char - - scrollbar $W.scroll -relief sunken -command [list $W.text yview] - pack $W.scroll -side right -fill y - pack $W.text -side left -expand yes -fill both - $W.text insert 0.0 "$err\n$info" - $W.text mark set insert 0.0 - bind $W.text <ButtonPress-1> { focus %W } - $W.text configure -state disabled - - # 2. Fill the top part with bitmap and message - - # Max-width of message is the width of the screen... - set wrapwidth [winfo screenwidth .bgerrorDialog] - # ...minus the width of the icon, padding and a fudge factor for - # the window manager decorations and aesthetics. - set wrapwidth [expr {$wrapwidth-60-[winfo pixels .bgerrorDialog 9m]}] - label .bgerrorDialog.msg -justify left -text $text -font $messageFont \ - -wraplength $wrapwidth - if {($tcl_platform(platform) eq "macintosh") - || ([tk windowingsystem] eq "aqua")} { - # On the Macintosh, use the stop bitmap - label .bgerrorDialog.bitmap -bitmap stop - } else { - # On other platforms, make the error icon - canvas .bgerrorDialog.bitmap -width 32 -height 32 -highlightthickness 0 - .bgerrorDialog.bitmap create oval 0 0 31 31 -fill red -outline black - .bgerrorDialog.bitmap create line 9 9 23 23 -fill white -width 4 - .bgerrorDialog.bitmap create line 9 23 23 9 -fill white -width 4 - } - grid .bgerrorDialog.bitmap .bgerrorDialog.msg \ - -in .bgerrorDialog.top \ - -row 0 \ - -padx 3m \ - -pady 3m - grid configure .bgerrorDialog.msg -sticky nsw -padx {0 3m} - grid rowconfigure .bgerrorDialog.top 1 -weight 1 - grid columnconfigure .bgerrorDialog.top 1 -weight 1 - - # 3. Create a row of buttons at the bottom of the dialog. - - set i 0 - foreach {name caption} $buttons { - button .bgerrorDialog.$name \ - -text $caption \ - -default normal \ - -command [namespace code "set button $i"] - grid .bgerrorDialog.$name \ - -in .bgerrorDialog.bot \ - -column $i \ - -row 0 \ - -sticky ew \ - -padx 10 - grid columnconfigure .bgerrorDialog.bot $i -weight 1 - # We boost the size of some Mac buttons for l&f - if {($tcl_platform(platform) eq "macintosh") - || ([tk windowingsystem] eq "aqua")} { - if {($name eq "ok") || ($name eq "dismiss")} { - grid columnconfigure .bgerrorDialog.bot $i -minsize 79 - } - } - incr i - } - # The "OK" button is the default for this dialog. - .bgerrorDialog.ok configure -default active - - bind .bgerrorDialog <Return> [namespace code Return] - bind .bgerrorDialog <Destroy> [namespace code [list Destroy %W]] - .bgerrorDialog.function configure -command [namespace code Details] - - # 6. Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. - - wm withdraw .bgerrorDialog - update idletasks - set parent [winfo parent .bgerrorDialog] - set width [winfo reqwidth .bgerrorDialog] - set height [winfo reqheight .bgerrorDialog] - set x [expr {([winfo screenwidth .bgerrorDialog] - $width )/2 - \ - [winfo vrootx $parent]}] - set y [expr {([winfo screenheight .bgerrorDialog] - $height)/2 - \ - [winfo vrooty $parent]}] - .bgerrorDialog configure -width $width - wm geometry .bgerrorDialog +$x+$y - wm deiconify .bgerrorDialog - - # 7. Set a grab and claim the focus too. - - set oldFocus [focus] - set oldGrab [grab current .bgerrorDialog] - if {$oldGrab != ""} { - set grabStatus [grab status $oldGrab] - } - grab .bgerrorDialog - focus .bgerrorDialog.ok - - # 8. Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - - vwait [namespace which -variable button] - set copy $button; # Save a copy... - catch {focus $oldFocus} - catch {destroy .bgerrorDialog} - if {$oldGrab ne ""} { - if {$grabStatus eq "global"} { - grab -global $oldGrab - } else { - grab $oldGrab - } - } - - if {$copy == 1} { - return -code break - } -} - -namespace eval :: { - # Fool the indexer - proc bgerror err {} - rename bgerror {} - namespace import ::tk::dialog::error::bgerror -} diff --git a/tcl/library/button.tcl b/tcl/library/button.tcl deleted file mode 100644 index d92facfa902..00000000000 --- a/tcl/library/button.tcl +++ /dev/null @@ -1,639 +0,0 @@ -# button.tcl -- -# -# This file defines the default bindings for Tk label, button, -# checkbutton, and radiobutton widgets and provides procedures -# that help in implementing those bindings. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 2002 ActiveState Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -#------------------------------------------------------------------------- -# The code below creates the default class bindings for buttons. -#------------------------------------------------------------------------- - -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - bind Radiobutton <Enter> { - tk::ButtonEnter %W - } - bind Radiobutton <1> { - tk::ButtonDown %W - } - bind Radiobutton <ButtonRelease-1> { - tk::ButtonUp %W - } - bind Checkbutton <Enter> { - tk::ButtonEnter %W - } - bind Checkbutton <1> { - tk::ButtonDown %W - } - bind Checkbutton <ButtonRelease-1> { - tk::ButtonUp %W - } -} -if {[string equal "windows" $tcl_platform(platform)]} { - bind Checkbutton <equal> { - tk::CheckRadioInvoke %W select - } - bind Checkbutton <plus> { - tk::CheckRadioInvoke %W select - } - bind Checkbutton <minus> { - tk::CheckRadioInvoke %W deselect - } - bind Checkbutton <1> { - tk::CheckRadioDown %W - } - bind Checkbutton <ButtonRelease-1> { - tk::ButtonUp %W - } - bind Checkbutton <Enter> { - tk::CheckRadioEnter %W - } - - bind Radiobutton <1> { - tk::CheckRadioDown %W - } - bind Radiobutton <ButtonRelease-1> { - tk::ButtonUp %W - } - bind Radiobutton <Enter> { - tk::CheckRadioEnter %W - } -} -if {[string equal "x11" [tk windowingsystem]]} { - bind Checkbutton <Return> { - if {!$tk_strictMotif} { - tk::CheckRadioInvoke %W - } - } - bind Radiobutton <Return> { - if {!$tk_strictMotif} { - tk::CheckRadioInvoke %W - } - } - bind Checkbutton <1> { - tk::CheckRadioInvoke %W - } - bind Radiobutton <1> { - tk::CheckRadioInvoke %W - } - bind Checkbutton <Enter> { - tk::ButtonEnter %W - } - bind Radiobutton <Enter> { - tk::ButtonEnter %W - } -} - -bind Button <space> { - tk::ButtonInvoke %W -} -bind Checkbutton <space> { - tk::CheckRadioInvoke %W -} -bind Radiobutton <space> { - tk::CheckRadioInvoke %W -} - -bind Button <FocusIn> {} -bind Button <Enter> { - tk::ButtonEnter %W -} -bind Button <Leave> { - tk::ButtonLeave %W -} -bind Button <1> { - tk::ButtonDown %W -} -bind Button <ButtonRelease-1> { - tk::ButtonUp %W -} - -bind Checkbutton <FocusIn> {} -bind Checkbutton <Leave> { - tk::ButtonLeave %W -} - -bind Radiobutton <FocusIn> {} -bind Radiobutton <Leave> { - tk::ButtonLeave %W -} - -if {[string equal "windows" $tcl_platform(platform)]} { - -######################### -# Windows implementation -######################### - -# ::tk::ButtonEnter -- -# The procedure below is invoked when the mouse pointer enters a -# button widget. It records the button we're in and changes the -# state of the button to active unless the button is disabled. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonEnter w { - variable ::tk::Priv - if {[$w cget -state] ne "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. - - set Priv($w,relief) [$w cget -relief] - if {$Priv(buttonWindow) eq $w} { - $w configure -relief sunken -state active - set Priv($w,prelief) sunken - } elseif {[set over [$w cget -overrelief]] ne ""} { - $w configure -relief $over - set Priv($w,prelief) $over - } - } - set Priv(window) $w -} - -# ::tk::ButtonLeave -- -# The procedure below is invoked when the mouse pointer leaves a -# button widget. It changes the state of the button back to inactive. -# Restore any modified relief too. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonLeave w { - variable ::tk::Priv - if {[$w cget -state] ne "disabled"} { - $w configure -state normal - } - - # Restore the original button relief if it was changed by Tk. - # That is signaled by the existence of Priv($w,prelief). - - if {[info exists Priv($w,relief)]} { - if {[info exists Priv($w,prelief)] && \ - $Priv($w,prelief) eq [$w cget -relief]} { - $w configure -relief $Priv($w,relief) - } - unset -nocomplain Priv($w,relief) Priv($w,prelief) - } - - set Priv(window) "" -} - -# ::tk::ButtonDown -- -# The procedure below is invoked when the mouse button is pressed in -# a button widget. It records the fact that the mouse is in the button, -# saves the button's relief so it can be restored later, and changes -# the relief to sunken. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonDown w { - variable ::tk::Priv - - # Only save the button's relief if it does not yet exist. If there - # is an overrelief setting, Priv($w,relief) will already have been set, - # and the current value of the -relief option will be incorrect. - - if {![info exists Priv($w,relief)]} { - set Priv($w,relief) [$w cget -relief] - } - - if {[$w cget -state] ne "disabled"} { - set Priv(buttonWindow) $w - $w configure -relief sunken -state active - set Priv($w,prelief) sunken - - # If this button has a repeatdelay set up, get it going with an after - after cancel $Priv(afterId) - set delay [$w cget -repeatdelay] - set Priv(repeated) 0 - if {$delay > 0} { - set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] - } - } -} - -# ::tk::ButtonUp -- -# The procedure below is invoked when the mouse button is released -# in a button widget. It restores the button's relief and invokes -# the command as long as the mouse hasn't left the button. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonUp w { - variable ::tk::Priv - if {$Priv(buttonWindow) eq $w} { - set Priv(buttonWindow) "" - - # Restore the button's relief if it was cached. - - if {[info exists Priv($w,relief)]} { - if {[info exists Priv($w,prelief)] && \ - $Priv($w,prelief) eq [$w cget -relief]} { - $w configure -relief $Priv($w,relief) - } - unset -nocomplain Priv($w,relief) Priv($w,prelief) - } - - # Clean up the after event from the auto-repeater - after cancel $Priv(afterId) - - if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { - $w configure -state normal - - # Only invoke the command if it wasn't already invoked by the - # auto-repeater functionality - if { $Priv(repeated) == 0 } { - uplevel #0 [list $w invoke] - } - } - } -} - -# ::tk::CheckRadioEnter -- -# 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 -# disabled. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::CheckRadioEnter w { - variable ::tk::Priv - if {[$w cget -state] ne "disabled"} { - if {$Priv(buttonWindow) eq $w} { - $w configure -state active - } - if {[set over [$w cget -overrelief]] ne ""} { - set Priv($w,relief) [$w cget -relief] - set Priv($w,prelief) $over - $w configure -relief $over - } - } - set Priv(window) $w -} - -# ::tk::CheckRadioDown -- -# The procedure below is invoked when the mouse button is pressed in -# a button widget. It records the fact that the mouse is in the button, -# saves the button's relief so it can be restored later, and changes -# the relief to sunken. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::CheckRadioDown w { - variable ::tk::Priv - if {![info exists Priv($w,relief)]} { - set Priv($w,relief) [$w cget -relief] - } - if {[$w cget -state] ne "disabled"} { - set Priv(buttonWindow) $w - set Priv(repeated) 0 - $w configure -state active - } -} - -} - -if {[string equal "x11" [tk windowingsystem]]} { - -##################### -# Unix implementation -##################### - -# ::tk::ButtonEnter -- -# The procedure below is invoked when the mouse pointer enters a -# button widget. It records the button we're in and changes the -# state of the button to active unless the button is disabled. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonEnter {w} { - variable ::tk::Priv - if {[$w cget -state] ne "disabled"} { - # On unix the state is active just with mouse-over - $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. - - set Priv($w,relief) [$w cget -relief] - if {$Priv(buttonWindow) eq $w} { - $w configure -relief sunken - set Priv($w,prelief) sunken - } elseif {[set over [$w cget -overrelief]] ne ""} { - $w configure -relief $over - set Priv($w,prelief) $over - } - } - set Priv(window) $w -} - -# ::tk::ButtonLeave -- -# The procedure below is invoked when the mouse pointer leaves a -# button widget. It changes the state of the button back to inactive. -# Restore any modified relief too. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonLeave w { - variable ::tk::Priv - if {[$w cget -state] ne "disabled"} { - $w configure -state normal - } - - # Restore the original button relief if it was changed by Tk. - # That is signaled by the existence of Priv($w,prelief). - - if {[info exists Priv($w,relief)]} { - if {[info exists Priv($w,prelief)] && \ - $Priv($w,prelief) eq [$w cget -relief]} { - $w configure -relief $Priv($w,relief) - } - unset -nocomplain Priv($w,relief) Priv($w,prelief) - } - - set Priv(window) "" -} - -# ::tk::ButtonDown -- -# The procedure below is invoked when the mouse button is pressed in -# a button widget. It records the fact that the mouse is in the button, -# saves the button's relief so it can be restored later, and changes -# the relief to sunken. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonDown w { - variable ::tk::Priv - - # Only save the button's relief if it does not yet exist. If there - # is an overrelief setting, Priv($w,relief) will already have been set, - # and the current value of the -relief option will be incorrect. - - if {![info exists Priv($w,relief)]} { - set Priv($w,relief) [$w cget -relief] - } - - if {[$w cget -state] ne "disabled"} { - set Priv(buttonWindow) $w - $w configure -relief sunken - set Priv($w,prelief) sunken - - # If this button has a repeatdelay set up, get it going with an after - after cancel $Priv(afterId) - set delay [$w cget -repeatdelay] - set Priv(repeated) 0 - if {$delay > 0} { - set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] - } - } -} - -# ::tk::ButtonUp -- -# The procedure below is invoked when the mouse button is released -# in a button widget. It restores the button's relief and invokes -# the command as long as the mouse hasn't left the button. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonUp w { - variable ::tk::Priv - if {[string equal $w $Priv(buttonWindow)]} { - set Priv(buttonWindow) "" - - # Restore the button's relief if it was cached. - - if {[info exists Priv($w,relief)]} { - if {[info exists Priv($w,prelief)] && \ - $Priv($w,prelief) eq [$w cget -relief]} { - $w configure -relief $Priv($w,relief) - } - unset -nocomplain Priv($w,relief) Priv($w,prelief) - } - - # Clean up the after event from the auto-repeater - after cancel $Priv(afterId) - - if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { - # Only invoke the command if it wasn't already invoked by the - # auto-repeater functionality - if { $Priv(repeated) == 0 } { - uplevel #0 [list $w invoke] - } - } - } -} - -} - -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - -#################### -# Mac implementation -#################### - -# ::tk::ButtonEnter -- -# The procedure below is invoked when the mouse pointer enters a -# button widget. It records the button we're in and changes the -# state of the button to active unless the button is disabled. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonEnter {w} { - variable ::tk::Priv - if {[$w cget -state] ne "disabled"} { - - # If there's an -overrelief value, set the relief to that. - - if {$Priv(buttonWindow) eq $w} { - $w configure -state active - } elseif {[set over [$w cget -overrelief]] ne ""} { - set Priv($w,relief) [$w cget -relief] - set Priv($w,prelief) $over - $w configure -relief $over - } - } - set Priv(window) $w -} - -# ::tk::ButtonLeave -- -# The procedure below is invoked when the mouse pointer leaves a -# button widget. It changes the state of the button back to -# inactive. If we're leaving the button window with a mouse button -# pressed (Priv(buttonWindow) == $w), restore the relief of the -# button too. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonLeave w { - variable ::tk::Priv - if {$w eq $Priv(buttonWindow)} { - $w configure -state normal - } - - # Restore the original button relief if it was changed by Tk. - # That is signaled by the existence of Priv($w,prelief). - - if {[info exists Priv($w,relief)]} { - if {[info exists Priv($w,prelief)] && \ - $Priv($w,prelief) eq [$w cget -relief]} { - $w configure -relief $Priv($w,relief) - } - unset -nocomplain Priv($w,relief) Priv($w,prelief) - } - - set Priv(window) "" -} - -# ::tk::ButtonDown -- -# The procedure below is invoked when the mouse button is pressed in -# a button widget. It records the fact that the mouse is in the button, -# saves the button's relief so it can be restored later, and changes -# the relief to sunken. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonDown w { - variable ::tk::Priv - - if {[$w cget -state] ne "disabled"} { - set Priv(buttonWindow) $w - $w configure -state active - - # If this button has a repeatdelay set up, get it going with an after - after cancel $Priv(afterId) - set Priv(repeated) 0 - if { ![catch {$w cget -repeatdelay} delay] } { - if {$delay > 0} { - set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] - } - } - } -} - -# ::tk::ButtonUp -- -# The procedure below is invoked when the mouse button is released -# in a button widget. It restores the button's relief and invokes -# the command as long as the mouse hasn't left the button. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonUp w { - variable ::tk::Priv - if {$Priv(buttonWindow) eq $w} { - set Priv(buttonWindow) "" - $w configure -state normal - - # Restore the button's relief if it was cached. - - if {[info exists Priv($w,relief)]} { - if {[info exists Priv($w,prelief)] && \ - $Priv($w,prelief) eq [$w cget -relief]} { - $w configure -relief $Priv($w,relief) - } - unset -nocomplain Priv($w,relief) Priv($w,prelief) - } - - # Clean up the after event from the auto-repeater - after cancel $Priv(afterId) - - if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { - # Only invoke the command if it wasn't already invoked by the - # auto-repeater functionality - if { $Priv(repeated) == 0 } { - uplevel #0 [list $w invoke] - } - } - } -} - -} - -################## -# Shared routines -################## - -# ::tk::ButtonInvoke -- -# The procedure below is called when a button is invoked through -# the keyboard. It simulate a press of the button via the mouse. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::ButtonInvoke w { - if {[$w cget -state] ne "disabled"} { - set oldRelief [$w cget -relief] - set oldState [$w cget -state] - $w configure -state active -relief sunken - update idletasks - after 100 - $w configure -state $oldState -relief $oldRelief - uplevel #0 [list $w invoke] - } -} - -# ::tk::ButtonAutoInvoke -- -# -# Invoke an auto-repeating button, and set it up to continue to repeat. -# -# Arguments: -# w button to invoke. -# -# Results: -# None. -# -# Side effects: -# May create an after event to call ::tk::ButtonAutoInvoke. - -proc ::tk::ButtonAutoInvoke {w} { - variable ::tk::Priv - after cancel $Priv(afterId) - set delay [$w cget -repeatinterval] - if {$Priv(window) eq $w} { - incr Priv(repeated) - uplevel #0 [list $w invoke] - } - if {$delay > 0} { - set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] - } -} - -# ::tk::CheckRadioInvoke -- -# The procedure below is invoked when the mouse button is pressed in -# a checkbutton or radiobutton widget, or when the widget is invoked -# through the keyboard. It invokes the widget if it -# isn't disabled. -# -# Arguments: -# w - The name of the widget. -# cmd - The subcommand to invoke (one of invoke, select, or deselect). - -proc ::tk::CheckRadioInvoke {w {cmd invoke}} { - if {[$w cget -state] ne "disabled"} { - uplevel #0 [list $w $cmd] - } -} diff --git a/tcl/library/choosedir.tcl b/tcl/library/choosedir.tcl deleted file mode 100644 index 12fd7447009..00000000000 --- a/tcl/library/choosedir.tcl +++ /dev/null @@ -1,283 +0,0 @@ -# choosedir.tcl -- -# -# Choose directory dialog implementation for Unix/Mac. -# -# Copyright (c) 1998-2000 by Scriptics Corporation. -# All rights reserved. -# -# RCS: @(#) $Id$ - -# Make sure the tk::dialog namespace, in which all dialogs should live, exists -namespace eval ::tk::dialog {} -namespace eval ::tk::dialog::file {} - -# Make the chooseDir namespace inside the dialog namespace -namespace eval ::tk::dialog::file::chooseDir { - namespace import ::tk::msgcat::* -} - -# ::tk::dialog::file::chooseDir:: -- -# -# Implements the TK directory selection dialog. -# -# Arguments: -# args Options parsed by the procedure. -# -proc ::tk::dialog::file::chooseDir:: {args} { - variable ::tk::Priv - set dataName __tk_choosedir - upvar ::tk::dialog::file::$dataName data - ::tk::dialog::file::chooseDir::Config $dataName $args - - if {[string equal $data(-parent) .]} { - set w .$dataName - } else { - set w $data(-parent).$dataName - } - - # (re)create the dialog box if necessary - # - if {![winfo exists $w]} { - ::tk::dialog::file::Create $w TkChooseDir - } elseif {[string compare [winfo class $w] TkChooseDir]} { - destroy $w - ::tk::dialog::file::Create $w TkChooseDir - } else { - set data(dirMenuBtn) $w.f1.menu - set data(dirMenu) $w.f1.menu.menu - set data(upBtn) $w.f1.up - set data(icons) $w.icons - set data(ent) $w.f2.ent - set data(okBtn) $w.f2.ok - set data(cancelBtn) $w.f3.cancel - } - - # Dialog boxes should be transient with respect to their parent, - # so that they will always stay on top of their parent window. However, - # some window managers will create the window as withdrawn if the parent - # window is withdrawn or iconified. Combined with the grab we put on the - # window, this can hang the entire application. Therefore we only make - # the dialog transient if the parent is viewable. - - if {[winfo viewable [winfo toplevel $data(-parent)]] } { - wm transient $w $data(-parent) - } - - trace variable data(selectPath) w [list ::tk::dialog::file::SetPath $w] - $data(dirMenuBtn) configure \ - -textvariable ::tk::dialog::file::${dataName}(selectPath) - - set data(filter) "*" - set data(previousEntryText) "" - ::tk::dialog::file::UpdateWhenIdle $w - - # Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. - - ::tk::PlaceWindow $w widget $data(-parent) - wm title $w $data(-title) - - # Set a grab and claim the focus too. - - ::tk::SetFocusGrab $w $data(ent) - $data(ent) delete 0 end - $data(ent) insert 0 $data(selectPath) - $data(ent) selection range 0 end - $data(ent) icursor end - - # Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - - vwait ::tk::Priv(selectFilePath) - - ::tk::RestoreFocusGrab $w $data(ent) withdraw - - # Cleanup traces on selectPath variable - # - - foreach trace [trace vinfo data(selectPath)] { - trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1] - } - $data(dirMenuBtn) configure -textvariable {} - - # Return value to user - # - - return $Priv(selectFilePath) -} - -# ::tk::dialog::file::chooseDir::Config -- -# -# Configures the Tk choosedir dialog according to the argument list -# -proc ::tk::dialog::file::chooseDir::Config {dataName argList} { - upvar ::tk::dialog::file::$dataName data - - # 0: Delete all variable that were set on data(selectPath) the - # last time the file dialog is used. The traces may cause troubles - # if the dialog is now used with a different -parent option. - # - foreach trace [trace vinfo data(selectPath)] { - trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1] - } - - # 1: the configuration specs - # - set specs { - {-mustexist "" "" 0} - {-initialdir "" "" ""} - {-parent "" "" "."} - {-title "" "" ""} - } - - # 2: default values depending on the type of the dialog - # - if {![info exists data(selectPath)]} { - # first time the dialog has been popped up - set data(selectPath) [pwd] - } - - # 3: parse the arguments - # - tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList - - if {$data(-title) == ""} { - set data(-title) "[mc "Choose Directory"]" - } - - # Stub out the -multiple value for the dialog; it doesn't make sense for - # choose directory dialogs, but we have to have something there because we - # share so much code with the file dialogs. - set data(-multiple) 0 - - # 4: set the default directory and selection according to the -initial - # settings - # - if {$data(-initialdir) != ""} { - # Ensure that initialdir is an absolute path name. - if {[file isdirectory $data(-initialdir)]} { - set old [pwd] - cd $data(-initialdir) - set data(selectPath) [pwd] - cd $old - } else { - set data(selectPath) [pwd] - } - } - - if {![winfo exists $data(-parent)]} { - error "bad window path name \"$data(-parent)\"" - } -} - -# Gets called when user presses Return in the "Selection" entry or presses OK. -# -proc ::tk::dialog::file::chooseDir::OkCmd {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - # This is the brains behind selecting non-existant directories. Here's - # the flowchart: - # 1. If the icon list has a selection, join it with the current dir, - # and return that value. - # 1a. If the icon list does not have a selection ... - # 2. If the entry is empty, do nothing. - # 3. If the entry contains an invalid directory, then... - # 3a. If the value is the same as last time through here, end dialog. - # 3b. If the value is different than last time, save it and return. - # 4. If entry contains a valid directory, then... - # 4a. If the value is the same as the current directory, end dialog. - # 4b. If the value is different from the current directory, change to - # that directory. - - set selection [tk::IconList_Curselection $data(icons)] - if { [llength $selection] != 0 } { - set iconText [tk::IconList_Get $data(icons) [lindex $selection 0]] - set iconText [file join $data(selectPath) $iconText] - ::tk::dialog::file::chooseDir::Done $w $iconText - } else { - set text [$data(ent) get] - if { [string equal $text ""] } { - return - } - set text [eval file join [file split [string trim $text]]] - if { ![file exists $text] || ![file isdirectory $text] } { - # Entry contains an invalid directory. If it's the same as the - # last time they came through here, reset the saved value and end - # the dialog. Otherwise, save the value (so we can do this test - # next time). - if { [string equal $text $data(previousEntryText)] } { - set data(previousEntryText) "" - ::tk::dialog::file::chooseDir::Done $w $text - } else { - set data(previousEntryText) $text - } - } else { - # Entry contains a valid directory. If it is the same as the - # current directory, end the dialog. Otherwise, change to that - # directory. - if { [string equal $text $data(selectPath)] } { - ::tk::dialog::file::chooseDir::Done $w $text - } else { - set data(selectPath) $text - } - } - } - return -} - -proc ::tk::dialog::file::chooseDir::DblClick {w} { - upvar ::tk::dialog::file::[winfo name $w] data - set selection [tk::IconList_Curselection $data(icons)] - if { [llength $selection] != 0 } { - set filenameFragment \ - [tk::IconList_Get $data(icons) [lindex $selection 0]] - set file $data(selectPath) - if {[file isdirectory $file]} { - ::tk::dialog::file::ListInvoke $w [list $filenameFragment] - return - } - } -} - -# Gets called when user browses the IconList widget (dragging mouse, arrow -# keys, etc) -# -proc ::tk::dialog::file::chooseDir::ListBrowse {w text} { - upvar ::tk::dialog::file::[winfo name $w] data - - if {[string equal $text ""]} { - return - } - - set file [::tk::dialog::file::JoinFile $data(selectPath) $text] - $data(ent) delete 0 end - $data(ent) insert 0 $file -} - -# ::tk::dialog::file::chooseDir::Done -- -# -# Gets called when user has input a valid filename. Pops up a -# dialog box to confirm selection when necessary. Sets the -# Priv(selectFilePath) variable, which will break the "vwait" -# 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 - variable ::tk::Priv - - if {[string equal $selectFilePath ""]} { - set selectFilePath $data(selectPath) - } - if { $data(-mustexist) } { - if { ![file exists $selectFilePath] || \ - ![file isdir $selectFilePath] } { - return - } - } - set Priv(selectFilePath) $selectFilePath -} diff --git a/tcl/library/clrpick.tcl b/tcl/library/clrpick.tcl deleted file mode 100644 index da174863be9..00000000000 --- a/tcl/library/clrpick.tcl +++ /dev/null @@ -1,697 +0,0 @@ -# clrpick.tcl -- -# -# Color selection dialog for platforms that do not support a -# standard color selection dialog. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# ToDo: -# -# (1): Find out how many free colors are left in the colormap and -# don't allocate too many colors. -# (2): Implement HSV color selection. -# - -# Make sure namespaces exist -namespace eval ::tk {} -namespace eval ::tk::dialog {} -namespace eval ::tk::dialog::color { - namespace import ::tk::msgcat::* -} - -# ::tk::dialog::color:: -- -# -# Create a color dialog and let the user choose a color. This function -# should not be called directly. It is called by the tk_chooseColor -# function when a native color selector widget does not exist -# -proc ::tk::dialog::color:: {args} { - variable ::tk::Priv - set dataName __tk__color - upvar ::tk::dialog::color::$dataName data - set w .$dataName - - # The lines variables track the start and end indices of the line - # elements in the colorbar canvases. - set data(lines,red,start) 0 - set data(lines,red,last) -1 - set data(lines,green,start) 0 - set data(lines,green,last) -1 - set data(lines,blue,start) 0 - set data(lines,blue,last) -1 - - # This is the actual number of lines that are drawn in each color strip. - # Note that the bars may be of any width. - # However, NUM_COLORBARS must be a number that evenly divides 256. - # Such as 256, 128, 64, etc. - set data(NUM_COLORBARS) 16 - - # BARS_WIDTH is the number of pixels wide the color bar portion of the - # canvas is. This number must be a multiple of NUM_COLORBARS - set data(BARS_WIDTH) 160 - - # PLGN_WIDTH is the number of pixels wide of the triangular selection - # polygon. This also results in the definition of the padding on the - # left and right sides which is half of PLGN_WIDTH. Make this number even. - set data(PLGN_HEIGHT) 10 - - # PLGN_HEIGHT is the height of the selection polygon and the height of the - # selection rectangle at the bottom of the color bar. No restrictions. - set data(PLGN_WIDTH) 10 - - Config $dataName $args - InitValues $dataName - - set sc [winfo screen $data(-parent)] - set winExists [winfo exists $w] - if {!$winExists || [string compare $sc [winfo screen $w]]} { - if {$winExists} { - destroy $w - } - toplevel $w -class TkColorDialog -screen $sc - BuildDialog $w - } - - # Dialog boxes should be transient with respect to their parent, - # so that they will always stay on top of their parent window. However, - # some window managers will create the window as withdrawn if the parent - # window is withdrawn or iconified. Combined with the grab we put on the - # window, this can hang the entire application. Therefore we only make - # the dialog transient if the parent is viewable. - - if {[winfo viewable [winfo toplevel $data(-parent)]] } { - wm transient $w $data(-parent) - } - - # 5. Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. - - ::tk::PlaceWindow $w widget $data(-parent) - wm title $w $data(-title) - - # 6. Set a grab and claim the focus too. - - ::tk::SetFocusGrab $w $data(okBtn) - - # 7. Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - - vwait ::tk::Priv(selectColor) - ::tk::RestoreFocusGrab $w $data(okBtn) - unset data - - return $Priv(selectColor) -} - -# ::tk::dialog::color::InitValues -- -# -# Get called during initialization or when user resets NUM_COLORBARS -# -proc ::tk::dialog::color::InitValues {dataName} { - upvar ::tk::dialog::color::$dataName data - - # IntensityIncr is the difference in color intensity between a colorbar - # and its neighbors. - set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}] - - # ColorbarWidth is the width of each colorbar - set data(colorbarWidth) \ - [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}] - - # Indent is the width of the space at the left and right side of the - # colorbar. It is always half the selector polygon width, because the - # polygon extends into the space. - set data(indent) [expr {$data(PLGN_WIDTH) / 2}] - - set data(colorPad) 2 - set data(selPad) [expr {$data(PLGN_WIDTH) / 2}] - - # - # minX is the x coordinate of the first colorbar - # - set data(minX) $data(indent) - - # - # maxX is the x coordinate of the last colorbar - # - set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}] - - # - # canvasWidth is the width of the entire canvas, including the indents - # - set data(canvasWidth) [expr {$data(BARS_WIDTH) + $data(PLGN_WIDTH)}] - - # Set the initial color, specified by -initialcolor, or the - # color chosen by the user the last time. - set data(selection) $data(-initialcolor) - set data(finalColor) $data(-initialcolor) - set rgb [winfo rgb . $data(selection)] - - set data(red,intensity) [expr {[lindex $rgb 0]/0x100}] - set data(green,intensity) [expr {[lindex $rgb 1]/0x100}] - set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}] -} - -# ::tk::dialog::color::Config -- -# -# Parses the command line arguments to tk_chooseColor -# -proc ::tk::dialog::color::Config {dataName argList} { - variable ::tk::Priv - upvar ::tk::dialog::color::$dataName data - - # 1: the configuration specs - # - if {[info exists Priv(selectColor)] && \ - [string compare $Priv(selectColor) ""]} { - set defaultColor $Priv(selectColor) - } else { - set defaultColor [. cget -background] - } - - set specs [list \ - [list -initialcolor "" "" $defaultColor] \ - [list -parent "" "" "."] \ - [list -title "" "" [mc "Color"]] \ - ] - - # 2: parse the arguments - # - tclParseConfigSpec ::tk::dialog::color::$dataName $specs "" $argList - - if {[string equal $data(-title) ""]} { - set data(-title) " " - } - if {[catch {winfo rgb . $data(-initialcolor)} err]} { - error $err - } - - if {![winfo exists $data(-parent)]} { - error "bad window path name \"$data(-parent)\"" - } -} - -# ::tk::dialog::color::BuildDialog -- -# -# Build the dialog. -# -proc ::tk::dialog::color::BuildDialog {w} { - upvar ::tk::dialog::color::[winfo name $w] data - - # TopFrame contains the color strips and the color selection - # - set topFrame [frame $w.top -relief raised -bd 1] - - # StripsFrame contains the colorstrips and the individual RGB entries - set stripsFrame [frame $topFrame.colorStrip] - - set maxWidth [::tk::mcmaxamp &Red &Green &Blue] - set maxWidth [expr {$maxWidth<6?6:$maxWidth}] - set colorList [list \ - red [mc "&Red"] \ - green [mc "&Green"] \ - blue [mc "&Blue"] \ - ] - foreach {color l} $colorList { - # each f frame contains an [R|G|B] entry and the equiv. color strip. - set f [frame $stripsFrame.$color] - - # The box frame contains the label and entry widget for an [R|G|B] - set box [frame $f.box] - - bind [::tk::AmpWidget label $box.label -text $l: -width $maxWidth \ - -anchor ne] <<AltUnderlined>> [list focus $box.entry] - - entry $box.entry -textvariable \ - ::tk::dialog::color::[winfo name $w]($color,intensity) \ - -width 4 - pack $box.label -side left -fill y -padx 2 -pady 3 - pack $box.entry -side left -anchor n -pady 0 - pack $box -side left -fill both - - set height [expr \ - {[winfo reqheight $box.entry] - \ - 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])}] - - canvas $f.color -height $height\ - -width $data(BARS_WIDTH) -relief sunken -bd 2 - canvas $f.sel -height $data(PLGN_HEIGHT) \ - -width $data(canvasWidth) -highlightthickness 0 - pack $f.color -expand yes -fill both - pack $f.sel -expand yes -fill both - - pack $f -side top -fill x -padx 0 -pady 2 - - set data($color,entry) $box.entry - set data($color,col) $f.color - set data($color,sel) $f.sel - - bind $data($color,col) <Configure> \ - [list tk::dialog::color::DrawColorScale $w $color 1] - bind $data($color,col) <Enter> \ - [list tk::dialog::color::EnterColorBar $w $color] - bind $data($color,col) <Leave> \ - [list tk::dialog::color::LeaveColorBar $w $color] - - bind $data($color,sel) <Enter> \ - [list tk::dialog::color::EnterColorBar $w $color] - bind $data($color,sel) <Leave> \ - [list tk::dialog::color::LeaveColorBar $w $color] - - bind $box.entry <Return> [list tk::dialog::color::HandleRGBEntry $w] - } - - pack $stripsFrame -side left -fill both -padx 4 -pady 10 - - # The selFrame contains a frame that demonstrates the currently - # selected color - # - set selFrame [frame $topFrame.sel] - set lab [::tk::AmpWidget label $selFrame.lab -text [mc "&Selection:"] \ - -anchor sw] - set ent [entry $selFrame.ent \ - -textvariable ::tk::dialog::color::[winfo name $w](selection) \ - -width 16] - set f1 [frame $selFrame.f1 -relief sunken -bd 2] - set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70] - - pack $lab $ent -side top -fill x -padx 4 -pady 2 - pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10 - pack $data(finalCanvas) -expand yes -fill both - - bind $ent <Return> [list tk::dialog::color::HandleSelEntry $w] - - pack $selFrame -side left -fill none -anchor nw - pack $topFrame -side top -expand yes -fill both -anchor nw - - # the botFrame frame contains the buttons - # - set botFrame [frame $w.bot -relief raised -bd 1] - set maxWidth [::tk::mcmaxamp &OK &Cancel] - set maxWidth [expr {$maxWidth<8?8:$maxWidth}] - ::tk::AmpWidget button $botFrame.ok -text [mc "&OK"] \ - -width $maxWidth \ - -command [list tk::dialog::color::OkCmd $w] - ::tk::AmpWidget button $botFrame.cancel -text [mc "&Cancel"] \ - -width $maxWidth \ - -command [list tk::dialog::color::CancelCmd $w] - - set data(okBtn) $botFrame.ok - set data(cancelBtn) $botFrame.cancel - - pack $botFrame.ok $botFrame.cancel \ - -padx 10 -pady 10 -expand yes -side left - pack $botFrame -side bottom -fill x - - - # Accelerator bindings - bind $lab <<AltUnderlined>> [list focus $ent] - bind $w <KeyPress-Escape> [list tk::ButtonInvoke $data(cancelBtn)] - bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A] - - wm protocol $w WM_DELETE_WINDOW [list tk::dialog::color::CancelCmd $w] -} - -# ::tk::dialog::color::SetRGBValue -- -# -# Sets the current selection of the dialog box -# -proc ::tk::dialog::color::SetRGBValue {w color} { - upvar ::tk::dialog::color::[winfo name $w] data - - set data(red,intensity) [lindex $color 0] - set data(green,intensity) [lindex $color 1] - set data(blue,intensity) [lindex $color 2] - - RedrawColorBars $w all - - # Now compute the new x value of each colorbars pointer polygon - foreach color [list red green blue ] { - set x [RgbToX $w $data($color,intensity)] - MoveSelector $w $data($color,sel) $color $x 0 - } -} - -# ::tk::dialog::color::XToRgb -- -# -# Converts a screen coordinate to intensity -# -proc ::tk::dialog::color::XToRgb {w x} { - upvar ::tk::dialog::color::[winfo name $w] data - - set x [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}] - if {$x > 255} { set x 255 } - return $x -} - -# ::tk::dialog::color::RgbToX -# -# Converts an intensity to screen coordinate. -# -proc ::tk::dialog::color::RgbToX {w color} { - upvar ::tk::dialog::color::[winfo name $w] data - - return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}] -} - - -# ::tk::dialog::color::DrawColorScale -- -# -# Draw color scale is called whenever the size of one of the color -# scale canvases is changed. -# -proc ::tk::dialog::color::DrawColorScale {w c {create 0}} { - upvar ::tk::dialog::color::[winfo name $w] data - - # col: color bar canvas - # sel: selector canvas - set col $data($c,col) - set sel $data($c,sel) - - # First handle the case that we are creating everything for the first time. - if {$create} { - # First remove all the lines that already exist. - if { $data(lines,$c,last) > $data(lines,$c,start)} { - for {set i $data(lines,$c,start)} \ - {$i <= $data(lines,$c,last)} { incr i} { - $sel delete $i - } - } - # Delete the selector if it exists - if {[info exists data($c,index)]} { - $sel delete $data($c,index) - } - - # Draw the selection polygons - CreateSelector $w $sel $c - $sel bind $data($c,index) <ButtonPress-1> \ - [list tk::dialog::color::StartMove $w $sel $c %x $data(selPad) 1] - $sel bind $data($c,index) <B1-Motion> \ - [list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)] - $sel bind $data($c,index) <ButtonRelease-1> \ - [list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)] - - set height [winfo height $col] - # Create an invisible region under the colorstrip to catch mouse clicks - # that aren't on the selector. - set data($c,clickRegion) [$sel create rectangle 0 0 \ - $data(canvasWidth) $height -fill {} -outline {}] - - bind $col <ButtonPress-1> \ - [list tk::dialog::color::StartMove $w $sel $c %x $data(colorPad)] - bind $col <B1-Motion> \ - [list tk::dialog::color::MoveSelector $w $sel $c %x $data(colorPad)] - bind $col <ButtonRelease-1> \ - [list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(colorPad)] - - $sel bind $data($c,clickRegion) <ButtonPress-1> \ - [list tk::dialog::color::StartMove $w $sel $c %x $data(selPad)] - $sel bind $data($c,clickRegion) <B1-Motion> \ - [list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)] - $sel bind $data($c,clickRegion) <ButtonRelease-1> \ - [list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)] - } else { - # l is the canvas index of the first colorbar. - set l $data(lines,$c,start) - } - - # Draw the color bars. - set highlightW [expr {[$col cget -highlightthickness] + [$col cget -bd]}] - for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} { - set intensity [expr {$i * $data(intensityIncr)}] - set startx [expr {$i * $data(colorbarWidth) + $highlightW}] - if {[string equal $c "red"]} { - set color [format "#%02x%02x%02x" \ - $intensity \ - $data(green,intensity) \ - $data(blue,intensity)] - } elseif {[string equal $c "green"]} { - set color [format "#%02x%02x%02x" \ - $data(red,intensity) \ - $intensity \ - $data(blue,intensity)] - } else { - set color [format "#%02x%02x%02x" \ - $data(red,intensity) \ - $data(green,intensity) \ - $intensity] - } - - if {$create} { - set index [$col create rect $startx $highlightW \ - [expr {$startx +$data(colorbarWidth)}] \ - [expr {[winfo height $col] + $highlightW}]\ - -fill $color -outline $color] - } else { - $col itemconfigure $l -fill $color -outline $color - incr l - } - } - $sel raise $data($c,index) - - if {$create} { - set data(lines,$c,last) $index - set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}] - } - - RedrawFinalColor $w -} - -# ::tk::dialog::color::CreateSelector -- -# -# Creates and draws the selector polygon at the position -# $data($c,intensity). -# -proc ::tk::dialog::color::CreateSelector {w sel c } { - upvar ::tk::dialog::color::[winfo name $w] data - set data($c,index) [$sel create polygon \ - 0 $data(PLGN_HEIGHT) \ - $data(PLGN_WIDTH) $data(PLGN_HEIGHT) \ - $data(indent) 0] - set data($c,x) [RgbToX $w $data($c,intensity)] - $sel move $data($c,index) $data($c,x) 0 -} - -# ::tk::dialog::color::RedrawFinalColor -# -# Combines the intensities of the three colors into the final color -# -proc ::tk::dialog::color::RedrawFinalColor {w} { - upvar ::tk::dialog::color::[winfo name $w] data - - set color [format "#%02x%02x%02x" $data(red,intensity) \ - $data(green,intensity) $data(blue,intensity)] - - $data(finalCanvas) configure -bg $color - set data(finalColor) $color - set data(selection) $color - set data(finalRGB) [list \ - $data(red,intensity) \ - $data(green,intensity) \ - $data(blue,intensity)] -} - -# ::tk::dialog::color::RedrawColorBars -- -# -# Only redraws the colors on the color strips that were not manipulated. -# Params: color of colorstrip that changed. If color is not [red|green|blue] -# Then all colorstrips will be updated -# -proc ::tk::dialog::color::RedrawColorBars {w colorChanged} { - upvar ::tk::dialog::color::[winfo name $w] data - - switch $colorChanged { - red { - DrawColorScale $w green - DrawColorScale $w blue - } - green { - DrawColorScale $w red - DrawColorScale $w blue - } - blue { - DrawColorScale $w red - DrawColorScale $w green - } - default { - DrawColorScale $w red - DrawColorScale $w green - DrawColorScale $w blue - } - } - RedrawFinalColor $w -} - -#---------------------------------------------------------------------- -# Event handlers -#---------------------------------------------------------------------- - -# ::tk::dialog::color::StartMove -- -# -# Handles a mousedown button event over the selector polygon. -# Adds the bindings for moving the mouse while the button is -# pressed. Sets the binding for the button-release event. -# -# Params: sel is the selector canvas window, color is the color of the strip. -# -proc ::tk::dialog::color::StartMove {w sel color x delta {dontMove 0}} { - upvar ::tk::dialog::color::[winfo name $w] data - - if {!$dontMove} { - MoveSelector $w $sel $color $x $delta - } -} - -# ::tk::dialog::color::MoveSelector -- -# -# Moves the polygon selector so that its middle point has the same -# x value as the specified x. If x is outside the bounds [0,255], -# the selector is set to the closest endpoint. -# -# Params: sel is the selector canvas, c is [red|green|blue] -# x is a x-coordinate. -# -proc ::tk::dialog::color::MoveSelector {w sel color x delta} { - upvar ::tk::dialog::color::[winfo name $w] data - - incr x -$delta - - if { $x < 0 } { - set x 0 - } elseif { $x > $data(BARS_WIDTH)} { - set x $data(BARS_WIDTH) - } - set diff [expr {$x - $data($color,x)}] - $sel move $data($color,index) $diff 0 - set data($color,x) [expr {$data($color,x) + $diff}] - - # Return the x value that it was actually set at - return $x -} - -# ::tk::dialog::color::ReleaseMouse -# -# Removes mouse tracking bindings, updates the colorbars. -# -# Params: sel is the selector canvas, color is the color of the strip, -# x is the x-coord of the mouse. -# -proc ::tk::dialog::color::ReleaseMouse {w sel color x delta} { - upvar ::tk::dialog::color::[winfo name $w] data - - set x [MoveSelector $w $sel $color $x $delta] - - # Determine exactly what color we are looking at. - set data($color,intensity) [XToRgb $w $x] - - RedrawColorBars $w $color -} - -# ::tk::dialog::color::ResizeColorbars -- -# -# Completely redraws the colorbars, including resizing the -# colorstrips -# -proc ::tk::dialog::color::ResizeColorBars {w} { - upvar ::tk::dialog::color::[winfo name $w] data - - if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || - (($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} { - set data(BARS_WIDTH) $data(NUM_COLORBARS) - } - InitValues [winfo name $w] - foreach color [list red green blue ] { - $data($color,col) configure -width $data(canvasWidth) - DrawColorScale $w $color 1 - } -} - -# ::tk::dialog::color::HandleSelEntry -- -# -# Handles the return keypress event in the "Selection:" entry -# -proc ::tk::dialog::color::HandleSelEntry {w} { - upvar ::tk::dialog::color::[winfo name $w] data - - set text [string trim $data(selection)] - # Check to make sure that the color is valid - if {[catch {set color [winfo rgb . $text]} ]} { - set data(selection) $data(finalColor) - return - } - - set R [expr {[lindex $color 0]/0x100}] - set G [expr {[lindex $color 1]/0x100}] - set B [expr {[lindex $color 2]/0x100}] - - SetRGBValue $w "$R $G $B" - set data(selection) $text -} - -# ::tk::dialog::color::HandleRGBEntry -- -# -# Handles the return keypress event in the R, G or B entry -# -proc ::tk::dialog::color::HandleRGBEntry {w} { - upvar ::tk::dialog::color::[winfo name $w] data - - foreach c [list red green blue] { - if {[catch { - set data($c,intensity) [expr {int($data($c,intensity))}] - }]} { - set data($c,intensity) 0 - } - - if {$data($c,intensity) < 0} { - set data($c,intensity) 0 - } - if {$data($c,intensity) > 255} { - set data($c,intensity) 255 - } - } - - SetRGBValue $w "$data(red,intensity) \ - $data(green,intensity) $data(blue,intensity)" -} - -# mouse cursor enters a color bar -# -proc ::tk::dialog::color::EnterColorBar {w color} { - upvar ::tk::dialog::color::[winfo name $w] data - - $data($color,sel) itemconfig $data($color,index) -fill red -} - -# mouse leaves enters a color bar -# -proc ::tk::dialog::color::LeaveColorBar {w color} { - upvar ::tk::dialog::color::[winfo name $w] data - - $data($color,sel) itemconfig $data($color,index) -fill black -} - -# user hits OK button -# -proc ::tk::dialog::color::OkCmd {w} { - variable ::tk::Priv - upvar ::tk::dialog::color::[winfo name $w] data - - set Priv(selectColor) $data(finalColor) -} - -# user hits Cancel button -# -proc ::tk::dialog::color::CancelCmd {w} { - variable ::tk::Priv - set Priv(selectColor) "" -} - diff --git a/tcl/library/comdlg.tcl b/tcl/library/comdlg.tcl deleted file mode 100644 index 7be38743984..00000000000 --- a/tcl/library/comdlg.tcl +++ /dev/null @@ -1,303 +0,0 @@ -# comdlg.tcl -- -# -# Some functions needed for the common dialog boxes. Probably need to go -# in a different file. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# tclParseConfigSpec -- -# -# Parses a list of "-option value" pairs. If all options and -# values are legal, the values are stored in -# $data($option). Otherwise an error message is returned. When -# an error happens, the data() array may have been partially -# modified, but all the modified members of the data(0 array are -# guaranteed to have valid values. This is different than -# Tk_ConfigureWidget() which does not modify the value of a -# widget record if any error occurs. -# -# Arguments: -# -# w = widget record to modify. Must be the pathname of a widget. -# -# specs = { -# {-commandlineswitch resourceName ResourceClass defaultValue verifier} -# {....} -# } -# -# flags = currently unused. -# -# argList = The list of "-option value" pairs. -# -proc tclParseConfigSpec {w specs flags argList} { - upvar #0 $w data - - # 1: Put the specs in associative arrays for faster access - # - foreach spec $specs { - if {[llength $spec] < 4} { - error "\"spec\" should contain 5 or 4 elements" - } - set cmdsw [lindex $spec 0] - set cmd($cmdsw) "" - set rname($cmdsw) [lindex $spec 1] - set rclass($cmdsw) [lindex $spec 2] - set def($cmdsw) [lindex $spec 3] - set verproc($cmdsw) [lindex $spec 4] - } - - if {[llength $argList] & 1} { - set cmdsw [lindex $argList end] - if {![info exists cmd($cmdsw)]} { - error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]" - } - error "value for \"$cmdsw\" missing" - } - - # 2: set the default values - # - foreach cmdsw [array names cmd] { - set data($cmdsw) $def($cmdsw) - } - - # 3: parse the argument list - # - foreach {cmdsw value} $argList { - if {![info exists cmd($cmdsw)]} { - error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]" - } - set data($cmdsw) $value - } - - # Done! -} - -proc tclListValidFlags {v} { - upvar $v cmd - - set len [llength [array names cmd]] - set i 1 - set separator "" - set errormsg "" - foreach cmdsw [lsort [array names cmd]] { - append errormsg "$separator$cmdsw" - incr i - if {$i == $len} { - set separator ", or " - } else { - set separator ", " - } - } - return $errormsg -} - -#---------------------------------------------------------------------- -# -# Focus Group -# -# Focus groups are used to handle the user's focusing actions inside a -# toplevel. -# -# One example of using focus groups is: when the user focuses on an -# entry, the text in the entry is highlighted and the cursor is put to -# the end of the text. When the user changes focus to another widget, -# the text in the previously focused entry is validated. -# -#---------------------------------------------------------------------- - - -# ::tk::FocusGroup_Create -- -# -# Create a focus group. All the widgets in a focus group must be -# within the same focus toplevel. Each toplevel can have only -# one focus group, which is identified by the name of the -# toplevel widget. -# -proc ::tk::FocusGroup_Create {t} { - variable ::tk::Priv - if {[string compare [winfo toplevel $t] $t]} { - error "$t is not a toplevel window" - } - if {![info exists Priv(fg,$t)]} { - set Priv(fg,$t) 1 - set Priv(focus,$t) "" - bind $t <FocusIn> [list tk::FocusGroup_In $t %W %d] - bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d] - bind $t <Destroy> [list tk::FocusGroup_Destroy $t %W] - } -} - -# ::tk::FocusGroup_BindIn -- -# -# Add a widget into the "FocusIn" list of the focus group. The $cmd will be -# called when the widget is focused on by the user. -# -proc ::tk::FocusGroup_BindIn {t w cmd} { - variable FocusIn - variable ::tk::Priv - if {![info exists Priv(fg,$t)]} { - error "focus group \"$t\" doesn't exist" - } - set FocusIn($t,$w) $cmd -} - - -# ::tk::FocusGroup_BindOut -- -# -# Add a widget into the "FocusOut" list of the focus group. The -# $cmd will be called when the widget loses the focus (User -# types Tab or click on another widget). -# -proc ::tk::FocusGroup_BindOut {t w cmd} { - variable FocusOut - variable ::tk::Priv - if {![info exists Priv(fg,$t)]} { - error "focus group \"$t\" doesn't exist" - } - set FocusOut($t,$w) $cmd -} - -# ::tk::FocusGroup_Destroy -- -# -# Cleans up when members of the focus group is deleted, or when the -# toplevel itself gets deleted. -# -proc ::tk::FocusGroup_Destroy {t w} { - variable FocusIn - variable FocusOut - variable ::tk::Priv - - if {[string equal $t $w]} { - unset Priv(fg,$t) - unset Priv(focus,$t) - - foreach name [array names FocusIn $t,*] { - unset FocusIn($name) - } - foreach name [array names FocusOut $t,*] { - unset FocusOut($name) - } - } else { - if {[info exists Priv(focus,$t)] && \ - [string equal $Priv(focus,$t) $w]} { - set Priv(focus,$t) "" - } - catch { - unset FocusIn($t,$w) - } - catch { - unset FocusOut($t,$w) - } - } -} - -# ::tk::FocusGroup_In -- -# -# Handles the <FocusIn> event. Calls the FocusIn command for the newly -# focused widget in the focus group. -# -proc ::tk::FocusGroup_In {t w detail} { - variable FocusIn - variable ::tk::Priv - - if {[string compare $detail NotifyNonlinear] && \ - [string compare $detail NotifyNonlinearVirtual]} { - # This is caused by mouse moving out&in of the window *or* - # ordinary keypresses some window managers (ie: CDE [Bug: 2960]). - return - } - if {![info exists FocusIn($t,$w)]} { - set FocusIn($t,$w) "" - return - } - if {![info exists Priv(focus,$t)]} { - return - } - if {[string equal $Priv(focus,$t) $w]} { - # This is already in focus - # - return - } else { - set Priv(focus,$t) $w - eval $FocusIn($t,$w) - } -} - -# ::tk::FocusGroup_Out -- -# -# 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. -# -proc ::tk::FocusGroup_Out {t w detail} { - variable FocusOut - variable ::tk::Priv - - if {[string compare $detail NotifyNonlinear] && \ - [string compare $detail NotifyNonlinearVirtual]} { - # This is caused by mouse moving out of the window - return - } - if {![info exists Priv(focus,$t)]} { - return - } - if {![info exists FocusOut($t,$w)]} { - return - } else { - eval $FocusOut($t,$w) - set Priv(focus,$t) "" - } -} - -# ::tk::FDGetFileTypes -- -# -# Process the string given by the -filetypes option of the file -# dialogs. Similar to the C function TkGetFileFilters() on the Mac -# and Windows platform. -# -proc ::tk::FDGetFileTypes {string} { - foreach t $string { - if {[llength $t] < 2 || [llength $t] > 3} { - error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\"" - } - eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1] - } - - set types {} - foreach t $string { - set label [lindex $t 0] - set exts {} - - if {[info exists hasDoneType($label)]} { - continue - } - - set name "$label (" - set sep "" - foreach ext $fileTypes($label) { - if {[string equal $ext ""]} { - continue - } - regsub {^[.]} $ext "*." ext - if {![info exists hasGotExt($label,$ext)]} { - append name $sep$ext - lappend exts $ext - set hasGotExt($label,$ext) 1 - } - set sep , - } - append name ")" - lappend types [list $name $exts] - - set hasDoneType($label) 1 - } - - return $types -} diff --git a/tcl/library/console.tcl b/tcl/library/console.tcl deleted file mode 100644 index cc5e3adb8bf..00000000000 --- a/tcl/library/console.tcl +++ /dev/null @@ -1,934 +0,0 @@ -# console.tcl -- -# -# This code constructs the console window for an application. It -# can be used by non-unix systems that do not have built-in support -# for shells. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1995-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# TODO: history - remember partially written command - -namespace eval ::tk::console { - variable blinkTime 500 ; # msecs to blink braced range for - variable blinkRange 1 ; # enable blinking of the entire braced range - variable magicKeys 1 ; # enable brace matching and proc/var recognition - variable maxLines 600 ; # maximum # of lines buffered in console - variable showMatches 1 ; # show multiple expand matches - - variable inPlugin [info exists embed_args] - variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used - - - if {$inPlugin} { - set defaultPrompt {subst {[history nextid] % }} - } else { - set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }} - } -} - -# simple compat function for tkcon code added for this console -interp alias {} EvalAttached {} consoleinterp eval - -# ::tk::ConsoleInit -- -# This procedure constructs and configures the console windows. -# -# Arguments: -# None. - -proc ::tk::ConsoleInit {} { - global tcl_platform - - if {![consoleinterp eval {set tcl_interactive}]} { - wm withdraw . - } - - if {[string equal $tcl_platform(platform) "macintosh"] - || [string equal [tk windowingsystem] "aqua"]} { - set mod "Cmd" - } else { - set mod "Ctrl" - } - - if {[catch {menu .menubar} err]} { bgerror "INIT: $err" } - .menubar add cascade -label File -menu .menubar.file -underline 0 - .menubar add cascade -label Edit -menu .menubar.edit -underline 0 - - menu .menubar.file -tearoff 0 - .menubar.file add command -label [mc "Source..."] \ - -underline 0 -command tk::ConsoleSource - .menubar.file add command -label [mc "Hide Console"] \ - -underline 0 -command {wm withdraw .} - .menubar.file add command -label [mc "Clear Console"] \ - -underline 0 -command {.console delete 1.0 "promptEnd linestart"} - if {[string equal $tcl_platform(platform) "macintosh"] - || [string equal [tk windowingsystem] "aqua"]} { - .menubar.file add command -label [mc "Quit"] \ - -command exit -accel Cmd-Q - } else { - .menubar.file add command -label [mc "Exit"] \ - -underline 1 -command exit - } - - menu .menubar.edit -tearoff 0 - .menubar.edit add command -label [mc "Cut"] -underline 2 \ - -command { event generate .console <<Cut>> } -accel "$mod+X" - .menubar.edit add command -label [mc "Copy"] -underline 0 \ - -command { event generate .console <<Copy>> } -accel "$mod+C" - .menubar.edit add command -label [mc "Paste"] -underline 1 \ - -command { event generate .console <<Paste>> } -accel "$mod+V" - - if {[string compare $tcl_platform(platform) "windows"]} { - .menubar.edit add command -label [mc "Clear"] -underline 2 \ - -command { event generate .console <<Clear>> } - } else { - .menubar.edit add command -label [mc "Delete"] -underline 0 \ - -command { event generate .console <<Clear>> } -accel "Del" - - .menubar add cascade -label Help -menu .menubar.help -underline 0 - menu .menubar.help -tearoff 0 - .menubar.help add command -label [mc "About..."] \ - -underline 0 -command tk::ConsoleAbout - } - - . configure -menu .menubar - - set con [text .console -yscrollcommand [list .sb set] -setgrid true] - scrollbar .sb -command [list $con yview] - pack .sb -side right -fill both - pack $con -fill both -expand 1 -side left - switch -exact $tcl_platform(platform) { - "macintosh" { - $con configure -font {Monaco 9 normal} -highlightthickness 0 - } - "windows" { - $con configure -font systemfixed - } - "unix" { - if {[string equal [tk windowingsystem] "aqua"]} { - $con configure -font {Monaco 9 normal} -highlightthickness 0 - } - } - } - - ConsoleBind $con - - $con tag configure stderr -foreground red - $con tag configure stdin -foreground blue - $con tag configure prompt -foreground \#8F4433 - $con tag configure proc -foreground \#008800 - $con tag configure var -background \#FFC0D0 - $con tag raise sel - $con tag configure blink -background \#FFFF00 - $con tag configure find -background \#FFFF00 - - focus $con - - wm protocol . WM_DELETE_WINDOW { wm withdraw . } - wm title . [mc "Console"] - flush stdout - $con mark set output [$con index "end - 1 char"] - tk::TextSetCursor $con end - $con mark set promptEnd insert - $con mark gravity promptEnd left -} - -# ::tk::ConsoleSource -- -# -# Prompts the user for a file to source in the main interpreter. -# -# Arguments: -# None. - -proc ::tk::ConsoleSource {} { - set filename [tk_getOpenFile -defaultextension .tcl -parent . \ - -title [mc "Select a file to source"] \ - -filetypes [list \ - [list [mc "Tcl Scripts"] .tcl] \ - [list [mc "All Files"] *]]] - if {[string compare $filename ""]} { - set cmd [list source $filename] - if {[catch {consoleinterp eval $cmd} result]} { - ConsoleOutput stderr "$result\n" - } - } -} - -# ::tk::ConsoleInvoke -- -# Processes the command line input. If the command is complete it -# is evaled in the main interpreter. Otherwise, the continuation -# prompt is added and more input may be added. -# -# Arguments: -# None. - -proc ::tk::ConsoleInvoke {args} { - set ranges [.console tag ranges input] - set cmd "" - if {[llength $ranges]} { - set pos 0 - while {[string compare [lindex $ranges $pos] ""]} { - set start [lindex $ranges $pos] - set end [lindex $ranges [incr pos]] - append cmd [.console get $start $end] - incr pos - } - } - if {[string equal $cmd ""]} { - ConsolePrompt - } elseif {[info complete $cmd]} { - .console mark set output end - .console tag delete input - set result [consoleinterp record $cmd] - if {[string compare $result ""]} { - puts $result - } - ConsoleHistory reset - ConsolePrompt - } else { - ConsolePrompt partial - } - .console yview -pickplace insert -} - -# ::tk::ConsoleHistory -- -# This procedure implements command line history for the -# console. In general is evals the history command in the -# main interpreter to obtain the history. The variable -# ::tk::HistNum is used to store the current location in the history. -# -# Arguments: -# cmd - Which action to take: prev, next, reset. - -set ::tk::HistNum 1 -proc ::tk::ConsoleHistory {cmd} { - variable HistNum - - switch $cmd { - prev { - incr HistNum -1 - if {$HistNum == 0} { - set cmd {history event [expr {[history nextid] -1}]} - } else { - set cmd "history event $HistNum" - } - if {[catch {consoleinterp eval $cmd} cmd]} { - incr HistNum - return - } - .console delete promptEnd end - .console insert promptEnd $cmd {input stdin} - } - next { - incr HistNum - if {$HistNum == 0} { - set cmd {history event [expr {[history nextid] -1}]} - } elseif {$HistNum > 0} { - set cmd "" - set HistNum 1 - } else { - set cmd "history event $HistNum" - } - if {[string compare $cmd ""]} { - catch {consoleinterp eval $cmd} cmd - } - .console delete promptEnd end - .console insert promptEnd $cmd {input stdin} - } - reset { - set HistNum 1 - } - } -} - -# ::tk::ConsolePrompt -- -# This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 -# exists in the main interpreter it will be called to generate the -# prompt. Otherwise, a hard coded default prompt is printed. -# -# Arguments: -# partial - Flag to specify which prompt to print. - -proc ::tk::ConsolePrompt {{partial normal}} { - set w .console - if {[string equal $partial "normal"]} { - set temp [$w index "end - 1 char"] - $w mark set output end - if {[consoleinterp eval "info exists tcl_prompt1"]} { - consoleinterp eval "eval \[set tcl_prompt1\]" - } else { - puts -nonewline [EvalAttached $::tk::console::defaultPrompt] - } - } else { - set temp [$w index output] - $w mark set output end - if {[consoleinterp eval "info exists tcl_prompt2"]} { - consoleinterp eval "eval \[set tcl_prompt2\]" - } else { - puts -nonewline "> " - } - } - flush stdout - $w mark set output $temp - ::tk::TextSetCursor $w end - $w mark set promptEnd insert - $w mark gravity promptEnd left - ::tk::console::ConstrainBuffer $w $::tk::console::maxLines - $w see end -} - -# ::tk::ConsoleBind -- -# This procedure first ensures that the default bindings for the Text -# class have been defined. Then certain bindings are overridden for -# the class. -# -# Arguments: -# None. - -proc ::tk::ConsoleBind {w} { - bindtags $w [list $w Console PostConsole [winfo toplevel $w] all] - - ## Get all Text bindings into Console - foreach ev [bind Text] { bind Console $ev [bind Text $ev] } - ## We really didn't want the newline insertion... - bind Console <Control-Key-o> {} - ## ...or any Control-v binding (would block <<Paste>>) - bind Console <Control-Key-v> {} - - # For the moment, transpose isn't enabled until the console - # gets and overhaul of how it handles input -- hobbs - bind Console <Control-Key-t> {} - - # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. - # Otherwise, if a widget binding for one of these is defined, the - - bind Console <Alt-KeyPress> {# nothing } - bind Console <Meta-KeyPress> {# nothing} - bind Console <Control-KeyPress> {# nothing} - - foreach {ev key} { - <<Console_Prev>> <Key-Up> - <<Console_Next>> <Key-Down> - <<Console_NextImmediate>> <Control-Key-n> - <<Console_PrevImmediate>> <Control-Key-p> - <<Console_PrevSearch>> <Control-Key-r> - <<Console_NextSearch>> <Control-Key-s> - - <<Console_Expand>> <Key-Tab> - <<Console_Expand>> <Key-Escape> - <<Console_ExpandFile>> <Control-Shift-Key-F> - <<Console_ExpandProc>> <Control-Shift-Key-P> - <<Console_ExpandVar>> <Control-Shift-Key-V> - <<Console_Tab>> <Control-Key-i> - <<Console_Tab>> <Meta-Key-i> - <<Console_Eval>> <Key-Return> - <<Console_Eval>> <Key-KP_Enter> - - <<Console_Clear>> <Control-Key-l> - <<Console_KillLine>> <Control-Key-k> - <<Console_Transpose>> <Control-Key-t> - <<Console_ClearLine>> <Control-Key-u> - <<Console_SaveCommand>> <Control-Key-z> - } { - event add $ev $key - bind Console $key {} - } - - bind Console <<Console_Expand>> { - if {[%W compare insert > promptEnd]} {::tk::console::Expand %W} - } - bind Console <<Console_ExpandFile>> { - if {[%W compare insert > promptEnd]} {::tk::console::Expand %W path} - } - bind Console <<Console_ExpandProc>> { - if {[%W compare insert > promptEnd]} {::tk::console::Expand %W proc} - } - bind Console <<Console_ExpandVar>> { - if {[%W compare insert > promptEnd]} {::tk::console::Expand %W var} - } - bind Console <<Console_Eval>> { - %W mark set insert {end - 1c} - tk::ConsoleInsert %W "\n" - tk::ConsoleInvoke - break - } - bind Console <Delete> { - if {[string compare {} [%W tag nextrange sel 1.0 end]] \ - && [%W compare sel.first >= promptEnd]} { - %W delete sel.first sel.last - } elseif {[%W compare insert >= promptEnd]} { - %W delete insert - %W see insert - } - } - bind Console <BackSpace> { - if {[string compare {} [%W tag nextrange sel 1.0 end]] \ - && [%W compare sel.first >= promptEnd]} { - %W delete sel.first sel.last - } elseif {[%W compare insert != 1.0] && \ - [%W compare insert > promptEnd]} { - %W delete insert-1c - %W see insert - } - } - bind Console <Control-h> [bind Console <BackSpace>] - - bind Console <Home> { - if {[%W compare insert < promptEnd]} { - tk::TextSetCursor %W {insert linestart} - } else { - tk::TextSetCursor %W promptEnd - } - } - bind Console <Control-a> [bind Console <Home>] - bind Console <End> { - tk::TextSetCursor %W {insert lineend} - } - bind Console <Control-e> [bind Console <End>] - bind Console <Control-d> { - if {[%W compare insert < promptEnd]} break - %W delete insert - } - bind Console <<Console_KillLine>> { - if {[%W compare insert < promptEnd]} break - if {[%W compare insert == {insert lineend}]} { - %W delete insert - } else { - %W delete insert {insert lineend} - } - } - bind Console <<Console_Clear>> { - ## Clear console display - %W delete 1.0 "promptEnd linestart" - } - bind Console <<Console_ClearLine>> { - ## Clear command line (Unix shell staple) - %W delete promptEnd end - } - bind Console <Meta-d> { - if {[%W compare insert >= promptEnd]} { - %W delete insert {insert wordend} - } - } - bind Console <Meta-BackSpace> { - if {[%W compare {insert -1c wordstart} >= promptEnd]} { - %W delete {insert -1c wordstart} insert - } - } - bind Console <Meta-d> { - if {[%W compare insert >= promptEnd]} { - %W delete insert {insert wordend} - } - } - bind Console <Meta-BackSpace> { - if {[%W compare {insert -1c wordstart} >= promptEnd]} { - %W delete {insert -1c wordstart} insert - } - } - bind Console <Meta-Delete> { - if {[%W compare insert >= promptEnd]} { - %W delete insert {insert wordend} - } - } - bind Console <<Console_Prev>> { - tk::ConsoleHistory prev - } - bind Console <<Console_Next>> { - tk::ConsoleHistory next - } - bind Console <Insert> { - catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]} - } - bind Console <KeyPress> { - tk::ConsoleInsert %W %A - } - bind Console <F9> { - eval destroy [winfo child .] - if {[string equal $tcl_platform(platform) "macintosh"]} { - if {[catch {source [file join $tk_library console.tcl]}]} {source -rsrc console} - } else { - source [file join $tk_library console.tcl] - } - } - bind Console <<Cut>> { - # Same as the copy event - if {![catch {set data [%W get sel.first sel.last]}]} { - clipboard clear -displayof %W - clipboard append -displayof %W $data - } - } - bind Console <<Copy>> { - if {![catch {set data [%W get sel.first sel.last]}]} { - clipboard clear -displayof %W - clipboard append -displayof %W $data - } - } - bind Console <<Paste>> { - catch { - set clip [::tk::GetSelection %W CLIPBOARD] - set list [split $clip \n\r] - tk::ConsoleInsert %W [lindex $list 0] - foreach x [lrange $list 1 end] { - %W mark set insert {end - 1c} - tk::ConsoleInsert %W "\n" - tk::ConsoleInvoke - tk::ConsoleInsert %W $x - } - } - } - - ## - ## Bindings for doing special things based on certain keys - ## - bind PostConsole <Key-parenright> { - if {[string compare \\ [%W get insert-2c]]} { - ::tk::console::MatchPair %W \( \) promptEnd - } - } - bind PostConsole <Key-bracketright> { - if {[string compare \\ [%W get insert-2c]]} { - ::tk::console::MatchPair %W \[ \] promptEnd - } - } - bind PostConsole <Key-braceright> { - if {[string compare \\ [%W get insert-2c]]} { - ::tk::console::MatchPair %W \{ \} promptEnd - } - } - bind PostConsole <Key-quotedbl> { - if {[string compare \\ [%W get insert-2c]]} { - ::tk::console::MatchQuote %W promptEnd - } - } - - bind PostConsole <KeyPress> { - if {"%A" != ""} { - ::tk::console::TagProc %W - } - break - } -} - -# ::tk::ConsoleInsert -- -# Insert a string into a text at the point of the insertion cursor. -# If there is a selection in the text, and it covers the point of the -# insertion cursor, then delete the selection before inserting. Insertion -# is restricted to the prompt area. -# -# Arguments: -# w - The text window in which to insert the string -# s - The string to insert (usually just a single character) - -proc ::tk::ConsoleInsert {w s} { - if {[string equal $s ""]} { - return - } - catch { - if {[$w compare sel.first <= insert] - && [$w compare sel.last >= insert]} { - $w tag remove sel sel.first promptEnd - $w delete sel.first sel.last - } - } - if {[$w compare insert < promptEnd]} { - $w mark set insert end - } - $w insert insert $s {input stdin} - $w see insert -} - -# ::tk::ConsoleOutput -- -# -# This routine is called directly by ConsolePutsCmd to cause a string -# to be displayed in the console. -# -# Arguments: -# dest - The output tag to be used: either "stderr" or "stdout". -# string - The string to be displayed. - -proc ::tk::ConsoleOutput {dest string} { - set w .console - $w insert output $string $dest - ::tk::console::ConstrainBuffer $w $::tk::console::maxLines - $w see insert -} - -# ::tk::ConsoleExit -- -# -# This routine is called by ConsoleEventProc when the main window of -# the application is destroyed. Don't call exit - that probably already -# happened. Just delete our window. -# -# Arguments: -# None. - -proc ::tk::ConsoleExit {} { - destroy . -} - -# ::tk::ConsoleAbout -- -# -# This routine displays an About box to show Tcl/Tk version info. -# -# Arguments: -# None. - -proc ::tk::ConsoleAbout {} { - tk_messageBox -type ok -message "[mc {Tcl for Windows}] - -Tcl $::tcl_patchLevel -Tk $::tk_patchLevel" -} - -# ::tk::console::TagProc -- -# -# Tags a procedure in the console if it's recognized -# This procedure is not perfect. However, making it perfect wastes -# too much CPU time... -# -# Arguments: -# w - console text widget - -proc ::tk::console::TagProc w { - if {!$::tk::console::magicKeys} { return } - set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]" - set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c] - if {$i == ""} {set i promptEnd} else {append i +2c} - regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c - if {[llength [EvalAttached [list info commands $c]]]} { - $w tag add proc $i "insert-1c wordend" - } else { - $w tag remove proc $i "insert-1c wordend" - } - if {[llength [EvalAttached [list info vars $c]]]} { - $w tag add var $i "insert-1c wordend" - } else { - $w tag remove var $i "insert-1c wordend" - } -} - -# ::tk::console::MatchPair -- -# -# Blinks a matching pair of characters -# c2 is assumed to be at the text index 'insert'. -# This proc is really loopy and took me an hour to figure out given -# all possible combinations with escaping except for escaped \'s. -# It doesn't take into account possible commenting... Oh well. If -# anyone has something better, I'd like to see/use it. This is really -# only efficient for small contexts. -# -# Arguments: -# w - console text widget -# c1 - first char of pair -# c2 - second char of pair -# -# Calls: ::tk::console::Blink - -proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} { - if {!$::tk::console::magicKeys} { return } - if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { - while { - [string match {\\} [$w get $ix-1c]] && - [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]] - } {} - set i1 insert-1c - while {[string compare {} $ix]} { - set i0 $ix - set j 0 - while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} { - append i0 +1c - if {[string match {\\} [$w get $i0-2c]]} continue - incr j - } - if {!$j} break - set i1 $ix - while {$j && [string compare {} \ - [set ix [$w search -back $c1 $ix $lim]]]} { - if {[string match {\\} [$w get $ix-1c]]} continue - incr j -1 - } - } - if {[string match {} $ix]} { set ix [$w index $lim] } - } else { set ix [$w index $lim] } - if {$::tk::console::blinkRange} { - Blink $w $ix [$w index insert] - } else { - Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert] - } -} - -# ::tk::console::MatchQuote -- -# -# Blinks between matching quotes. -# Blinks just the quote if it's unmatched, otherwise blinks quoted string -# The quote to match is assumed to be at the text index 'insert'. -# -# Arguments: -# w - console text widget -# -# Calls: ::tk::console::Blink - -proc ::tk::console::MatchQuote {w {lim 1.0}} { - if {!$::tk::console::magicKeys} { return } - set i insert-1c - set j 0 - while {[string compare [set i [$w search -back \" $i $lim]] {}]} { - if {[string match {\\} [$w get $i-1c]]} continue - if {!$j} {set i0 $i} - incr j - } - if {$j&1} { - if {$::tk::console::blinkRange} { - Blink $w $i0 [$w index insert] - } else { - Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert] - } - } else { - Blink $w [$w index insert-1c] [$w index insert] - } -} - -# ::tk::console::Blink -- -# -# Blinks between n index pairs for a specified duration. -# -# Arguments: -# w - console text widget -# i1 - start index to blink region -# i2 - end index of blink region -# dur - duration in usecs to blink for -# -# Outputs: -# blinks selected characters in $w - -proc ::tk::console::Blink {w args} { - eval [list $w tag add blink] $args - after $::tk::console::blinkTime [list $w] tag remove blink $args -} - -# ::tk::console::ConstrainBuffer -- -# -# This limits the amount of data in the text widget -# Called by Prompt and ConsoleOutput -# -# Arguments: -# w - console text widget -# size - # of lines to constrain to -# -# Outputs: -# may delete data in console widget - -proc ::tk::console::ConstrainBuffer {w size} { - if {[$w index end] > $size} { - $w delete 1.0 [expr {int([$w index end])-$size}].0 - } -} - -# ::tk::console::Expand -- -# -# Arguments: -# ARGS: w - text widget in which to expand str -# type - type of expansion (path / proc / variable) -# -# Calls: ::tk::console::Expand(Pathname|Procname|Variable) -# -# Outputs: The string to match is expanded to the longest possible match. -# If ::tk::console::showMatches is non-zero and the longest match -# equaled the string to expand, then all possible matches are -# output to stdout. Triggers bell if no matches are found. -# -# Returns: number of matches found - -proc ::tk::console::Expand {w {type ""}} { - set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]" - set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c] - if {$tmp == ""} {set tmp promptEnd} else {append tmp +2c} - if {[$w compare $tmp >= insert]} { return } - set str [$w get $tmp insert] - switch -glob $type { - path* { set res [ExpandPathname $str] } - proc* { set res [ExpandProcname $str] } - var* { set res [ExpandVariable $str] } - default { - set res {} - foreach t {Pathname Procname Variable} { - if {![catch {Expand$t $str} res] && ($res != "")} { break } - } - } - } - set len [llength $res] - if {$len} { - set repl [lindex $res 0] - $w delete $tmp insert - $w insert $tmp $repl {input stdin} - if {($len > 1) && $::tk::console::showMatches \ - && [string equal $repl $str]} { - puts stdout [lsort [lreplace $res 0 0]] - } - } else { bell } - return [incr len -1] -} - -# ::tk::console::ExpandPathname -- -# -# Expand a file pathname based on $str -# This is based on UNIX file name conventions -# -# Arguments: -# str - partial file pathname to expand -# -# Calls: ::tk::console::ExpandBestMatch -# -# Returns: list containing longest unique match followed by all the -# possible further matches - -proc ::tk::console::ExpandPathname str { - set pwd [EvalAttached pwd] - if {[catch {EvalAttached [list cd [file dirname $str]]} err]} { - return -code error $err - } - set dir [file tail $str] - ## Check to see if it was known to be a directory and keep the trailing - ## slash if so (file tail cuts it off) - if {[string match */ $str]} { append dir / } - if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} { - set match {} - } else { - if {[llength $m] > 1} { - global tcl_platform - if {[string match windows $tcl_platform(platform)]} { - ## Windows is screwy because it's case insensitive - set tmp [ExpandBestMatch [string tolower $m] \ - [string tolower $dir]] - ## Don't change case if we haven't changed the word - if {[string length $dir]==[string length $tmp]} { - set tmp $dir - } - } else { - set tmp [ExpandBestMatch $m $dir] - } - if {[string match ?*/* $str]} { - set tmp [file dirname $str]/$tmp - } elseif {[string match /* $str]} { - set tmp /$tmp - } - regsub -all { } $tmp {\\ } tmp - set match [linsert $m 0 $tmp] - } else { - ## This may look goofy, but it handles spaces in path names - eval append match $m - if {[file isdir $match]} {append match /} - if {[string match ?*/* $str]} { - set match [file dirname $str]/$match - } elseif {[string match /* $str]} { - set match /$match - } - regsub -all { } $match {\\ } match - ## Why is this one needed and the ones below aren't!! - set match [list $match] - } - } - EvalAttached [list cd $pwd] - return $match -} - -# ::tk::console::ExpandProcname -- -# -# Expand a tcl proc name based on $str -# -# Arguments: -# str - partial proc name to expand -# -# Calls: ::tk::console::ExpandBestMatch -# -# Returns: list containing longest unique match followed by all the -# possible further matches - -proc ::tk::console::ExpandProcname str { - set match [EvalAttached [list info commands $str*]] - if {[llength $match] == 0} { - set ns [EvalAttached \ - "namespace children \[namespace current\] [list $str*]"] - if {[llength $ns]==1} { - set match [EvalAttached [list info commands ${ns}::*]] - } else { - set match $ns - } - } - if {[llength $match] > 1} { - regsub -all { } [ExpandBestMatch $match $str] {\\ } str - set match [linsert $match 0 $str] - } else { - regsub -all { } $match {\\ } match - } - return $match -} - -# ::tk::console::ExpandVariable -- -# -# Expand a tcl variable name based on $str -# -# Arguments: -# str - partial tcl var name to expand -# -# Calls: ::tk::console::ExpandBestMatch -# -# Returns: list containing longest unique match followed by all the -# possible further matches - -proc ::tk::console::ExpandVariable str { - if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { - ## Looks like they're trying to expand an array. - set match [EvalAttached [list array names $ary $str*]] - if {[llength $match] > 1} { - set vars $ary\([ExpandBestMatch $match $str] - foreach var $match {lappend vars $ary\($var\)} - return $vars - } else {set match $ary\($match\)} - ## Space transformation avoided for array names. - } else { - set match [EvalAttached [list info vars $str*]] - if {[llength $match] > 1} { - regsub -all { } [ExpandBestMatch $match $str] {\\ } str - set match [linsert $match 0 $str] - } else { - regsub -all { } $match {\\ } match - } - } - return $match -} - -# ::tk::console::ExpandBestMatch -- -# -# Finds the best unique match in a list of names. -# The extra $e in this argument allows us to limit the innermost loop a little -# further. This improves speed as $l becomes large or $e becomes long. -# -# Arguments: -# l - list to find best unique match in -# e - currently best known unique match -# -# Returns: longest unique match in the list - -proc ::tk::console::ExpandBestMatch {l {e {}}} { - set ec [lindex $l 0] - if {[llength $l]>1} { - set e [string length $e]; incr e -1 - set ei [string length $ec]; incr ei -1 - foreach l $l { - while {$ei>=$e && [string first $ec $l]} { - set ec [string range $ec 0 [incr ei -1]] - } - } - } - return $ec -} - -# now initialize the console -::tk::ConsoleInit diff --git a/tcl/library/dde1.0/pkgIndex.tcl b/tcl/library/dde1.0/pkgIndex.tcl deleted file mode 100755 index 62777593152..00000000000 --- a/tcl/library/dde1.0/pkgIndex.tcl +++ /dev/null @@ -1 +0,0 @@ -package ifneeded dde 1.0 "load [list [file join $dir tcldde81.dll]] dde"
diff --git a/tcl/library/dde1.1/pkgIndex.tcl b/tcl/library/dde1.1/pkgIndex.tcl deleted file mode 100644 index f818736326f..00000000000 --- a/tcl/library/dde1.1/pkgIndex.tcl +++ /dev/null @@ -1,5 +0,0 @@ -if {[info exists tcl_platform(debug)]} { - package ifneeded dde 1.1 [list load [file join $dir tcldde83d.dll] dde] -} else { - package ifneeded dde 1.1 [list load [file join $dir tcldde83.dll] dde] -} diff --git a/tcl/library/demos/README b/tcl/library/demos/README deleted file mode 100644 index b8dd11f60fa..00000000000 --- a/tcl/library/demos/README +++ /dev/null @@ -1,46 +0,0 @@ -This directory contains a collection of programs to demonstrate -the features of the Tk toolkit. The programs are all scripts for -"wish", a windowing shell. If wish has been installed in /usr/local -then you can invoke any of the programs in this directory just -by typing its file name to your command shell. Otherwise invoke -wish with the file as its first argument, e.g., "wish hello". -The rest of this file contains a brief description of each program. -Files with names ending in ".tcl" are procedure packages used by one -or more of the demo programs; they can't be used as programs by -themselves so they aren't described below. - -hello - Creates a single button; if you click on it, a message - is typed and the application terminates. - -widget - Contains a collection of demonstrations of the widgets - currently available in the Tk library. Most of the .tcl - files are scripts for individual demos available through - the "widget" program. - -ixset - A simple Tk-based wrapper for the "xset" program, which - allows you to interactively query and set various X options - such as mouse acceleration and bell volume. Thanks to - Pierre David for contributing this example. - -rolodex - A mock-up of a simple rolodex application. It has much of - the user interface for such an application but no back-end - database. This program was written in response to Tom - LaStrange's toolkit benchmark challenge. - -tcolor - A color editor. Allows you to edit colors in several - different ways, and will also perform automatic updates - using "send". - -rmt - Allows you to "hook-up" remotely to any Tk application - on the display. Select an application with the menu, - then just type commands: they'll go to that application. - -timer - Displays a seconds timer with start and stop buttons. - Control-c and control-q cause it to exit. - -browse - A simple directory browser. Invoke it with and argument - giving the name of the directory you'd like to browse. - Double-click on files or subdirectories to browse them. - Control-c and control-q cause the program to exit. - -RCS: @(#) $Id$ diff --git a/tcl/library/demos/arrow.tcl b/tcl/library/demos/arrow.tcl deleted file mode 100644 index c2d0d4b7e9e..00000000000 --- a/tcl/library/demos/arrow.tcl +++ /dev/null @@ -1,239 +0,0 @@ -# arrow.tcl -- -# -# This demonstration script creates a canvas widget that displays a -# large line with an arrowhead whose shape can be edited interactively. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -# arrowSetup -- -# This procedure regenerates all the text and graphics in the canvas -# window. It's called when the canvas is initially created, and also -# whenever any of the parameters of the arrow head are changed -# interactively. -# -# Arguments: -# c - Name of the canvas widget. - -proc arrowSetup c { - upvar #0 demo_arrowInfo v - - # Remember the current box, if there is one. - - set tags [$c gettags current] - if {$tags != ""} { - set cur [lindex $tags [lsearch -glob $tags box?]] - } else { - set cur "" - } - - # Create the arrow and outline. - - $c delete all - eval {$c create line $v(x1) $v(y) $v(x2) $v(y) -arrow last \ - -width [expr {10*$v(width)}] -arrowshape [list \ - [expr {10*$v(a)}] [expr {10*$v(b)}] [expr {10*$v(c)}]]} \ - $v(bigLineStyle) - set xtip [expr {$v(x2)-10*$v(b)}] - set deltaY [expr {10*$v(c)+5*$v(width)}] - $c create line $v(x2) $v(y) $xtip [expr {$v(y)+$deltaY}] \ - [expr {$v(x2)-10*$v(a)}] $v(y) $xtip [expr {$v(y)-$deltaY}] \ - $v(x2) $v(y) -width 2 -capstyle round -joinstyle round - - # Create the boxes for reshaping the line and arrowhead. - - eval {$c create rect [expr {$v(x2)-10*$v(a)-5}] [expr {$v(y)-5}] \ - [expr {$v(x2)-10*$v(a)+5}] [expr {$v(y)+5}] \ - -tags {box1 box}} $v(boxStyle) - eval {$c create rect [expr {$xtip-5}] [expr {$v(y)-$deltaY-5}] \ - [expr {$xtip+5}] [expr {$v(y)-$deltaY+5}] \ - -tags {box2 box}} $v(boxStyle) - eval {$c create rect [expr {$v(x1)-5}] [expr {$v(y)-5*$v(width)-5}] \ - [expr {$v(x1)+5}] [expr {$v(y)-5*$v(width)+5}] \ - -tags {box3 box}} $v(boxStyle) - if {$cur != ""} { - eval $c itemconfigure $cur $v(activeStyle) - } - - # Create three arrows in actual size with the same parameters - - $c create line [expr {$v(x2)+50}] 0 [expr {$v(x2)+50}] 1000 \ - -width 2 - set tmp [expr {$v(x2)+100}] - $c create line $tmp [expr {$v(y)-125}] $tmp [expr {$v(y)-75}] \ - -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - $c create line [expr {$tmp-25}] $v(y) [expr {$tmp+25}] $v(y) \ - -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - $c create line [expr {$tmp-25}] [expr {$v(y)+75}] [expr {$tmp+25}] \ - [expr {$v(y)+125}] -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - - # Create a bunch of other arrows and text items showing the - # current dimensions. - - set tmp [expr {$v(x2)+10}] - $c create line $tmp [expr {$v(y)-5*$v(width)}] \ - $tmp [expr {$v(y)-$deltaY}] \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x2)+15}] [expr {$v(y)-$deltaY+5*$v(c)}] \ - -text $v(c) -anchor w - set tmp [expr {$v(x1)-10}] - $c create line $tmp [expr {$v(y)-5*$v(width)}] \ - $tmp [expr {$v(y)+5*$v(width)}] \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x1)-15}] $v(y) -text $v(width) -anchor e - set tmp [expr {$v(y)+5*$v(width)+10*$v(c)+10}] - $c create line [expr {$v(x2)-10*$v(a)}] $tmp $v(x2) $tmp \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x2)-5*$v(a)}] [expr {$tmp+5}] \ - -text $v(a) -anchor n - set tmp [expr {$tmp+25}] - $c create line [expr {$v(x2)-10*$v(b)}] $tmp $v(x2) $tmp \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x2)-5*$v(b)}] [expr {$tmp+5}] \ - -text $v(b) -anchor n - - $c create text $v(x1) 310 -text "-width $v(width)" \ - -anchor w -font {Helvetica 18} - $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \ - -anchor w -font {Helvetica 18} - - incr v(count) -} - -set w .arrow -global tk_library -catch {destroy $w} -toplevel $w -wm title $w "Arrowhead Editor Demonstration" -wm iconname $w "arrow" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 5i -justify left -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a canvas line item." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -canvas $c -width 500 -height 350 -relief sunken -borderwidth 2 -pack $c -expand yes -fill both - -set demo_arrowInfo(a) 8 -set demo_arrowInfo(b) 10 -set demo_arrowInfo(c) 3 -set demo_arrowInfo(width) 2 -set demo_arrowInfo(motionProc) arrowMoveNull -set demo_arrowInfo(x1) 40 -set demo_arrowInfo(x2) 350 -set demo_arrowInfo(y) 150 -set demo_arrowInfo(smallTips) {5 5 2} -set demo_arrowInfo(count) 0 -if {[winfo depth $c] > 1} { - set demo_arrowInfo(bigLineStyle) "-fill SkyBlue1" - set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" - set demo_arrowInfo(activeStyle) "-fill red -outline black -width 1" -} else { - set demo_arrowInfo(bigLineStyle) "-fill black \ - -stipple @[file join $tk_library demos images grey.25]" - set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" - set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1" -} -arrowSetup $c -$c bind box <Enter> "$c itemconfigure current $demo_arrowInfo(activeStyle)" -$c bind box <Leave> "$c itemconfigure current $demo_arrowInfo(boxStyle)" -$c bind box <B1-Enter> " " -$c bind box <B1-Leave> " " -$c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1} -$c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2} -$c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3} -$c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y" -bind $c <Any-ButtonRelease-1> "arrowSetup $c" - -# arrowMove1 -- -# This procedure is called for each mouse motion event on box1 (the -# one at the vertex of the arrow). It updates the controlling parameters -# for the line and arrowhead. -# -# Arguments: -# c - The name of the canvas window. -# x, y - The coordinates of the mouse. - -proc arrowMove1 {c x y} { - upvar #0 demo_arrowInfo v - set newA [expr {($v(x2)+5-round([$c canvasx $x]))/10}] - if {$newA < 0} { - set newA 0 - } - if {$newA > 25} { - set newA 25 - } - if {$newA != $v(a)} { - $c move box1 [expr {10*($v(a)-$newA)}] 0 - set v(a) $newA - } -} - -# arrowMove2 -- -# This procedure is called for each mouse motion event on box2 (the -# one at the trailing tip of the arrowhead). It updates the controlling -# parameters for the line and arrowhead. -# -# Arguments: -# c - The name of the canvas window. -# x, y - The coordinates of the mouse. - -proc arrowMove2 {c x y} { - upvar #0 demo_arrowInfo v - set newB [expr {($v(x2)+5-round([$c canvasx $x]))/10}] - if {$newB < 0} { - set newB 0 - } - if {$newB > 25} { - set newB 25 - } - set newC [expr {($v(y)+5-round([$c canvasy $y])-5*$v(width))/10}] - if {$newC < 0} { - set newC 0 - } - if {$newC > 20} { - set newC 20 - } - if {($newB != $v(b)) || ($newC != $v(c))} { - $c move box2 [expr {10*($v(b)-$newB)}] [expr {10*($v(c)-$newC)}] - set v(b) $newB - set v(c) $newC - } -} - -# arrowMove3 -- -# This procedure is called for each mouse motion event on box3 (the -# one that controls the thickness of the line). It updates the -# controlling parameters for the line and arrowhead. -# -# Arguments: -# c - The name of the canvas window. -# x, y - The coordinates of the mouse. - -proc arrowMove3 {c x y} { - upvar #0 demo_arrowInfo v - set newWidth [expr {($v(y)+2-round([$c canvasy $y]))/5}] - if {$newWidth < 0} { - set newWidth 0 - } - if {$newWidth > 20} { - set newWidth 20 - } - if {$newWidth != $v(width)} { - $c move box3 0 [expr {5*($v(width)-$newWidth)}] - set v(width) $newWidth - } -} diff --git a/tcl/library/demos/bind.tcl b/tcl/library/demos/bind.tcl deleted file mode 100644 index c2b2a2eb462..00000000000 --- a/tcl/library/demos/bind.tcl +++ /dev/null @@ -1,79 +0,0 @@ -# bind.tcl -- -# -# This demonstration script creates a text widget with bindings set -# up for hypertext-like effects. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .bind -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Tag Bindings" -wm iconname $w "bind" -positionWindow $w - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ - -width 60 -height 24 -font $font -wrap word -scrollbar $w.scroll -command "$w.text yview" -pack $w.scroll -side right -fill y -pack $w.text -expand yes -fill both - -# Set up display styles. - -if {[winfo depth $w] > 1} { - set bold "-background #43ce80 -relief raised -borderwidth 1" - set normal "-background {} -relief flat" -} else { - set bold "-foreground white -background black" - set normal "-foreground {} -background {}" -} - -# Add text to widget. - -$w.text insert 0.0 {\ -The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 1 over a description then that particular demonstration is invoked. - -} -$w.text insert end \ -{1. Samples of all the different types of items that can be created in canvas widgets.} d1 -$w.text insert end \n\n -$w.text insert end \ -{2. A simple two-dimensional plot that allows you to adjust the positions of the data points.} d2 -$w.text insert end \n\n -$w.text insert end \ -{3. Anchoring and justification modes for text items.} d3 -$w.text insert end \n\n -$w.text insert end \ -{4. An editor for arrow-head shapes for line items.} d4 -$w.text insert end \n\n -$w.text insert end \ -{5. A ruler with facilities for editing tab stops.} d5 -$w.text insert end \n\n -$w.text insert end \ -{6. A grid that demonstrates how canvases can be scrolled.} d6 - -# Create bindings for tags. - -foreach tag {d1 d2 d3 d4 d5 d6} { - $w.text tag bind $tag <Any-Enter> "$w.text tag configure $tag $bold" - $w.text tag bind $tag <Any-Leave> "$w.text tag configure $tag $normal" -} -$w.text tag bind d1 <1> {source [file join $tk_library demos items.tcl]} -$w.text tag bind d2 <1> {source [file join $tk_library demos plot.tcl]} -$w.text tag bind d3 <1> {source [file join $tk_library demos ctext.tcl]} -$w.text tag bind d4 <1> {source [file join $tk_library demos arrow.tcl]} -$w.text tag bind d5 <1> {source [file join $tk_library demos ruler.tcl]} -$w.text tag bind d6 <1> {source [file join $tk_library demos cscroll.tcl]} - -$w.text mark set insert 0.0 -$w.text configure -state disabled diff --git a/tcl/library/demos/bitmap.tcl b/tcl/library/demos/bitmap.tcl deleted file mode 100644 index e69187eb40d..00000000000 --- a/tcl/library/demos/bitmap.tcl +++ /dev/null @@ -1,55 +0,0 @@ -# bitmap.tcl -- -# -# This demonstration script creates a toplevel window that displays -# all of Tk's built-in bitmaps. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -# bitmapRow -- -# Create a row of bitmap items in a window. -# -# Arguments: -# w - The window that is to contain the row. -# args - The names of one or more bitmaps, which will be displayed -# in a new row across the bottom of w along with their -# names. - -proc bitmapRow {w args} { - frame $w - pack $w -side top -fill both - set i 0 - foreach bitmap $args { - frame $w.$i - pack $w.$i -side left -fill both -pady .25c -padx .25c - label $w.$i.bitmap -bitmap $bitmap - label $w.$i.label -text $bitmap -width 9 - pack $w.$i.label $w.$i.bitmap -side bottom - incr i - } -} - -set w .bitmap -global tk_library -catch {destroy $w} -toplevel $w -wm title $w "Bitmap Demonstration" -wm iconname $w "bitmap" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.frame -bitmapRow $w.frame.0 error gray12 gray25 gray50 gray75 -bitmapRow $w.frame.1 hourglass info question questhead warning -pack $w.frame -side top -expand yes -fill both diff --git a/tcl/library/demos/browse b/tcl/library/demos/browse deleted file mode 100644 index 3ec0366d588..00000000000 --- a/tcl/library/demos/browse +++ /dev/null @@ -1,66 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish "$0" ${1+"$@"} - -# browse -- -# This script generates a directory browser, which lists the working -# directory and allows you to open files or subdirectories by -# double-clicking. -# -# RCS: @(#) $Id$ - -# Create a scrollbar on the right side of the main window and a listbox -# on the left side. - -scrollbar .scroll -command ".list yview" -pack .scroll -side right -fill y -listbox .list -yscroll ".scroll set" -relief sunken -width 20 -height 20 \ - -setgrid yes -pack .list -side left -fill both -expand yes -wm minsize . 1 1 - -# The procedure below is invoked to open a browser on a given file; if the -# file is a directory then another instance of this program is invoked; if -# the file is a regular file then the Mx editor is invoked to display -# the file. - -set browseScript [file join [pwd] $argv0] -proc browse {dir file} { - global env browseScript - if {[string compare $dir "."] != 0} {set file $dir/$file} - switch [file type $file] { - directory { - exec [info nameofexecutable] $browseScript $file & - } - file { - if {[info exists env(EDITOR)]} { - eval exec $env(EDITOR) $file & - } else { - exec xedit $file & - } - } - default { - puts stdout "\"$file\" isn't a directory or regular file" - } - } -} - -# Fill the listbox with a list of all the files in the directory. - -if {$argc>0} {set dir [lindex $argv 0]} else {set dir "."} -foreach i [lsort [glob * .* *.*]] { - if {[file type $i] eq "directory"} { - # Safe to do since it is still a directory. - append i / - } - .list insert end $i -} - -# Set up bindings for the browser. - -bind all <Control-c> {destroy .} -bind .list <Double-Button-1> {foreach i [selection get] {browse $dir $i}} - -# Local Variables: -# mode: tcl -# End: diff --git a/tcl/library/demos/button.tcl b/tcl/library/demos/button.tcl deleted file mode 100644 index fe00a1c99cb..00000000000 --- a/tcl/library/demos/button.tcl +++ /dev/null @@ -1,36 +0,0 @@ -# button.tcl -- -# -# This demonstration script creates a toplevel window containing -# several button widgets. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .button -catch {destroy $w} -toplevel $w -wm title $w "Button Demonstration" -wm iconname $w "button" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "If you click on any of the four buttons below, the background of the button area will change to the color indicated in the button. You can press Tab to move among the buttons, then press Space to invoke the current button." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -button $w.b1 -text "Peach Puff" -width 10 \ - -command "$w config -bg PeachPuff1; $w.buttons config -bg PeachPuff1" -button $w.b2 -text "Light Blue" -width 10 \ - -command "$w config -bg LightBlue1; $w.buttons config -bg LightBlue1" -button $w.b3 -text "Sea Green" -width 10 \ - -command "$w config -bg SeaGreen2; $w.buttons config -bg SeaGreen2" -button $w.b4 -text "Yellow" -width 10 \ - -command "$w config -bg Yellow1; $w.buttons config -bg Yellow1" -pack $w.b1 $w.b2 $w.b3 $w.b4 -side top -expand yes -pady 2 diff --git a/tcl/library/demos/check.tcl b/tcl/library/demos/check.tcl deleted file mode 100644 index f863b5796c7..00000000000 --- a/tcl/library/demos/check.tcl +++ /dev/null @@ -1,33 +0,0 @@ -# check.tcl -- -# -# This demonstration script creates a toplevel window containing -# several checkbuttons. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .check -catch {destroy $w} -toplevel $w -wm title $w "Checkbutton Demonstration" -wm iconname $w "check" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Three checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. Click the \"See Variables\" button to see the current values of the variables." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -button $w.buttons.vars -text "See Variables" \ - -command "showVars $w.dialog wipers brakes sober" -pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 - -checkbutton $w.b1 -text "Wipers OK" -variable wipers -relief flat -checkbutton $w.b2 -text "Brakes OK" -variable brakes -relief flat -checkbutton $w.b3 -text "Driver Sober" -variable sober -relief flat -pack $w.b1 $w.b2 $w.b3 -side top -pady 2 -anchor w diff --git a/tcl/library/demos/clrpick.tcl b/tcl/library/demos/clrpick.tcl deleted file mode 100644 index 983cbe1deb4..00000000000 --- a/tcl/library/demos/clrpick.tcl +++ /dev/null @@ -1,56 +0,0 @@ -# clrpick.tcl -- -# -# This demonstration script prompts the user to select a color. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .clrpick -catch {destroy $w} -toplevel $w -wm title $w "Color Selection Dialog" -wm iconname $w "colors" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Press the buttons below to choose the foreground and background colors for the widgets in this window." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -button $w.back -text "Set background color ..." \ - -command \ - "setColor $w $w.back background {-background -highlightbackground}" -button $w.fore -text "Set foreground color ..." \ - -command \ - "setColor $w $w.back foreground -foreground" - -pack $w.back $w.fore -side top -anchor c -pady 2m - -proc setColor {w button name options} { - grab $w - set initialColor [$button cget -$name] - set color [tk_chooseColor -title "Choose a $name color" -parent $w \ - -initialcolor $initialColor] - if {[string compare $color ""]} { - setColor_helper $w $options $color - } - grab release $w -} - -proc setColor_helper {w options color} { - foreach option $options { - catch { - $w config $option $color - } - } - foreach child [winfo children $w] { - setColor_helper $child $options $color - } -} diff --git a/tcl/library/demos/colors.tcl b/tcl/library/demos/colors.tcl deleted file mode 100644 index aad1d1dde45..00000000000 --- a/tcl/library/demos/colors.tcl +++ /dev/null @@ -1,101 +0,0 @@ -# colors.tcl -- -# -# This demonstration script creates a listbox widget that displays -# many of the colors from the X color database. You can click on -# a color to change the application's palette. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .colors -catch {destroy $w} -toplevel $w -wm title $w "Listbox Demonstration (colors)" -wm iconname $w "Listbox" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing several color names is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the application's color palette will be set to match that color" -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.frame -borderwidth 10 -pack $w.frame -side top -expand yes -fill y - -scrollbar $w.frame.scroll -command "$w.frame.list yview" -listbox $w.frame.list -yscroll "$w.frame.scroll set" \ - -width 20 -height 16 -setgrid 1 -pack $w.frame.list $w.frame.scroll -side left -fill y -expand 1 - -bind $w.frame.list <Double-1> { - tk_setPalette [selection get] -} -$w.frame.list insert 0 gray60 gray70 gray80 gray85 gray90 gray95 \ - snow1 snow2 snow3 snow4 seashell1 seashell2 \ - seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \ - AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \ - PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \ - NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \ - LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \ - cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \ - honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \ - LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \ - MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \ - SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \ - RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \ - DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \ - SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \ - DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \ - SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \ - LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \ - LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \ - LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \ - LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \ - PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \ - CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \ - turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \ - DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \ - DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \ - aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \ - DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \ - PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \ - SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \ - green3 green4 chartreuse1 chartreuse2 chartreuse3 \ - chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \ - DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \ - DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \ - LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \ - LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \ - LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \ - gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \ - DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \ - RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \ - IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \ - sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \ - wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \ - chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \ - firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \ - salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \ - LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \ - DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \ - coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \ - OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \ - red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 \ - HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 \ - LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 \ - PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 \ - maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \ - VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \ - orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \ - MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \ - DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \ - purple2 purple3 purple4 MediumPurple1 MediumPurple2 \ - MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \ - thistle4 diff --git a/tcl/library/demos/cscroll.tcl b/tcl/library/demos/cscroll.tcl deleted file mode 100644 index aeabc181662..00000000000 --- a/tcl/library/demos/cscroll.tcl +++ /dev/null @@ -1,96 +0,0 @@ -# cscroll.tcl -- -# -# This demonstration script creates a simple canvas that can be -# scrolled in two dimensions. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .cscroll -catch {destroy $w} -toplevel $w -wm title $w "Scrollable Canvas Demonstration" -wm iconname $w "cscroll" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.grid -scrollbar $w.hscroll -orient horiz -command "$c xview" -scrollbar $w.vscroll -command "$c yview" -canvas $c -relief sunken -borderwidth 2 -scrollregion {-11c -11c 50c 20c} \ - -xscrollcommand "$w.hscroll set" \ - -yscrollcommand "$w.vscroll set" -pack $w.grid -expand yes -fill both -padx 1 -pady 1 -grid rowconfig $w.grid 0 -weight 1 -minsize 0 -grid columnconfig $w.grid 0 -weight 1 -minsize 0 - -grid $c -padx 1 -in $w.grid -pady 1 \ - -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid $w.vscroll -in $w.grid -padx 1 -pady 1 \ - -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -grid $w.hscroll -in $w.grid -padx 1 -pady 1 \ - -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news - - -set bg [lindex [$c config -bg] 4] -for {set i 0} {$i < 20} {incr i} { - set x [expr {-10 + 3*$i}] - for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { - $c create rect ${x}c ${y}c [expr {$x+2}]c [expr {$y+2}]c \ - -outline black -fill $bg -tags rect - $c create text [expr {$x+1}]c [expr {$y+1}]c -text "$i,$j" \ - -anchor center -tags text - } -} - -$c bind all <Any-Enter> "scrollEnter $c" -$c bind all <Any-Leave> "scrollLeave $c" -$c bind all <1> "scrollButton $c" -bind $c <2> "$c scan mark %x %y" -bind $c <B2-Motion> "$c scan dragto %x %y" - -proc scrollEnter canvas { - global oldFill - set id [$canvas find withtag current] - if {[lsearch [$canvas gettags current] text] >= 0} { - set id [expr {$id-1}] - } - set oldFill [lindex [$canvas itemconfig $id -fill] 4] - if {[winfo depth $canvas] > 1} { - $canvas itemconfigure $id -fill SeaGreen1 - } else { - $canvas itemconfigure $id -fill black - $canvas itemconfigure [expr {$id+1}] -fill white - } -} - -proc scrollLeave canvas { - global oldFill - set id [$canvas find withtag current] - if {[lsearch [$canvas gettags current] text] >= 0} { - set id [expr {$id-1}] - } - $canvas itemconfigure $id -fill $oldFill - $canvas itemconfigure [expr {$id+1}] -fill black -} - -proc scrollButton canvas { - global oldFill - set id [$canvas find withtag current] - if {[lsearch [$canvas gettags current] text] < 0} { - set id [expr {$id+1}] - } - puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]" -} diff --git a/tcl/library/demos/ctext.tcl b/tcl/library/demos/ctext.tcl deleted file mode 100644 index d5efcc3da23..00000000000 --- a/tcl/library/demos/ctext.tcl +++ /dev/null @@ -1,147 +0,0 @@ -# ctext.tcl -- -# -# This demonstration script creates a canvas widget with a text -# item that can be edited and reconfigured in various ways. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .ctext -catch {destroy $w} -toplevel $w -wm title $w "Canvas Text Demonstration" -wm iconname $w "Text" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 5i -justify left -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification. The text also supports the following simple bindings for editing: - 1. You can point, click, and type. - 2. You can also select with button 1. - 3. You can copy the selection to the mouse position with button 2. - 4. Backspace and Control+h delete the selection if there is one; - otherwise they delete the character just before the insertion cursor. - 5. Delete deletes the selection if there is one; otherwise it deletes - the character just after the insertion cursor." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -canvas $c -relief flat -borderwidth 0 -width 500 -height 350 -pack $w.c -side top -expand yes -fill both - -set textFont {Helvetica 24} - -$c create rectangle 245 195 255 205 -outline black -fill red - -# First, create the text item and give it bindings so it can be edited. - -$c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been been defined to support editing (see above)." -width 440 -anchor n -font {Helvetica 24} -justify left] -$c bind text <1> "textB1Press $c %x %y" -$c bind text <B1-Motion> "textB1Move $c %x %y" -$c bind text <Shift-1> "$c select adjust current @%x,%y" -$c bind text <Shift-B1-Motion> "textB1Move $c %x %y" -$c bind text <KeyPress> "textInsert $c %A" -$c bind text <Return> "textInsert $c \\n" -$c bind text <Control-h> "textBs $c" -$c bind text <BackSpace> "textBs $c" -$c bind text <Delete> "textDel $c" -$c bind text <2> "textPaste $c @%x,%y" - -# Next, create some items that allow the text's anchor position -# to be edited. - -proc mkTextConfig {w x y option value color} { - set item [$w create rect $x $y [expr {$x+30}] [expr {$y+30}] \ - -outline black -fill $color -width 1] - $w bind $item <1> "$w itemconf text $option $value" - $w addtag config withtag $item -} - -set x 50 -set y 50 -set color LightSkyBlue1 -mkTextConfig $c $x $y -anchor se $color -mkTextConfig $c [expr {$x+30}] [expr {$y }] -anchor s $color -mkTextConfig $c [expr {$x+60}] [expr {$y }] -anchor sw $color -mkTextConfig $c [expr {$x }] [expr {$y+30}] -anchor e $color -mkTextConfig $c [expr {$x+30}] [expr {$y+30}] -anchor center $color -mkTextConfig $c [expr {$x+60}] [expr {$y+30}] -anchor w $color -mkTextConfig $c [expr {$x }] [expr {$y+60}] -anchor ne $color -mkTextConfig $c [expr {$x+30}] [expr {$y+60}] -anchor n $color -mkTextConfig $c [expr {$x+60}] [expr {$y+60}] -anchor nw $color -set item [$c create rect \ - [expr {$x+40}] [expr {$y+40}] [expr {$x+50}] [expr {$y+50}] \ - -outline black -fill red] -$c bind $item <1> "$c itemconf text -anchor center" -$c create text [expr {$x+45}] [expr {$y-5}] \ - -text {Text Position} -anchor s -font {Times 24} -fill brown - -# Lastly, create some items that allow the text's justification to be -# changed. - -set x 350 -set y 50 -set color SeaGreen2 -mkTextConfig $c $x $y -justify left $color -mkTextConfig $c [expr {$x+30}] $y -justify center $color -mkTextConfig $c [expr {$x+60}] $y -justify right $color -$c create text [expr {$x+45}] [expr {$y-5}] \ - -text {Justification} -anchor s -font {Times 24} -fill brown - -$c bind config <Enter> "textEnter $c" -$c bind config <Leave> "$c itemconf current -fill \$textConfigFill" - -set textConfigFill {} - -proc textEnter {w} { - global textConfigFill - set textConfigFill [lindex [$w itemconfig current -fill] 4] - $w itemconfig current -fill black -} - -proc textInsert {w string} { - if {$string == ""} { - return - } - catch {$w dchars text sel.first sel.last} - $w insert text insert $string -} - -proc textPaste {w pos} { - catch { - $w insert text $pos [selection get] - } -} - -proc textB1Press {w x y} { - $w icursor current @$x,$y - $w focus current - focus $w - $w select from current @$x,$y -} - -proc textB1Move {w x y} { - $w select to current @$x,$y -} - -proc textBs {w} { - if {![catch {$w dchars text sel.first sel.last}]} { - return - } - set char [expr {[$w index text insert] - 1}] - if {$char >= 0} {$w dchar text $char} -} - -proc textDel {w} { - if {![catch {$w dchars text sel.first sel.last}]} { - return - } - $w dchars text insert -} diff --git a/tcl/library/demos/dialog1.tcl b/tcl/library/demos/dialog1.tcl deleted file mode 100644 index 0a1b48d4974..00000000000 --- a/tcl/library/demos/dialog1.tcl +++ /dev/null @@ -1,15 +0,0 @@ -# dialog1.tcl -- -# -# This demonstration script creates a dialog box with a local grab. -# -# RCS: @(#) $Id$ - -after idle {.dialog1.msg configure -wraplength 4i} -set i [tk_dialog .dialog1 "Dialog with local grab" {This is a modal dialog box. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any pointer-related events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications.} \ -info 0 OK Cancel {Show Code}] - -switch $i { - 0 {puts "You pressed OK"} - 1 {puts "You pressed Cancel"} - 2 {showCode .dialog1} -} diff --git a/tcl/library/demos/dialog2.tcl b/tcl/library/demos/dialog2.tcl deleted file mode 100644 index bc074455b21..00000000000 --- a/tcl/library/demos/dialog2.tcl +++ /dev/null @@ -1,19 +0,0 @@ -# dialog2.tcl -- -# -# This demonstration script creates a dialog box with a global grab. -# -# RCS: @(#) $Id$ - -after idle { - .dialog2.msg configure -wraplength 4i -} -after 100 { - grab -global .dialog2 -} -set i [tk_dialog .dialog2 "Dialog with global grab" {This dialog box uses a global grab, so it prevents you from interacting with anything on your display until you invoke one of the buttons below. Global grabs are almost always a bad idea; don't use them unless you're truly desperate.} warning 0 OK Cancel {Show Code}] - -switch $i { - 0 {puts "You pressed OK"} - 1 {puts "You pressed Cancel"} - 2 {showCode .dialog2} -} diff --git a/tcl/library/demos/entry1.tcl b/tcl/library/demos/entry1.tcl deleted file mode 100644 index 062eb45f489..00000000000 --- a/tcl/library/demos/entry1.tcl +++ /dev/null @@ -1,36 +0,0 @@ -# entry1.tcl -- -# -# This demonstration script creates several entry widgets without -# scrollbars. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .entry1 -catch {destroy $w} -toplevel $w -wm title $w "Entry Demonstration (no scrollbars)" -wm iconname $w "entry1" -positionWindow $w - -label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -entry $w.e1 -entry $w.e2 -entry $w.e3 -pack $w.e1 $w.e2 $w.e3 -side top -pady 5 -padx 10 -fill x - -$w.e1 insert 0 "Initial value" -$w.e2 insert end "This entry contains a long value, much too long " -$w.e2 insert end "to fit in the window at one time, so long in fact " -$w.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/tcl/library/demos/entry2.tcl b/tcl/library/demos/entry2.tcl deleted file mode 100644 index 87a91cb34d7..00000000000 --- a/tcl/library/demos/entry2.tcl +++ /dev/null @@ -1,48 +0,0 @@ -# entry2.tcl -- -# -# This demonstration script is the same as the entry1.tcl script -# except that it creates scrollbars for the entries. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .entry2 -catch {destroy $w} -toplevel $w -wm title $w "Entry Demonstration (with scrollbars)" -wm iconname $w "entry2" -positionWindow $w - -label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with mouse button2 pressed." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.frame -borderwidth 10 -pack $w.frame -side top -fill x -expand 1 - -entry $w.frame.e1 -xscrollcommand "$w.frame.s1 set" -scrollbar $w.frame.s1 -relief sunken -orient horiz -command \ - "$w.frame.e1 xview" -frame $w.frame.spacer1 -width 20 -height 10 -entry $w.frame.e2 -xscrollcommand "$w.frame.s2 set" -scrollbar $w.frame.s2 -relief sunken -orient horiz -command \ - "$w.frame.e2 xview" -frame $w.frame.spacer2 -width 20 -height 10 -entry $w.frame.e3 -xscrollcommand "$w.frame.s3 set" -scrollbar $w.frame.s3 -relief sunken -orient horiz -command \ - "$w.frame.e3 xview" -pack $w.frame.e1 $w.frame.s1 $w.frame.spacer1 $w.frame.e2 $w.frame.s2 \ - $w.frame.spacer2 $w.frame.e3 $w.frame.s3 -side top -fill x - -$w.frame.e1 insert 0 "Initial value" -$w.frame.e2 insert end "This entry contains a long value, much too long " -$w.frame.e2 insert end "to fit in the window at one time, so long in fact " -$w.frame.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/tcl/library/demos/entry3.tcl b/tcl/library/demos/entry3.tcl deleted file mode 100644 index 54ad80fd1a6..00000000000 --- a/tcl/library/demos/entry3.tcl +++ /dev/null @@ -1,187 +0,0 @@ -# entry2.tcl -- -# -# This demonstration script creates several entry widgets whose -# permitted input is constrained in some way. It also shows off a -# password entry. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .entry3 -catch {destroy $w} -toplevel $w -wm title $w "Constrained Entry Demonstration" -wm iconname $w "entry3" -positionWindow $w - - -label $w.msg -font $font -wraplength 5i -justify left -text "Four different\ - entries are displayed below. You can add characters by pointing,\ - clicking and typing, though each is constrained in what it will\ - accept. The first only accepts integers or the empty string\ - (checking when focus leaves it) and will flash to indicate any\ - problem. The second only accepts strings with fewer than ten\ - characters and sounds the bell when an attempt to go over the limit\ - is made. The third accepts US phone numbers, mapping letters to\ - their digit equivalent and sounding the bell on encountering an\ - illegal character or if trying to type over a character that is not\ - a digit. The fourth is a password field that accepts up to eight\ - characters (silently ignoring further ones), and displaying them as\ - asterisk characters." - -frame $w.buttons -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - - -# focusAndFlash -- -# Error handler for entry widgets that forces the focus onto the -# widget and makes the widget flash by exchanging the foreground and -# background colours at intervals of 200ms (i.e. at approximately -# 2.5Hz). -# -# Arguments: -# W - Name of entry widget to flash -# fg - Initial foreground colour -# bg - Initial background colour -# count - Counter to control the number of times flashed - -proc focusAndFlash {W fg bg {count 9}} { - focus -force $W - if {$count<1} { - $W configure -foreground $fg -background $bg - } else { - if {$count%2} { - $W configure -foreground $bg -background $fg - } else { - $W configure -foreground $fg -background $bg - } - after 200 [list focusAndFlash $W $fg $bg [expr {$count-1}]] - } -} - -labelframe $w.l1 -text "Integer Entry" -entry $w.l1.e -validate focus -vcmd {string is integer %P} -$w.l1.e configure -invalidcommand \ - "focusAndFlash %W [$w.l1.e cget -fg] [$w.l1.e cget -bg]" -pack $w.l1.e -fill x -expand 1 -padx 1m -pady 1m - -labelframe $w.l2 -text "Length-Constrained Entry" -entry $w.l2.e -validate key -invcmd bell -vcmd {expr {[string length %P]<10}} -pack $w.l2.e -fill x -expand 1 -padx 1m -pady 1m - -### PHONE NUMBER ENTRY ### -# Note that the source to this is quite a bit longer as the behaviour -# demonstrated is a lot more ambitious than with the others. - -# Initial content for the third entry widget -set entry3content "1-(000)-000-0000" -# Mapping from alphabetic characters to numbers. This is probably -# wrong, but it is the only mapping I have; the UK doesn't really go -# for associating letters with digits for some reason. -set phoneNumberMap {} -foreach {chars digit} {abc 2 def 3 ghi 4 jkl 5 mno 6 pqrs 7 tuv 8 wxyz 9} { - foreach char [split $chars ""] { - lappend phoneNumberMap $char $digit [string toupper $char] $digit - } -} - -# validatePhoneChange -- -# Checks that the replacement (mapped to a digit) of the given -# character in an entry widget at the given position will leave a -# valid phone number in the widget. -# -# W - The entry widget to validate -# vmode - The widget's validation mode -# idx - The index where replacement is to occur -# char - The character (or string, though that will always be -# refused) to be overwritten at that point. - -proc validatePhoneChange {W vmode idx char} { - global phoneNumberMap entry3content - if {$idx == -1} {return 1} - after idle [list $W configure -validate $vmode -invcmd bell] - if { - !($idx<3 || $idx==6 || $idx==7 || $idx==11 || $idx>15) && - [string match {[0-9A-Za-z]} $char] - } then { - $W delete $idx - $W insert $idx [string map $phoneNumberMap $char] - after idle [list phoneSkipRight $W -1] - return 1 - } - return 0 -} - -# phoneSkipLeft -- -# Skip over fixed characters in a phone-number string when moving left. -# -# Arguments: -# W - The entry widget containing the phone-number. - -proc phoneSkipLeft {W} { - set idx [$W index insert] - if {$idx == 8} { - # Skip back two extra characters - $W icursor [incr idx -2] - } elseif {$idx == 7 || $idx == 12} { - # Skip back one extra character - $W icursor [incr idx -1] - } elseif {$idx <= 3} { - # Can't move any further - bell - return -code break - } -} - -# phoneSkipRight -- -# Skip over fixed characters in a phone-number string when moving right. -# -# Arguments: -# W - The entry widget containing the phone-number. -# add - Offset to add to index before calculation (used by validation.) - -proc phoneSkipRight {W {add 0}} { - set idx [$W index insert] - if {$idx+$add == 5} { - # Skip forward two extra characters - $W icursor [incr idx 2] - } elseif {$idx+$add == 6 || $idx+$add == 10} { - # Skip forward one extra character - $W icursor [incr idx] - } elseif {$idx+$add == 15 && !$add} { - # Can't move any further - bell - return -code break - } -} - -labelframe $w.l3 -text "US Phone-Number Entry" -entry $w.l3.e -validate key -invcmd bell -textvariable entry3content \ - -vcmd {validatePhoneChange %W %v %i %S} -# Click to focus goes to the first editable character... -bind $w.l3.e <FocusIn> { - if {"%d" ne "NotifyAncestor"} { - %W icursor 3 - after idle {%W selection clear} - } -} -bind $w.l3.e <Left> {phoneSkipLeft %W} -bind $w.l3.e <Right> {phoneSkipRight %W} -pack $w.l3.e -fill x -expand 1 -padx 1m -pady 1m - -labelframe $w.l4 -text "Password Entry" -entry $w.l4.e -validate key -show "*" -vcmd {expr {[string length %P]<=8}} -pack $w.l4.e -fill x -expand 1 -padx 1m -pady 1m - -lower [frame $w.mid] -grid $w.l1 $w.l2 -in $w.mid -padx 3m -pady 1m -sticky ew -grid $w.l3 $w.l4 -in $w.mid -padx 3m -pady 1m -sticky ew -grid columnconfigure $w.mid {0 1} -uniform 1 -pack $w.msg -side top -pack $w.buttons -side bottom -fill x -pady 2m -pack $w.mid -fill both -expand 1 diff --git a/tcl/library/demos/filebox.tcl b/tcl/library/demos/filebox.tcl deleted file mode 100644 index a0c32a585b7..00000000000 --- a/tcl/library/demos/filebox.tcl +++ /dev/null @@ -1,70 +0,0 @@ -# filebox.tcl -- -# -# This demonstration script prompts the user to select a file. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .filebox -catch {destroy $w} -toplevel $w -wm title $w "File Selection Dialogs" -wm iconname $w "filebox" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -foreach i {open save} { - set f [frame $w.$i] - label $f.lab -text "Select a file to $i: " -anchor e - entry $f.ent -width 20 - button $f.but -text "Browse ..." -command "fileDialog $w $f.ent $i" - pack $f.lab -side left - pack $f.ent -side left -expand yes -fill x - pack $f.but -side left - pack $f -fill x -padx 1c -pady 3 -} - -if {![string compare $tcl_platform(platform) unix]} { - checkbutton $w.strict -text "Use Motif Style Dialog" \ - -variable tk_strictMotif -onvalue 1 -offvalue 0 - pack $w.strict -anchor c -} - -proc fileDialog {w ent operation} { - # Type names Extension(s) Mac File Type(s) - # - #--------------------------------------------------------- - set types { - {"Text files" {.txt .doc} } - {"Text files" {} TEXT} - {"Tcl Scripts" {.tcl} TEXT} - {"C Source Files" {.c .h} } - {"All Source Files" {.tcl .c .h} } - {"Image Files" {.gif} } - {"Image Files" {.jpeg .jpg} } - {"Image Files" "" {GIFF JPEG}} - {"All files" *} - } - if {$operation == "open"} { - set file [tk_getOpenFile -filetypes $types -parent $w] - } else { - set file [tk_getSaveFile -filetypes $types -parent $w \ - -initialfile Untitled -defaultextension .txt] - } - if {[string compare $file ""]} { - $ent delete 0 end - $ent insert 0 $file - $ent xview end - } -} diff --git a/tcl/library/demos/floor.tcl b/tcl/library/demos/floor.tcl deleted file mode 100644 index d488eacea17..00000000000 --- a/tcl/library/demos/floor.tcl +++ /dev/null @@ -1,1370 +0,0 @@ -# floor.tcl -- -# -# This demonstration script creates a canvas widet that displays the -# floorplan for DEC's Western Research Laboratory. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -# floorDisplay -- -# Recreate the floorplan display in the canvas given by "w". The -# floor given by "active" is displayed on top with its office structure -# visible. -# -# Arguments: -# w - Name of the canvas window. -# active - Number of active floor (1, 2, or 3). - -proc floorDisplay {w active} { - global floorLabels floorItems colors activeFloor - - if {$activeFloor == $active} { - return - } - - $w delete all - set activeFloor $active - - # First go through the three floors, displaying the backgrounds for - # each floor. - - bg1 $w $colors(bg1) $colors(outline1) - bg2 $w $colors(bg2) $colors(outline2) - bg3 $w $colors(bg3) $colors(outline3) - - # Raise the background for the active floor so that it's on top. - - $w raise floor$active - - # Create a dummy item just to mark this point in the display list, - # so we can insert highlights here. - - $w create rect 0 100 1 101 -fill {} -outline {} -tags marker - - # Add the walls and labels for the active floor, along with - # transparent polygons that define the rooms on the floor. - # Make sure that the room polygons are on top. - - catch {unset floorLabels} - catch {unset floorItems} - fg$active $w $colors(offices) - $w raise room - - # Offset the floors diagonally from each other. - - $w move floor1 2c 2c - $w move floor2 1c 1c - - # Create items for the room entry and its label. - - $w create window 600 100 -anchor w -window $w.entry - $w create text 600 100 -anchor e -text "Room: " - $w config -scrollregion [$w bbox all] -} - -# newRoom -- -# This procedure is invoked whenever the mouse enters a room -# in the floorplan. It changes tags so that the current room is -# highlighted. -# -# Arguments: -# w - The name of the canvas window. - -proc newRoom w { - global currentRoom floorLabels - - set id [$w find withtag current] - if {$id != ""} { - set currentRoom $floorLabels($id) - } - update idletasks -} - -# roomChanged -- -# This procedure is invoked whenever the currentRoom variable changes. -# It highlights the current room and unhighlights any previous room. -# -# Arguments: -# w - The canvas window displaying the floorplan. -# args - Not used. - -proc roomChanged {w args} { - global currentRoom floorItems colors - $w delete highlight - if {[catch {set item $floorItems($currentRoom)}]} { - return - } - set new [eval \ - "$w create polygon [$w coords $item] -fill $colors(active) \ - -tags highlight"] - $w raise $new marker -} - -# bg1 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the background information for the first -# floor. -# -# Arguments: -# w - The canvas window. -# fill - Fill color to use for the floor's background. -# outline - Color to use for the floor's outline. - -proc bg1 {w fill outline} { - $w create poly 347 80 349 82 351 84 353 85 363 92 375 99 386 104 \ - 386 129 398 129 398 162 484 162 484 129 559 129 559 133 725 \ - 133 725 129 802 129 802 389 644 389 644 391 559 391 559 327 \ - 508 327 508 311 484 311 484 278 395 278 395 288 400 288 404 \ - 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 \ - 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 \ - 342 331 347 332 351 334 354 336 357 341 359 340 360 335 363 \ - 331 365 326 366 304 366 304 355 258 355 258 387 60 387 60 391 \ - 0 391 0 337 3 337 3 114 8 114 8 25 30 25 30 5 93 5 98 5 104 7 \ - 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 34 221 \ - 22 223 17 227 13 231 8 236 4 242 2 246 0 260 0 283 1 300 5 \ - 321 14 335 22 348 25 365 29 363 39 358 48 352 56 337 70 \ - 344 76 347 80 \ - -tags {floor1 bg} -fill $fill - $w create line 386 129 398 129 -fill $outline -tags {floor1 bg} - $w create line 258 355 258 387 -fill $outline -tags {floor1 bg} - $w create line 60 387 60 391 -fill $outline -tags {floor1 bg} - $w create line 0 337 0 391 -fill $outline -tags {floor1 bg} - $w create line 60 391 0 391 -fill $outline -tags {floor1 bg} - $w create line 3 114 3 337 -fill $outline -tags {floor1 bg} - $w create line 258 387 60 387 -fill $outline -tags {floor1 bg} - $w create line 484 162 398 162 -fill $outline -tags {floor1 bg} - $w create line 398 162 398 129 -fill $outline -tags {floor1 bg} - $w create line 484 278 484 311 -fill $outline -tags {floor1 bg} - $w create line 484 311 508 311 -fill $outline -tags {floor1 bg} - $w create line 508 327 508 311 -fill $outline -tags {floor1 bg} - $w create line 559 327 508 327 -fill $outline -tags {floor1 bg} - $w create line 644 391 559 391 -fill $outline -tags {floor1 bg} - $w create line 644 389 644 391 -fill $outline -tags {floor1 bg} - $w create line 559 129 484 129 -fill $outline -tags {floor1 bg} - $w create line 484 162 484 129 -fill $outline -tags {floor1 bg} - $w create line 725 133 559 133 -fill $outline -tags {floor1 bg} - $w create line 559 129 559 133 -fill $outline -tags {floor1 bg} - $w create line 725 129 802 129 -fill $outline -tags {floor1 bg} - $w create line 802 389 802 129 -fill $outline -tags {floor1 bg} - $w create line 3 337 0 337 -fill $outline -tags {floor1 bg} - $w create line 559 391 559 327 -fill $outline -tags {floor1 bg} - $w create line 802 389 644 389 -fill $outline -tags {floor1 bg} - $w create line 725 133 725 129 -fill $outline -tags {floor1 bg} - $w create line 8 25 8 114 -fill $outline -tags {floor1 bg} - $w create line 8 114 3 114 -fill $outline -tags {floor1 bg} - $w create line 30 25 8 25 -fill $outline -tags {floor1 bg} - $w create line 484 278 395 278 -fill $outline -tags {floor1 bg} - $w create line 30 25 30 5 -fill $outline -tags {floor1 bg} - $w create line 93 5 30 5 -fill $outline -tags {floor1 bg} - $w create line 98 5 93 5 -fill $outline -tags {floor1 bg} - $w create line 104 7 98 5 -fill $outline -tags {floor1 bg} - $w create line 110 10 104 7 -fill $outline -tags {floor1 bg} - $w create line 116 16 110 10 -fill $outline -tags {floor1 bg} - $w create line 119 20 116 16 -fill $outline -tags {floor1 bg} - $w create line 122 28 119 20 -fill $outline -tags {floor1 bg} - $w create line 123 32 122 28 -fill $outline -tags {floor1 bg} - $w create line 123 68 123 32 -fill $outline -tags {floor1 bg} - $w create line 220 68 123 68 -fill $outline -tags {floor1 bg} - $w create line 386 129 386 104 -fill $outline -tags {floor1 bg} - $w create line 386 104 375 99 -fill $outline -tags {floor1 bg} - $w create line 375 99 363 92 -fill $outline -tags {floor1 bg} - $w create line 353 85 363 92 -fill $outline -tags {floor1 bg} - $w create line 220 68 220 34 -fill $outline -tags {floor1 bg} - $w create line 337 70 352 56 -fill $outline -tags {floor1 bg} - $w create line 352 56 358 48 -fill $outline -tags {floor1 bg} - $w create line 358 48 363 39 -fill $outline -tags {floor1 bg} - $w create line 363 39 365 29 -fill $outline -tags {floor1 bg} - $w create line 365 29 348 25 -fill $outline -tags {floor1 bg} - $w create line 348 25 335 22 -fill $outline -tags {floor1 bg} - $w create line 335 22 321 14 -fill $outline -tags {floor1 bg} - $w create line 321 14 300 5 -fill $outline -tags {floor1 bg} - $w create line 300 5 283 1 -fill $outline -tags {floor1 bg} - $w create line 283 1 260 0 -fill $outline -tags {floor1 bg} - $w create line 260 0 246 0 -fill $outline -tags {floor1 bg} - $w create line 246 0 242 2 -fill $outline -tags {floor1 bg} - $w create line 242 2 236 4 -fill $outline -tags {floor1 bg} - $w create line 236 4 231 8 -fill $outline -tags {floor1 bg} - $w create line 231 8 227 13 -fill $outline -tags {floor1 bg} - $w create line 223 17 227 13 -fill $outline -tags {floor1 bg} - $w create line 221 22 223 17 -fill $outline -tags {floor1 bg} - $w create line 220 34 221 22 -fill $outline -tags {floor1 bg} - $w create line 340 360 335 363 -fill $outline -tags {floor1 bg} - $w create line 335 363 331 365 -fill $outline -tags {floor1 bg} - $w create line 331 365 326 366 -fill $outline -tags {floor1 bg} - $w create line 326 366 304 366 -fill $outline -tags {floor1 bg} - $w create line 304 355 304 366 -fill $outline -tags {floor1 bg} - $w create line 395 288 400 288 -fill $outline -tags {floor1 bg} - $w create line 404 288 400 288 -fill $outline -tags {floor1 bg} - $w create line 409 290 404 288 -fill $outline -tags {floor1 bg} - $w create line 413 292 409 290 -fill $outline -tags {floor1 bg} - $w create line 418 297 413 292 -fill $outline -tags {floor1 bg} - $w create line 421 302 418 297 -fill $outline -tags {floor1 bg} - $w create line 422 309 421 302 -fill $outline -tags {floor1 bg} - $w create line 421 318 422 309 -fill $outline -tags {floor1 bg} - $w create line 421 318 417 325 -fill $outline -tags {floor1 bg} - $w create line 417 325 411 330 -fill $outline -tags {floor1 bg} - $w create line 411 330 405 332 -fill $outline -tags {floor1 bg} - $w create line 405 332 397 333 -fill $outline -tags {floor1 bg} - $w create line 397 333 344 333 -fill $outline -tags {floor1 bg} - $w create line 344 333 340 334 -fill $outline -tags {floor1 bg} - $w create line 340 334 336 336 -fill $outline -tags {floor1 bg} - $w create line 336 336 335 338 -fill $outline -tags {floor1 bg} - $w create line 335 338 332 342 -fill $outline -tags {floor1 bg} - $w create line 331 347 332 342 -fill $outline -tags {floor1 bg} - $w create line 332 351 331 347 -fill $outline -tags {floor1 bg} - $w create line 334 354 332 351 -fill $outline -tags {floor1 bg} - $w create line 336 357 334 354 -fill $outline -tags {floor1 bg} - $w create line 341 359 336 357 -fill $outline -tags {floor1 bg} - $w create line 341 359 340 360 -fill $outline -tags {floor1 bg} - $w create line 395 288 395 278 -fill $outline -tags {floor1 bg} - $w create line 304 355 258 355 -fill $outline -tags {floor1 bg} - $w create line 347 80 344 76 -fill $outline -tags {floor1 bg} - $w create line 344 76 337 70 -fill $outline -tags {floor1 bg} - $w create line 349 82 347 80 -fill $outline -tags {floor1 bg} - $w create line 351 84 349 82 -fill $outline -tags {floor1 bg} - $w create line 353 85 351 84 -fill $outline -tags {floor1 bg} -} - -# bg2 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the background information for the second -# floor. -# -# Arguments: -# w - The canvas window. -# fill - Fill color to use for the floor's background. -# outline - Color to use for the floor's outline. - -proc bg2 {w fill outline} { - $w create poly 559 129 484 129 484 162 398 162 398 129 315 129 \ - 315 133 176 133 176 129 96 129 96 133 3 133 3 339 0 339 0 391 \ - 60 391 60 387 258 387 258 329 350 329 350 311 395 311 395 280 \ - 484 280 484 311 508 311 508 327 558 327 558 391 644 391 644 \ - 367 802 367 802 129 725 129 725 133 559 133 559 129 \ - -tags {floor2 bg} -fill $fill - $w create line 350 311 350 329 -fill $outline -tags {floor2 bg} - $w create line 398 129 398 162 -fill $outline -tags {floor2 bg} - $w create line 802 367 802 129 -fill $outline -tags {floor2 bg} - $w create line 802 129 725 129 -fill $outline -tags {floor2 bg} - $w create line 725 133 725 129 -fill $outline -tags {floor2 bg} - $w create line 559 129 559 133 -fill $outline -tags {floor2 bg} - $w create line 559 133 725 133 -fill $outline -tags {floor2 bg} - $w create line 484 162 484 129 -fill $outline -tags {floor2 bg} - $w create line 559 129 484 129 -fill $outline -tags {floor2 bg} - $w create line 802 367 644 367 -fill $outline -tags {floor2 bg} - $w create line 644 367 644 391 -fill $outline -tags {floor2 bg} - $w create line 644 391 558 391 -fill $outline -tags {floor2 bg} - $w create line 558 327 558 391 -fill $outline -tags {floor2 bg} - $w create line 558 327 508 327 -fill $outline -tags {floor2 bg} - $w create line 508 327 508 311 -fill $outline -tags {floor2 bg} - $w create line 484 311 508 311 -fill $outline -tags {floor2 bg} - $w create line 484 280 484 311 -fill $outline -tags {floor2 bg} - $w create line 398 162 484 162 -fill $outline -tags {floor2 bg} - $w create line 484 280 395 280 -fill $outline -tags {floor2 bg} - $w create line 395 280 395 311 -fill $outline -tags {floor2 bg} - $w create line 258 387 60 387 -fill $outline -tags {floor2 bg} - $w create line 3 133 3 339 -fill $outline -tags {floor2 bg} - $w create line 3 339 0 339 -fill $outline -tags {floor2 bg} - $w create line 60 391 0 391 -fill $outline -tags {floor2 bg} - $w create line 0 339 0 391 -fill $outline -tags {floor2 bg} - $w create line 60 387 60 391 -fill $outline -tags {floor2 bg} - $w create line 258 329 258 387 -fill $outline -tags {floor2 bg} - $w create line 350 329 258 329 -fill $outline -tags {floor2 bg} - $w create line 395 311 350 311 -fill $outline -tags {floor2 bg} - $w create line 398 129 315 129 -fill $outline -tags {floor2 bg} - $w create line 176 133 315 133 -fill $outline -tags {floor2 bg} - $w create line 176 129 96 129 -fill $outline -tags {floor2 bg} - $w create line 3 133 96 133 -fill $outline -tags {floor2 bg} - $w create line 315 133 315 129 -fill $outline -tags {floor2 bg} - $w create line 176 133 176 129 -fill $outline -tags {floor2 bg} - $w create line 96 133 96 129 -fill $outline -tags {floor2 bg} -} - -# bg3 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the background information for the third -# floor. -# -# Arguments: -# w - The canvas window. -# fill - Fill color to use for the floor's background. -# outline - Color to use for the floor's outline. - -proc bg3 {w fill outline} { - $w create poly 159 300 107 300 107 248 159 248 159 129 96 129 96 \ - 133 21 133 21 331 0 331 0 391 60 391 60 370 159 370 159 300 \ - -tags {floor3 bg} -fill $fill - $w create poly 258 370 258 329 350 329 350 311 399 311 399 129 \ - 315 129 315 133 176 133 176 129 159 129 159 370 258 370 \ - -tags {floor3 bg} -fill $fill - $w create line 96 133 96 129 -fill $outline -tags {floor3 bg} - $w create line 176 129 96 129 -fill $outline -tags {floor3 bg} - $w create line 176 129 176 133 -fill $outline -tags {floor3 bg} - $w create line 315 133 176 133 -fill $outline -tags {floor3 bg} - $w create line 315 133 315 129 -fill $outline -tags {floor3 bg} - $w create line 399 129 315 129 -fill $outline -tags {floor3 bg} - $w create line 399 311 399 129 -fill $outline -tags {floor3 bg} - $w create line 399 311 350 311 -fill $outline -tags {floor3 bg} - $w create line 350 329 350 311 -fill $outline -tags {floor3 bg} - $w create line 350 329 258 329 -fill $outline -tags {floor3 bg} - $w create line 258 370 258 329 -fill $outline -tags {floor3 bg} - $w create line 60 370 258 370 -fill $outline -tags {floor3 bg} - $w create line 60 370 60 391 -fill $outline -tags {floor3 bg} - $w create line 60 391 0 391 -fill $outline -tags {floor3 bg} - $w create line 0 391 0 331 -fill $outline -tags {floor3 bg} - $w create line 21 331 0 331 -fill $outline -tags {floor3 bg} - $w create line 21 331 21 133 -fill $outline -tags {floor3 bg} - $w create line 96 133 21 133 -fill $outline -tags {floor3 bg} - $w create line 107 300 159 300 159 248 107 248 107 300 \ - -fill $outline -tags {floor3 bg} -} - -# fg1 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the foreground information for the first -# floor (office outlines and numbers). -# -# Arguments: -# w - The canvas window. -# color - Color to use for drawing foreground information. - -proc fg1 {w color} { - global floorLabels floorItems - set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor1 room}] - set floorLabels($i) 101 - set {floorItems(101)} $i - $w create text 358 209 -text 101 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor1 room}] - set floorLabels($i) {Pub Lift1} - set {floorItems(Pub Lift1)} $i - $w create text 323 223 -text {Pub Lift1} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor1 room}] - set floorLabels($i) {Priv Lift1} - set {floorItems(Priv Lift1)} $i - $w create text 323 188 -text {Priv Lift1} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 42 389 42 337 1 337 1 389 -fill {} -tags {floor1 room}] - set floorLabels($i) 110 - set {floorItems(110)} $i - $w create text 21.5 363 -text 110 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 59 389 59 385 90 385 90 337 44 337 44 389 -fill {} -tags {floor1 room}] - set floorLabels($i) 109 - set {floorItems(109)} $i - $w create text 67 363 -text 109 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 51 300 51 253 6 253 6 300 -fill {} -tags {floor1 room}] - set floorLabels($i) 111 - set {floorItems(111)} $i - $w create text 28.5 276.5 -text 111 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 98 248 98 309 79 309 79 248 -fill {} -tags {floor1 room}] - set floorLabels($i) 117B - set {floorItems(117B)} $i - $w create text 88.5 278.5 -text 117B -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 51 251 51 204 6 204 6 251 -fill {} -tags {floor1 room}] - set floorLabels($i) 112 - set {floorItems(112)} $i - $w create text 28.5 227.5 -text 112 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 6 156 51 156 51 203 6 203 -fill {} -tags {floor1 room}] - set floorLabels($i) 113 - set {floorItems(113)} $i - $w create text 28.5 179.5 -text 113 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 85 169 79 169 79 192 85 192 -fill {} -tags {floor1 room}] - set floorLabels($i) 117A - set {floorItems(117A)} $i - $w create text 82 180.5 -text 117A -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 77 302 77 168 53 168 53 302 -fill {} -tags {floor1 room}] - set floorLabels($i) 117 - set {floorItems(117)} $i - $w create text 65 235 -text 117 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 51 155 51 115 6 115 6 155 -fill {} -tags {floor1 room}] - set floorLabels($i) 114 - set {floorItems(114)} $i - $w create text 28.5 135 -text 114 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 95 115 53 115 53 168 95 168 -fill {} -tags {floor1 room}] - set floorLabels($i) 115 - set {floorItems(115)} $i - $w create text 74 141.5 -text 115 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 87 113 87 27 10 27 10 113 -fill {} -tags {floor1 room}] - set floorLabels($i) 116 - set {floorItems(116)} $i - $w create text 48.5 70 -text 116 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 89 91 128 91 128 113 89 113 -fill {} -tags {floor1 room}] - set floorLabels($i) 118 - set {floorItems(118)} $i - $w create text 108.5 102 -text 118 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128 -fill {} -tags {floor1 room}] - set floorLabels($i) 120 - set {floorItems(120)} $i - $w create text 189.5 111.5 -text 120 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246 -fill {} -tags {floor1 room}] - set floorLabels($i) 122 - set {floorItems(122)} $i - $w create text 131 207.5 -text 122 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 138 169 154 169 154 191 138 191 -fill {} -tags {floor1 room}] - set floorLabels($i) 121 - set {floorItems(121)} $i - $w create text 146 180 -text 121 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 99 300 126 300 126 309 99 309 -fill {} -tags {floor1 room}] - set floorLabels($i) 106A - set {floorItems(106A)} $i - $w create text 112.5 304.5 -text 106A -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 128 299 128 309 150 309 150 248 99 248 99 299 -fill {} -tags {floor1 room}] - set floorLabels($i) 105 - set {floorItems(105)} $i - $w create text 124.5 278.5 -text 105 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 174 309 174 300 152 300 152 309 -fill {} -tags {floor1 room}] - set floorLabels($i) 106B - set {floorItems(106B)} $i - $w create text 163 304.5 -text 106B -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 176 299 176 309 216 309 216 248 152 248 152 299 -fill {} -tags {floor1 room}] - set floorLabels($i) 104 - set {floorItems(104)} $i - $w create text 184 278.5 -text 104 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 138 385 138 337 91 337 91 385 -fill {} -tags {floor1 room}] - set floorLabels($i) 108 - set {floorItems(108)} $i - $w create text 114.5 361 -text 108 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 256 337 140 337 140 385 256 385 -fill {} -tags {floor1 room}] - set floorLabels($i) 107 - set {floorItems(107)} $i - $w create text 198 361 -text 107 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 300 353 300 329 260 329 260 353 -fill {} -tags {floor1 room}] - set floorLabels($i) Smoking - set {floorItems(Smoking)} $i - $w create text 280 341 -text Smoking -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 314 135 314 170 306 170 306 246 177 246 177 135 -fill {} -tags {floor1 room}] - set floorLabels($i) 123 - set {floorItems(123)} $i - $w create text 245.5 190.5 -text 123 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 217 248 301 248 301 326 257 326 257 310 217 310 -fill {} -tags {floor1 room}] - set floorLabels($i) 103 - set {floorItems(103)} $i - $w create text 259 287 -text 103 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 396 188 377 188 377 169 316 169 316 131 396 131 -fill {} -tags {floor1 room}] - set floorLabels($i) 124 - set {floorItems(124)} $i - $w create text 356 150 -text 124 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 397 226 407 226 407 189 377 189 377 246 397 246 -fill {} -tags {floor1 room}] - set floorLabels($i) 125 - set {floorItems(125)} $i - $w create text 392 217.5 -text 125 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 399 187 409 187 409 207 474 207 474 164 399 164 -fill {} -tags {floor1 room}] - set floorLabels($i) 126 - set {floorItems(126)} $i - $w create text 436.5 185.5 -text 126 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209 -fill {} -tags {floor1 room}] - set floorLabels($i) 127 - set {floorItems(127)} $i - $w create text 436.5 231 -text 127 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164 -fill {} -tags {floor1 room}] - set floorLabels($i) MShower - set {floorItems(MShower)} $i - $w create text 488.5 184 -text MShower -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 497 176 513 176 513 204 492 204 492 190 497 190 -fill {} -tags {floor1 room}] - set floorLabels($i) Closet - set {floorItems(Closet)} $i - $w create text 502.5 190 -text Closet -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 476 237 476 206 513 206 513 254 488 254 488 237 -fill {} -tags {floor1 room}] - set floorLabels($i) WShower - set {floorItems(WShower)} $i - $w create text 494.5 230 -text WShower -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161 -fill {} -tags {floor1 room}] - set floorLabels($i) 130 - set {floorItems(130)} $i - $w create text 638.5 205 -text 130 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248 -fill {} -tags {floor1 room}] - set floorLabels($i) 102 - set {floorItems(102)} $i - $w create text 367.5 278.5 -text 102 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 397 255 486 255 486 276 397 276 -fill {} -tags {floor1 room}] - set floorLabels($i) 128 - set {floorItems(128)} $i - $w create text 441.5 265.5 -text 128 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325 -fill {} -tags {floor1 room}] - set floorLabels($i) 129 - set {floorItems(129)} $i - $w create text 535.5 293 -text 129 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277 -fill {} -tags {floor1 room}] - set floorLabels($i) 133 - set {floorItems(133)} $i - $w create text 628.5 335 -text 133 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 742 387 742 281 800 281 800 387 -fill {} -tags {floor1 room}] - set floorLabels($i) 132 - set {floorItems(132)} $i - $w create text 771 334 -text 132 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 800 168 800 280 699 280 699 168 -fill {} -tags {floor1 room}] - set floorLabels($i) 134 - set {floorItems(134)} $i - $w create text 749.5 224 -text 134 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 726 131 726 166 800 166 800 131 -fill {} -tags {floor1 room}] - set floorLabels($i) 135 - set {floorItems(135)} $i - $w create text 763 148.5 -text 135 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359 -fill {} -tags {floor1 room}] - set floorLabels($i) {Ramona Stair} - set {floorItems(Ramona Stair)} $i - $w create text 368 323 -text {Ramona Stair} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23 -fill {} -tags {floor1 room}] - set floorLabels($i) {University Stair} - set {floorItems(University Stair)} $i - $w create text 155 77.5 -text {University Stair} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34 -fill {} -tags {floor1 room}] - set floorLabels($i) {Plaza Stair} - set {floorItems(Plaza Stair)} $i - $w create text 317.5 28.5 -text {Plaza Stair} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128 -fill {} -tags {floor1 room}] - set floorLabels($i) {Plaza Deck} - set {floorItems(Plaza Deck)} $i - $w create text 303 81 -text {Plaza Deck} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 257 336 77 336 6 336 6 301 77 301 77 310 257 310 -fill {} -tags {floor1 room}] - set floorLabels($i) 106 - set {floorItems(106)} $i - $w create text 131.5 318.5 -text 106 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131 -fill {} -tags {floor1 room}] - set floorLabels($i) 119 - set {floorItems(119)} $i - $w create text 143.5 133 -text 119 -fill $color -anchor c -tags {floor1 label} - $w create line 155 191 155 189 -fill $color -tags {floor1 wall} - $w create line 155 177 155 169 -fill $color -tags {floor1 wall} - $w create line 96 129 96 169 -fill $color -tags {floor1 wall} - $w create line 78 169 176 169 -fill $color -tags {floor1 wall} - $w create line 176 247 176 129 -fill $color -tags {floor1 wall} - $w create line 340 206 307 206 -fill $color -tags {floor1 wall} - $w create line 340 187 340 170 -fill $color -tags {floor1 wall} - $w create line 340 210 340 201 -fill $color -tags {floor1 wall} - $w create line 340 247 340 224 -fill $color -tags {floor1 wall} - $w create line 340 241 307 241 -fill $color -tags {floor1 wall} - $w create line 376 246 376 170 -fill $color -tags {floor1 wall} - $w create line 307 247 307 170 -fill $color -tags {floor1 wall} - $w create line 376 170 307 170 -fill $color -tags {floor1 wall} - $w create line 315 129 315 170 -fill $color -tags {floor1 wall} - $w create line 147 129 176 129 -fill $color -tags {floor1 wall} - $w create line 202 133 176 133 -fill $color -tags {floor1 wall} - $w create line 398 129 315 129 -fill $color -tags {floor1 wall} - $w create line 258 352 258 387 -fill $color -tags {floor1 wall} - $w create line 60 387 60 391 -fill $color -tags {floor1 wall} - $w create line 0 337 0 391 -fill $color -tags {floor1 wall} - $w create line 60 391 0 391 -fill $color -tags {floor1 wall} - $w create line 3 114 3 337 -fill $color -tags {floor1 wall} - $w create line 258 387 60 387 -fill $color -tags {floor1 wall} - $w create line 52 237 52 273 -fill $color -tags {floor1 wall} - $w create line 52 189 52 225 -fill $color -tags {floor1 wall} - $w create line 52 140 52 177 -fill $color -tags {floor1 wall} - $w create line 395 306 395 311 -fill $color -tags {floor1 wall} - $w create line 531 254 398 254 -fill $color -tags {floor1 wall} - $w create line 475 178 475 238 -fill $color -tags {floor1 wall} - $w create line 502 162 398 162 -fill $color -tags {floor1 wall} - $w create line 398 129 398 188 -fill $color -tags {floor1 wall} - $w create line 383 188 376 188 -fill $color -tags {floor1 wall} - $w create line 408 188 408 194 -fill $color -tags {floor1 wall} - $w create line 398 227 398 254 -fill $color -tags {floor1 wall} - $w create line 408 227 398 227 -fill $color -tags {floor1 wall} - $w create line 408 222 408 227 -fill $color -tags {floor1 wall} - $w create line 408 206 408 210 -fill $color -tags {floor1 wall} - $w create line 408 208 475 208 -fill $color -tags {floor1 wall} - $w create line 484 278 484 311 -fill $color -tags {floor1 wall} - $w create line 484 311 508 311 -fill $color -tags {floor1 wall} - $w create line 508 327 508 311 -fill $color -tags {floor1 wall} - $w create line 559 327 508 327 -fill $color -tags {floor1 wall} - $w create line 644 391 559 391 -fill $color -tags {floor1 wall} - $w create line 644 389 644 391 -fill $color -tags {floor1 wall} - $w create line 514 205 475 205 -fill $color -tags {floor1 wall} - $w create line 496 189 496 187 -fill $color -tags {floor1 wall} - $w create line 559 129 484 129 -fill $color -tags {floor1 wall} - $w create line 484 162 484 129 -fill $color -tags {floor1 wall} - $w create line 725 133 559 133 -fill $color -tags {floor1 wall} - $w create line 559 129 559 133 -fill $color -tags {floor1 wall} - $w create line 725 149 725 167 -fill $color -tags {floor1 wall} - $w create line 725 129 802 129 -fill $color -tags {floor1 wall} - $w create line 802 389 802 129 -fill $color -tags {floor1 wall} - $w create line 739 167 802 167 -fill $color -tags {floor1 wall} - $w create line 396 188 408 188 -fill $color -tags {floor1 wall} - $w create line 0 337 9 337 -fill $color -tags {floor1 wall} - $w create line 58 337 21 337 -fill $color -tags {floor1 wall} - $w create line 43 391 43 337 -fill $color -tags {floor1 wall} - $w create line 105 337 75 337 -fill $color -tags {floor1 wall} - $w create line 91 387 91 337 -fill $color -tags {floor1 wall} - $w create line 154 337 117 337 -fill $color -tags {floor1 wall} - $w create line 139 387 139 337 -fill $color -tags {floor1 wall} - $w create line 227 337 166 337 -fill $color -tags {floor1 wall} - $w create line 258 337 251 337 -fill $color -tags {floor1 wall} - $w create line 258 328 302 328 -fill $color -tags {floor1 wall} - $w create line 302 355 302 311 -fill $color -tags {floor1 wall} - $w create line 395 311 302 311 -fill $color -tags {floor1 wall} - $w create line 484 278 395 278 -fill $color -tags {floor1 wall} - $w create line 395 294 395 278 -fill $color -tags {floor1 wall} - $w create line 473 278 473 275 -fill $color -tags {floor1 wall} - $w create line 473 256 473 254 -fill $color -tags {floor1 wall} - $w create line 533 257 531 254 -fill $color -tags {floor1 wall} - $w create line 553 276 551 274 -fill $color -tags {floor1 wall} - $w create line 698 276 553 276 -fill $color -tags {floor1 wall} - $w create line 559 391 559 327 -fill $color -tags {floor1 wall} - $w create line 802 389 644 389 -fill $color -tags {floor1 wall} - $w create line 741 314 741 389 -fill $color -tags {floor1 wall} - $w create line 698 280 698 167 -fill $color -tags {floor1 wall} - $w create line 707 280 698 280 -fill $color -tags {floor1 wall} - $w create line 802 280 731 280 -fill $color -tags {floor1 wall} - $w create line 741 280 741 302 -fill $color -tags {floor1 wall} - $w create line 698 167 727 167 -fill $color -tags {floor1 wall} - $w create line 725 137 725 129 -fill $color -tags {floor1 wall} - $w create line 514 254 514 175 -fill $color -tags {floor1 wall} - $w create line 496 175 514 175 -fill $color -tags {floor1 wall} - $w create line 502 175 502 162 -fill $color -tags {floor1 wall} - $w create line 475 166 475 162 -fill $color -tags {floor1 wall} - $w create line 496 176 496 175 -fill $color -tags {floor1 wall} - $w create line 491 189 496 189 -fill $color -tags {floor1 wall} - $w create line 491 205 491 189 -fill $color -tags {floor1 wall} - $w create line 487 238 475 238 -fill $color -tags {floor1 wall} - $w create line 487 240 487 238 -fill $color -tags {floor1 wall} - $w create line 487 252 487 254 -fill $color -tags {floor1 wall} - $w create line 315 133 304 133 -fill $color -tags {floor1 wall} - $w create line 256 133 280 133 -fill $color -tags {floor1 wall} - $w create line 78 247 270 247 -fill $color -tags {floor1 wall} - $w create line 307 247 294 247 -fill $color -tags {floor1 wall} - $w create line 214 133 232 133 -fill $color -tags {floor1 wall} - $w create line 217 247 217 266 -fill $color -tags {floor1 wall} - $w create line 217 309 217 291 -fill $color -tags {floor1 wall} - $w create line 217 309 172 309 -fill $color -tags {floor1 wall} - $w create line 154 309 148 309 -fill $color -tags {floor1 wall} - $w create line 175 300 175 309 -fill $color -tags {floor1 wall} - $w create line 151 300 175 300 -fill $color -tags {floor1 wall} - $w create line 151 247 151 309 -fill $color -tags {floor1 wall} - $w create line 78 237 78 265 -fill $color -tags {floor1 wall} - $w create line 78 286 78 309 -fill $color -tags {floor1 wall} - $w create line 106 309 78 309 -fill $color -tags {floor1 wall} - $w create line 130 309 125 309 -fill $color -tags {floor1 wall} - $w create line 99 309 99 247 -fill $color -tags {floor1 wall} - $w create line 127 299 99 299 -fill $color -tags {floor1 wall} - $w create line 127 309 127 299 -fill $color -tags {floor1 wall} - $w create line 155 191 137 191 -fill $color -tags {floor1 wall} - $w create line 137 169 137 191 -fill $color -tags {floor1 wall} - $w create line 78 171 78 169 -fill $color -tags {floor1 wall} - $w create line 78 190 78 218 -fill $color -tags {floor1 wall} - $w create line 86 192 86 169 -fill $color -tags {floor1 wall} - $w create line 86 192 78 192 -fill $color -tags {floor1 wall} - $w create line 52 301 3 301 -fill $color -tags {floor1 wall} - $w create line 52 286 52 301 -fill $color -tags {floor1 wall} - $w create line 52 252 3 252 -fill $color -tags {floor1 wall} - $w create line 52 203 3 203 -fill $color -tags {floor1 wall} - $w create line 3 156 52 156 -fill $color -tags {floor1 wall} - $w create line 8 25 8 114 -fill $color -tags {floor1 wall} - $w create line 63 114 3 114 -fill $color -tags {floor1 wall} - $w create line 75 114 97 114 -fill $color -tags {floor1 wall} - $w create line 108 114 129 114 -fill $color -tags {floor1 wall} - $w create line 129 114 129 89 -fill $color -tags {floor1 wall} - $w create line 52 114 52 128 -fill $color -tags {floor1 wall} - $w create line 132 89 88 89 -fill $color -tags {floor1 wall} - $w create line 88 25 88 89 -fill $color -tags {floor1 wall} - $w create line 88 114 88 89 -fill $color -tags {floor1 wall} - $w create line 218 89 144 89 -fill $color -tags {floor1 wall} - $w create line 147 111 147 129 -fill $color -tags {floor1 wall} - $w create line 162 111 147 111 -fill $color -tags {floor1 wall} - $w create line 162 109 162 111 -fill $color -tags {floor1 wall} - $w create line 162 96 162 89 -fill $color -tags {floor1 wall} - $w create line 218 89 218 94 -fill $color -tags {floor1 wall} - $w create line 218 89 218 119 -fill $color -tags {floor1 wall} - $w create line 8 25 88 25 -fill $color -tags {floor1 wall} - $w create line 258 337 258 328 -fill $color -tags {floor1 wall} - $w create line 113 129 96 129 -fill $color -tags {floor1 wall} - $w create line 302 355 258 355 -fill $color -tags {floor1 wall} - $w create line 386 104 386 129 -fill $color -tags {floor1 wall} - $w create line 377 100 386 104 -fill $color -tags {floor1 wall} - $w create line 365 94 377 100 -fill $color -tags {floor1 wall} - $w create line 350 83 365 94 -fill $color -tags {floor1 wall} - $w create line 337 70 350 83 -fill $color -tags {floor1 wall} - $w create line 337 70 323 56 -fill $color -tags {floor1 wall} - $w create line 312 49 323 56 -fill $color -tags {floor1 wall} - $w create line 295 40 312 49 -fill $color -tags {floor1 wall} - $w create line 282 37 295 40 -fill $color -tags {floor1 wall} - $w create line 260 34 282 37 -fill $color -tags {floor1 wall} - $w create line 253 34 260 34 -fill $color -tags {floor1 wall} - $w create line 386 128 386 104 -fill $color -tags {floor1 wall} - $w create line 113 152 156 152 -fill $color -tags {floor1 wall} - $w create line 113 152 156 152 -fill $color -tags {floor1 wall} - $w create line 113 152 113 129 -fill $color -tags {floor1 wall} -} - -# fg2 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the foreground information for the second -# floor (office outlines and numbers). -# -# Arguments: -# w - The canvas window. -# color - Color to use for drawing foreground information. - -proc fg2 {w color} { - global floorLabels floorItems - set i [$w create polygon 748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168 -fill {} -tags {floor2 room}] - set floorLabels($i) 238 - set {floorItems(238)} $i - $w create text 774 195 -text 238 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 726 188 746 188 746 166 800 166 800 131 726 131 -fill {} -tags {floor2 room}] - set floorLabels($i) 237 - set {floorItems(237)} $i - $w create text 763 148.5 -text 237 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187 -fill {} -tags {floor2 room}] - set floorLabels($i) 246 - set {floorItems(246)} $i - $w create text 600 264 -text 246 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 694 279 643 279 643 314 694 314 -fill {} -tags {floor2 room}] - set floorLabels($i) 247 - set {floorItems(247)} $i - $w create text 668.5 296.5 -text 247 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274 -fill {} -tags {floor2 room}] - set floorLabels($i) 202 - set {floorItems(202)} $i - $w create text 285.5 260 -text 202 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228 -fill {} -tags {floor2 room}] - set floorLabels($i) 206 - set {floorItems(206)} $i - $w create text 143 267 -text 206 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 51 277 6 277 6 338 51 338 -fill {} -tags {floor2 room}] - set floorLabels($i) 212 - set {floorItems(212)} $i - $w create text 28.5 307.5 -text 212 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 557 276 486 276 486 309 510 309 510 325 557 325 -fill {} -tags {floor2 room}] - set floorLabels($i) 245 - set {floorItems(245)} $i - $w create text 521.5 300.5 -text 245 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 560 389 599 389 599 326 560 326 -fill {} -tags {floor2 room}] - set floorLabels($i) 244 - set {floorItems(244)} $i - $w create text 579.5 357.5 -text 244 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 601 389 601 326 643 326 643 389 -fill {} -tags {floor2 room}] - set floorLabels($i) 243 - set {floorItems(243)} $i - $w create text 622 357.5 -text 243 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 688 316 645 316 645 365 688 365 -fill {} -tags {floor2 room}] - set floorLabels($i) 242 - set {floorItems(242)} $i - $w create text 666.5 340.5 -text 242 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 802 367 759 367 759 226 802 226 -fill {} -tags {floor2 room}] - set floorLabels($i) {Barbecue Deck} - set {floorItems(Barbecue Deck)} $i - $w create text 780.5 296.5 -text {Barbecue Deck} -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 755 262 755 314 717 314 717 262 -fill {} -tags {floor2 room}] - set floorLabels($i) 240 - set {floorItems(240)} $i - $w create text 736 288 -text 240 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 755 316 689 316 689 365 755 365 -fill {} -tags {floor2 room}] - set floorLabels($i) 241 - set {floorItems(241)} $i - $w create text 722 340.5 -text 241 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 755 206 717 206 717 261 755 261 -fill {} -tags {floor2 room}] - set floorLabels($i) 239 - set {floorItems(239)} $i - $w create text 736 233.5 -text 239 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 695 277 643 277 643 206 695 206 -fill {} -tags {floor2 room}] - set floorLabels($i) 248 - set {floorItems(248)} $i - $w create text 669 241.5 -text 248 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 676 135 676 185 724 185 724 135 -fill {} -tags {floor2 room}] - set floorLabels($i) 236 - set {floorItems(236)} $i - $w create text 700 160 -text 236 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 675 135 635 135 635 145 628 145 628 185 675 185 -fill {} -tags {floor2 room}] - set floorLabels($i) 235 - set {floorItems(235)} $i - $w create text 651.5 160 -text 235 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185 -fill {} -tags {floor2 room}] - set floorLabels($i) 234 - set {floorItems(234)} $i - $w create text 606 160 -text 234 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131 -fill {} -tags {floor2 room}] - set floorLabels($i) 233 - set {floorItems(233)} $i - $w create text 552.5 158 -text 233 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 476 249 557 249 557 205 476 205 -fill {} -tags {floor2 room}] - set floorLabels($i) 230 - set {floorItems(230)} $i - $w create text 516.5 227 -text 230 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 476 164 486 164 486 131 525 131 525 185 476 185 -fill {} -tags {floor2 room}] - set floorLabels($i) 232 - set {floorItems(232)} $i - $w create text 500.5 158 -text 232 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 476 186 495 186 495 204 476 204 -fill {} -tags {floor2 room}] - set floorLabels($i) 229 - set {floorItems(229)} $i - $w create text 485.5 195 -text 229 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 474 207 409 207 409 187 399 187 399 164 474 164 -fill {} -tags {floor2 room}] - set floorLabels($i) 227 - set {floorItems(227)} $i - $w create text 436.5 185.5 -text 227 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 399 228 399 253 474 253 474 209 409 209 409 228 -fill {} -tags {floor2 room}] - set floorLabels($i) 228 - set {floorItems(228)} $i - $w create text 436.5 231 -text 228 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 397 246 397 226 407 226 407 189 377 189 377 246 -fill {} -tags {floor2 room}] - set floorLabels($i) 226 - set {floorItems(226)} $i - $w create text 392 217.5 -text 226 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 377 169 316 169 316 131 397 131 397 188 377 188 -fill {} -tags {floor2 room}] - set floorLabels($i) 225 - set {floorItems(225)} $i - $w create text 356.5 150 -text 225 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 234 198 306 198 306 249 234 249 -fill {} -tags {floor2 room}] - set floorLabels($i) 224 - set {floorItems(224)} $i - $w create text 270 223.5 -text 224 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 270 179 306 179 306 170 314 170 314 135 270 135 -fill {} -tags {floor2 room}] - set floorLabels($i) 223 - set {floorItems(223)} $i - $w create text 292 157 -text 223 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 268 179 221 179 221 135 268 135 -fill {} -tags {floor2 room}] - set floorLabels($i) 222 - set {floorItems(222)} $i - $w create text 244.5 157 -text 222 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 177 179 219 179 219 135 177 135 -fill {} -tags {floor2 room}] - set floorLabels($i) 221 - set {floorItems(221)} $i - $w create text 198 157 -text 221 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 299 327 349 327 349 284 341 284 341 276 299 276 -fill {} -tags {floor2 room}] - set floorLabels($i) 204 - set {floorItems(204)} $i - $w create text 324 301.5 -text 204 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 234 276 297 276 297 327 257 327 257 338 234 338 -fill {} -tags {floor2 room}] - set floorLabels($i) 205 - set {floorItems(205)} $i - $w create text 265.5 307 -text 205 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 256 385 256 340 212 340 212 385 -fill {} -tags {floor2 room}] - set floorLabels($i) 207 - set {floorItems(207)} $i - $w create text 234 362.5 -text 207 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 210 340 164 340 164 385 210 385 -fill {} -tags {floor2 room}] - set floorLabels($i) 208 - set {floorItems(208)} $i - $w create text 187 362.5 -text 208 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 115 340 162 340 162 385 115 385 -fill {} -tags {floor2 room}] - set floorLabels($i) 209 - set {floorItems(209)} $i - $w create text 138.5 362.5 -text 209 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 89 228 89 156 53 156 53 228 -fill {} -tags {floor2 room}] - set floorLabels($i) 217 - set {floorItems(217)} $i - $w create text 71 192 -text 217 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 89 169 97 169 97 190 89 190 -fill {} -tags {floor2 room}] - set floorLabels($i) 217A - set {floorItems(217A)} $i - $w create text 93 179.5 -text 217A -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 89 156 89 168 95 168 95 135 53 135 53 156 -fill {} -tags {floor2 room}] - set floorLabels($i) 216 - set {floorItems(216)} $i - $w create text 71 145.5 -text 216 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 51 179 51 135 6 135 6 179 -fill {} -tags {floor2 room}] - set floorLabels($i) 215 - set {floorItems(215)} $i - $w create text 28.5 157 -text 215 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 51 227 6 227 6 180 51 180 -fill {} -tags {floor2 room}] - set floorLabels($i) 214 - set {floorItems(214)} $i - $w create text 28.5 203.5 -text 214 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 51 275 6 275 6 229 51 229 -fill {} -tags {floor2 room}] - set floorLabels($i) 213 - set {floorItems(213)} $i - $w create text 28.5 252 -text 213 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 114 340 67 340 67 385 114 385 -fill {} -tags {floor2 room}] - set floorLabels($i) 210 - set {floorItems(210)} $i - $w create text 90.5 362.5 -text 210 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 59 389 59 385 65 385 65 340 1 340 1 389 -fill {} -tags {floor2 room}] - set floorLabels($i) 211 - set {floorItems(211)} $i - $w create text 33 364.5 -text 211 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 393 309 350 309 350 282 342 282 342 276 393 276 -fill {} -tags {floor2 room}] - set floorLabels($i) 203 - set {floorItems(203)} $i - $w create text 367.5 292.5 -text 203 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169 -fill {} -tags {floor2 room}] - set floorLabels($i) 220 - set {floorItems(220)} $i - $w create text 132.5 208.5 -text 220 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor2 room}] - set floorLabels($i) {Priv Lift2} - set {floorItems(Priv Lift2)} $i - $w create text 323 188 -text {Priv Lift2} -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor2 room}] - set floorLabels($i) {Pub Lift 2} - set {floorItems(Pub Lift 2)} $i - $w create text 323 223 -text {Pub Lift 2} -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor2 room}] - set floorLabels($i) 218 - set {floorItems(218)} $i - $w create text 136 149.5 -text 218 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor2 room}] - set floorLabels($i) 219 - set {floorItems(219)} $i - $w create text 132.5 180 -text 219 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor2 room}] - set floorLabels($i) 201 - set {floorItems(201)} $i - $w create text 358 209 -text 201 -fill $color -anchor c -tags {floor2 label} - $w create line 641 186 678 186 -fill $color -tags {floor2 wall} - $w create line 757 350 757 367 -fill $color -tags {floor2 wall} - $w create line 634 133 634 144 -fill $color -tags {floor2 wall} - $w create line 634 144 627 144 -fill $color -tags {floor2 wall} - $w create line 572 133 572 144 -fill $color -tags {floor2 wall} - $w create line 572 144 579 144 -fill $color -tags {floor2 wall} - $w create line 398 129 398 162 -fill $color -tags {floor2 wall} - $w create line 174 197 175 197 -fill $color -tags {floor2 wall} - $w create line 175 197 175 227 -fill $color -tags {floor2 wall} - $w create line 757 206 757 221 -fill $color -tags {floor2 wall} - $w create line 396 188 408 188 -fill $color -tags {floor2 wall} - $w create line 727 189 725 189 -fill $color -tags {floor2 wall} - $w create line 747 167 802 167 -fill $color -tags {floor2 wall} - $w create line 747 167 747 189 -fill $color -tags {floor2 wall} - $w create line 755 189 739 189 -fill $color -tags {floor2 wall} - $w create line 769 224 757 224 -fill $color -tags {floor2 wall} - $w create line 802 224 802 129 -fill $color -tags {floor2 wall} - $w create line 802 129 725 129 -fill $color -tags {floor2 wall} - $w create line 725 189 725 129 -fill $color -tags {floor2 wall} - $w create line 725 186 690 186 -fill $color -tags {floor2 wall} - $w create line 676 133 676 186 -fill $color -tags {floor2 wall} - $w create line 627 144 627 186 -fill $color -tags {floor2 wall} - $w create line 629 186 593 186 -fill $color -tags {floor2 wall} - $w create line 579 144 579 186 -fill $color -tags {floor2 wall} - $w create line 559 129 559 133 -fill $color -tags {floor2 wall} - $w create line 725 133 559 133 -fill $color -tags {floor2 wall} - $w create line 484 162 484 129 -fill $color -tags {floor2 wall} - $w create line 559 129 484 129 -fill $color -tags {floor2 wall} - $w create line 526 129 526 186 -fill $color -tags {floor2 wall} - $w create line 540 186 581 186 -fill $color -tags {floor2 wall} - $w create line 528 186 523 186 -fill $color -tags {floor2 wall} - $w create line 511 186 475 186 -fill $color -tags {floor2 wall} - $w create line 496 190 496 186 -fill $color -tags {floor2 wall} - $w create line 496 205 496 202 -fill $color -tags {floor2 wall} - $w create line 475 205 527 205 -fill $color -tags {floor2 wall} - $w create line 558 205 539 205 -fill $color -tags {floor2 wall} - $w create line 558 205 558 249 -fill $color -tags {floor2 wall} - $w create line 558 249 475 249 -fill $color -tags {floor2 wall} - $w create line 662 206 642 206 -fill $color -tags {floor2 wall} - $w create line 695 206 675 206 -fill $color -tags {floor2 wall} - $w create line 695 278 642 278 -fill $color -tags {floor2 wall} - $w create line 642 291 642 206 -fill $color -tags {floor2 wall} - $w create line 695 291 695 206 -fill $color -tags {floor2 wall} - $w create line 716 208 716 206 -fill $color -tags {floor2 wall} - $w create line 757 206 716 206 -fill $color -tags {floor2 wall} - $w create line 757 221 757 224 -fill $color -tags {floor2 wall} - $w create line 793 224 802 224 -fill $color -tags {floor2 wall} - $w create line 757 262 716 262 -fill $color -tags {floor2 wall} - $w create line 716 220 716 264 -fill $color -tags {floor2 wall} - $w create line 716 315 716 276 -fill $color -tags {floor2 wall} - $w create line 757 315 703 315 -fill $color -tags {floor2 wall} - $w create line 757 325 757 224 -fill $color -tags {floor2 wall} - $w create line 757 367 644 367 -fill $color -tags {floor2 wall} - $w create line 689 367 689 315 -fill $color -tags {floor2 wall} - $w create line 647 315 644 315 -fill $color -tags {floor2 wall} - $w create line 659 315 691 315 -fill $color -tags {floor2 wall} - $w create line 600 325 600 391 -fill $color -tags {floor2 wall} - $w create line 627 325 644 325 -fill $color -tags {floor2 wall} - $w create line 644 391 644 315 -fill $color -tags {floor2 wall} - $w create line 615 325 575 325 -fill $color -tags {floor2 wall} - $w create line 644 391 558 391 -fill $color -tags {floor2 wall} - $w create line 563 325 558 325 -fill $color -tags {floor2 wall} - $w create line 558 391 558 314 -fill $color -tags {floor2 wall} - $w create line 558 327 508 327 -fill $color -tags {floor2 wall} - $w create line 558 275 484 275 -fill $color -tags {floor2 wall} - $w create line 558 302 558 275 -fill $color -tags {floor2 wall} - $w create line 508 327 508 311 -fill $color -tags {floor2 wall} - $w create line 484 311 508 311 -fill $color -tags {floor2 wall} - $w create line 484 275 484 311 -fill $color -tags {floor2 wall} - $w create line 475 208 408 208 -fill $color -tags {floor2 wall} - $w create line 408 206 408 210 -fill $color -tags {floor2 wall} - $w create line 408 222 408 227 -fill $color -tags {floor2 wall} - $w create line 408 227 398 227 -fill $color -tags {floor2 wall} - $w create line 398 227 398 254 -fill $color -tags {floor2 wall} - $w create line 408 188 408 194 -fill $color -tags {floor2 wall} - $w create line 383 188 376 188 -fill $color -tags {floor2 wall} - $w create line 398 188 398 162 -fill $color -tags {floor2 wall} - $w create line 398 162 484 162 -fill $color -tags {floor2 wall} - $w create line 475 162 475 254 -fill $color -tags {floor2 wall} - $w create line 398 254 475 254 -fill $color -tags {floor2 wall} - $w create line 484 280 395 280 -fill $color -tags {floor2 wall} - $w create line 395 311 395 275 -fill $color -tags {floor2 wall} - $w create line 307 197 293 197 -fill $color -tags {floor2 wall} - $w create line 278 197 233 197 -fill $color -tags {floor2 wall} - $w create line 233 197 233 249 -fill $color -tags {floor2 wall} - $w create line 307 179 284 179 -fill $color -tags {floor2 wall} - $w create line 233 249 278 249 -fill $color -tags {floor2 wall} - $w create line 269 179 269 133 -fill $color -tags {floor2 wall} - $w create line 220 179 220 133 -fill $color -tags {floor2 wall} - $w create line 155 191 110 191 -fill $color -tags {floor2 wall} - $w create line 90 190 98 190 -fill $color -tags {floor2 wall} - $w create line 98 169 98 190 -fill $color -tags {floor2 wall} - $w create line 52 133 52 165 -fill $color -tags {floor2 wall} - $w create line 52 214 52 177 -fill $color -tags {floor2 wall} - $w create line 52 226 52 262 -fill $color -tags {floor2 wall} - $w create line 52 274 52 276 -fill $color -tags {floor2 wall} - $w create line 234 275 234 339 -fill $color -tags {floor2 wall} - $w create line 226 339 258 339 -fill $color -tags {floor2 wall} - $w create line 211 387 211 339 -fill $color -tags {floor2 wall} - $w create line 214 339 177 339 -fill $color -tags {floor2 wall} - $w create line 258 387 60 387 -fill $color -tags {floor2 wall} - $w create line 3 133 3 339 -fill $color -tags {floor2 wall} - $w create line 165 339 129 339 -fill $color -tags {floor2 wall} - $w create line 117 339 80 339 -fill $color -tags {floor2 wall} - $w create line 68 339 59 339 -fill $color -tags {floor2 wall} - $w create line 0 339 46 339 -fill $color -tags {floor2 wall} - $w create line 60 391 0 391 -fill $color -tags {floor2 wall} - $w create line 0 339 0 391 -fill $color -tags {floor2 wall} - $w create line 60 387 60 391 -fill $color -tags {floor2 wall} - $w create line 258 329 258 387 -fill $color -tags {floor2 wall} - $w create line 350 329 258 329 -fill $color -tags {floor2 wall} - $w create line 395 311 350 311 -fill $color -tags {floor2 wall} - $w create line 398 129 315 129 -fill $color -tags {floor2 wall} - $w create line 176 133 315 133 -fill $color -tags {floor2 wall} - $w create line 176 129 96 129 -fill $color -tags {floor2 wall} - $w create line 3 133 96 133 -fill $color -tags {floor2 wall} - $w create line 66 387 66 339 -fill $color -tags {floor2 wall} - $w create line 115 387 115 339 -fill $color -tags {floor2 wall} - $w create line 163 387 163 339 -fill $color -tags {floor2 wall} - $w create line 234 275 276 275 -fill $color -tags {floor2 wall} - $w create line 288 275 309 275 -fill $color -tags {floor2 wall} - $w create line 298 275 298 329 -fill $color -tags {floor2 wall} - $w create line 341 283 350 283 -fill $color -tags {floor2 wall} - $w create line 321 275 341 275 -fill $color -tags {floor2 wall} - $w create line 375 275 395 275 -fill $color -tags {floor2 wall} - $w create line 315 129 315 170 -fill $color -tags {floor2 wall} - $w create line 376 170 307 170 -fill $color -tags {floor2 wall} - $w create line 307 250 307 170 -fill $color -tags {floor2 wall} - $w create line 376 245 376 170 -fill $color -tags {floor2 wall} - $w create line 340 241 307 241 -fill $color -tags {floor2 wall} - $w create line 340 245 340 224 -fill $color -tags {floor2 wall} - $w create line 340 210 340 201 -fill $color -tags {floor2 wall} - $w create line 340 187 340 170 -fill $color -tags {floor2 wall} - $w create line 340 206 307 206 -fill $color -tags {floor2 wall} - $w create line 293 250 307 250 -fill $color -tags {floor2 wall} - $w create line 271 179 238 179 -fill $color -tags {floor2 wall} - $w create line 226 179 195 179 -fill $color -tags {floor2 wall} - $w create line 176 129 176 179 -fill $color -tags {floor2 wall} - $w create line 182 179 176 179 -fill $color -tags {floor2 wall} - $w create line 174 169 176 169 -fill $color -tags {floor2 wall} - $w create line 162 169 90 169 -fill $color -tags {floor2 wall} - $w create line 96 169 96 129 -fill $color -tags {floor2 wall} - $w create line 175 227 90 227 -fill $color -tags {floor2 wall} - $w create line 90 190 90 227 -fill $color -tags {floor2 wall} - $w create line 52 179 3 179 -fill $color -tags {floor2 wall} - $w create line 52 228 3 228 -fill $color -tags {floor2 wall} - $w create line 52 276 3 276 -fill $color -tags {floor2 wall} - $w create line 155 177 155 169 -fill $color -tags {floor2 wall} - $w create line 110 191 110 169 -fill $color -tags {floor2 wall} - $w create line 155 189 155 197 -fill $color -tags {floor2 wall} - $w create line 350 283 350 329 -fill $color -tags {floor2 wall} - $w create line 162 197 155 197 -fill $color -tags {floor2 wall} - $w create line 341 275 341 283 -fill $color -tags {floor2 wall} -} - -# fg3 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the foreground information for the third -# floor (office outlines and numbers). -# -# Arguments: -# w - The canvas window. -# color - Color to use for drawing foreground information. - -proc fg3 {w color} { - global floorLabels floorItems - set i [$w create polygon 89 228 89 180 70 180 70 228 -fill {} -tags {floor3 room}] - set floorLabels($i) 316 - set {floorItems(316)} $i - $w create text 79.5 204 -text 316 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 115 368 162 368 162 323 115 323 -fill {} -tags {floor3 room}] - set floorLabels($i) 309 - set {floorItems(309)} $i - $w create text 138.5 345.5 -text 309 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 164 323 164 368 211 368 211 323 -fill {} -tags {floor3 room}] - set floorLabels($i) 308 - set {floorItems(308)} $i - $w create text 187.5 345.5 -text 308 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 256 368 212 368 212 323 256 323 -fill {} -tags {floor3 room}] - set floorLabels($i) 307 - set {floorItems(307)} $i - $w create text 234 345.5 -text 307 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 244 276 297 276 297 327 260 327 260 321 244 321 -fill {} -tags {floor3 room}] - set floorLabels($i) 305 - set {floorItems(305)} $i - $w create text 270.5 301.5 -text 305 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 251 219 251 203 244 203 244 219 -fill {} -tags {floor3 room}] - set floorLabels($i) 324B - set {floorItems(324B)} $i - $w create text 247.5 211 -text 324B -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 251 249 244 249 244 232 251 232 -fill {} -tags {floor3 room}] - set floorLabels($i) 324A - set {floorItems(324A)} $i - $w create text 247.5 240.5 -text 324A -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 223 135 223 179 177 179 177 135 -fill {} -tags {floor3 room}] - set floorLabels($i) 320 - set {floorItems(320)} $i - $w create text 200 157 -text 320 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 114 368 114 323 67 323 67 368 -fill {} -tags {floor3 room}] - set floorLabels($i) 310 - set {floorItems(310)} $i - $w create text 90.5 345.5 -text 310 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 23 277 23 321 68 321 68 277 -fill {} -tags {floor3 room}] - set floorLabels($i) 312 - set {floorItems(312)} $i - $w create text 45.5 299 -text 312 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 23 229 68 229 68 275 23 275 -fill {} -tags {floor3 room}] - set floorLabels($i) 313 - set {floorItems(313)} $i - $w create text 45.5 252 -text 313 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 68 227 23 227 23 180 68 180 -fill {} -tags {floor3 room}] - set floorLabels($i) 314 - set {floorItems(314)} $i - $w create text 45.5 203.5 -text 314 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 95 179 95 135 23 135 23 179 -fill {} -tags {floor3 room}] - set floorLabels($i) 315 - set {floorItems(315)} $i - $w create text 59 157 -text 315 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 99 226 99 204 91 204 91 226 -fill {} -tags {floor3 room}] - set floorLabels($i) 316B - set {floorItems(316B)} $i - $w create text 95 215 -text 316B -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 91 202 99 202 99 180 91 180 -fill {} -tags {floor3 room}] - set floorLabels($i) 316A - set {floorItems(316A)} $i - $w create text 95 191 -text 316A -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179 -fill {} -tags {floor3 room}] - set floorLabels($i) 319 - set {floorItems(319)} $i - $w create text 141.5 209 -text 319 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323 -fill {} -tags {floor3 room}] - set floorLabels($i) 311 - set {floorItems(311)} $i - $w create text 29.5 361 -text 311 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor3 room}] - set floorLabels($i) 318 - set {floorItems(318)} $i - $w create text 132.5 180 -text 318 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor3 room}] - set floorLabels($i) 317 - set {floorItems(317)} $i - $w create text 136 149.5 -text 317 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 274 194 274 221 306 221 306 194 -fill {} -tags {floor3 room}] - set floorLabels($i) 323 - set {floorItems(323)} $i - $w create text 290 207.5 -text 323 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 306 222 274 222 274 249 306 249 -fill {} -tags {floor3 room}] - set floorLabels($i) 325 - set {floorItems(325)} $i - $w create text 290 235.5 -text 325 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 263 179 224 179 224 135 263 135 -fill {} -tags {floor3 room}] - set floorLabels($i) 321 - set {floorItems(321)} $i - $w create text 243.5 157 -text 321 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 314 169 306 169 306 192 273 192 264 181 264 135 314 135 -fill {} -tags {floor3 room}] - set floorLabels($i) 322 - set {floorItems(322)} $i - $w create text 293.5 163.5 -text 322 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor3 room}] - set floorLabels($i) {Pub Lift3} - set {floorItems(Pub Lift3)} $i - $w create text 323 223 -text {Pub Lift3} -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor3 room}] - set floorLabels($i) {Priv Lift3} - set {floorItems(Priv Lift3)} $i - $w create text 323 188 -text {Priv Lift3} -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 350 284 376 284 376 276 397 276 397 309 350 309 -fill {} -tags {floor3 room}] - set floorLabels($i) 303 - set {floorItems(303)} $i - $w create text 373.5 292.5 -text 303 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203 -fill {} -tags {floor3 room}] - set floorLabels($i) 324 - set {floorItems(324)} $i - $w create text 262 226 -text 324 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 299 276 299 327 349 327 349 284 341 284 341 276 -fill {} -tags {floor3 room}] - set floorLabels($i) 304 - set {floorItems(304)} $i - $w create text 324 301.5 -text 304 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor3 room}] - set floorLabels($i) 301 - set {floorItems(301)} $i - $w create text 358 209 -text 301 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 397 246 377 246 377 185 397 185 -fill {} -tags {floor3 room}] - set floorLabels($i) 327 - set {floorItems(327)} $i - $w create text 387 215.5 -text 327 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 316 131 316 169 377 169 377 185 397 185 397 131 -fill {} -tags {floor3 room}] - set floorLabels($i) 326 - set {floorItems(326)} $i - $w create text 356.5 150 -text 326 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242 -fill {} -tags {floor3 room}] - set floorLabels($i) 302 - set {floorItems(302)} $i - $w create text 319.5 261 -text 302 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275 -fill {} -tags {floor3 room}] - set floorLabels($i) 306 - set {floorItems(306)} $i - $w create text 200.5 284.5 -text 306 -fill $color -anchor c -tags {floor3 label} - $w create line 341 275 341 283 -fill $color -tags {floor3 wall} - $w create line 162 197 155 197 -fill $color -tags {floor3 wall} - $w create line 396 247 399 247 -fill $color -tags {floor3 wall} - $w create line 399 129 399 311 -fill $color -tags {floor3 wall} - $w create line 258 202 243 202 -fill $color -tags {floor3 wall} - $w create line 350 283 350 329 -fill $color -tags {floor3 wall} - $w create line 251 231 243 231 -fill $color -tags {floor3 wall} - $w create line 243 220 251 220 -fill $color -tags {floor3 wall} - $w create line 243 250 243 202 -fill $color -tags {floor3 wall} - $w create line 155 197 155 190 -fill $color -tags {floor3 wall} - $w create line 110 192 110 169 -fill $color -tags {floor3 wall} - $w create line 155 192 110 192 -fill $color -tags {floor3 wall} - $w create line 155 177 155 169 -fill $color -tags {floor3 wall} - $w create line 176 197 176 227 -fill $color -tags {floor3 wall} - $w create line 69 280 69 274 -fill $color -tags {floor3 wall} - $w create line 21 276 69 276 -fill $color -tags {floor3 wall} - $w create line 69 262 69 226 -fill $color -tags {floor3 wall} - $w create line 21 228 69 228 -fill $color -tags {floor3 wall} - $w create line 21 179 75 179 -fill $color -tags {floor3 wall} - $w create line 69 179 69 214 -fill $color -tags {floor3 wall} - $w create line 90 220 90 227 -fill $color -tags {floor3 wall} - $w create line 90 204 90 202 -fill $color -tags {floor3 wall} - $w create line 90 203 100 203 -fill $color -tags {floor3 wall} - $w create line 90 187 90 179 -fill $color -tags {floor3 wall} - $w create line 90 227 176 227 -fill $color -tags {floor3 wall} - $w create line 100 179 100 227 -fill $color -tags {floor3 wall} - $w create line 100 179 87 179 -fill $color -tags {floor3 wall} - $w create line 96 179 96 129 -fill $color -tags {floor3 wall} - $w create line 162 169 96 169 -fill $color -tags {floor3 wall} - $w create line 173 169 176 169 -fill $color -tags {floor3 wall} - $w create line 182 179 176 179 -fill $color -tags {floor3 wall} - $w create line 176 129 176 179 -fill $color -tags {floor3 wall} - $w create line 195 179 226 179 -fill $color -tags {floor3 wall} - $w create line 224 133 224 179 -fill $color -tags {floor3 wall} - $w create line 264 179 264 133 -fill $color -tags {floor3 wall} - $w create line 238 179 264 179 -fill $color -tags {floor3 wall} - $w create line 273 207 273 193 -fill $color -tags {floor3 wall} - $w create line 273 235 273 250 -fill $color -tags {floor3 wall} - $w create line 273 224 273 219 -fill $color -tags {floor3 wall} - $w create line 273 193 307 193 -fill $color -tags {floor3 wall} - $w create line 273 222 307 222 -fill $color -tags {floor3 wall} - $w create line 273 250 307 250 -fill $color -tags {floor3 wall} - $w create line 384 247 376 247 -fill $color -tags {floor3 wall} - $w create line 340 206 307 206 -fill $color -tags {floor3 wall} - $w create line 340 187 340 170 -fill $color -tags {floor3 wall} - $w create line 340 210 340 201 -fill $color -tags {floor3 wall} - $w create line 340 247 340 224 -fill $color -tags {floor3 wall} - $w create line 340 241 307 241 -fill $color -tags {floor3 wall} - $w create line 376 247 376 170 -fill $color -tags {floor3 wall} - $w create line 307 250 307 170 -fill $color -tags {floor3 wall} - $w create line 376 170 307 170 -fill $color -tags {floor3 wall} - $w create line 315 129 315 170 -fill $color -tags {floor3 wall} - $w create line 376 283 366 283 -fill $color -tags {floor3 wall} - $w create line 376 283 376 275 -fill $color -tags {floor3 wall} - $w create line 399 275 376 275 -fill $color -tags {floor3 wall} - $w create line 341 275 320 275 -fill $color -tags {floor3 wall} - $w create line 341 283 350 283 -fill $color -tags {floor3 wall} - $w create line 298 275 298 329 -fill $color -tags {floor3 wall} - $w create line 308 275 298 275 -fill $color -tags {floor3 wall} - $w create line 243 322 243 275 -fill $color -tags {floor3 wall} - $w create line 243 275 284 275 -fill $color -tags {floor3 wall} - $w create line 258 322 226 322 -fill $color -tags {floor3 wall} - $w create line 212 370 212 322 -fill $color -tags {floor3 wall} - $w create line 214 322 177 322 -fill $color -tags {floor3 wall} - $w create line 163 370 163 322 -fill $color -tags {floor3 wall} - $w create line 165 322 129 322 -fill $color -tags {floor3 wall} - $w create line 84 322 117 322 -fill $color -tags {floor3 wall} - $w create line 71 322 64 322 -fill $color -tags {floor3 wall} - $w create line 115 322 115 370 -fill $color -tags {floor3 wall} - $w create line 66 322 66 370 -fill $color -tags {floor3 wall} - $w create line 52 322 21 322 -fill $color -tags {floor3 wall} - $w create line 21 331 0 331 -fill $color -tags {floor3 wall} - $w create line 21 331 21 133 -fill $color -tags {floor3 wall} - $w create line 96 133 21 133 -fill $color -tags {floor3 wall} - $w create line 176 129 96 129 -fill $color -tags {floor3 wall} - $w create line 315 133 176 133 -fill $color -tags {floor3 wall} - $w create line 315 129 399 129 -fill $color -tags {floor3 wall} - $w create line 399 311 350 311 -fill $color -tags {floor3 wall} - $w create line 350 329 258 329 -fill $color -tags {floor3 wall} - $w create line 258 322 258 370 -fill $color -tags {floor3 wall} - $w create line 60 370 258 370 -fill $color -tags {floor3 wall} - $w create line 60 370 60 391 -fill $color -tags {floor3 wall} - $w create line 0 391 0 331 -fill $color -tags {floor3 wall} - $w create line 60 391 0 391 -fill $color -tags {floor3 wall} - $w create line 307 250 307 242 -fill $color -tags {floor3 wall} - $w create line 273 250 307 250 -fill $color -tags {floor3 wall} - $w create line 258 250 243 250 -fill $color -tags {floor3 wall} -} - -# Below is the "main program" that creates the floorplan demonstration. - -set w .floor -global c tk_library currentRoom colors activeFloor -catch {destroy $w} -toplevel $w -wm title $w "Floorplan Canvas Demonstration" -wm iconname $w "Floorplan" -wm geometry $w +20+20 -wm minsize $w 100 100 - -label $w.msg -font $font -wraplength 8i -justify left -text "This window contains a canvas widget showing the floorplan of Digital Equipment Corporation's Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the \"Room:\" entry. You can also type a room number in the entry and the room will light up." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -set f [frame $w.frame] -pack $f -side top -fill both -expand yes -set h [scrollbar $f.hscroll -highlightthickness 0 -orient horizontal] -set v [scrollbar $f.vscroll -highlightthickness 0 -orient vertical] -set f1 [frame $f.f1 -bd 2 -relief sunken] -set c [canvas $f1.c -width 900 -height 500 -borderwidth 0 \ - -highlightthickness 0 -xscrollcommand "$h set" -yscrollcommand "$v set"] -pack $c -expand yes -fill both -grid $f1 -padx 1 -pady 1 \ - -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid $v -padx 1 -pady 1 \ - -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -grid $h -padx 1 -pady 1 \ - -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid rowconfig $f 0 -weight 1 -minsize 0 -grid columnconfig $f 0 -weight 1 -minsize 0 -pack $f -expand yes -fill both -padx 1 -pady 1 - -$v config -command "$c yview" -$h config -command "$c xview" - -# Create an entry for displaying and typing in current room. - -entry $c.entry -width 10 -relief sunken -bd 2 -textvariable currentRoom - -# Choose colors, then fill in the floorplan. - -if {[winfo depth $c] > 1} { - set colors(bg1) #a9c1da - set colors(outline1) #77889a - set colors(bg2) #9ab0c6 - set colors(outline2) #687786 - set colors(bg3) #8ba0b3 - set colors(outline3) #596673 - set colors(offices) Black - set colors(active) #c4d1df -} else { - set colors(bg1) white - set colors(outline1) black - set colors(bg2) white - set colors(outline2) black - set colors(bg3) white - set colors(outline3) black - set colors(offices) Black - set colors(active) black -} -set activeFloor "" -floorDisplay $c 3 - -# Set up event bindings for canvas: - -$c bind floor1 <1> "floorDisplay $c 1" -$c bind floor2 <1> "floorDisplay $c 2" -$c bind floor3 <1> "floorDisplay $c 3" -$c bind room <Enter> "newRoom $c" -$c bind room <Leave> {set currentRoom ""} -bind $c <2> "$c scan mark %x %y" -bind $c <B2-Motion> "$c scan dragto %x %y" -bind $c <Destroy> "unset currentRoom" -set currentRoom "" -trace variable currentRoom w "roomChanged $c" diff --git a/tcl/library/demos/form.tcl b/tcl/library/demos/form.tcl deleted file mode 100644 index 082cbf3d31f..00000000000 --- a/tcl/library/demos/form.tcl +++ /dev/null @@ -1,40 +0,0 @@ -# form.tcl -- -# -# This demonstration script creates a simple form with a bunch -# of entry widgets. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .form -catch {destroy $w} -toplevel $w -wm title $w "Form Demonstration" -wm iconname $w "form" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -foreach i {f1 f2 f3 f4 f5} { - frame $w.$i -bd 2 - entry $w.$i.entry -relief sunken -width 40 - label $w.$i.label - pack $w.$i.entry -side right - pack $w.$i.label -side left -} -$w.f1.label config -text Name: -$w.f2.label config -text Address: -$w.f5.label config -text Phone: -pack $w.msg $w.f1 $w.f2 $w.f3 $w.f4 $w.f5 -side top -fill x -bind $w <Return> "destroy $w" -focus $w.f1.entry diff --git a/tcl/library/demos/hello b/tcl/library/demos/hello deleted file mode 100644 index b163175fb93..00000000000 --- a/tcl/library/demos/hello +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish "$0" "$@" - -# hello -- -# Simple Tk script to create a button that prints "Hello, world". -# Click on the button to terminate the program. -# -# RCS: @(#) $Id$ -# -# The first line below creates the button, and the second line -# asks the packer to shrink-wrap the application's main window -# around the button. - -button .hello -text "Hello, world" -command { - puts stdout "Hello, world"; destroy . -} -pack .hello - -# Local Variables: -# mode: tcl -# End: diff --git a/tcl/library/demos/hscale.tcl b/tcl/library/demos/hscale.tcl deleted file mode 100644 index 25ae7794a4d..00000000000 --- a/tcl/library/demos/hscale.tcl +++ /dev/null @@ -1,47 +0,0 @@ -# hscale.tcl -- -# -# This demonstration script shows an example with a horizontal scale. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .hscale -catch {destroy $w} -toplevel $w -wm title $w "Horizontal Scale Demonstration" -wm iconname $w "hscale" -positionWindow $w - -label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the length of the arrow." -pack $w.msg -side top -padx .5c - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.frame -borderwidth 10 -pack $w.frame -side top -fill x - -canvas $w.frame.canvas -width 50 -height 50 -bd 0 -highlightthickness 0 -$w.frame.canvas create polygon 0 0 1 1 2 2 -fill DeepSkyBlue3 -tags poly -$w.frame.canvas create line 0 0 1 1 2 2 0 0 -fill black -tags line -scale $w.frame.scale -orient horizontal -length 284 -from 0 -to 250 \ - -command "setWidth $w.frame.canvas" -tickinterval 50 -pack $w.frame.canvas -side top -expand yes -anchor s -fill x -padx 15 -pack $w.frame.scale -side bottom -expand yes -anchor n -$w.frame.scale set 75 - -proc setWidth {w width} { - incr width 21 - set x2 [expr {$width - 30}] - if {$x2 < 21} { - set x2 21 - } - $w coords poly 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15 - $w coords line 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15 -} diff --git a/tcl/library/demos/icon.tcl b/tcl/library/demos/icon.tcl deleted file mode 100644 index 06cdc1fd63a..00000000000 --- a/tcl/library/demos/icon.tcl +++ /dev/null @@ -1,52 +0,0 @@ -# icon.tcl -- -# -# This demonstration script creates a toplevel window containing -# buttons that display bitmaps instead of text. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .icon -catch {destroy $w} -toplevel $w -wm title $w "Iconic Button Demonstration" -wm iconname $w "icon" -positionWindow $w - -label $w.msg -font $font -wraplength 5i -justify left -text "This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -image create bitmap flagup \ - -file [file join $tk_library demos images flagup.bmp] \ - -maskfile [file join $tk_library demos images flagup.bmp] -image create bitmap flagdown \ - -file [file join $tk_library demos images flagdown.bmp] \ - -maskfile [file join $tk_library demos images flagdown.bmp] -frame $w.frame -borderwidth 10 -pack $w.frame -side top - -checkbutton $w.frame.b1 -image flagdown -selectimage flagup \ - -indicatoron 0 -$w.frame.b1 configure -selectcolor [$w.frame.b1 cget -background] -checkbutton $w.frame.b2 \ - -bitmap @[file join $tk_library demos images letters.bmp] \ - -indicatoron 0 -selectcolor SeaGreen1 -frame $w.frame.left -pack $w.frame.left $w.frame.b1 $w.frame.b2 -side left -expand yes -padx 5m - -radiobutton $w.frame.left.b3 \ - -bitmap @[file join $tk_library demos images letters.bmp] \ - -variable letters -value full -radiobutton $w.frame.left.b4 \ - -bitmap @[file join $tk_library demos images noletter.bmp] \ - -variable letters -value empty -pack $w.frame.left.b3 $w.frame.left.b4 -side top -expand yes diff --git a/tcl/library/demos/image1.tcl b/tcl/library/demos/image1.tcl deleted file mode 100644 index 820c9c1f10e..00000000000 --- a/tcl/library/demos/image1.tcl +++ /dev/null @@ -1,36 +0,0 @@ -# image1.tcl -- -# -# This demonstration script displays two image widgets. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .image1 -catch {destroy $w} -toplevel $w -wm title $w "Image Demonstration #1" -wm iconname $w "Image1" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration displays two images, each in a separate label widget." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -catch {image delete image1a} -image create photo image1a -file [file join $tk_library demos images earth.gif] -label $w.l1 -image image1a -bd 1 -relief sunken - -catch {image delete image1b} -image create photo image1b \ - -file [file join $tk_library demos images earthris.gif] -label $w.l2 -image image1b -bd 1 -relief sunken - -pack $w.l1 $w.l2 -side top -padx .5m -pady .5m diff --git a/tcl/library/demos/image2.tcl b/tcl/library/demos/image2.tcl deleted file mode 100644 index 226202461d7..00000000000 --- a/tcl/library/demos/image2.tcl +++ /dev/null @@ -1,104 +0,0 @@ -# image2.tcl -- -# -# This demonstration script creates a simple collection of widgets -# that allow you to select and view images in a Tk label. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -# loadDir -- -# This procedure reloads the directory listbox from the directory -# named in the demo's entry. -# -# Arguments: -# w - Name of the toplevel window of the demo. - -proc loadDir w { - global dirName - - $w.f.list delete 0 end - foreach i [lsort [glob -directory $dirName *]] { - $w.f.list insert end [file tail $i] - } -} - -# selectAndLoadDir -- -# This procedure pops up a dialog to ask for a directory to load into -# the listobx and (if the user presses OK) reloads the directory -# listbox from the directory named in the demo's entry. -# -# Arguments: -# w - Name of the toplevel window of the demo. - -proc selectAndLoadDir w { - global dirName - set dir [tk_chooseDirectory -initialdir $dirName -parent $w -mustexist 1] - if {[string length $dir] != 0} { - set dirName $dir - loadDir $w - } -} - -# loadImage -- -# Given the name of the toplevel window of the demo and the mouse -# position, extracts the directory entry under the mouse and loads -# that file into a photo image for display. -# -# Arguments: -# w - Name of the toplevel window of the demo. -# x, y- Mouse position within the listbox. - -proc loadImage {w x y} { - global dirName - - set file [file join $dirName [$w.f.list get @$x,$y]] - image2a configure -file $file -} - -set w .image2 -catch {destroy $w} -toplevel $w -wm title $w "Image Demonstration #2" -wm iconname $w "Image2" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration allows you to view images using a Tk \"photo\" image. First type a directory name in the listbox, then type Return to load the directory into the listbox. Then double-click on a file name in the listbox to see that image." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.mid -pack $w.mid -fill both -expand 1 - -labelframe $w.dir -text "Directory:" -set dirName [file join $tk_library demos images] -entry $w.dir.e -width 30 -textvariable dirName -button $w.dir.b -pady 0 -padx 2m -text "Select Dir." \ - -command "selectAndLoadDir $w" -bind $w.dir.e <Return> "loadDir $w" -pack $w.dir.e -side left -fill both -padx 2m -pady 2m -expand true -pack $w.dir.b -side left -fill y -padx {0 2m} -pady 2m -labelframe $w.f -text "File:" -padx 2m -pady 2m - -listbox $w.f.list -width 20 -height 10 -yscrollcommand "$w.f.scroll set" -scrollbar $w.f.scroll -command "$w.f.list yview" -pack $w.f.list $w.f.scroll -side left -fill y -expand 1 -$w.f.list insert 0 earth.gif earthris.gif teapot.ppm -bind $w.f.list <Double-1> "loadImage $w %x %y" - -catch {image delete image2a} -image create photo image2a -labelframe $w.image -text "Image:" -label $w.image.image -image image2a -pack $w.image.image -padx 2m -pady 2m - -grid $w.dir - -sticky ew -padx 1m -pady 1m -in $w.mid -grid $w.f $w.image -sticky nw -padx 1m -pady 1m -in $w.mid -grid columnconfigure $w.mid 1 -weight 1 diff --git a/tcl/library/demos/images/earth.gif b/tcl/library/demos/images/earth.gif Binary files differdeleted file mode 100644 index 2c229eb1101..00000000000 --- a/tcl/library/demos/images/earth.gif +++ /dev/null diff --git a/tcl/library/demos/images/earthris.gif b/tcl/library/demos/images/earthris.gif Binary files differdeleted file mode 100644 index c4ee4737279..00000000000 --- a/tcl/library/demos/images/earthris.gif +++ /dev/null diff --git a/tcl/library/demos/images/face.bmp b/tcl/library/demos/images/face.bmp deleted file mode 100644 index 03d829f4d1f..00000000000 --- a/tcl/library/demos/images/face.bmp +++ /dev/null @@ -1,173 +0,0 @@ -#define face_width 108 -#define face_height 144 -#define face_x_hot 48 -#define face_y_hot 80 -static char face_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08, 0x09, - 0x20, 0x80, 0x24, 0x05, 0x00, 0x80, 0x08, 0x00, 0x00, 0x00, 0x00, 0x88, - 0x24, 0x20, 0x80, 0x24, 0x00, 0x00, 0x00, 0x10, 0x80, 0x04, 0x00, 0x01, - 0x00, 0x01, 0x40, 0x0a, 0x09, 0x00, 0x92, 0x04, 0x80, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x10, 0x40, 0x12, 0x00, 0x00, 0x10, 0x40, 0x00, 0x00, 0x84, - 0x24, 0x40, 0x22, 0xa8, 0x02, 0x14, 0x84, 0x92, 0x40, 0x42, 0x12, 0x04, - 0x10, 0x00, 0x00, 0x00, 0x00, 0x52, 0x00, 0x52, 0x11, 0x00, 0x12, 0x00, - 0x40, 0x02, 0x00, 0x20, 0x00, 0x08, 0x00, 0xaa, 0x02, 0x54, 0x85, 0x24, - 0x00, 0x10, 0x12, 0x00, 0x00, 0x81, 0x44, 0x00, 0x90, 0x5a, 0x00, 0xea, - 0x1b, 0x00, 0x80, 0x40, 0x40, 0x02, 0x00, 0x08, 0x00, 0x20, 0xa2, 0x05, - 0x8a, 0xb4, 0x6e, 0x45, 0x12, 0x04, 0x08, 0x00, 0x00, 0x00, 0x10, 0x02, - 0xa8, 0x92, 0x00, 0xda, 0x5f, 0x10, 0x00, 0x10, 0xa1, 0x04, 0x20, 0x41, - 0x02, 0x00, 0x5a, 0x25, 0xa0, 0xff, 0xfb, 0x05, 0x41, 0x02, 0x04, 0x00, - 0x00, 0x08, 0x40, 0x80, 0xec, 0x9b, 0xec, 0xfe, 0x7f, 0x01, 0x04, 0x20, - 0x90, 0x02, 0x04, 0x00, 0x08, 0x20, 0xfb, 0x2e, 0xf5, 0xff, 0xff, 0x57, - 0x00, 0x04, 0x02, 0x00, 0x00, 0x20, 0x01, 0xc1, 0x6e, 0xab, 0xfa, 0xff, - 0xff, 0x05, 0x90, 0x20, 0x48, 0x02, 0x00, 0x04, 0x20, 0xa8, 0xdf, 0xb5, - 0xfe, 0xff, 0xff, 0x0b, 0x01, 0x00, 0x01, 0x00, 0x80, 0x80, 0x04, 0xe0, - 0xbb, 0xef, 0xff, 0xff, 0x7f, 0x01, 0x00, 0x04, 0x48, 0x02, 0x00, 0x20, - 0x80, 0xf4, 0x6f, 0xfb, 0xff, 0xff, 0xff, 0x20, 0x90, 0x40, 0x02, 0x00, - 0x00, 0x04, 0x08, 0xb8, 0xf6, 0xff, 0xff, 0xdf, 0xbe, 0x12, 0x45, 0x10, - 0x90, 0x04, 0x90, 0x00, 0x22, 0xfa, 0xff, 0xff, 0xff, 0xbb, 0xd7, 0xe9, - 0x3a, 0x02, 0x02, 0x00, 0x04, 0x90, 0x80, 0xfe, 0xdf, 0xf6, 0xb7, 0xef, - 0xbe, 0x56, 0x57, 0x40, 0x48, 0x09, 0x00, 0x04, 0x00, 0xfa, 0xf5, 0xdf, - 0xed, 0x5a, 0xd5, 0xea, 0xbd, 0x09, 0x00, 0x00, 0x40, 0x00, 0x92, 0xfe, - 0xbf, 0x7d, 0xb7, 0x6a, 0x55, 0xbf, 0xf7, 0x02, 0x11, 0x01, 0x00, 0x91, - 0x00, 0xff, 0xff, 0xaf, 0x55, 0x55, 0x5b, 0xeb, 0xef, 0x22, 0x04, 0x04, - 0x04, 0x00, 0xa4, 0xff, 0xf7, 0xad, 0xaa, 0xaa, 0xaa, 0xbe, 0xfe, 0x03, - 0x20, 0x00, 0x10, 0x44, 0x80, 0xff, 0x7f, 0x55, 0x12, 0x91, 0x2a, 0xeb, - 0xbf, 0x0b, 0x82, 0x02, 0x00, 0x00, 0xd1, 0x7f, 0xdf, 0xa2, 0xa4, 0x54, - 0x55, 0xfd, 0xfd, 0x47, 0x08, 0x08, 0x00, 0x21, 0xe4, 0xff, 0x37, 0x11, - 0x09, 0xa5, 0xaa, 0xb6, 0xff, 0x0d, 0x80, 0x00, 0x00, 0x04, 0xd0, 0xff, - 0x4f, 0x44, 0x20, 0x48, 0x55, 0xfb, 0xff, 0x27, 0x11, 0x02, 0x40, 0x40, - 0xe2, 0xfb, 0x15, 0x11, 0x4a, 0x55, 0x4a, 0x7d, 0xf7, 0x0f, 0x00, 0x00, - 0x04, 0x08, 0xf8, 0xdf, 0x52, 0x44, 0x01, 0x52, 0xb5, 0xfa, 0xff, 0x0f, - 0x49, 0x02, 0x00, 0x02, 0xe9, 0xf6, 0x0a, 0x11, 0xa4, 0x88, 0x4a, 0x6d, - 0xff, 0x5f, 0x00, 0x00, 0x10, 0x20, 0xf0, 0x2f, 0x21, 0x44, 0x10, 0x52, - 0xb5, 0xfa, 0xff, 0x0f, 0x44, 0x04, 0x80, 0x08, 0xf8, 0xab, 0x8a, 0x00, - 0x81, 0xa4, 0xd4, 0xd6, 0xfe, 0x2f, 0x00, 0x00, 0x04, 0x40, 0xb5, 0x2d, - 0x21, 0x08, 0x04, 0x90, 0xaa, 0xfa, 0xff, 0x1f, 0x11, 0x01, 0x00, 0x04, - 0xf0, 0x57, 0x0a, 0x22, 0x40, 0x4a, 0xda, 0x5e, 0xfb, 0x1f, 0x40, 0x00, - 0x40, 0x20, 0xba, 0x95, 0x90, 0x00, 0x01, 0xa0, 0xaa, 0xea, 0xff, 0x5f, - 0x02, 0x02, 0x00, 0x01, 0xe8, 0x57, 0x05, 0x00, 0x00, 0x12, 0xd5, 0xfe, - 0xfd, 0x1f, 0x48, 0x00, 0x04, 0x48, 0x7a, 0x95, 0x08, 0x02, 0x10, 0x40, - 0xaa, 0x55, 0xf7, 0x1f, 0x00, 0x09, 0x20, 0x00, 0xf8, 0x57, 0x22, 0x10, - 0x00, 0x28, 0xa9, 0xfa, 0xff, 0x5f, 0x02, 0x00, 0x00, 0x49, 0xdd, 0x29, - 0x01, 0x00, 0x80, 0x80, 0xaa, 0xd7, 0xff, 0x0f, 0x10, 0x00, 0x08, 0x00, - 0xf8, 0x96, 0x08, 0x00, 0x00, 0x20, 0x54, 0xfa, 0xee, 0x3f, 0x81, 0x04, - 0x40, 0x24, 0xfe, 0x55, 0x82, 0x00, 0x00, 0x82, 0xd2, 0xad, 0xff, 0x0f, - 0x08, 0x00, 0x04, 0x80, 0x6c, 0x97, 0x00, 0x00, 0x02, 0x20, 0xa9, 0xf6, - 0xdf, 0x5f, 0x00, 0x02, 0x20, 0x09, 0xfa, 0x49, 0x12, 0x00, 0x20, 0x84, - 0x54, 0xdb, 0xfe, 0x1f, 0x91, 0x00, 0x00, 0x00, 0xf8, 0x2b, 0x00, 0x20, - 0x00, 0x40, 0xa4, 0xf6, 0xbb, 0x1f, 0x04, 0x00, 0x44, 0x92, 0x7e, 0x95, - 0x02, 0x00, 0x00, 0x89, 0xaa, 0xdd, 0xff, 0x1f, 0x20, 0x09, 0x10, 0x00, - 0xf4, 0x57, 0x20, 0x01, 0x08, 0x20, 0xa9, 0x76, 0xff, 0x5f, 0x02, 0x00, - 0x00, 0x21, 0xfc, 0x4a, 0x05, 0x00, 0x01, 0x80, 0x54, 0xdb, 0xff, 0x1e, - 0x08, 0x02, 0x04, 0x08, 0xf9, 0x2b, 0x00, 0x00, 0x40, 0x28, 0xd2, 0xf6, - 0xff, 0xbf, 0x80, 0x00, 0x90, 0x00, 0xbc, 0x92, 0x08, 0x10, 0x00, 0x82, - 0x54, 0xdb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x44, 0xf9, 0x55, 0x02, 0x01, - 0x00, 0x20, 0xaa, 0xbd, 0xfd, 0x3f, 0x08, 0x04, 0x04, 0x10, 0xf4, 0x2a, - 0x01, 0x00, 0x22, 0x80, 0xd4, 0xf6, 0xff, 0x5f, 0x82, 0x00, 0x40, 0x02, - 0xf8, 0x55, 0x20, 0x00, 0x00, 0x50, 0x6a, 0xdf, 0xfe, 0x3f, 0x00, 0x00, - 0x00, 0x48, 0xe9, 0x4a, 0x05, 0x08, 0x00, 0xa5, 0xd5, 0xf5, 0xff, 0x3f, - 0x10, 0x01, 0x10, 0x01, 0xb0, 0xab, 0x92, 0x02, 0x40, 0xf8, 0xbf, 0xde, - 0xfe, 0x5f, 0x02, 0x04, 0x04, 0x48, 0xfa, 0xd4, 0x6f, 0x20, 0x84, 0xef, - 0xff, 0xfb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x00, 0xe0, 0xed, 0xbf, 0x0b, - 0xa1, 0x7e, 0xff, 0xbf, 0xfd, 0x5f, 0x04, 0x01, 0x20, 0x49, 0xd2, 0xfb, - 0xfe, 0x55, 0xd4, 0xff, 0xff, 0xf6, 0xff, 0x07, 0x00, 0x04, 0x00, 0x00, - 0xc0, 0xaa, 0xfb, 0x2b, 0xa2, 0xfe, 0xff, 0xdf, 0xee, 0x1f, 0x91, 0x00, - 0x82, 0xa4, 0xa4, 0xf5, 0xff, 0x57, 0xd5, 0xff, 0xbf, 0xfd, 0xff, 0x4d, - 0x00, 0x00, 0x20, 0x00, 0x88, 0x5b, 0xff, 0x2f, 0x69, 0xff, 0xff, 0xdb, - 0xfe, 0x1f, 0x24, 0x02, 0x00, 0x49, 0xa2, 0xd6, 0xff, 0x5f, 0xea, 0xff, - 0x7f, 0x7f, 0x7f, 0x0d, 0x00, 0x00, 0x10, 0x00, 0x40, 0xab, 0xf7, 0xbb, - 0xf0, 0xdf, 0xff, 0xd5, 0xff, 0xbf, 0x82, 0x04, 0x42, 0x24, 0x91, 0xd5, - 0xaa, 0xae, 0xd4, 0xaa, 0x52, 0x7b, 0xff, 0x15, 0x08, 0x00, 0x00, 0x01, - 0x04, 0x55, 0xd5, 0x55, 0x70, 0x5b, 0x75, 0xdd, 0xdf, 0x1f, 0x40, 0x00, - 0x08, 0x48, 0xa0, 0x4a, 0xa9, 0x56, 0xea, 0x56, 0xad, 0x6a, 0x7d, 0x9b, - 0x04, 0x01, 0x00, 0x02, 0x42, 0x2a, 0xd5, 0xaa, 0xa8, 0xaa, 0xaa, 0xfa, - 0xdf, 0x2f, 0x10, 0x04, 0x22, 0x48, 0x08, 0x45, 0x2a, 0x15, 0x68, 0x55, - 0x55, 0xd7, 0x76, 0x1b, 0x00, 0x00, 0x00, 0x01, 0x40, 0x2a, 0x80, 0xa0, - 0xb2, 0x09, 0x48, 0xb9, 0xdf, 0x17, 0x22, 0x01, 0x00, 0x24, 0x45, 0x8a, - 0x24, 0x4a, 0x54, 0x51, 0x91, 0xf6, 0x6e, 0x4b, 0x00, 0x04, 0x90, 0x00, - 0x80, 0x52, 0x00, 0x20, 0x69, 0x05, 0xa4, 0xaa, 0xff, 0x1e, 0x48, 0x00, - 0x02, 0x92, 0x08, 0x05, 0x81, 0x94, 0xd4, 0x92, 0x40, 0xfd, 0xb6, 0x8b, - 0x00, 0x01, 0x40, 0x00, 0x82, 0x54, 0x00, 0x48, 0x68, 0x05, 0x90, 0xa4, - 0xef, 0x06, 0x24, 0x00, 0x08, 0x12, 0x10, 0x05, 0x00, 0x10, 0xb5, 0x01, - 0x42, 0xfb, 0xbf, 0x43, 0x00, 0x09, 0x00, 0x40, 0x81, 0xa8, 0x08, 0x4a, - 0xaa, 0x96, 0x90, 0xac, 0x6d, 0x15, 0x22, 0x00, 0x20, 0x09, 0x04, 0x15, - 0x80, 0x28, 0xdc, 0x01, 0x24, 0xfb, 0xbf, 0x01, 0x80, 0x04, 0x09, 0x00, - 0x40, 0x48, 0x02, 0x45, 0xb2, 0x2e, 0x41, 0x6d, 0xef, 0x05, 0x11, 0x00, - 0x40, 0x52, 0x02, 0x15, 0x29, 0x2a, 0xac, 0x42, 0x54, 0xfb, 0x3b, 0x51, - 0x84, 0x00, 0x08, 0x00, 0x20, 0x54, 0x80, 0x05, 0xb5, 0x3d, 0xa2, 0xb6, - 0xdf, 0x00, 0x20, 0x04, 0x20, 0x49, 0x89, 0xa8, 0x6a, 0x29, 0xac, 0xd6, - 0x54, 0xff, 0x3f, 0x84, 0x00, 0x01, 0x04, 0x10, 0x00, 0x94, 0xa8, 0x56, - 0xda, 0x5f, 0xab, 0xd5, 0x1e, 0x10, 0x48, 0x00, 0x90, 0x82, 0x48, 0xa8, - 0xb2, 0xac, 0xfd, 0x55, 0xd5, 0xfe, 0x9f, 0x80, 0x00, 0x0a, 0x02, 0x08, - 0x02, 0x55, 0x5a, 0x75, 0xff, 0xaf, 0xb6, 0xf7, 0x2d, 0x12, 0x92, 0x00, - 0x10, 0x20, 0x10, 0xa8, 0x54, 0xd5, 0xbf, 0x5d, 0xad, 0xdd, 0x0f, 0x00, - 0x00, 0x04, 0x40, 0x09, 0x84, 0xa8, 0xaa, 0x5a, 0xed, 0xeb, 0x6a, 0xff, - 0x9f, 0xa4, 0x24, 0x01, 0x02, 0xa0, 0x20, 0x50, 0x55, 0xd5, 0xbe, 0xae, - 0xad, 0xfd, 0x16, 0x00, 0x10, 0x04, 0x20, 0x0a, 0x08, 0xb4, 0xaa, 0x95, - 0xaa, 0x7b, 0xb7, 0xdb, 0x5f, 0x92, 0x04, 0x01, 0x84, 0x20, 0x21, 0x51, - 0xd5, 0x2a, 0xa9, 0xee, 0xd5, 0xfe, 0x0d, 0x00, 0x20, 0x04, 0x10, 0x00, - 0x08, 0x50, 0xe9, 0xd7, 0xd4, 0xfb, 0xb5, 0xff, 0x9f, 0x24, 0x09, 0x01, - 0x42, 0x4a, 0xa2, 0x64, 0xd5, 0x55, 0x7b, 0x7f, 0xda, 0x7d, 0x4f, 0x00, - 0x20, 0x04, 0x00, 0x80, 0x00, 0xa0, 0x2a, 0x13, 0x84, 0x6a, 0x55, 0xff, - 0x1d, 0x48, 0x8a, 0x00, 0x94, 0x24, 0x8a, 0xc8, 0xaa, 0x42, 0x20, 0x5d, - 0xf5, 0xff, 0x5f, 0x01, 0x00, 0x02, 0x01, 0x00, 0x20, 0xa2, 0x4a, 0x1a, - 0x82, 0x56, 0xda, 0xbd, 0x3f, 0x92, 0x92, 0x00, 0x90, 0x92, 0x00, 0x40, - 0x95, 0x6a, 0xf4, 0x55, 0x6d, 0xff, 0xd6, 0x00, 0x00, 0x0a, 0x04, 0x20, - 0x14, 0x49, 0x4b, 0xaa, 0xaa, 0x56, 0xf5, 0xff, 0xbf, 0xab, 0xa4, 0x00, - 0x20, 0x89, 0x40, 0x80, 0xaa, 0xaa, 0xaa, 0xaa, 0xde, 0xbf, 0xeb, 0x03, - 0x00, 0x02, 0x04, 0x02, 0x0a, 0x10, 0x2b, 0x2a, 0x55, 0x5b, 0xf5, 0xff, - 0xd7, 0x2f, 0x92, 0x00, 0x10, 0x28, 0x21, 0x01, 0x56, 0x95, 0xa0, 0x56, - 0xdf, 0xef, 0xea, 0x87, 0x40, 0x0a, 0x42, 0x41, 0x00, 0x90, 0xaa, 0x52, - 0xb6, 0xad, 0xfa, 0xff, 0xd5, 0x2f, 0x14, 0x00, 0x00, 0x04, 0x95, 0x04, - 0xaa, 0xac, 0x55, 0x6b, 0xff, 0xb7, 0xea, 0x9f, 0x40, 0x02, 0x28, 0x51, - 0x00, 0x40, 0x58, 0xd5, 0xda, 0xd6, 0x6e, 0x7f, 0xf9, 0x3f, 0x12, 0x04, - 0x02, 0x04, 0x49, 0x25, 0x55, 0xaa, 0x77, 0xab, 0xff, 0x2b, 0xfd, 0x3f, - 0x48, 0x01, 0x20, 0x41, 0x00, 0x00, 0x58, 0xa9, 0xda, 0xea, 0xfd, 0xaf, - 0xfa, 0xff, 0x02, 0x04, 0x08, 0x14, 0x29, 0x49, 0x52, 0x55, 0x55, 0x55, - 0xff, 0x8d, 0xfe, 0x3f, 0xa8, 0x00, 0x02, 0x41, 0x00, 0x02, 0xa0, 0xa2, - 0xaa, 0xea, 0xff, 0x53, 0xfd, 0xff, 0x02, 0x04, 0x50, 0x04, 0x25, 0xa8, - 0x54, 0x49, 0x52, 0xb5, 0xbf, 0x8a, 0xfe, 0xff, 0xa9, 0x08, 0x04, 0x50, - 0x80, 0x02, 0xa1, 0x2a, 0x95, 0xea, 0xff, 0xa1, 0xff, 0xff, 0x03, 0x02, - 0x90, 0x02, 0x09, 0x08, 0x44, 0x49, 0x52, 0xbd, 0x7f, 0xca, 0xff, 0xff, - 0x2b, 0x09, 0x04, 0x48, 0x40, 0x82, 0x90, 0x56, 0xa9, 0xf6, 0xbf, 0xd0, - 0xff, 0xff, 0x47, 0x00, 0x50, 0x02, 0x15, 0x11, 0x40, 0x95, 0xaa, 0xfd, - 0x2f, 0xe9, 0xff, 0xff, 0x8f, 0x0a, 0x84, 0x50, 0x40, 0x84, 0x14, 0xaa, - 0x6a, 0xff, 0x5f, 0xf2, 0xff, 0xff, 0x7f, 0x00, 0x10, 0x02, 0x09, 0x10, - 0x40, 0x7d, 0xf7, 0xff, 0x0b, 0xfc, 0xff, 0xff, 0xaf, 0x02, 0x84, 0x50, - 0x42, 0x85, 0x12, 0xd0, 0xdd, 0xff, 0xa7, 0xf2, 0xff, 0xff, 0xff, 0x04, - 0x00, 0x0a, 0x08, 0x10, 0x48, 0xf8, 0xff, 0xff, 0x0a, 0xfe, 0xff, 0xff, - 0x7f, 0x03, 0xa4, 0x80, 0xa2, 0x8a, 0x02, 0x68, 0xff, 0xff, 0x52, 0xfd, - 0xff, 0xff, 0xff, 0x07, 0x00, 0x2a, 0x08, 0x20, 0x28, 0xdc, 0xff, 0x5f, - 0x05, 0xff, 0xff, 0xff, 0xff, 0x0d, 0x92, 0x40, 0x22, 0x09, 0x02, 0xea, - 0xfb, 0xaf, 0x48, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x12, 0x81, 0xa0, - 0x48, 0x9c, 0x6e, 0x93, 0xa2, 0xff, 0xff, 0xff, 0xff, 0x07, 0xa8, 0x40, - 0x28, 0x0a, 0x02, 0x74, 0xb5, 0x45, 0x81, 0xff, 0xff, 0xff, 0xff, 0x0f, - 0x02, 0x0a, 0x81, 0x20, 0x08, 0xae, 0xaa, 0x90, 0xe8, 0xff, 0xff, 0xff, - 0xff, 0x0f, 0x90, 0x40, 0x28, 0x88, 0x12, 0x58, 0x15, 0x50, 0xd0, 0xff, - 0xff, 0xff, 0xff, 0x0f, 0x44, 0x0a, 0x41, 0x21, 0x08, 0xae, 0x04, 0x14, - 0xf0, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40, 0x14, 0x88, 0x04, 0xba, - 0x02, 0x28, 0xe8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x42, 0x15, 0x41, 0x21, - 0x05, 0xad, 0x00, 0x05, 0xf8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40, - 0x24, 0x8a, 0x0e, 0x36, 0x00, 0x0a, 0xf4, 0xff, 0xff, 0xff, 0xff, 0x0f, - 0x42, 0x25, 0x90, 0xd0, 0x8b, 0xc2, 0x41, 0x05, 0xfc, 0xff, 0xff, 0xff, - 0xff, 0x0f, 0x10, 0x08, 0x05, 0xe8, 0x8e, 0x58, 0x80, 0x02, 0xfa, 0xff, - 0xff, 0xff, 0xff, 0x0f, 0x4a, 0x20, 0xa8, 0xba, 0x0b, 0x2b, 0x51, 0x01, - 0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x8a, 0x02, 0xe8, 0xaf, 0x84, - 0x90, 0x04, 0xfd, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x52, 0x21, 0x54, 0xbf, - 0x1f, 0x15, 0xa5, 0x02, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x08, - 0x01, 0xfa, 0xb6, 0xa4, 0x52, 0x40, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, - 0x4a, 0xa2, 0x54, 0xef, 0x5f, 0x4b, 0xa4, 0x80, 0xff, 0xff, 0xff, 0xff, - 0xff, 0x0f, 0x80, 0x10, 0x82, 0xfe, 0xbf, 0x92, 0x52, 0x42, 0xff, 0xff, - 0xff, 0xff, 0xff, 0x0f, 0x12, 0x42, 0xa8, 0xbf, 0x1f, 0x24, 0x80, 0xa0, - 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28, 0x8a, 0xf7, 0x37, 0x80, - 0x52, 0x80, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x82, 0xe0, 0xff, - 0x1f, 0x00, 0x20, 0xe1, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28, - 0xca, 0xff, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, - 0x10, 0x42, 0xf0, 0xfd, 0x1b, 0x00, 0x50, 0xf0, 0xff, 0xff, 0xff, 0xff, - 0xff, 0x0f, 0xa4, 0x10, 0xc5, 0xff, 0x1f, 0x00, 0x00, 0xe0, 0xff, 0xff, - 0xff, 0xff, 0xff, 0x0f, 0x00, 0x22, 0xf8, 0xff, 0x0e, 0x00, 0x00, 0xf0, - 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xaa, 0x88, 0xe2, 0xff, 0x0f, 0x10, - 0x00, 0xf0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x25, 0xfa, 0xff, - 0x0f, 0x01, 0x11, 0xfd, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xff, 0xfb, - 0xfb, 0xff, 0x7f, 0x5d, 0xd5, 0xfa, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f}; diff --git a/tcl/library/demos/images/flagdown.bmp b/tcl/library/demos/images/flagdown.bmp deleted file mode 100644 index 55abc51825b..00000000000 --- a/tcl/library/demos/images/flagdown.bmp +++ /dev/null @@ -1,27 +0,0 @@ -#define flagdown_width 48 -#define flagdown_height 48 -static char flagdown_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, - 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xe1, 0x00, 0x00, - 0x00, 0x00, 0x70, 0x80, 0x01, 0x00, 0x00, 0x00, 0x18, 0x00, 0x03, 0x00, - 0x00, 0x00, 0x0c, 0x00, 0x03, 0x00, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, - 0x00, 0x00, 0x03, 0x00, 0x06, 0x06, 0x00, 0x80, 0x01, 0x00, 0x06, 0x07, - 0x00, 0xc0, 0x1f, 0x00, 0x87, 0x07, 0x00, 0xe0, 0x7f, 0x80, 0xc7, 0x07, - 0x00, 0x70, 0xe0, 0xc0, 0xe5, 0x07, 0x00, 0x38, 0x80, 0xe1, 0x74, 0x07, - 0x00, 0x18, 0x80, 0x71, 0x3c, 0x07, 0x00, 0x0c, 0x00, 0x3b, 0x1e, 0x03, - 0x00, 0x0c, 0x00, 0x1f, 0x0f, 0x00, 0x00, 0x86, 0x1f, 0x8e, 0x07, 0x00, - 0x00, 0x06, 0x06, 0xc6, 0x05, 0x00, 0x00, 0x06, 0x00, 0xc6, 0x05, 0x00, - 0x00, 0x06, 0x00, 0xc6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, - 0x7f, 0x06, 0x00, 0x06, 0xe4, 0xff, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, - 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x06, 0x00, - 0x00, 0x06, 0x00, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00, - 0x00, 0x06, 0x00, 0xc6, 0x00, 0x00, 0x00, 0x06, 0x00, 0x66, 0x00, 0x00, - 0x00, 0x06, 0x00, 0x36, 0x00, 0x00, 0x00, 0x06, 0x00, 0x3e, 0x00, 0x00, - 0x00, 0xfe, 0xff, 0x2f, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x27, 0x00, 0x00, - 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, - 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, - 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, - 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, - 0xf7, 0xbf, 0x8e, 0xfc, 0xdf, 0xf8, 0x9d, 0xeb, 0x9b, 0x76, 0xd2, 0x7a, - 0x46, 0x30, 0xe2, 0x0f, 0xe1, 0x47, 0x55, 0x84, 0x48, 0x11, 0x84, 0x19}; diff --git a/tcl/library/demos/images/flagup.bmp b/tcl/library/demos/images/flagup.bmp deleted file mode 100644 index 6eb0d846a32..00000000000 --- a/tcl/library/demos/images/flagup.bmp +++ /dev/null @@ -1,27 +0,0 @@ -#define flagup_width 48 -#define flagup_height 48 -static char flagup_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, - 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xef, 0x6a, 0x00, - 0x00, 0x00, 0xc0, 0x7b, 0x75, 0x00, 0x00, 0x00, 0xe0, 0xe0, 0x6a, 0x00, - 0x00, 0x00, 0x30, 0x60, 0x75, 0x00, 0x00, 0x00, 0x18, 0xe0, 0x7f, 0x00, - 0x00, 0x00, 0x0c, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x06, 0xe0, 0x04, 0x00, - 0x00, 0x00, 0x03, 0xe0, 0x04, 0x00, 0x00, 0x80, 0x01, 0xe0, 0x06, 0x00, - 0x00, 0xc0, 0x1f, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x7f, 0xe0, 0x07, 0x00, - 0x00, 0x70, 0xe0, 0xe0, 0x05, 0x00, 0x00, 0x38, 0x80, 0xe1, 0x04, 0x00, - 0x00, 0x18, 0x80, 0xf1, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xfb, 0x04, 0x00, - 0x00, 0x0c, 0x00, 0xff, 0x04, 0x00, 0x00, 0x86, 0x1f, 0xee, 0x04, 0x00, - 0x00, 0x06, 0x06, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, - 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x66, 0x04, 0x00, - 0x7f, 0x56, 0x52, 0x06, 0xe4, 0xff, 0x00, 0x76, 0x55, 0x06, 0x04, 0x00, - 0x00, 0x56, 0x57, 0x06, 0x04, 0x00, 0x00, 0x56, 0x55, 0x06, 0x06, 0x00, - 0x00, 0x56, 0xd5, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00, - 0x54, 0x06, 0x00, 0xc6, 0x54, 0x55, 0xaa, 0x06, 0x00, 0x66, 0xaa, 0x2a, - 0x54, 0x06, 0x00, 0x36, 0x55, 0x55, 0xaa, 0x06, 0x00, 0xbe, 0xaa, 0x2a, - 0x54, 0xfe, 0xff, 0x6f, 0x55, 0x55, 0xaa, 0xfc, 0xff, 0xa7, 0xaa, 0x2a, - 0x54, 0x01, 0x88, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, - 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, - 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, - 0x54, 0x55, 0x8d, 0x50, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa8, 0xaa, 0x2a, - 0x54, 0x55, 0x95, 0x54, 0x55, 0x55, 0xaa, 0xaa, 0xaa, 0xaa, 0xaa, 0x2a, - 0x54, 0x55, 0x55, 0x55, 0x55, 0x15, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; diff --git a/tcl/library/demos/images/gray25.bmp b/tcl/library/demos/images/gray25.bmp deleted file mode 100644 index b234b3cb0be..00000000000 --- a/tcl/library/demos/images/gray25.bmp +++ /dev/null @@ -1,6 +0,0 @@ -#define grey_width 16 -#define grey_height 16 -static char grey_bits[] = { - 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, - 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, - 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44}; diff --git a/tcl/library/demos/images/letters.bmp b/tcl/library/demos/images/letters.bmp deleted file mode 100644 index 0f12568d1a0..00000000000 --- a/tcl/library/demos/images/letters.bmp +++ /dev/null @@ -1,27 +0,0 @@ -#define letters_width 48 -#define letters_height 48 -static char letters_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0xfe, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0x00, 0x00, 0x00, 0x20, - 0x00, 0xfa, 0x00, 0x00, 0x00, 0x2e, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2a, - 0x00, 0x3a, 0x00, 0x00, 0x00, 0x2a, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2e, - 0xe0, 0xff, 0xff, 0xff, 0xff, 0x21, 0x20, 0x00, 0x00, 0x00, 0x00, 0x21, - 0xa0, 0x03, 0x00, 0x00, 0x70, 0x21, 0x20, 0x00, 0x00, 0x00, 0x50, 0x21, - 0xa0, 0x1f, 0x00, 0x00, 0x50, 0x21, 0x20, 0x00, 0x00, 0x00, 0x70, 0x21, - 0xfe, 0xff, 0xff, 0xff, 0x0f, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21, - 0xfa, 0x01, 0x00, 0x80, 0x0b, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0a, 0x21, - 0xba, 0x01, 0x00, 0x80, 0x0a, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0b, 0x21, - 0x3a, 0x00, 0x00, 0x00, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21, - 0x02, 0xc0, 0xfb, 0x03, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x3f, - 0x02, 0xc0, 0xbd, 0x0f, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01, - 0x02, 0xc0, 0x7f, 0x7b, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01, - 0x02, 0x00, 0x00, 0x00, 0xf8, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, - 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, - 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, - 0xfe, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; diff --git a/tcl/library/demos/images/noletter.bmp b/tcl/library/demos/images/noletter.bmp deleted file mode 100644 index 5774124efe9..00000000000 --- a/tcl/library/demos/images/noletter.bmp +++ /dev/null @@ -1,27 +0,0 @@ -#define noletters_width 48 -#define noletters_height 48 -static char noletters_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00, - 0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00, - 0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00, - 0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01, - 0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, - 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x0f, 0xe0, 0x00, 0x00, 0x00, 0x78, 0x0e, - 0xf0, 0x00, 0x00, 0x00, 0x3c, 0x1e, 0x70, 0x00, 0x00, 0x00, 0x1e, 0x1c, - 0x38, 0x00, 0x00, 0x00, 0x0f, 0x38, 0x38, 0x00, 0x00, 0x80, 0x07, 0x38, - 0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x1c, 0x04, 0x00, 0xe0, 0x41, 0x70, - 0x1c, 0x04, 0x00, 0xf0, 0x40, 0x70, 0x1c, 0x74, 0x00, 0x78, 0x4e, 0x70, - 0x0e, 0x04, 0x00, 0x3c, 0x4a, 0xe0, 0x0e, 0x74, 0x03, 0x1e, 0x4a, 0xe0, - 0x0e, 0x04, 0x00, 0x0f, 0x4e, 0xe0, 0x0e, 0x04, 0x80, 0x07, 0x40, 0xe0, - 0x0e, 0x04, 0xf8, 0x0f, 0x40, 0xe0, 0x0e, 0x04, 0xe0, 0x01, 0x40, 0xe0, - 0x0e, 0x04, 0xf8, 0x00, 0x40, 0xe0, 0x0e, 0x04, 0x78, 0x00, 0x40, 0xe0, - 0x0e, 0x04, 0xfc, 0xf3, 0x40, 0xe0, 0x1c, 0x04, 0x1e, 0x00, 0x40, 0x70, - 0x1c, 0x04, 0x0f, 0x00, 0x40, 0x70, 0x1c, 0x84, 0x07, 0x00, 0x40, 0x70, - 0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x38, 0xe0, 0x01, 0x00, 0x00, 0x38, - 0x38, 0xf0, 0x00, 0x00, 0x00, 0x38, 0x70, 0x78, 0x00, 0x00, 0x00, 0x1c, - 0xf0, 0x3c, 0x00, 0x00, 0x00, 0x1e, 0xe0, 0x1e, 0x00, 0x00, 0x00, 0x0e, - 0xe0, 0x0f, 0x00, 0x00, 0x00, 0x0f, 0xc0, 0x07, 0x00, 0x00, 0x80, 0x07, - 0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01, - 0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00, - 0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00, - 0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00}; diff --git a/tcl/library/demos/images/pattern.bmp b/tcl/library/demos/images/pattern.bmp deleted file mode 100644 index df31baf7895..00000000000 --- a/tcl/library/demos/images/pattern.bmp +++ /dev/null @@ -1,6 +0,0 @@ -#define foo_width 16 -#define foo_height 16 -static char foo_bits[] = { - 0x60, 0x06, 0x90, 0x09, 0x90, 0x09, 0xb0, 0x0d, 0x4e, 0x72, 0x49, 0x92, - 0x71, 0x8e, 0x8e, 0x71, 0x8e, 0x71, 0x71, 0x8e, 0x49, 0x92, 0x4e, 0x72, - 0xb0, 0x0d, 0x90, 0x09, 0x90, 0x09, 0x60, 0x06}; diff --git a/tcl/library/demos/images/tcllogo.gif b/tcl/library/demos/images/tcllogo.gif Binary files differdeleted file mode 100644 index 4603d4ff417..00000000000 --- a/tcl/library/demos/images/tcllogo.gif +++ /dev/null diff --git a/tcl/library/demos/images/teapot.ppm b/tcl/library/demos/images/teapot.ppm deleted file mode 100644 index b8ab85f3a5d..00000000000 --- a/tcl/library/demos/images/teapot.ppm +++ /dev/null @@ -1,31 +0,0 @@ -P6 -256 256 -255 -\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À[7 eOLjQLmSMoTMnSMlRMhPL_9 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀnSMtVMzYN~[N~[N\N\O€\O€]O€]O€]O€]O€\O€\O}[NyYNtVM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG- wXN}[N€]O„^O†_O†`O‡`Oˆ`Oˆ`OˆaO‰aO‰aO‰aO‰aO‰aO‰aOˆaOˆ`O†_Oƒ^O\N \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀaMLyYN…_O‰aP‹bPcPŽcPŽdPŽdPdPdPdPdPdPdPdPeP‘eP’eP’eP‘ePdPcP…_OpUM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀwXN…_OdP“fP•gQ–hQ˜hQ˜iQ™iQ™iQšiQšiQšjQ›jQ›jQœjQœjQœjQœjQœjQ›jQœjQ™iQ“fP‡`O\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJiQL‹bP—hQkQ¡mR¤nR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¦pR¨pS©qSªqS«rS¬rS«rS©qS¤oRœjQ€]O\KK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀfOLrUMcPŸlR©qS¯tS²uTµwT·xT¸xT¹yTºyT»zT»zU¼zU¼zU¼zU»zUºyT¸xT¶wT¯tS¡mR‰aOhPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\Àa0 cNLqUM€\O”fQ¦pS²wVºzV¿|VÂ}VÄVÆVÇ€VÉ‚WÌ…[Õeæ w÷³‹êª…Ĉg§qT“fQ{ZNYIK9 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀO1 {G#‘JkRMqUMtVN–iS¨v\·€d¹bµzZ±vU°uT®sSªqS¤nRœjQ’eP„^OrUMHh>!T4 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG- V5 wE"~I#†M%U+¥e7²l:°g2®b*a(`(©^(¥])¡^-›]1ŠS,qC$`9 R3 G- \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À@) J/ i>!pA"tD"wF$yH&xH&tE$wE#yG%}M+ƒT4S5mE*Z7!K/ B* ;' \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À‰aO¦oR½{UÇ€VÏ…X<( F- a: e<!h>!j@#k@$h>"d<!c=$hD-fF2[<)K0 @) ;' 5$ Ë‚VÇ€V¿|U_LKYIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À…_O·xTÉ‚Wó«€ûµ‹Ö’k¼|X×>µf-¨^(¡Z'šW&–T&œN>) F- J/ b; g>#nD(jB&c<!b=%jH2_A/I0!<( 8& 5$ ”J¥Y ’S%8& ;' ?) E, <:HA=HE?IJAISFJYIKXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À£nRÁ}UܘqÊŠe±vU²e,™V&¥V†C
€@ |> y< u: r9 o7 l6 -j5 -h4 -g3 -5$ D, K/ b; h>"wM1tK.e="a<#cA,U8&E- <( 9& .!a0 b1 c1 - -+ 3# @) 46G<:HMCIXHK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀU*´vT¿~X¸{YÃk+›W&‰N$|> u: p8 k5 -f3 -a0 _/ ]. [- I¡\*ª_(‘LkRMmSMmSMnSMnSMD, R3 W5 mA"|O0|P1j?"c<!a=%Y7"N1 F, ;' NCJNCJNDJODJODJODJh>!a: X/K% -g3 -a0 Z- \/ T*Q(ŠHµm8kRMmSMnTMoTMpTMpUM15G15G05G04G04GpUMpTM5^9 d<!yF#O+€N,rC#qB"pB#k?"a: Z7 6ODJPDJPEJQEJQEJREJREJREJRFJSFJSFJSFJSFJe<!X/ -^/ V+Q(L&I$r9 TlRMnSM46G47G47G46G46G46G46G46G36G36G25G25G15G04G/4F.3F - -X&pUMuWMwXNxXN<:H<:H<:H<:H<;H<;H<;H<;H=;H=;H=;H=;H>;H>;H?<H@<HA=HC>HG@ILBIREJ[JKcNLjQL§pR±uTºzUÃ~VÈWË‚XÖŽcäsÒŽe¼{V²vT¨pSžkR•gQŒbP†_O‚^O]O€\O€\O€\O€\O€]O]O]O]O]O]O]O]O]O]O]O€\O€\O~\N}[N|ZNxXN•T%H$ -›W&rVMvWNyYNzYN|ZN}[N}[N><H?<H?<H?<H?<H?<H@<H@<H@<HA=HA=HB=HC>HE?IG@IIAIKBIODJSFJWHK—hQŸlR§pR°b(¾i*Én+Ù|7Û|6Ïr,Íq+Êp-Ãl+»g)±b(®sS§pS lRšiQ•gQePcPŠaPˆaO‡`O‡`O†_O†_O…_O…_O…_O…_O…_O…_O…_O„_O„^O„^Oƒ^Oƒ^O‚]O]O€\O~[N{ZN•T% - - -@%<-$G?@…pfdNLuWM\NdNL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀTFJvWN‰aP./01„E}[N]O…_Oˆ`O‰aP‹bPŒbPcPcPŽcPdPdPdPeP‘eP’eP’eP“fP“fQ”fQ•gQ•gQ–gQ–hQ—hQ˜hQ™iQšiQ›jQœjQkQkRžlRŸlRžY&¤\'¨^'µ^½bÀcÃe Çi Äg Àc½b¼a¹`µ^´]¯X¢[' Z'žY&¢mR¡mR¡mR lRŸlRŸlRžkRkQœkQœjQ›jQšjQšiQ™iQ™iQ˜iQ˜hQ—hQ—hQ—hQ–gQ–gQ•gQ•gQ•gQ”fQ”fQ“fQ“fP’eP‘ePdPcP‰aP—O - B\À\À\À\À\À\À\À\À\À\À%7!!C*F#P) {dYœze»p€\OgPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ`LKvWNŠaPm6 - -$ 5 ¬`(¶e)£nRœjQƒ^OJAI\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀXIK^KKdNLhPLuWM‚]OŒbP”fQeP
m6 -†`OŽcP“fQ—hQ˜hQ™iQšiQšjQ›jQ›jQ›jQœjQœjQœjQœkQkQkQkRžkRžkRžkRžlRŸlRŸlRŸlR lR lR lR¡mR¡mR¡mR¡mRºg)³c(²c(±b(V¿cÂe Åi!Åi!Àd ¼bº`¹`·_·_¶^¢Q§]'ª_(`(¹f)£nR£nR£nR£nR£nR£nR£nR¢nR¢nR¢nR¢nR¢nR¢nR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢nR¢mR¢mR£nR¢mR¢mR¡mR mRkR—hQˆGa0 ŠbP mRœjQ“fQ‰aP}[NrUMmSM…L$\À\À\À\À\À\À\À\À B B
#C, 8& H. Z7 §pR›jQ{ZN\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀQEJ[JK`LKdNLhQLqUM{ZN…_OŽcP–gQ—hQ -‹bP‘eP–hQšiQ›jQœjQkQkQkRžkRžkRžlRžlRŸlRŸlRŸlRŸlRŸlR lR lR lR mR¡mR¡mR¡mR¡mR¡mR¢mR¢mR¢mR¢nR£nRÀj*ºg)·e)¶d)Âd°XÅg Åh Âe ¿c½b½b¾bªU`(®a(¯a(³c(¾i*¤oR¤oR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤oR¤oR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¥oR¥oR¤nR¡mR›jQŽQ%Z- œjQ£nRŸlR—hQŽdP…_OuWMpTMnSMkRLa: \À\À\À\À\À\À\À B B&D 2
@* S6#G@IPDJ˜hQmSM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ]KKbMLeOLiQLlRMvWN\OˆaO‘eP—hQœjQ•gQ -!C +E'0F.4F7% 8% U/lG.SFJZIK]KKZIKB=H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀREJZJK`LKdNLgPLjQLlRMnSMpTMqUMtWMxXN{ZN~[N]O„^O†`O‰aO‹bPdP•gQ™iQœkQ lR¤nR§pSªrSsS¯tT²uT´vT¶wT·xT¹yT¹yTºyTºyT¹yT¶xT´vT¬rS¢nR—hQ¿|U¿|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ}UÀ}UÁ}UÁ}UÁ}UÁ}UÂ}UÂ~UÃ~UÃ~VÃ~VÄVÅ€WÆX®a(ŸlRªrS´vT¸yT¼zU¾|UÁ~VÃXÆ‚[Ɇ_΋dÓ‘jÔ“mÔ“nБlÊŒhĆd½_¶{[°vWªsU¦pS¢nRžkRšiQ˜hQ•gQ“fQ‘ePdPŒbP‰aO†_Oƒ^O€\O|ZNxXNsVMpTMnTMmSMjQL€C B)D&/F-3F47G6% >" Y7 kA$YIK]KK^KKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ\KKbMLeOLhPLkRLmSMnTMpTMrUMuWNyYN|ZN\N‚]O„_O‡`OŠaPŒbPŽcPeP“fP—hQ›jQžlR¢nR¥oS©qT¬sT¯uU²vU´wV¶xV¸yV¹yUºzU»zU¼{U½{U¾{U¾|U¿|U¿|U¿|U¿|U¾{U½{U¼{U¼zU»zTºyT¹yT¸xTµwT³vT´vT´vT´vT´wT´wTµwT·xT¹yTºzT¼zU½{U¾{U¿|UÀ|UÂ}UÄVÅ€WÇ‚YÉ„\͈_ÑŒdÙ”láuç£|쩂ſtî‡ëª…æ¦ÞŸ{Õ—sËŽl†d¹^³yZuW¨qU¤oSŸlRžkRœjQšiQ˜hQ–gQ”fQ‘ePdPcPŠaP‡`O„^O]O}[NyYNuWMpTMoTMmSMkRLgPL&D#.E,3F46G;' <( D"iB(VGJ]KK`LK[JKB>H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRMmSMoTMqUMsVMvXNzYN}[N€\O‚^O…_Oˆ`OŠaPŒcPdP‘eP“fQ•gQ—hQ™iQkR mS¤oT¨rU¬tW°wY´zZ¸}\»]¾€^À^Á‚^‚^Â\Á€ZÁYÁXÁ~WÁ~WÂ~VÂ~VÂ~VÃ~VÃ~UÃ~UÄ~UÄ~UÄUÄUÅVÅVÅVÅVÆVÆ€VÆ€VÇ€WÇWÈ‚XɃZË…[͇^ЊaÓdØ’iÜ—nâtè£zî©ó¯‡ø´û¸‘üº“û¹“÷¶ñ±Œé©…à¡~Ö˜vËmÇf»€`´z[®vX©rU¥pT£oS¢nS lRžkRœkRšjQ˜iQ–hQ”fQ’ePdPcP‹bPˆ`O…_O‚]O~[NzYNvWNpTMoTMnSMkRMhQLo7 ,2F36G99HC+ @ ]8 nA"\JK`ML_LKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMpTMqUMtVMwXNzZN}[N€]Oƒ^O†_OˆaO‹bPcPdP‘eP“fQ•gQ—hQ™iQ›jRžlR mS£oU§rW¬vZ²{]¹€a¿…fÅŠjËnГqÓ•sÕ–sÕ–rÕ–qÕ”oÓ’mÑjÏgÍŠcˈaɆ^È„\Ç‚[ÆYÅ€XÅ€WÅWÅWÅVÅVÅWÅ€WÆ€WÇXÈ‚YɃ[Ê…\͇_ÏŠaÒeÕ‘hÙ•mÝ™qávä¡zç¤}ê§€ë©ƒëª„é¨ƒå¥€ß |Ù›wÓ•rÌmƉh¿„c¸~^²yZ®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRœkR›jQ™iQ—hQ•gQ“fPePŽcP‹bPˆaO…_O‚^O\N{ZNwXNsVMoTMnSMlRMiQL~I#26G99G?<HA* E$ i@$ZIKaMLbML[JK;:H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀWHJ]KKbMLeOLhPLjRLlSMnTMpTMrUMuWMxXN{ZN~\N]O„^O†`O‰aO‹bPŽcPdP’eP”fQ–gQ˜hQšiQœkRžlS mT£oU¦rWªuZ¯y]´~aºƒfŠlË’sÔšzÜ¡€ã§†è«‰ë®‹í¯Œí®‹ë¬ˆè¨„ã£~ßžyÚ™tÖ•oÒjÎŒfˈbÈ…_ƃ\ÅZÄ€YÃXÂWÂ~WÂ~WÂ~WÃXÀXÄ€YÅZƃ\Ç…^Ɇ`ˈbÌŠdÍ‹fÎgÎŽiÎŽjÎŽjÍŽjËŒiljgÆd¿ƒaº^¸}]¶|\´{[²yZ°xY®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRkR›jQ™iQ—hQ•gQ“fP‘ePŽdPŒbP‰aO†_Oƒ^O€\O|ZNxXNtVMpTMnSMmSMjQLgPL99G?<HG- E&b;!YIK`MLdOM`LKNCJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀŸlRºyTÄ~UÊ‚XʃYÄXº{WtUšW'¢[(—hQ lRcP€\OhQL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRLmSMoTMqUMrVMvWNyYN|ZN\N‚]O„_O‡`O‰aPŒbPŽcPdP’fP”gQ–hQ˜iQšjRœkRžlS¡nT¤pU§sW«vZ°z]µb»„gŠlÉ‘sИyØžÞ¤…ã©Šèì±ï³‘ﳑëŠç©…⣀ݞzؘtÒ“nÎiɉdÆ…`Â]Á€[¿~Y¾}X½|W½|V¼{V¼{V¼{V¼{V¼{V¼|W¼|W½}X½}Y½~Z½~Z¼~Z»}[º}[º}[º~\º~\º~]º~]¹~]¸~]·}]¶|\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS mRŸlRkR›jQšiQ˜hQ–gQ“fQ‘ePdPŒcPŠaP‡`O„^O]O}[NyYNuWNpTMnTMmSMkRLhPL|H$D>IQ2 P+XHK_LLfQOcNLXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À©qSºyTÃ~VΈ`遲ޜv¾€]ªqS–LŽG|> g3 -S)? *%.—hQ—hQ‘eP‡`OuWM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMoTMqUMsVMwXNzYN}[N€\O‚^O…_O‡`OŠaPŒbPŽdP‘eP“fP•gQ—hQ˜iQšjRœkRŸlS¡nT¤pV§sX«vZ°z^¶b¼…gËmÊ’sјzØŸ€Þ¤…ã©Šèê¯ë°ê¯Žè¬‹å¨‡à¤‚Ûž|Ö™wÑ“qÌŽlljgÃ…bÀ‚_½\»}Zº{X¹zW¸yV·yU·xU·xU·xT·xT·xU·xU·xU·yV·yV·yW¸zW¸{X¹{Y¹|Zº}[º}[º}\º~\¹~]¹~]¸}]·|\µ{\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS¡mRŸlRkRœjQšiQ˜hQ–gQ”fQ’ePdPcPŠbP‡`O…_O‚]O~[NzZNvWNrUMoTMmSMlRMiQLeOLJAIJ(h>!]KKfQOgQN_LKD>I\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À™iQ°tS¸yT¼{UÂYÎŒeïˆô´Õ—u¶|\ Z'™LˆD
|> - -
& 3#.$ -% .% .& /&!,# ,# @70A71XNHXNHWNHWNHZRLYQLYQLXQLWQLWPLUOLSNLQMKOLJMJJ0//.-.,,-&(+ "( !' - % ' %$#" ! !$
diff --git a/tcl/library/demos/items.tcl b/tcl/library/demos/items.tcl deleted file mode 100644 index fea5e8b1a5e..00000000000 --- a/tcl/library/demos/items.tcl +++ /dev/null @@ -1,285 +0,0 @@ -# items.tcl -- -# -# This demonstration script creates a canvas that displays the -# canvas item types. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .items -catch {destroy $w} -toplevel $w -wm title $w "Canvas Item Demonstration" -wm iconname $w "Items" -positionWindow $w -set c $w.frame.c - -label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.frame -pack $w.frame -side top -fill both -expand yes - -canvas $c -scrollregion {0c 0c 30c 24c} -width 15c -height 10c \ - -relief sunken -borderwidth 2 \ - -xscrollcommand "$w.frame.hscroll set" \ - -yscrollcommand "$w.frame.vscroll set" -scrollbar $w.frame.vscroll -command "$c yview" -scrollbar $w.frame.hscroll -orient horiz -command "$c xview" - -grid $c -in $w.frame \ - -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid $w.frame.vscroll \ - -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -grid $w.frame.hscroll \ - -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid rowconfig $w.frame 0 -weight 1 -minsize 0 -grid columnconfig $w.frame 0 -weight 1 -minsize 0 - -# Display a 3x3 rectangular grid. - -$c create rect 0c 0c 30c 24c -width 2 -$c create line 0c 8c 30c 8c -width 2 -$c create line 0c 16c 30c 16c -width 2 -$c create line 10c 0c 10c 24c -width 2 -$c create line 20c 0c 20c 24c -width 2 - -set font1 {Helvetica 12} -set font2 {Helvetica 24 bold} -if {[winfo depth $c] > 1} { - set blue DeepSkyBlue3 - set red red - set bisque bisque3 - set green SeaGreen3 -} else { - set blue black - set red black - set bisque black - set green black -} - -# Set up demos within each of the areas of the grid. - -$c create text 5c .2c -text Lines -anchor n -$c create line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m -fill $blue \ - -cap butt -join miter -tags item -$c create line 4.67c 1c 4.67c 4c -arrow last -tags item -$c create line 6.33c 1c 6.33c 4c -arrow both -tags item -$c create line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c \ - 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c \ - -width 3 -fill $red -tags item -$c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \ - -stipple @[file join $tk_library demos images gray25.bmp] \ - -arrow both -arrowshape {15 15 7} -tags item -$c create line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c \ - -cap round -join round -tags item - -$c create text 15c .2c -text "Curves (smoothed lines)" -anchor n -$c create line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on \ - -fill $blue -tags item -$c create line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on \ - -arrow both -width 3 -tags item -$c create line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c \ - 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round \ - -stipple @[file join $tk_library demos images gray25.bmp] \ - -fill $red -tags item - -$c create text 25c .2c -text Polygons -anchor n -$c create polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c \ - 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c -fill $green \ - -outline black -width 4 -tags item -$c create polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c \ - 29c 1c 29c 4c 29c 4c -fill $red -smooth on -tags item -$c create polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c \ - 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c \ - -stipple @[file join $tk_library demos images gray25.bmp] \ - -outline black -tags item - -$c create text 5c 8.2c -text Rectangles -anchor n -$c create rectangle 1c 9.5c 4c 12.5c -outline $red -width 3m -tags item -$c create rectangle 0.5c 13.5c 4.5c 15.5c -fill $green -tags item -$c create rectangle 6c 10c 9c 15c -outline {} \ - -stipple @[file join $tk_library demos images gray25.bmp] \ - -fill $blue -tags item - -$c create text 15c 8.2c -text Ovals -anchor n -$c create oval 11c 9.5c 14c 12.5c -outline $red -width 3m -tags item -$c create oval 10.5c 13.5c 14.5c 15.5c -fill $green -tags item -$c create oval 16c 10c 19c 15c -outline {} \ - -stipple @[file join $tk_library demos images gray25.bmp] \ - -fill $blue -tags item - -$c create text 25c 8.2c -text Text -anchor n -$c create rectangle 22.4c 8.9c 22.6c 9.1c -$c create text 22.5c 9c -anchor n -font $font1 -width 4c \ - -text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text." -tags item -$c create rectangle 25.4c 10.9c 25.6c 11.1c -$c create text 25.5c 11c -anchor w -font $font1 -fill $blue \ - -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \ - -justify center -tags item -$c create rectangle 24.9c 13.9c 25.1c 14.1c -$c create text 25c 14c -font $font2 -anchor c -fill $red -stipple gray50 \ - -text "Stippled characters" -tags item - -$c create text 5c 16.2c -text Arcs -anchor n -$c create arc 0.5c 17c 7c 20c -fill $green -outline black \ - -start 45 -extent 270 -style pieslice -tags item -$c create arc 6.5c 17c 9.5c 20c -width 4m -style arc \ - -outline $blue -start -135 -extent 270 -tags item \ - -outlinestipple @[file join $tk_library demos images gray25.bmp] -$c create arc 0.5c 20c 9.5c 24c -width 4m -style pieslice \ - -fill {} -outline $red -start 225 -extent -90 -tags item -$c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ - -fill $blue -outline {} -start 45 -extent 270 -tags item - -$c create text 15c 16.2c -text Bitmaps -anchor n -$c create bitmap 13c 20c -tags item \ - -bitmap @[file join $tk_library demos images face.bmp] -$c create bitmap 17c 18.5c -tags item \ - -bitmap @[file join $tk_library demos images noletter.bmp] -$c create bitmap 17c 21.5c -tags item \ - -bitmap @[file join $tk_library demos images letters.bmp] - -$c create text 25c 16.2c -text Windows -anchor n -button $c.button -text "Press Me" -command "butPress $c $red" -$c create window 21c 18c -window $c.button -anchor nw -tags item -entry $c.entry -width 20 -relief sunken -$c.entry insert end "Edit this text" -$c create window 21c 21c -window $c.entry -anchor nw -tags item -scale $c.scale -from 0 -to 100 -length 6c -sliderlength .4c \ - -width .5c -tickinterval 0 -$c create window 28.5c 17.5c -window $c.scale -anchor n -tags item -$c create text 21c 17.9c -text Button: -anchor sw -$c create text 21c 20.9c -text Entry: -anchor sw -$c create text 28.5c 17.4c -text Scale: -anchor s - -# Set up event bindings for canvas: - -$c bind item <Any-Enter> "itemEnter $c" -$c bind item <Any-Leave> "itemLeave $c" -bind $c <2> "$c scan mark %x %y" -bind $c <B2-Motion> "$c scan dragto %x %y" -bind $c <3> "itemMark $c %x %y" -bind $c <B3-Motion> "itemStroke $c %x %y" -bind $c <Control-f> "itemsUnderArea $c" -bind $c <1> "itemStartDrag $c %x %y" -bind $c <B1-Motion> "itemDrag $c %x %y" - -# Utility procedures for highlighting the item under the pointer: - -proc itemEnter {c} { - global restoreCmd - - if {[winfo depth $c] == 1} { - set restoreCmd {} - return - } - set type [$c type current] - if {$type == "window"} { - set restoreCmd {} - return - } - if {$type == "bitmap"} { - set bg [lindex [$c itemconf current -background] 4] - set restoreCmd [list $c itemconfig current -background $bg] - $c itemconfig current -background SteelBlue2 - return - } - set fill [lindex [$c itemconfig current -fill] 4] - if {(($type == "rectangle") || ($type == "oval") || ($type == "arc")) - && ($fill == "")} { - set outline [lindex [$c itemconfig current -outline] 4] - set restoreCmd "$c itemconfig current -outline $outline" - $c itemconfig current -outline SteelBlue2 - } else { - set restoreCmd "$c itemconfig current -fill $fill" - $c itemconfig current -fill SteelBlue2 - } -} - -proc itemLeave {c} { - global restoreCmd - - eval $restoreCmd -} - -# Utility procedures for stroking out a rectangle and printing what's -# underneath the rectangle's area. - -proc itemMark {c x y} { - global areaX1 areaY1 - set areaX1 [$c canvasx $x] - set areaY1 [$c canvasy $y] - $c delete area -} - -proc itemStroke {c x y} { - global areaX1 areaY1 areaX2 areaY2 - set x [$c canvasx $x] - set y [$c canvasy $y] - if {($areaX1 != $x) && ($areaY1 != $y)} { - $c delete area - $c addtag area withtag [$c create rect $areaX1 $areaY1 $x $y \ - -outline black] - set areaX2 $x - set areaY2 $y - } -} - -proc itemsUnderArea {c} { - global areaX1 areaY1 areaX2 areaY2 - set area [$c find withtag area] - set items "" - foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] { - if {[lsearch [$c gettags $i] item] != -1} { - lappend items $i - } - } - puts stdout "Items enclosed by area: $items" - set items "" - foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] { - if {[lsearch [$c gettags $i] item] != -1} { - lappend items $i - } - } - puts stdout "Items overlapping area: $items" -} - -set areaX1 0 -set areaY1 0 -set areaX2 0 -set areaY2 0 - -# Utility procedures to support dragging of items. - -proc itemStartDrag {c x y} { - global lastX lastY - set lastX [$c canvasx $x] - set lastY [$c canvasy $y] -} - -proc itemDrag {c x y} { - global lastX lastY - set x [$c canvasx $x] - set y [$c canvasy $y] - $c move current [expr {$x-$lastX}] [expr {$y-$lastY}] - set lastX $x - set lastY $y -} - -# Procedure that's invoked when the button embedded in the canvas -# is invoked. - -proc butPress {w color} { - set i [$w create text 25c 18.1c -text "Ouch!!" -fill $color -anchor n] - after 500 "$w delete $i" -} diff --git a/tcl/library/demos/ixset b/tcl/library/demos/ixset deleted file mode 100644 index 76319cc0bb6..00000000000 --- a/tcl/library/demos/ixset +++ /dev/null @@ -1,335 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish "$0" ${1+"$@"} - -# ixset -- -# A nice interface to "xset" to change X server settings -# -# History : -# 91/11/23 : pda@masi.ibp.fr, jt@ratp.fr : design -# 92/08/01 : pda@masi.ibp.fr : cleaning -# -# RCS: @(#) $Id$ - -# -# Button actions -# - -proc quit {} { - destroy . -} - -proc ok {} { - writesettings - quit -} - -proc cancel {} { - readsettings - dispsettings - .buttons.apply configure -state disabled - .buttons.cancel configure -state disabled -} - -proc apply {} { - writesettings - .buttons.apply configure -state disabled - .buttons.cancel configure -state disabled -} - -# -# Read current settings -# - -proc readsettings {} { - global kbdrep ; set kbdrep "on" - global kbdcli ; set kbdcli 0 - global bellvol ; set bellvol 100 - global bellpit ; set bellpit 440 - global belldur ; set belldur 100 - global mouseacc ; set mouseacc "3/1" - global mousethr ; set mousethr 4 - global screenbla ; set screenbla "blank" - global screentim ; set screentim 600 - global screencyc ; set screencyc 600 - - set xfd [open "|xset q" r] - while {[gets $xfd line] > -1} { - set kw [lindex $line 0] - - case $kw in { - {auto} - { - set rpt [lindex $line 1] - if {[expr "{$rpt} == {repeat:}"]} then { - set kbdrep [lindex $line 2] - set kbdcli [lindex $line 6] - } - } - {bell} - { - set bellvol [lindex $line 2] - set bellpit [lindex $line 5] - set belldur [lindex $line 8] - } - {acceleration:} - { - set mouseacc [lindex $line 1] - set mousethr [lindex $line 3] - } - {prefer} - { - set bla [lindex $line 2] - set screenbla [expr "{$bla} == {yes} ? {blank} : {noblank}"] - } - {timeout:} - { - set screentim [lindex $line 1] - set screencyc [lindex $line 3] - } - } - } - close $xfd - - # puts stdout [format "Key REPEAT = %s\n" $kbdrep] - # puts stdout [format "Key CLICK = %s\n" $kbdcli] - # puts stdout [format "Bell VOLUME = %s\n" $bellvol] - # puts stdout [format "Bell PITCH = %s\n" $bellpit] - # puts stdout [format "Bell DURATION = %s\n" $belldur] - # puts stdout [format "Mouse ACCELERATION = %s\n" $mouseacc] - # puts stdout [format "Mouse THRESHOLD = %s\n" $mousethr] - # puts stdout [format "Screen BLANCK = %s\n" $screenbla] - # puts stdout [format "Screen TIMEOUT = %s\n" $screentim] - # puts stdout [format "Screen CYCLE = %s\n" $screencyc] -} - - -# -# Write settings into the X server -# - -proc writesettings {} { - global kbdrep kbdcli bellvol bellpit belldur - global mouseacc mousethr screenbla screentim screencyc - - set bellvol [.bell.vol get] - set bellpit [.bell.val.pit.entry get] - set belldur [.bell.val.dur.entry get] - - if {[expr "{$kbdrep} == {on}"]} then { - set kbdcli [.kbd.val.cli get] - } else { - set kbdcli "off" - } - - set mouseacc [.mouse.hor.acc.entry get] - set mousethr [.mouse.hor.thr.entry get] - - set screentim [.screen.tim.entry get] - set screencyc [.screen.cyc.entry get] - - exec xset \ - b $bellvol $bellpit $belldur \ - c $kbdcli \ - r $kbdrep \ - m $mouseacc $mousethr \ - s $screentim $screencyc \ - s $screenbla -} - - -# -# Sends all settings to the window -# - -proc dispsettings {} { - global kbdrep kbdcli bellvol bellpit belldur - global mouseacc mousethr screenbla screentim screencyc - - .bell.vol set $bellvol - .bell.val.pit.entry delete 0 end - .bell.val.pit.entry insert 0 $bellpit - .bell.val.dur.entry delete 0 end - .bell.val.dur.entry insert 0 $belldur - - .kbd.val.onoff [expr "{$kbdrep} == {on} ? {select} : {deselect}"] - .kbd.val.cli set $kbdcli - - .mouse.hor.acc.entry delete 0 end - .mouse.hor.acc.entry insert 0 $mouseacc - .mouse.hor.thr.entry delete 0 end - .mouse.hor.thr.entry insert 0 $mousethr - - .screen.blank [expr "{$screenbla}=={blank} ? {select} : {deselect}"] - .screen.pat [expr "{$screenbla}!={blank} ? {select} : {deselect}"] - .screen.tim.entry delete 0 end - .screen.tim.entry insert 0 $screentim - .screen.cyc.entry delete 0 end - .screen.cyc.entry insert 0 $screencyc -} - - -# -# Create all windows, and pack them -# - -proc labelentry {path text length {range {}}} { - frame $path - label $path.label -text $text - if {[llength $range]} { - spinbox $path.entry -width $length -relief sunken \ - -from [lindex $range 0] -to [lindex $range 1] - } else { - entry $path.entry -width $length -relief sunken - } - pack $path.label -side left - pack $path.entry -side right -expand y -fill x -} - -proc createwindows {} { - # - # Buttons - # - - frame .buttons - button .buttons.ok -default active -command ok -text "Ok" - button .buttons.apply -default normal -command apply -text "Apply" \ - -state disabled - button .buttons.cancel -default normal -command cancel -text "Cancel" \ - -state disabled - button .buttons.quit -default normal -command quit -text "Quit" - - pack .buttons.ok .buttons.apply .buttons.cancel .buttons.quit \ - -side left -expand yes -pady 5 - - bind . <Return> {.buttons.ok flash; .buttons.ok invoke} - bind . <Escape> {.buttons.quit flash; .buttons.quit invoke} - bind . <1> { - if {![string match .buttons* %W]} { - .buttons.apply configure -state normal - .buttons.cancel configure -state normal - } - } - bind . <Key> { - if {![string match .buttons* %W]} { - switch -glob %K { - Return - Escape - Tab - *Shift* {} - default { - .buttons.apply configure -state normal - .buttons.cancel configure -state normal - } - } - } - } - - # - # Bell settings - # - - labelframe .bell -text "Bell Settings" -padx 1.5m -pady 1.5m - scale .bell.vol \ - -from 0 -to 100 -length 200 -tickinterval 20 \ - -label "Volume (%)" -orient horizontal - - frame .bell.val - labelentry .bell.val.pit "Pitch (Hz)" 6 {25 20000} - labelentry .bell.val.dur "Duration (ms)" 6 {1 10000} - pack .bell.val.pit -side left -padx 5 - pack .bell.val.dur -side right -padx 5 - pack .bell.vol .bell.val -side top -expand yes - - # - # Keyboard settings - # - - labelframe .kbd -text "Keyboard Repeat Settings" -padx 1.5m -pady 1.5m - - frame .kbd.val - checkbutton .kbd.val.onoff \ - -text "On" \ - -onvalue "on" -offvalue "off" -variable kbdrep \ - -relief flat - scale .kbd.val.cli \ - -from 0 -to 100 -length 200 -tickinterval 20 \ - -label "Click Volume (%)" -orient horizontal - pack .kbd.val.onoff -side left -fill x -expand yes -padx {0 1m} - pack .kbd.val.cli -side left -expand yes -fill x -padx {1m 0} - - pack .kbd.val -side top -expand yes -pady 2 -fill x - - # - # Mouse settings - # - - labelframe .mouse -text "Mouse Settings" -padx 1.5m -pady 1.5m - - frame .mouse.hor - labelentry .mouse.hor.acc "Acceleration" 5 - labelentry .mouse.hor.thr "Threshold (pixels)" 3 {1 2000} - - pack .mouse.hor.acc -side left -padx {0 1m} - pack .mouse.hor.thr -side right -padx {1m 0} - - pack .mouse.hor -side top -expand yes - - # - # Screen Saver settings - # - - labelframe .screen -text "Screen-saver Settings" -padx 1.5m -pady 1.5m - - radiobutton .screen.blank \ - -variable screenblank -text "Blank" -relief flat \ - -value "blank" -variable screenbla -anchor w - radiobutton .screen.pat \ - -variable screenblank -text "Pattern" -relief flat \ - -value "noblank" -variable screenbla -anchor w - labelentry .screen.tim "Timeout (s)" 5 {1 100000} - labelentry .screen.cyc "Cycle (s)" 5 {1 100000} - - grid .screen.blank .screen.tim -sticky e - grid .screen.pat .screen.cyc -sticky e - grid configure .screen.blank .screen.pat -sticky ew - - # - # Main window - # - - pack .buttons -side top -fill both - pack .bell .kbd .mouse .screen -side top -fill both -expand yes \ - -padx 1m -pady 1m - - # - # Let the user resize our window - # - wm minsize . 10 10 -} - -############################################################################## -# Main program - -# -# Listen what "xset" tells us... -# - -readsettings - -# -# Create all windows -# - -createwindows - -# -# Write xset parameters -# - -dispsettings - -# -# Now, wait for user actions... -# - -# Local Variables: -# mode: tcl -# End: diff --git a/tcl/library/demos/label.tcl b/tcl/library/demos/label.tcl deleted file mode 100644 index 86ff4d61b5f..00000000000 --- a/tcl/library/demos/label.tcl +++ /dev/null @@ -1,40 +0,0 @@ -# label.tcl -- -# -# This demonstration script creates a toplevel window containing -# several label widgets. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .label -catch {destroy $w} -toplevel $w -wm title $w "Label Demonstration" -wm iconname $w "label" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.left -frame $w.right -pack $w.left $w.right -side left -expand yes -padx 10 -pady 10 -fill both - -label $w.left.l1 -text "First label" -label $w.left.l2 -text "Second label, raised" -relief raised -label $w.left.l3 -text "Third label, sunken" -relief sunken -pack $w.left.l1 $w.left.l2 $w.left.l3 -side top -expand yes -pady 2 -anchor w - -label $w.right.bitmap -borderwidth 2 -relief sunken \ - -bitmap @[file join $tk_library demos images face.bmp] -label $w.right.caption -text "Tcl/Tk Proprietor" -pack $w.right.bitmap $w.right.caption -side top diff --git a/tcl/library/demos/labelframe.tcl b/tcl/library/demos/labelframe.tcl deleted file mode 100644 index 7688368025f..00000000000 --- a/tcl/library/demos/labelframe.tcl +++ /dev/null @@ -1,80 +0,0 @@ -# labelframe.tcl -- -# -# This demonstration script creates a toplevel window containing -# several labelframe widgets. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .labelframe -catch {destroy $w} -toplevel $w -wm title $w "Labelframe Demonstration" -wm iconname $w "labelframe" -positionWindow $w - -# Some information - -label $w.msg -font $font -wraplength 4i -justify left -text "Labelframes are\ - used to group related widgets together. The label may be either \ - plain text or another widget." -pack $w.msg -side top - -# The bottom buttons - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -width 15 -button $w.buttons.code -text "See Code" -command "showCode $w" -width 15 -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -# Demo area - -frame $w.f -pack $w.f -side bottom -fill both -expand 1 -set w $w.f - -# A group of radiobuttons in a labelframe - -labelframe $w.f -text "Value" -padx 2 -pady 2 -grid $w.f -row 0 -column 0 -pady 2m -padx 2m - -foreach value {1 2 3 4} { - radiobutton $w.f.b$value -text "This is value $value" \ - -variable lfdummy -value $value - pack $w.f.b$value -side top -fill x -pady 2 -} - - -# Using a label window to control a group of options. - -proc lfEnableButtons {w} { - foreach child [winfo children $w] { - if {$child == "$w.cb"} continue - if {$::lfdummy2} { - $child configure -state normal - } else { - $child configure -state disabled - } - } -} - -labelframe $w.f2 -pady 2 -padx 2 -checkbutton $w.f2.cb -text "Use this option." -variable lfdummy2 \ - -command "lfEnableButtons $w.f2" -padx 0 -$w.f2 configure -labelwidget $w.f2.cb -grid $w.f2 -row 0 -column 1 -pady 2m -padx 2m - -set t 0 -foreach str {Option1 Option2 Option3} { - checkbutton $w.f2.b$t -text $str - pack $w.f2.b$t -side top -fill x -pady 2 - incr t -} -lfEnableButtons $w.f2 - - -grid columnconfigure $w {0 1} -weight 1 diff --git a/tcl/library/demos/license.terms b/tcl/library/demos/license.terms deleted file mode 100644 index 03ca6fcb319..00000000000 --- a/tcl/library/demos/license.terms +++ /dev/null @@ -1,39 +0,0 @@ -This software is copyrighted by the Regents of the University of -California, Sun Microsystems, Inc., and other parties. The following -terms apply to all files associated with the software unless explicitly -disclaimed in individual files. - -The authors hereby grant permission to use, copy, modify, distribute, -and license this software and its documentation for any purpose, provided -that existing copyright notices are retained in all copies and that this -notice is included verbatim in any distributions. No written agreement, -license, or royalty fee is required for any of the authorized uses. -Modifications to this software may be copyrighted by their authors -and need not follow the licensing terms described here, provided that -the new terms are clearly indicated on the first page of each file where -they apply. - -IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY -FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY -DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. - -THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE -IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE -NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR -MODIFICATIONS. - -GOVERNMENT USE: If you are acquiring this software on behalf of the -U.S. government, the Government shall have only "Restricted Rights" -in the software and related documentation as defined in the Federal -Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you -are acquiring the software on behalf of the Department of Defense, the -software shall be classified as "Commercial Computer Software" and the -Government shall have only "Restricted Rights" as defined in Clause -252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the -authors grant the U.S. Government and others acting in its behalf -permission to use and distribute the software in accordance with the -terms specified in this license. diff --git a/tcl/library/demos/menu.tcl b/tcl/library/demos/menu.tcl deleted file mode 100644 index 9b0f6bb4fe1..00000000000 --- a/tcl/library/demos/menu.tcl +++ /dev/null @@ -1,160 +0,0 @@ -# menu.tcl -- -# -# This demonstration script creates a window with a bunch of menus -# and cascaded menus using menubars. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .menu -catch {destroy $w} -toplevel $w -wm title $w "Menu Demonstration" -wm iconname $w "menu" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - $w.msg configure -text "This window contains a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where \"x\" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by dragging outside of its bounds and releasing the mouse." -} else { - $w.msg configure -text "This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where \"x\" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator. The rightmost menu can be torn off into a palette by selecting the first item in the menu." -} -pack $w.msg -side top - -set menustatus " " -frame $w.statusBar -label $w.statusBar.label -textvariable menustatus -relief sunken -bd 1 -font "Helvetica 10" -anchor w -pack $w.statusBar.label -side left -padx 2 -expand yes -fill both -pack $w.statusBar -side bottom -fill x -pady 2 - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -menu $w.menu -tearoff 0 - -set m $w.menu.file -menu $m -tearoff 0 -$w.menu add cascade -label "File" -menu $m -underline 0 -$m add command -label "Open..." -command {error "this is just a demo: no action has been defined for the \"Open...\" entry"} -$m add command -label "New" -command {error "this is just a demo: no action has been defined for the \"New\" entry"} -$m add command -label "Save" -command {error "this is just a demo: no action has been defined for the \"Save\" entry"} -$m add command -label "Save As..." -command {error "this is just a demo: no action has been defined for the \"Save As...\" entry"} -$m add separator -$m add command -label "Print Setup..." -command {error "this is just a demo: no action has been defined for the \"Print Setup...\" entry"} -$m add command -label "Print..." -command {error "this is just a demo: no action has been defined for the \"Print...\" entry"} -$m add separator -$m add command -label "Dismiss Menus Demo" -command "destroy $w" - -set m $w.menu.basic -$w.menu add cascade -label "Basic" -menu $m -underline 0 -menu $m -tearoff 0 -$m add command -label "Long entry that does nothing" -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - set modifier Command -} elseif {$tcl_platform(platform) == "windows"} { - set modifier Control -} else { - set modifier Meta -} -foreach i {A B C D E F} { - $m add command -label "Print letter \"$i\"" -underline 14 \ - -accelerator Meta+$i -command "puts $i" -accelerator $modifier+$i - bind $w <$modifier-[string tolower $i]> "puts $i" -} - -set m $w.menu.cascade -$w.menu add cascade -label "Cascades" -menu $m -underline 0 -menu $m -tearoff 0 -$m add command -label "Print hello" \ - -command {puts stdout "Hello"} -accelerator $modifier+H -underline 6 -bind $w <$modifier-h> {puts stdout "Hello"} -$m add command -label "Print goodbye" -command {\ - puts stdout "Goodbye"} -accelerator $modifier+G -underline 6 -bind $w <$modifier-g> {puts stdout "Goodbye"} -$m add cascade -label "Check buttons" \ - -menu $w.menu.cascade.check -underline 0 -$m add cascade -label "Radio buttons" \ - -menu $w.menu.cascade.radio -underline 0 - -set m $w.menu.cascade.check -menu $m -tearoff 0 -$m add check -label "Oil checked" -variable oil -$m add check -label "Transmission checked" -variable trans -$m add check -label "Brakes checked" -variable brakes -$m add check -label "Lights checked" -variable lights -$m add separator -$m add command -label "Show current values" \ - -command "showVars $w.menu.cascade.dialog oil trans brakes lights" -$m invoke 1 -$m invoke 3 - -set m $w.menu.cascade.radio -menu $m -tearoff 0 -$m add radio -label "10 point" -variable pointSize -value 10 -$m add radio -label "14 point" -variable pointSize -value 14 -$m add radio -label "18 point" -variable pointSize -value 18 -$m add radio -label "24 point" -variable pointSize -value 24 -$m add radio -label "32 point" -variable pointSize -value 32 -$m add sep -$m add radio -label "Roman" -variable style -value roman -$m add radio -label "Bold" -variable style -value bold -$m add radio -label "Italic" -variable style -value italic -$m add sep -$m add command -label "Show current values" \ - -command "showVars $w.menu.cascade.dialog pointSize style" -$m invoke 1 -$m invoke 7 - -set m $w.menu.icon -$w.menu add cascade -label "Icons" -menu $m -underline 0 -menu $m -tearoff 0 -$m add command \ - -bitmap @[file join $tk_library demos images pattern.bmp] \ - -hidemargin 1 \ - -command { - tk_dialog .pattern {Bitmap Menu Entry} {The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.} {} 0 OK -} -foreach i {info questhead error} { - $m add command -bitmap $i -command "puts {You invoked the $i bitmap}" -hidemargin 1 -} -$m entryconfigure 2 -columnbreak 1 - -set m $w.menu.more -$w.menu add cascade -label "More" -menu $m -underline 0 -menu $m -tearoff 0 -foreach i {{An entry} {Another entry} {Does nothing} {Does almost nothing} {Make life meaningful}} { - $m add command -label $i -command [list puts "You invoked \"$i\""] -} -$m entryconfigure "Does almost nothing" \ - -bitmap questhead -compound left -command { - tk_dialog .compound {Compound Menu Entry} {The menu entry you invoked\ - displays both a bitmap and a text string. Other than this, it\ - is just like any other menu entry.} {} 0 OK -} - -set m $w.menu.colors -$w.menu add cascade -label "Colors" -menu $m -underline 1 -menu $m -foreach i {red orange yellow green blue} { - $m add command -label $i -background $i \ - -command [list puts "You invoked \"$i\""] -} - -$w configure -menu $w.menu - -bind Menu <<MenuSelect>> { - global $menustatus - if {[catch {%W entrycget active -label} label]} { - set label " " - } - set menustatus $label - update idletasks -} diff --git a/tcl/library/demos/menubu.tcl b/tcl/library/demos/menubu.tcl deleted file mode 100644 index 2f9fea930b0..00000000000 --- a/tcl/library/demos/menubu.tcl +++ /dev/null @@ -1,94 +0,0 @@ -# menubutton.tcl -- -# -# This demonstration script creates a window with a bunch of menus -# and cascaded menus using menubuttons. -# -# # RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .menubutton -catch {destroy $w} -toplevel $w -wm title $w "Menu Button Demonstration" -wm iconname $w "menubutton" -positionWindow $w - - -frame $w.body -pack $w.body -expand 1 -fill both - -menubutton $w.body.below -text "Below" -underline 0 -direction below -menu $w.body.below.m -relief raised -menu $w.body.below.m -tearoff 0 -$w.body.below.m add command -label "Below menu: first item" -command "puts \"You have selected the first item from the Below menu.\"" -$w.body.below.m add command -label "Below menu: second item" -command "puts \"You have selected the second item from the Below menu.\"" -grid $w.body.below -row 0 -column 1 -sticky n -menubutton $w.body.right -text "Right" -underline 0 -direction right -menu $w.body.right.m -relief raised -menu $w.body.right.m -tearoff 0 -$w.body.right.m add command -label "Right menu: first item" -command "puts \"You have selected the first item from the Right menu.\"" -$w.body.right.m add command -label "Right menu: second item" -command "puts \"You have selected the second item from the Right menu.\"" -frame $w.body.center -menubutton $w.body.left -text "Left" -underline 0 -direction left -menu $w.body.left.m -relief raised -menu $w.body.left.m -tearoff 0 -$w.body.left.m add command -label "Left menu: first item" -command "puts \"You have selected the first item from the Left menu.\"" -$w.body.left.m add command -label "Left menu: second item" -command "puts \"You have selected the second item from the Left menu.\"" -grid $w.body.right -row 1 -column 0 -sticky w -grid $w.body.center -row 1 -column 1 -sticky news -grid $w.body.left -row 1 -column 2 -sticky e -menubutton $w.body.above -text "Above" -underline 0 -direction above -menu $w.body.above.m -relief raised -menu $w.body.above.m -tearoff 0 -$w.body.above.m add command -label "Above menu: first item" -command "puts \"You have selected the first item from the Above menu.\"" -$w.body.above.m add command -label "Above menu: second item" -command "puts \"You have selected the second item from the Above menu.\"" -grid $w.body.above -row 2 -column 1 -sticky s - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode .menubu" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -set body $w.body.center -label $body.label -wraplength 300 -font "Helvetica 14" -justify left -text "This is a demonstration of menubuttons. The \"Below\" menubutton pops its menu below the button; the \"Right\" button pops to the right, etc. There are two option menus directly below this text; one is just a standard menu and the other is a 16-color palette." -pack $body.label -side top -padx 25 -pady 25 -frame $body.buttons -pack $body.buttons -padx 25 -pady 25 -tk_optionMenu $body.buttons.options menubuttonoptions one two three -pack $body.buttons.options -side left -padx 25 -pady 25 -set m [tk_optionMenu $body.buttons.colors paletteColor Black red4 DarkGreen NavyBlue gray75 Red Green Blue gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet] -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - set topBorderColor Black - set bottomBorderColor Black -} else { - set topBorderColor gray50 - set bottomBorderColor gray75 -} -for {set i 0} {$i <= [$m index last]} {incr i} { - set name [$m entrycget $i -label] - image create photo image_$name -height 16 -width 16 - image_$name put $topBorderColor -to 0 0 16 1 - image_$name put $topBorderColor -to 0 1 1 16 - image_$name put $bottomBorderColor -to 0 15 16 16 - image_$name put $bottomBorderColor -to 15 1 16 16 - image_$name put $name -to 1 1 15 15 - - image create photo image_${name}_s -height 16 -width 16 - image_${name}_s put Black -to 0 0 16 2 - image_${name}_s put Black -to 0 2 2 16 - image_${name}_s put Black -to 2 14 16 16 - image_${name}_s put Black -to 14 2 16 14 - image_${name}_s put $name -to 2 2 14 14 - - $m entryconfigure $i -image image_$name -selectimage image_${name}_s -hidemargin 1 -} -$m configure -tearoff 1 -foreach i {Black gray75 gray50 White} { - $m entryconfigure $i -columnbreak 1 -} - -pack $body.buttons.colors -side left -padx 25 -pady 25 - - - diff --git a/tcl/library/demos/msgbox.tcl b/tcl/library/demos/msgbox.tcl deleted file mode 100644 index bc286c16c50..00000000000 --- a/tcl/library/demos/msgbox.tcl +++ /dev/null @@ -1,65 +0,0 @@ -# msgbox.tcl -- -# -# This demonstration script creates message boxes of various type -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .msgbox -catch {destroy $w} -toplevel $w -wm title $w "Message Box Demonstration" -wm iconname $w "messagebox" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Choose the icon and type option of the message box. Then press the \"Message Box\" button to see the message box." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -button $w.buttons.vars -text "Message Box" \ - -command "showMessageBox $w" -pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 - -frame $w.left -frame $w.right -pack $w.left $w.right -side left -expand yes -fill y -pady .5c -padx .5c - -label $w.left.label -text "Icon" -frame $w.left.sep -relief ridge -bd 1 -height 2 -pack $w.left.label -side top -pack $w.left.sep -side top -fill x -expand no - -set msgboxIcon info -foreach i {error info question warning} { - radiobutton $w.left.b$i -text $i -variable msgboxIcon \ - -relief flat -value $i -width 16 -anchor w - pack $w.left.b$i -side top -pady 2 -anchor w -fill x -} - -label $w.right.label -text "Type" -frame $w.right.sep -relief ridge -bd 1 -height 2 -pack $w.right.label -side top -pack $w.right.sep -side top -fill x -expand no - -set msgboxType ok -foreach t {abortretryignore ok okcancel retrycancel yesno yesnocancel} { - radiobutton $w.right.$t -text $t -variable msgboxType \ - -relief flat -value $t -width 16 -anchor w - pack $w.right.$t -side top -pady 2 -anchor w -fill x -} - -proc showMessageBox {w} { - global msgboxIcon msgboxType - set button [tk_messageBox -icon $msgboxIcon -type $msgboxType \ - -title Message -parent $w\ - -message "This is a \"$msgboxType\" type messagebox with the \"$msgboxIcon\" icon"] - - tk_messageBox -icon info -message "You have selected \"$button\"" -type ok\ - -parent $w -} diff --git a/tcl/library/demos/paned1.tcl b/tcl/library/demos/paned1.tcl deleted file mode 100644 index 5adc2550c75..00000000000 --- a/tcl/library/demos/paned1.tcl +++ /dev/null @@ -1,34 +0,0 @@ -# paned1.tcl -- -# -# This demonstration script creates a toplevel window containing -# a paned window that separates two windows horizontally. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .paned1 -catch {destroy $w} -toplevel $w -wm title $w "Horizontal Paned Window Demonstration" -wm iconname $w "paned1" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "The sash between the two coloured windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)" -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -panedwindow $w.pane -pack $w.pane -side top -expand yes -fill both -pady 2 -padx 2m - -label $w.pane.left -text "This is the\nleft side" -bg yellow -label $w.pane.right -text "This is the\nright side" -bg cyan - -$w.pane add $w.pane.left $w.pane.right diff --git a/tcl/library/demos/paned2.tcl b/tcl/library/demos/paned2.tcl deleted file mode 100644 index 5bfcf06f837..00000000000 --- a/tcl/library/demos/paned2.tcl +++ /dev/null @@ -1,76 +0,0 @@ -# paned2.tcl -- -# -# This demonstration script creates a toplevel window containing -# a paned window that separates two windows vertically. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .paned2 -catch {destroy $w} -toplevel $w -wm title $w "Vertical Paned Window Demonstration" -wm iconname $w "paned2" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "The sash between the two scrolled windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)" -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -# Create the pane itself -panedwindow $w.pane -orient vertical -pack $w.pane -side top -expand yes -fill both -pady 2 -padx 2m - -# The top window is a listbox with scrollbar -set paneList { - {List of Tk Widgets} - button - canvas - checkbutton - entry - frame - label - labelframe - listbox - menu - menubutton - message - panedwindow - radiobutton - scale - scrollbar - spinbox - text - toplevel -} -set f [frame $w.pane.top] -listbox $f.list -listvariable paneList -yscrollcommand "$f.scr set" -# Invert the first item to highlight it -$f.list itemconfigure 0 \ - -background [$f.list cget -fg] -foreground [$f.list cget -bg] -scrollbar $f.scr -orient vertical -command "$f.list yview" -pack $f.scr -side right -fill y -pack $f.list -fill both -expand 1 - -# The bottom window is a text widget with scrollbar -set f [frame $w.pane.bottom] -text $f.text -xscrollcommand "$f.xscr set" -yscrollcommand "$f.yscr set" \ - -width 30 -wrap none -scrollbar $f.xscr -orient horizontal -command "$f.text xview" -scrollbar $f.yscr -orient vertical -command "$f.text yview" -grid $f.text $f.yscr -sticky nsew -grid $f.xscr -sticky nsew -grid columnconfigure $f 0 -weight 1 -grid rowconfigure $f 0 -weight 1 -$f.text insert 1.0 "This is just a normal text widget" - -# Now add our contents to the paned window -$w.pane add $w.pane.top $w.pane.bottom diff --git a/tcl/library/demos/plot.tcl b/tcl/library/demos/plot.tcl deleted file mode 100644 index dadf6158c4d..00000000000 --- a/tcl/library/demos/plot.tcl +++ /dev/null @@ -1,99 +0,0 @@ -# plot.tcl -- -# -# This demonstration script creates a canvas widget showing a 2-D -# plot with data points that can be dragged with the mouse. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .plot -catch {destroy $w} -toplevel $w -wm title $w "Plot Demonstration" -wm iconname $w "Plot" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -canvas $c -relief raised -width 450 -height 300 -pack $w.c -side top -fill x - -set plotFont {Helvetica 18} - -$c create line 100 250 400 250 -width 2 -$c create line 100 250 100 50 -width 2 -$c create text 225 20 -text "A Simple Plot" -font $plotFont -fill brown - -for {set i 0} {$i <= 10} {incr i} { - set x [expr {100 + ($i*30)}] - $c create line $x 250 $x 245 -width 2 - $c create text $x 254 -text [expr {10*$i}] -anchor n -font $plotFont -} -for {set i 0} {$i <= 5} {incr i} { - set y [expr {250 - ($i*40)}] - $c create line 100 $y 105 $y -width 2 - $c create text 96 $y -text [expr {$i*50}].0 -anchor e -font $plotFont -} - -foreach point { - {12 56} {20 94} {33 98} {32 120} {61 180} {75 160} {98 223} -} { - set x [expr {100 + (3*[lindex $point 0])}] - set y [expr {250 - (4*[lindex $point 1])/5}] - set item [$c create oval [expr {$x-6}] [expr {$y-6}] \ - [expr {$x+6}] [expr {$y+6}] -width 1 -outline black \ - -fill SkyBlue2] - $c addtag point withtag $item -} - -$c bind point <Any-Enter> "$c itemconfig current -fill red" -$c bind point <Any-Leave> "$c itemconfig current -fill SkyBlue2" -$c bind point <1> "plotDown $c %x %y" -$c bind point <ButtonRelease-1> "$c dtag selected" -bind $c <B1-Motion> "plotMove $c %x %y" - -set plot(lastX) 0 -set plot(lastY) 0 - -# plotDown -- -# This procedure is invoked when the mouse is pressed over one of the -# data points. It sets up state to allow the point to be dragged. -# -# Arguments: -# w - The canvas window. -# x, y - The coordinates of the mouse press. - -proc plotDown {w x y} { - global plot - $w dtag selected - $w addtag selected withtag current - $w raise current - set plot(lastX) $x - set plot(lastY) $y -} - -# plotMove -- -# This procedure is invoked during mouse motion events. It drags the -# current item. -# -# Arguments: -# w - The canvas window. -# x, y - The coordinates of the mouse. - -proc plotMove {w x y} { - global plot - $w move selected [expr {$x-$plot(lastX)}] [expr {$y-$plot(lastY)}] - set plot(lastX) $x - set plot(lastY) $y -} diff --git a/tcl/library/demos/puzzle.tcl b/tcl/library/demos/puzzle.tcl deleted file mode 100644 index 31f13facd52..00000000000 --- a/tcl/library/demos/puzzle.tcl +++ /dev/null @@ -1,84 +0,0 @@ -# puzzle.tcl -- -# -# This demonstration script creates a 15-puzzle game using a collection -# of buttons. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -# puzzleSwitch -- -# This procedure is invoked when the user clicks on a particular button; -# if the button is next to the empty space, it moves the button into th -# empty space. - -proc puzzleSwitch {w num} { - global xpos ypos - if {(($ypos($num) >= ($ypos(space) - .01)) - && ($ypos($num) <= ($ypos(space) + .01)) - && ($xpos($num) >= ($xpos(space) - .26)) - && ($xpos($num) <= ($xpos(space) + .26))) - || (($xpos($num) >= ($xpos(space) - .01)) - && ($xpos($num) <= ($xpos(space) + .01)) - && ($ypos($num) >= ($ypos(space) - .26)) - && ($ypos($num) <= ($ypos(space) + .26)))} { - set tmp $xpos(space) - set xpos(space) $xpos($num) - set xpos($num) $tmp - set tmp $ypos(space) - set ypos(space) $ypos($num) - set ypos($num) $tmp - place $w.frame.$num -relx $xpos($num) -rely $ypos($num) - } -} - -set w .puzzle -catch {destroy $w} -toplevel $w -wm title $w "15-Puzzle Demonstration" -wm iconname $w "15-Puzzle" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -# Special trick: select a darker color for the space by creating a -# scrollbar widget and using its trough color. - -scrollbar $w.s - -# The button metrics are a bit bigger in Aqua, and since we are -# using place which doesn't autosize, then we need to have a -# slightly larger frame here... - -if {[string equal [tk windowingsystem] aqua]} { - set frameSize 160 -} else { - set frameSize 120 -} - -frame $w.frame -width $frameSize -height $frameSize -borderwidth 2\ - -relief sunken -bg [$w.s cget -troughcolor] -pack $w.frame -side top -pady 1c -padx 1c -destroy $w.s - -set order {3 1 6 2 5 7 15 13 4 11 8 9 14 10 12} -for {set i 0} {$i < 15} {set i [expr {$i+1}]} { - set num [lindex $order $i] - set xpos($num) [expr {($i%4)*.25}] - set ypos($num) [expr {($i/4)*.25}] - button $w.frame.$num -relief raised -text $num -highlightthickness 0 \ - -command "puzzleSwitch $w $num" - place $w.frame.$num -relx $xpos($num) -rely $ypos($num) \ - -relwidth .25 -relheight .25 -} -set xpos(space) .75 -set ypos(space) .75 diff --git a/tcl/library/demos/radio.tcl b/tcl/library/demos/radio.tcl deleted file mode 100644 index 80bfd37dc65..00000000000 --- a/tcl/library/demos/radio.tcl +++ /dev/null @@ -1,59 +0,0 @@ -# radio.tcl -- -# -# This demonstration script creates a toplevel window containing -# several radiobutton widgets. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .radio -catch {destroy $w} -toplevel $w -wm title $w "Radiobutton Demonstration" -wm iconname $w "radio" -positionWindow $w -label $w.msg -font $font -wraplength 5i -justify left -text "Three groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -button $w.buttons.vars -text "See Variables" \ - -command "showVars $w.dialog size color align" -pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 - -labelframe $w.left -pady 2 -text "Point Size" -padx 2 -labelframe $w.mid -pady 2 -text "Color" -padx 2 -labelframe $w.right -pady 2 -text "Alignment" -padx 2 -pack $w.left $w.mid $w.right -side left -expand yes -pady .5c -padx .5c - -foreach i {10 12 14 18 24} { - radiobutton $w.left.b$i -text "Point Size $i" -variable size \ - -relief flat -value $i - pack $w.left.b$i -side top -pady 2 -anchor w -fill x -} - -foreach c {Red Green Blue Yellow Orange Purple} { - set lower [string tolower $c] - radiobutton $w.mid.$lower -text $c -variable color \ - -relief flat -value $lower -anchor w \ - -command "$w.mid configure -fg \$color" - pack $w.mid.$lower -side top -pady 2 -fill x -} - -label $w.right.l -text "Label" -bitmap questhead -compound left -$w.right.l configure -width [winfo reqwidth $w.right.l] -compound top -$w.right.l configure -height [winfo reqheight $w.right.l] -foreach a {Top Left Right Bottom} { - set lower [string tolower $a] - radiobutton $w.right.$lower -text $a -variable align \ - -relief flat -value $lower -indicatoron 0 -width 7 \ - -command "$w.right.l configure -compound \$align" -} -grid x $w.right.top -grid $w.right.left $w.right.l $w.right.right -grid x $w.right.bottom diff --git a/tcl/library/demos/rmt b/tcl/library/demos/rmt deleted file mode 100644 index d0df5e25107..00000000000 --- a/tcl/library/demos/rmt +++ /dev/null @@ -1,210 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish "$0" "$@" - -# rmt -- -# This script implements a simple remote-control mechanism for -# Tk applications. It allows you to select an application and -# then type commands to that application. -# -# RCS: @(#) $Id$ - -wm title . "Tk Remote Controller" -wm iconname . "Tk Remote" -wm minsize . 1 1 - -# The global variable below keeps track of the remote application -# that we're sending to. If it's an empty string then we execute -# the commands locally. - -set app "local" - -# The global variable below keeps track of whether we're in the -# middle of executing a command entered via the text. - -set executing 0 - -# The global variable below keeps track of the last command executed, -# so it can be re-executed in response to !! commands. - -set lastCommand "" - -# Create menu bar. Arrange to recreate all the information in the -# applications sub-menu whenever it is cascaded to. - -. configure -menu [menu .menu] -menu .menu.file -menu .menu.file.apps -postcommand fillAppsMenu -.menu add cascade -label "File" -underline 0 -menu .menu.file -.menu.file add cascade -label "Select Application" -underline 0 \ - -menu .menu.file.apps -.menu.file add command -label "Quit" -command "destroy ." -underline 0 - -# Create text window and scrollbar. - -text .t -relief sunken -bd 2 -yscrollcommand ".s set" -setgrid true -scrollbar .s -command ".t yview" -grid .t .s -sticky nsew -grid rowconfigure . 0 -weight 1 -grid columnconfigure . 0 -weight 1 - -# Create a binding to forward commands to the target application, -# plus modify many of the built-in bindings so that only information -# in the current command can be deleted (can still set the cursor -# earlier in the text and select and insert; just can't delete). - -bindtags .t {.t Text . all} -bind .t <Return> { - .t mark set insert {end - 1c} - .t insert insert \n - invoke - break -} -bind .t <Delete> { - catch {.t tag remove sel sel.first promptEnd} - if {[.t tag nextrange sel 1.0 end] == ""} { - if [.t compare insert < promptEnd] { - break - } - } -} -bind .t <BackSpace> { - catch {.t tag remove sel sel.first promptEnd} - if {[.t tag nextrange sel 1.0 end] == ""} { - if [.t compare insert <= promptEnd] { - break - } - } -} -bind .t <Control-d> { - if [.t compare insert < promptEnd] { - break - } -} -bind .t <Control-k> { - if [.t compare insert < promptEnd] { - .t mark set insert promptEnd - } -} -bind .t <Control-t> { - if [.t compare insert < promptEnd] { - break - } -} -bind .t <Meta-d> { - if [.t compare insert < promptEnd] { - break - } -} -bind .t <Meta-BackSpace> { - if [.t compare insert <= promptEnd] { - break - } -} -bind .t <Control-h> { - if [.t compare insert <= promptEnd] { - break - } -} -auto_load tkTextInsert -proc tkTextInsert {w s} { - if {$s == ""} { - return - } - catch { - if {[$w compare sel.first <= insert] - && [$w compare sel.last >= insert]} { - $w tag remove sel sel.first promptEnd - $w delete sel.first sel.last - } - } - $w insert insert $s - $w see insert -} - -.t configure -font {Courier 12} -.t tag configure bold -font {Courier 12 bold} - -# The procedure below is used to print out a prompt at the -# insertion point (which should be at the beginning of a line -# right now). - -proc prompt {} { - global app - .t insert insert "$app: " - .t mark set promptEnd {insert} - .t mark gravity promptEnd left - .t tag add bold {promptEnd linestart} promptEnd -} - -# The procedure below executes a command (it takes everything on the -# current line after the prompt and either sends it to the remote -# application or executes it locally, depending on "app". - -proc invoke {} { - global app executing lastCommand - set cmd [.t get promptEnd insert] - incr executing 1 - if [info complete $cmd] { - if {$cmd == "!!\n"} { - set cmd $lastCommand - } else { - set lastCommand $cmd - } - if {$app == "local"} { - set result [catch [list uplevel #0 $cmd] msg] - } else { - set result [catch [list send $app $cmd] msg] - } - if {$result != 0} { - .t insert insert "Error: $msg\n" - } else { - if {$msg != ""} { - .t insert insert $msg\n - } - } - prompt - .t mark set promptEnd insert - } - incr executing -1 - .t yview -pickplace insert -} - -# The following procedure is invoked to change the application that -# we're talking to. It also updates the prompt for the current -# command, unless we're in the middle of executing a command from -# the text item (in which case a new prompt is about to be output -# so there's no need to change the old one). - -proc newApp appName { - global app executing - set app $appName - if !$executing { - .t mark gravity promptEnd right - .t delete "promptEnd linestart" promptEnd - .t insert promptEnd "$appName: " - .t tag add bold "promptEnd linestart" promptEnd - .t mark gravity promptEnd left - } - return {} -} - -# The procedure below will fill in the applications sub-menu with a list -# of all the applications that currently exist. - -proc fillAppsMenu {} { - set m .menu.file.apps - catch {$m delete 0 last} - foreach i [lsort [winfo interps]] { - $m add command -label $i -command [list newApp $i] - } - $m add command -label local -command {newApp local} -} - -set app [winfo name .] -prompt -focus .t - -# Local Variables: -# mode: tcl -# End: diff --git a/tcl/library/demos/rolodex b/tcl/library/demos/rolodex deleted file mode 100644 index 58bb0520b7a..00000000000 --- a/tcl/library/demos/rolodex +++ /dev/null @@ -1,196 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish "$0" ${1+"$@"} - -# rolodex -- -# This script was written as an entry in Tom LaStrange's rolodex -# benchmark. It creates something that has some of the look and -# feel of a rolodex program, although it's lifeless and doesn't -# actually do the rolodex application. -# -# RCS: @(#) $Id$ - -foreach i [winfo child .] { - catch {destroy $i} -} - -set version 1.2 - -#------------------------------------------ -# Phase 0: create the front end. -#------------------------------------------ - -frame .frame -relief flat -pack .frame -side top -fill y -anchor center - -set names {{} Name: Address: {} {} {Home Phone:} {Work Phone:} Fax:} -foreach i {1 2 3 4 5 6 7} { - label .frame.label$i -text [lindex $names $i] -anchor e - entry .frame.entry$i -width 35 - grid .frame.label$i .frame.entry$i -sticky ew -pady 2 -padx 1 -} - -frame .buttons -pack .buttons -side bottom -pady 2 -anchor center -button .buttons.clear -text Clear -button .buttons.add -text Add -button .buttons.search -text Search -button .buttons.delete -text "Delete ..." -pack .buttons.clear .buttons.add .buttons.search .buttons.delete \ - -side left -padx 2 - -#------------------------------------------ -# Phase 1: Add menus, dialog boxes -#------------------------------------------ - -frame .menu -relief raised -borderwidth 1 -pack .menu -before .frame -side top -fill x - -menubutton .menu.file -text "File" -menu .menu.file.m -underline 0 -menu .menu.file.m -.menu.file.m add command -label "Load ..." -command fileAction -underline 0 -.menu.file.m add command -label "Exit" -command {destroy .} -underline 0 -pack .menu.file -side left - -menubutton .menu.help -text "Help" -menu .menu.help.m -underline 0 -menu .menu.help.m -pack .menu.help -side right - -proc deleteAction {} { - if {[tk_dialog .delete {Confirm Action} {Are you sure?} {} 0 Cancel] - == 0} { - clearAction - } -} -.buttons.delete config -command deleteAction - -proc fileAction {} { - tk_dialog .fileSelection {File Selection} {This is a dummy file selection dialog box, which is used because there isn't a good file selection dialog built into Tk yet.} {} 0 OK - puts stderr {dummy file name} -} - -#------------------------------------------ -# Phase 3: Print contents of card -#------------------------------------------ - -proc addAction {} { - global names - foreach i {1 2 3 4 5 6 7} { - puts stderr [format "%-12s %s" [lindex $names $i] [.frame.entry$i get]] - } -} -.buttons.add config -command addAction - -#------------------------------------------ -# Phase 4: Miscellaneous other actions -#------------------------------------------ - -proc clearAction {} { - foreach i {1 2 3 4 5 6 7} { - .frame.entry$i delete 0 end - } -} -.buttons.clear config -command clearAction - -proc fillCard {} { - clearAction - .frame.entry1 insert 0 "John Ousterhout" - .frame.entry2 insert 0 "CS Division, Department of EECS" - .frame.entry3 insert 0 "University of California" - .frame.entry4 insert 0 "Berkeley, CA 94720" - .frame.entry5 insert 0 "private" - .frame.entry6 insert 0 "510-642-0865" - .frame.entry7 insert 0 "510-642-5775" -} -.buttons.search config -command "addAction; fillCard" - -#---------------------------------------------------- -# Phase 5: Accelerators, mnemonics, command-line info -#---------------------------------------------------- - -.buttons.clear config -text "Clear Ctrl+C" -bind . <Control-c> clearAction -.buttons.add config -text "Add Ctrl+A" -bind . <Control-a> addAction -.buttons.search config -text "Search Ctrl+S" -bind . <Control-s> "addAction; fillCard" -.buttons.delete config -text "Delete... Ctrl+D" -bind . <Control-d> deleteAction - -.menu.file.m entryconfig 1 -accel Ctrl+F -bind . <Control-f> fileAction -.menu.file.m entryconfig 2 -accel Ctrl+Q -bind . <Control-q> {destroy .} - -focus .frame.entry1 - -#---------------------------------------------------- -# Phase 6: help -#---------------------------------------------------- - -proc Help {topic {x 0} {y 0}} { - global helpTopics helpCmds - if {$topic == ""} return - while {[info exists helpCmds($topic)]} { - set topic [eval $helpCmds($topic)] - } - if [info exists helpTopics($topic)] { - set msg $helpTopics($topic) - } else { - set msg "Sorry, but no help is available for this topic" - } - tk_dialog .help {Rolodex Help} "Information on $topic:\n\n$msg" \ - {} 0 OK -} - -proc getMenuTopic {w x y} { - return $w.[$w index @[expr {$y-[winfo rooty $w]}]] -} - -event add <<Help>> <F1> <Help> -bind . <<Help>> {Help [winfo containing %X %Y] %X %Y} -bind Menu <<Help>> {Help [winfo containing %X %Y] %X %Y} - -# Help text and commands follow: - -set helpTopics(.menu.file) {This is the "file" menu. It can be used to invoke some overall operations on the rolodex applications, such as loading a file or exiting.} - -set helpCmds(.menu.file.m) {getMenuTopic $topic $x $y} -set helpTopics(.menu.file.m.1) {The "Load" entry in the "File" menu posts a dialog box that you can use to select a rolodex file} -set helpTopics(.menu.file.m.2) {The "Exit" entry in the "File" menu causes the rolodex application to terminate} -set helpCmds(.menu.file.m.none) {set topic ".menu.file"} - -set helpTopics(.frame.entry1) {In this field of the rolodex entry you should type the person's name} -set helpTopics(.frame.entry2) {In this field of the rolodex entry you should type the first line of the person's address} -set helpTopics(.frame.entry3) {In this field of the rolodex entry you should type the second line of the person's address} -set helpTopics(.frame.entry4) {In this field of the rolodex entry you should type the third line of the person's address} -set helpTopics(.frame.entry5) {In this field of the rolodex entry you should type the person's home phone number, or "private" if the person doesn't want his or her number publicized} -set helpTopics(.frame.entry6) {In this field of the rolodex entry you should type the person's work phone number} -set helpTopics(.frame.entry7) {In this field of the rolodex entry you should type the phone number for the person's FAX machine} - -set helpCmds(.frame.label1) {set topic .frame.entry1} -set helpCmds(.frame.label2) {set topic .frame.entry2} -set helpCmds(.frame.label3) {set topic .frame.entry3} -set helpCmds(.frame.label4) {set topic .frame.entry4} -set helpCmds(.frame.label5) {set topic .frame.entry5} -set helpCmds(.frame.label6) {set topic .frame.entry6} -set helpCmds(.frame.label7) {set topic .frame.entry7} - -set helpTopics(context) {Unfortunately, this application doesn't support context-sensitive help in the usual way, because when this demo was written Tk didn't have a grab mechanism and this is needed for context-sensitive help. Instead, you can achieve much the same effect by simply moving the mouse over the window you're curious about and pressing the Help or F1 keys. You can do this anytime.} -set helpTopics(help) {This application provides only very crude help. Besides the entries in this menu, you can get help on individual windows by moving the mouse cursor over the window and pressing the Help or F1 keys.} -set helpTopics(window) {This window is a dummy rolodex application created as part of Tom LaStrange's toolkit benchmark. It doesn't really do anything useful except to demonstrate a few features of the Tk toolkit.} -set helpTopics(keys) "The following accelerator keys are defined for this application (in addition to those already available for the entry windows):\n\nCtrl+A:\t\tAdd\nCtrl+C:\t\tClear\nCtrl+D:\t\tDelete\nCtrl+F:\t\tEnter file name\nCtrl+Q:\t\tExit application (quit)\nCtrl+S:\t\tSearch (dummy operation)" -set helpTopics(version) "This is version $version." - -# Entries in "Help" menu - -.menu.help.m add command -label "On Context..." -command {Help context} \ - -underline 3 -.menu.help.m add command -label "On Help..." -command {Help help} \ - -underline 3 -.menu.help.m add command -label "On Window..." -command {Help window} \ - -underline 3 -.menu.help.m add command -label "On Keys..." -command {Help keys} \ - -underline 3 -.menu.help.m add command -label "On Version..." -command {Help version} \ - -underline 3 diff --git a/tcl/library/demos/ruler.tcl b/tcl/library/demos/ruler.tcl deleted file mode 100644 index 38b7170b9b4..00000000000 --- a/tcl/library/demos/ruler.tcl +++ /dev/null @@ -1,173 +0,0 @@ -# ruler.tcl -- -# -# This demonstration script creates a canvas widget that displays a ruler -# with tab stops that can be set, moved, and deleted. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -# rulerMkTab -- -# This procedure creates a new triangular polygon in a canvas to -# represent a tab stop. -# -# Arguments: -# c - The canvas window. -# x, y - Coordinates at which to create the tab stop. - -proc rulerMkTab {c x y} { - upvar #0 demo_rulerInfo v - $c create polygon $x $y [expr {$x+$v(size)}] [expr {$y+$v(size)}] \ - [expr {$x-$v(size)}] [expr {$y+$v(size)}] -} - -set w .ruler -global tk_library -catch {destroy $w} -toplevel $w -wm title $w "Ruler Demonstration" -wm iconname $w "ruler" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 5i -justify left -text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -canvas $c -width 14.8c -height 2.5c -pack $w.c -side top -fill x - -set demo_rulerInfo(grid) .25c -set demo_rulerInfo(left) [winfo fpixels $c 1c] -set demo_rulerInfo(right) [winfo fpixels $c 13c] -set demo_rulerInfo(top) [winfo fpixels $c 1c] -set demo_rulerInfo(bottom) [winfo fpixels $c 1.5c] -set demo_rulerInfo(size) [winfo fpixels $c .2c] -set demo_rulerInfo(normalStyle) "-fill black" -if {[winfo depth $c] > 1} { - set demo_rulerInfo(activeStyle) "-fill red -stipple {}" - set demo_rulerInfo(deleteStyle) [list -fill red \ - -stipple @[file join $tk_library demos images gray25.bmp]] -} else { - set demo_rulerInfo(activeStyle) "-fill black -stipple {}" - set demo_rulerInfo(deleteStyle) [list -fill black \ - -stipple @[file join $tk_library demos images gray25.bmp]] -} - -$c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 -for {set i 0} {$i < 12} {incr i} { - set x [expr {$i+1}] - $c create line ${x}c 1c ${x}c 0.6c -width 1 - $c create line $x.25c 1c $x.25c 0.8c -width 1 - $c create line $x.5c 1c $x.5c 0.7c -width 1 - $c create line $x.75c 1c $x.75c 0.8c -width 1 - $c create text $x.15c .75c -text $i -anchor sw -} -$c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ - -outline black -fill [lindex [$c config -bg] 4]] -$c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ - [winfo pixels $c .65c]] - -$c bind well <1> "rulerNewTab $c %x %y" -$c bind tab <1> "rulerSelectTab $c %x %y" -bind $c <B1-Motion> "rulerMoveTab $c %x %y" -bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c" - -# rulerNewTab -- -# Does all the work of creating a tab stop, including creating the -# triangle object and adding tags to it to give it tab behavior. -# -# Arguments: -# c - The canvas window. -# x, y - The coordinates of the tab stop. - -proc rulerNewTab {c x y} { - upvar #0 demo_rulerInfo v - $c addtag active withtag [rulerMkTab $c $x $y] - $c addtag tab withtag active - set v(x) $x - set v(y) $y - rulerMoveTab $c $x $y -} - -# rulerSelectTab -- -# This procedure is invoked when mouse button 1 is pressed over -# a tab. It remembers information about the tab so that it can -# be dragged interactively. -# -# Arguments: -# c - The canvas widget. -# x, y - The coordinates of the mouse (identifies the point by -# which the tab was picked up for dragging). - -proc rulerSelectTab {c x y} { - upvar #0 demo_rulerInfo v - set v(x) [$c canvasx $x $v(grid)] - set v(y) [expr {$v(top)+2}] - $c addtag active withtag current - eval "$c itemconf active $v(activeStyle)" - $c raise active -} - -# rulerMoveTab -- -# This procedure is invoked during mouse motion events to drag a tab. -# It adjusts the position of the tab, and changes its appearance if -# it is about to be dragged out of the ruler. -# -# Arguments: -# c - The canvas widget. -# x, y - The coordinates of the mouse. - -proc rulerMoveTab {c x y} { - upvar #0 demo_rulerInfo v - if {[$c find withtag active] == ""} { - return - } - set cx [$c canvasx $x $v(grid)] - set cy [$c canvasy $y] - if {$cx < $v(left)} { - set cx $v(left) - } - if {$cx > $v(right)} { - set cx $v(right) - } - if {($cy >= $v(top)) && ($cy <= $v(bottom))} { - set cy [expr {$v(top)+2}] - eval "$c itemconf active $v(activeStyle)" - } else { - set cy [expr {$cy-$v(size)-2}] - eval "$c itemconf active $v(deleteStyle)" - } - $c move active [expr {$cx-$v(x)}] [expr {$cy-$v(y)}] - set v(x) $cx - set v(y) $cy -} - -# rulerReleaseTab -- -# This procedure is invoked during button release events that end -# a tab drag operation. It deselects the tab and deletes the tab if -# it was dragged out of the ruler. -# -# Arguments: -# c - The canvas widget. -# x, y - The coordinates of the mouse. - -proc rulerReleaseTab c { - upvar #0 demo_rulerInfo v - if {[$c find withtag active] == {}} { - return - } - if {$v(y) != $v(top)+2} { - $c delete active - } else { - eval "$c itemconf active $v(normalStyle)" - $c dtag active - } -} diff --git a/tcl/library/demos/sayings.tcl b/tcl/library/demos/sayings.tcl deleted file mode 100644 index 872e5d26095..00000000000 --- a/tcl/library/demos/sayings.tcl +++ /dev/null @@ -1,46 +0,0 @@ -# sayings.tcl -- -# -# This demonstration script creates a listbox that can be scrolled -# both horizontally and vertically. It displays a collection of -# well-known sayings. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .sayings -catch {destroy $w} -toplevel $w -wm title $w "Listbox Demonstration (well-known sayings)" -wm iconname $w "sayings" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.frame -borderwidth 10 -pack $w.frame -side top -expand yes -fill y - - -scrollbar $w.frame.yscroll -command "$w.frame.list yview" -scrollbar $w.frame.xscroll -orient horizontal \ - -command "$w.frame.list xview" -listbox $w.frame.list -width 20 -height 10 -setgrid 1 \ - -yscroll "$w.frame.yscroll set" -xscroll "$w.frame.xscroll set" - -grid $w.frame.list -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid $w.frame.yscroll -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -grid $w.frame.xscroll -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid rowconfig $w.frame 0 -weight 1 -minsize 0 -grid columnconfig $w.frame 0 -weight 1 -minsize 0 - - -$w.frame.list insert 0 "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" diff --git a/tcl/library/demos/search.tcl b/tcl/library/demos/search.tcl deleted file mode 100644 index c8b267101eb..00000000000 --- a/tcl/library/demos/search.tcl +++ /dev/null @@ -1,141 +0,0 @@ -# search.tcl -- -# -# This demonstration script creates a collection of widgets that -# allow you to load a file into a text widget, then perform searches -# on that file. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -# textLoadFile -- -# This procedure below loads a file into a text widget, discarding -# the previous contents of the widget. Tags for the old widget are -# not affected, however. -# -# Arguments: -# w - The window into which to load the file. Must be a -# text widget. -# file - The name of the file to load. Must be readable. - -proc textLoadFile {w file} { - set f [open $file] - $w delete 1.0 end - while {![eof $f]} { - $w insert end [read $f 10000] - } - close $f -} - -# textSearch -- -# Search for all instances of a given string in a text widget and -# apply a given tag to each instance found. -# -# Arguments: -# w - The window in which to search. Must be a text widget. -# string - The string to search for. The search is done using -# exact matching only; no special characters. -# tag - Tag to apply to each instance of a matching string. - -proc textSearch {w string tag} { - $w tag remove search 0.0 end - if {$string == ""} { - return - } - set cur 1.0 - while 1 { - set cur [$w search -count length $string $cur end] - if {$cur == ""} { - break - } - $w tag add $tag $cur "$cur + $length char" - set cur [$w index "$cur + $length char"] - } -} - -# textToggle -- -# This procedure is invoked repeatedly to invoke two commands at -# periodic intervals. It normally reschedules itself after each -# execution but if an error occurs (e.g. because the window was -# deleted) then it doesn't reschedule itself. -# -# Arguments: -# cmd1 - Command to execute when procedure is called. -# sleep1 - Ms to sleep after executing cmd1 before executing cmd2. -# cmd2 - Command to execute in the *next* invocation of this -# procedure. -# sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again. - -proc textToggle {cmd1 sleep1 cmd2 sleep2} { - catch { - eval $cmd1 - after $sleep1 [list textToggle $cmd2 $sleep2 $cmd1 $sleep1] - } -} - -set w .search -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Search and Highlight" -wm iconname $w "search" -positionWindow $w - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.file -label $w.file.label -text "File name:" -width 13 -anchor w -entry $w.file.entry -width 40 -textvariable fileName -button $w.file.button -text "Load File" \ - -command "textLoadFile $w.text \$fileName" -pack $w.file.label $w.file.entry -side left -pack $w.file.button -side left -pady 5 -padx 10 -bind $w.file.entry <Return> " - textLoadFile $w.text \$fileName - focus $w.string.entry -" -focus $w.file.entry - -frame $w.string -label $w.string.label -text "Search string:" -width 13 -anchor w -entry $w.string.entry -width 40 -textvariable searchString -button $w.string.button -text "Highlight" \ - -command "textSearch $w.text \$searchString search" -pack $w.string.label $w.string.entry -side left -pack $w.string.button -side left -pady 5 -padx 10 -bind $w.string.entry <Return> "textSearch $w.text \$searchString search" - -text $w.text -yscrollcommand "$w.scroll set" -setgrid true -scrollbar $w.scroll -command "$w.text yview" -pack $w.file $w.string -side top -fill x -pack $w.scroll -side right -fill y -pack $w.text -expand yes -fill both - -# Set up display styles for text highlighting. - -if {[winfo depth $w] > 1} { - textToggle "$w.text tag configure search -background \ - #ce5555 -foreground white" 800 "$w.text tag configure \ - search -background {} -foreground {}" 200 -} else { - textToggle "$w.text tag configure search -background \ - black -foreground white" 800 "$w.text tag configure \ - search -background {} -foreground {}" 200 -} -$w.text insert 1.0 \ -{This window demonstrates how to use the tagging facilities in text -widgets to implement a searching mechanism. First, type a file name -in the top entry, then type <Return> or click on "Load File". Then -type a string in the lower entry and type <Return> or click on -"Load File". This will cause all of the instances of the string to -be tagged with the tag "search", and it will arrange for the tag's -display attributes to change to make all of the strings blink.} -$w.text mark set insert 0.0 - -set fileName "" -set searchString "" diff --git a/tcl/library/demos/spin.tcl b/tcl/library/demos/spin.tcl deleted file mode 100644 index 4ba158b9b8d..00000000000 --- a/tcl/library/demos/spin.tcl +++ /dev/null @@ -1,55 +0,0 @@ -# spin.tcl -- -# -# This demonstration script creates several spinbox widgets. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .spin -catch {destroy $w} -toplevel $w -wm title $w "Spinbox Demonstration" -wm iconname $w "spin" -positionWindow $w - -label $w.msg -font $font -wraplength 5i -justify left -text "Three different\ - spin-boxes are displayed below. You can add characters by pointing,\ - clicking and typing. The normal Motif editing characters are\ - supported, along with many Emacs bindings. For example, Backspace\ - and Control-h delete the character to the left of the insertion\ - cursor and Delete and Control-d delete the chararacter to the right\ - of the insertion cursor. For values that are too large to fit in the\ - window all at once, you can scan through the value by dragging with\ - mouse button2 pressed. Note that the first spin-box will only permit\ - you to type in integers, and the third selects from a list of\ - Australian cities." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -set australianCities { - Canberra Sydney Melbourne Perth Adelaide Brisbane - Hobart Darwin "Alice Springs" -} - -spinbox $w.s1 -from 1 -to 10 -width 10 -validate key \ - -vcmd {string is integer %P} -spinbox $w.s2 -from 0 -to 3 -increment .5 -format %05.2f -width 10 -spinbox $w.s3 -values $australianCities -width 10 - -#entry $w.e1 -#entry $w.e2 -#entry $w.e3 -pack $w.s1 $w.s2 $w.s3 -side top -pady 5 -padx 10 ;#-fill x - -#$w.e1 insert 0 "Initial value" -#$w.e2 insert end "This entry contains a long value, much too long " -#$w.e2 insert end "to fit in the window at one time, so long in fact " -#$w.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/tcl/library/demos/square b/tcl/library/demos/square deleted file mode 100644 index 2ea0722f924..00000000000 --- a/tcl/library/demos/square +++ /dev/null @@ -1,55 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish "$0" "$@" - -# square -- -# This script generates a demo application containing only a "square" -# widget. It's only usable in the "tktest" application or if Tk has -# been compiled with tkSquare.c. This demo arranges the following -# bindings for the widget: -# -# Button-1 press/drag: moves square to mouse -# "a": toggle size animation on/off -# -# RCS: @(#) $Id$ - -square .s -pack .s -expand yes -fill both -wm minsize . 1 1 - -bind .s <1> {center %x %y} -bind .s <B1-Motion> {center %x %y} -bind .s a animate -focus .s - -# The procedure below centers the square on a given position. - -proc center {x y} { - set a [.s size] - .s position [expr $x-($a/2)] [expr $y-($a/2)] -} - -# The procedures below provide a simple form of animation where -# the box changes size in a pulsing pattern: larger, smaller, larger, -# and so on. - -set inc 0 -proc animate {} { - global inc - if {$inc == 0} { - set inc 3 - timer - } else { - set inc 0 - } -} - -proc timer {} { - global inc - set s [.s size] - if {$inc == 0} return - if {$s >= 40} {set inc -3} - if {$s <= 10} {set inc 3} - .s size [expr {$s+$inc}] - after 30 timer -} diff --git a/tcl/library/demos/states.tcl b/tcl/library/demos/states.tcl deleted file mode 100644 index 08834eea470..00000000000 --- a/tcl/library/demos/states.tcl +++ /dev/null @@ -1,45 +0,0 @@ -# states.tcl -- -# -# This demonstration script creates a listbox widget that displays -# the names of the 50 states in the United States of America. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .states -catch {destroy $w} -toplevel $w -wm title $w "Listbox Demonstration (50 states)" -wm iconname $w "states" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by scanning. To scan, press button 2 in the widget and drag up or down." -pack $w.msg -side top - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.frame -borderwidth .5c -pack $w.frame -side top -expand yes -fill y - -scrollbar $w.frame.scroll -command "$w.frame.list yview" -listbox $w.frame.list -yscroll "$w.frame.scroll set" -setgrid 1 -height 12 -pack $w.frame.scroll -side right -fill y -pack $w.frame.list -side left -expand 1 -fill both - -$w.frame.list insert 0 Alabama Alaska Arizona Arkansas California \ - Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois \ - Indiana Iowa Kansas Kentucky Louisiana Maine Maryland \ - Massachusetts Michigan Minnesota Mississippi Missouri \ - Montana Nebraska Nevada "New Hampshire" "New Jersey" "New Mexico" \ - "New York" "North Carolina" "North Dakota" \ - Ohio Oklahoma Oregon Pennsylvania "Rhode Island" \ - "South Carolina" "South Dakota" \ - Tennessee Texas Utah Vermont Virginia Washington \ - "West Virginia" Wisconsin Wyoming diff --git a/tcl/library/demos/style.tcl b/tcl/library/demos/style.tcl deleted file mode 100644 index 136d4e22898..00000000000 --- a/tcl/library/demos/style.tcl +++ /dev/null @@ -1,152 +0,0 @@ -# style.tcl -- -# -# This demonstration script creates a text widget that illustrates the -# various display styles that may be set for tags. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .style -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Display Styles" -wm iconname $w "style" -positionWindow $w - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ - -width 70 -height 32 -wrap word -scrollbar $w.scroll -command "$w.text yview" -pack $w.scroll -side right -fill y -pack $w.text -expand yes -fill both - -# Set up display styles - -$w.text tag configure bold -font {Courier 12 bold italic} -$w.text tag configure big -font {Courier 14 bold} -$w.text tag configure verybig -font {Helvetica 24 bold} -if {[winfo depth $w] > 1} { - $w.text tag configure color1 -background #a0b7ce - $w.text tag configure color2 -foreground red - $w.text tag configure raised -relief raised -borderwidth 1 - $w.text tag configure sunken -relief sunken -borderwidth 1 -} else { - $w.text tag configure color1 -background black -foreground white - $w.text tag configure color2 -background black -foreground white - $w.text tag configure raised -background white -relief raised \ - -borderwidth 1 - $w.text tag configure sunken -background white -relief sunken \ - -borderwidth 1 -} -$w.text tag configure bgstipple -background black -borderwidth 0 \ - -bgstipple gray12 -$w.text tag configure fgstipple -fgstipple gray50 -$w.text tag configure underline -underline on -$w.text tag configure overstrike -overstrike on -$w.text tag configure right -justify right -$w.text tag configure center -justify center -$w.text tag configure super -offset 4p -font {Courier 10} -$w.text tag configure sub -offset -2p -font {Courier 10} -$w.text tag configure margins -lmargin1 12m -lmargin2 6m -rmargin 10m -$w.text tag configure spacing -spacing1 10p -spacing2 2p \ - -lmargin1 12m -lmargin2 6m -rmargin 10m - -$w.text insert end {Text widgets like this one allow you to display information in a -variety of styles. Display styles are controlled using a mechanism -called } -$w.text insert end tags bold -$w.text insert end {. Tags are just textual names that you can apply to one -or more ranges of characters within a text widget. You can configure -tags with various display styles. If you do this, then the tagged -characters will be displayed with the styles you chose. The -available display styles are: -} -$w.text insert end "\n1. Font." big -$w.text insert end " You can choose any X font, " -$w.text insert end large verybig -$w.text insert end " or " -$w.text insert end "small.\n" -$w.text insert end "\n2. Color." big -$w.text insert end " You can change either the " -$w.text insert end background color1 -$w.text insert end " or " -$w.text insert end foreground color2 -$w.text insert end "\ncolor, or " -$w.text insert end both {color1 color2} -$w.text insert end ".\n" -$w.text insert end "\n3. Stippling." big -$w.text insert end " You can cause either the " -$w.text insert end background bgstipple -$w.text insert end " or " -$w.text insert end foreground fgstipple -$w.text insert end { -information to be drawn with a stipple fill instead of a solid fill. -} -$w.text insert end "\n4. Underlining." big -$w.text insert end " You can " -$w.text insert end underline underline -$w.text insert end " ranges of text.\n" -$w.text insert end "\n5. Overstrikes." big -$w.text insert end " You can " -$w.text insert end "draw lines through" overstrike -$w.text insert end " ranges of text.\n" -$w.text insert end "\n6. 3-D effects." big -$w.text insert end { You can arrange for the background to be drawn -with a border that makes characters appear either } -$w.text insert end raised raised -$w.text insert end " or " -$w.text insert end sunken sunken -$w.text insert end ".\n" -$w.text insert end "\n7. Justification." big -$w.text insert end " You can arrange for lines to be displayed\n" -$w.text insert end "left-justified,\n" -$w.text insert end "right-justified, or\n" right -$w.text insert end "centered.\n" center -$w.text insert end "\n8. Superscripts and subscripts." big -$w.text insert end " You can control the vertical\n" -$w.text insert end "position of text to generate superscript effects like 10" -$w.text insert end "n" super -$w.text insert end " or\nsubscript effects like X" -$w.text insert end "i" sub -$w.text insert end ".\n" -$w.text insert end "\n9. Margins." big -$w.text insert end " You can control the amount of extra space left" -$w.text insert end " on\neach side of the text:\n" -$w.text insert end "This paragraph is an example of the use of " margins -$w.text insert end "margins. It consists of a single line of text " margins -$w.text insert end "that wraps around on the screen. There are two " margins -$w.text insert end "separate left margin values, one for the first " margins -$w.text insert end "display line associated with the text line, " margins -$w.text insert end "and one for the subsequent display lines, which " margins -$w.text insert end "occur because of wrapping. There is also a " margins -$w.text insert end "separate specification for the right margin, " margins -$w.text insert end "which is used to choose wrap points for lines.\n" margins -$w.text insert end "\n10. Spacing." big -$w.text insert end " You can control the spacing of lines with three\n" -$w.text insert end "separate parameters. \"Spacing1\" tells how much " -$w.text insert end "extra space to leave\nabove a line, \"spacing3\" " -$w.text insert end "tells how much space to leave below a line,\nand " -$w.text insert end "if a text line wraps, \"spacing2\" tells how much " -$w.text insert end "space to leave\nbetween the display lines that " -$w.text insert end "make up the text line.\n" -$w.text insert end "These indented paragraphs illustrate how spacing " spacing -$w.text insert end "can be used. Each paragraph is actually a " spacing -$w.text insert end "single line in the text widget, which is " spacing -$w.text insert end "word-wrapped by the widget.\n" spacing -$w.text insert end "Spacing1 is set to 10 points for this text, " spacing -$w.text insert end "which results in relatively large gaps between " spacing -$w.text insert end "the paragraphs. Spacing2 is set to 2 points, " spacing -$w.text insert end "which results in just a bit of extra space " spacing -$w.text insert end "within a pararaph. Spacing3 isn't used " spacing -$w.text insert end "in this example.\n" spacing -$w.text insert end "To see where the space is, select ranges of " spacing -$w.text insert end "text within these paragraphs. The selection " spacing -$w.text insert end "highlight will cover the extra space." spacing diff --git a/tcl/library/demos/tclIndex b/tcl/library/demos/tclIndex deleted file mode 100644 index 86a72e2443e..00000000000 --- a/tcl/library/demos/tclIndex +++ /dev/null @@ -1,67 +0,0 @@ -# Tcl autoload index file, version 2.0 -# This file is generated by the "auto_mkindex" command -# and sourced to set up indexing information for one or -# more commands. Typically each line is a command that -# sets an element in the auto_index array, where the -# element name is the name of a command and the value is -# a script that loads the command. - -set auto_index(arrowSetup) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove1) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove2) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove3) [list source [file join $dir arrow.tcl]] -set auto_index(textLoadFile) [list source [file join $dir search.tcl]] -set auto_index(textSearch) [list source [file join $dir search.tcl]] -set auto_index(textToggle) [list source [file join $dir search.tcl]] -set auto_index(itemEnter) [list source [file join $dir items.tcl]] -set auto_index(itemLeave) [list source [file join $dir items.tcl]] -set auto_index(itemMark) [list source [file join $dir items.tcl]] -set auto_index(itemStroke) [list source [file join $dir items.tcl]] -set auto_index(itemsUnderArea) [list source [file join $dir items.tcl]] -set auto_index(itemStartDrag) [list source [file join $dir items.tcl]] -set auto_index(itemDrag) [list source [file join $dir items.tcl]] -set auto_index(butPress) [list source [file join $dir items.tcl]] -set auto_index(loadDir) [list source [file join $dir image2.tcl]] -set auto_index(loadImage) [list source [file join $dir image2.tcl]] -set auto_index(rulerMkTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerNewTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerSelectTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerMoveTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerReleaseTab) [list source [file join $dir ruler.tcl]] -set auto_index(mkTextConfig) [list source [file join $dir ctext.tcl]] -set auto_index(textEnter) [list source [file join $dir ctext.tcl]] -set auto_index(textInsert) [list source [file join $dir ctext.tcl]] -set auto_index(textPaste) [list source [file join $dir ctext.tcl]] -set auto_index(textB1Press) [list source [file join $dir ctext.tcl]] -set auto_index(textB1Move) [list source [file join $dir ctext.tcl]] -set auto_index(textBs) [list source [file join $dir ctext.tcl]] -set auto_index(textDel) [list source [file join $dir ctext.tcl]] -set auto_index(bitmapRow) [list source [file join $dir bitmap.tcl]] -set auto_index(scrollEnter) [list source [file join $dir cscroll.tcl]] -set auto_index(scrollLeave) [list source [file join $dir cscroll.tcl]] -set auto_index(scrollButton) [list source [file join $dir cscroll.tcl]] -set auto_index(textWindOn) [list source [file join $dir twind.tcl]] -set auto_index(textWindOff) [list source [file join $dir twind.tcl]] -set auto_index(textWindPlot) [list source [file join $dir twind.tcl]] -set auto_index(embPlotDown) [list source [file join $dir twind.tcl]] -set auto_index(embPlotMove) [list source [file join $dir twind.tcl]] -set auto_index(textWindDel) [list source [file join $dir twind.tcl]] -set auto_index(embDefBg) [list source [file join $dir twind.tcl]] -set auto_index(floorDisplay) [list source [file join $dir floor.tcl]] -set auto_index(newRoom) [list source [file join $dir floor.tcl]] -set auto_index(roomChanged) [list source [file join $dir floor.tcl]] -set auto_index(bg1) [list source [file join $dir floor.tcl]] -set auto_index(bg2) [list source [file join $dir floor.tcl]] -set auto_index(bg3) [list source [file join $dir floor.tcl]] -set auto_index(fg1) [list source [file join $dir floor.tcl]] -set auto_index(fg2) [list source [file join $dir floor.tcl]] -set auto_index(fg3) [list source [file join $dir floor.tcl]] -set auto_index(setWidth) [list source [file join $dir hscale.tcl]] -set auto_index(plotDown) [list source [file join $dir plot.tcl]] -set auto_index(plotMove) [list source [file join $dir plot.tcl]] -set auto_index(puzzleSwitch) [list source [file join $dir puzzle.tcl]] -set auto_index(setHeight) [list source [file join $dir vscale.tcl]] -set auto_index(showMessageBox) [list source [file join $dir msgbox.tcl]] -set auto_index(setColor) [list source [file join $dir clrpick.tcl]] -set auto_index(setColor_helper) [list source [file join $dir clrpick.tcl]] -set auto_index(fileDialog) [list source [file join $dir filebox.tcl]] diff --git a/tcl/library/demos/tcolor b/tcl/library/demos/tcolor deleted file mode 100644 index 27b931fc73e..00000000000 --- a/tcl/library/demos/tcolor +++ /dev/null @@ -1,366 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish "$0" "$@" - -# tcolor -- -# This script implements a simple color editor, where you can -# create colors using either the RGB, HSB, or CYM color spaces -# and apply the color to existing applications. -# -# RCS: @(#) $Id$ - -wm title . "Color Editor" - -# Global variables that control the program: -# -# colorSpace - Color space currently being used for -# editing. Must be "rgb", "cmy", or "hsb". -# label1, label2, label3 - Labels for the scales. -# red, green, blue - Current color intensities in decimal -# on a scale of 0-65535. -# color - A string giving the current color value -# in the proper form for x: -# #RRRRGGGGBBBB -# updating - Non-zero means that we're in the middle of -# updating the scales to load a new color,so -# information shouldn't be propagating back -# from the scales to other elements of the -# program: this would make an infinite loop. -# command - Holds the command that has been typed -# into the "Command" entry. -# autoUpdate - 1 means execute the update command -# automatically whenever the color changes. -# name - Name for new color, typed into entry. - -set colorSpace hsb -set red 65535 -set green 0 -set blue 0 -set color #ffff00000000 -set updating 0 -set autoUpdate 1 -set name "" - -if {$tcl_platform(platform) eq "unix"} { - option add *Entry.background white -} - -# Create the menu bar at the top of the window. - -. configure -menu [menu .menu] -menu .menu.file -.menu add cascade -menu .menu.file -label File -underline 0 -.menu.file add radio -label "RGB color space" -variable colorSpace \ - -value rgb -underline 0 -command {changeColorSpace rgb} -.menu.file add radio -label "CMY color space" -variable colorSpace \ - -value cmy -underline 0 -command {changeColorSpace cmy} -.menu.file add radio -label "HSB color space" -variable colorSpace \ - -value hsb -underline 0 -command {changeColorSpace hsb} -.menu.file add separator -.menu.file add radio -label "Automatic updates" -variable autoUpdate \ - -value 1 -underline 0 -.menu.file add radio -label "Manual updates" -variable autoUpdate \ - -value 0 -underline 0 -.menu.file add separator -.menu.file add command -label "Exit program" -underline 0 -command {exit} - -# Create the command entry window at the bottom of the window, along -# with the update button. - -labelframe .command -text "Command:" -padx {1m 0} -entry .command.e -relief sunken -borderwidth 2 -textvariable command \ - -font {Courier 12} -button .command.update -text Update -command doUpdate -pack .command.update -side right -pady .1c -padx {.25c 0} -pack .command.e -expand yes -fill x -ipadx 0.25c - - -# Create the listbox that holds all of the color names in rgb.txt, -# if an rgb.txt file can be found. - -grid .command -sticky nsew -row 2 -columnspan 3 -padx 1m -pady {0 1m} - -grid columnconfigure . {1 2} -weight 1 -grid rowconfigure . 0 -weight 1 -foreach i { - /usr/local/lib/X11/rgb.txt /usr/lib/X11/rgb.txt - /X11/R5/lib/X11/rgb.txt /X11/R4/lib/rgb/rgb.txt - /usr/openwin/lib/X11/rgb.txt -} { - if {![file readable $i]} { - continue; - } - set f [open $i] - labelframe .names -text "Select:" -padx .1c -pady .1c - grid .names -row 0 -column 0 -sticky nsew -padx .15c -pady .15c -rowspan 2 - grid columnconfigure . 0 -weight 1 - listbox .names.lb -width 20 -height 12 -yscrollcommand ".names.s set" \ - -relief sunken -borderwidth 2 -exportselection false - bind .names.lb <Double-1> { - tc_loadNamedColor [.names.lb get [.names.lb curselection]] - } - scrollbar .names.s -orient vertical -command ".names.lb yview" \ - -relief sunken -borderwidth 2 - pack .names.lb .names.s -side left -fill y -expand 1 - while {[gets $f line] >= 0} { - if {[regexp {^\s*\d+\s+\d+\s+\d+\s+(\S+)$} $line -> col]} { - .names.lb insert end $col - } - } - close $f - break -} - -# Create the three scales for editing the color, and the entry for -# typing in a color value. - -frame .adjust -foreach i {1 2 3} { - label .adjust.l$i -textvariable label$i -pady 0 - labelframe .adjust.$i -labelwidget .adjust.l$i -padx 1m -pady 1m - scale .scale$i -from 0 -to 1000 -length 6c -orient horizontal \ - -command tc_scaleChanged - pack .scale$i -in .adjust.$i - pack .adjust.$i -} -grid .adjust -row 0 -column 1 -sticky nsew -padx .15c -pady .15c - -labelframe .name -text "Name:" -padx 1m -pady 1m -entry .name.e -relief sunken -borderwidth 2 -textvariable name -width 10 \ - -font {Courier 12} -pack .name.e -side right -expand 1 -fill x -bind .name.e <Return> {tc_loadNamedColor $name} -grid .name -column 1 -row 1 -sticky nsew -padx .15c -pady .15c - -# Create the color display swatch on the right side of the window. - -labelframe .sample -text "Color:" -padx 1m -pady 1m -frame .sample.swatch -width 2c -height 5c -background $color -label .sample.value -textvariable color -width 13 -font {Courier 12} -pack .sample.swatch -side top -expand yes -fill both -pack .sample.value -side bottom -pady .25c -grid .sample -row 0 -column 2 -sticky nsew -padx .15c -pady .15c -rowspan 2 - - -# The procedure below is invoked when one of the scales is adjusted. -# It propagates color information from the current scale readings -# to everywhere else that it is used. - -proc tc_scaleChanged args { - global red green blue colorSpace color updating autoUpdate - if {$updating} { - return - } - switch $colorSpace { - rgb { - set red [format %.0f [expr {[.scale1 get]*65.535}]] - set green [format %.0f [expr {[.scale2 get]*65.535}]] - set blue [format %.0f [expr {[.scale3 get]*65.535}]] - } - cmy { - set red [format %.0f [expr {65535 - [.scale1 get]*65.535}]] - set green [format %.0f [expr {65535 - [.scale2 get]*65.535}]] - set blue [format %.0f [expr {65535 - [.scale3 get]*65.535}]] - } - hsb { - set list [hsbToRgb [expr {[.scale1 get]/1000.0}] \ - [expr {[.scale2 get]/1000.0}] \ - [expr {[.scale3 get]/1000.0}]] - set red [lindex $list 0] - set green [lindex $list 1] - set blue [lindex $list 2] - } - } - set color [format "#%04x%04x%04x" $red $green $blue] - .sample.swatch config -bg $color - if {$autoUpdate} doUpdate - update idletasks -} - -# The procedure below is invoked to update the scales from the -# current red, green, and blue intensities. It's invoked after -# a change in the color space and after a named color value has -# been loaded. - -proc tc_setScales {} { - global red green blue colorSpace updating - set updating 1 - switch $colorSpace { - rgb { - .scale1 set [format %.0f [expr {$red/65.535}]] - .scale2 set [format %.0f [expr {$green/65.535}]] - .scale3 set [format %.0f [expr {$blue/65.535}]] - } - cmy { - .scale1 set [format %.0f [expr {(65535-$red)/65.535}]] - .scale2 set [format %.0f [expr {(65535-$green)/65.535}]] - .scale3 set [format %.0f [expr {(65535-$blue)/65.535}]] - } - hsb { - set list [rgbToHsv $red $green $blue] - .scale1 set [format %.0f [expr {[lindex $list 0] * 1000.0}]] - .scale2 set [format %.0f [expr {[lindex $list 1] * 1000.0}]] - .scale3 set [format %.0f [expr {[lindex $list 2] * 1000.0}]] - } - } - set updating 0 -} - -# The procedure below is invoked when a named color has been -# selected from the listbox or typed into the entry. It loads -# the color into the editor. - -proc tc_loadNamedColor name { - global red green blue color autoUpdate - - if {[string index $name 0] != "#"} { - set list [winfo rgb .sample.swatch $name] - set red [lindex $list 0] - set green [lindex $list 1] - set blue [lindex $list 2] - } else { - switch [string length $name] { - 4 {set format "#%1x%1x%1x"; set shift 12} - 7 {set format "#%2x%2x%2x"; set shift 8} - 10 {set format "#%3x%3x%3x"; set shift 4} - 13 {set format "#%4x%4x%4x"; set shift 0} - default {error "syntax error in color name \"$name\""} - } - if {[scan $name $format red green blue] != 3} { - error "syntax error in color name \"$name\"" - } - set red [expr {$red<<$shift}] - set green [expr {$green<<$shift}] - set blue [expr {$blue<<$shift}] - } - tc_setScales - set color [format "#%04x%04x%04x" $red $green $blue] - .sample.swatch config -bg $color - if {$autoUpdate} doUpdate -} - -# The procedure below is invoked when a new color space is selected. -# It changes the labels on the scales and re-loads the scales with -# the appropriate values for the current color in the new color space - -proc changeColorSpace space { - global label1 label2 label3 - switch $space { - rgb { - set label1 "Adjust Red:" - set label2 "Adjust Green:" - set label3 "Adjust Blue:" - tc_setScales - return - } - cmy { - set label1 "Adjust Cyan:" - set label2 "Adjust Magenta:" - set label3 "Adjust Yellow:" - tc_setScales - return - } - hsb { - set label1 "Adjust Hue:" - set label2 "Adjust Saturation:" - set label3 "Adjust Brightness:" - tc_setScales - return - } - } -} - -# The procedure below converts an RGB value to HSB. It takes red, green, -# and blue components (0-65535) as arguments, and returns a list containing -# HSB components (floating-point, 0-1) as result. The code here is a copy -# of the code on page 615 of "Fundamentals of Interactive Computer Graphics" -# by Foley and Van Dam. - -proc rgbToHsv {red green blue} { - if {$red > $green} { - set max [expr {double($red)}] - set min [expr {double($green)}] - } else { - set max [expr {double($green)}] - set min [expr {double($red)}] - } - if {$blue > $max} { - set max [expr {double($blue)}] - } elseif {$blue < $min} { - set min [expr {double($blue)}] - } - set range [expr {$max-$min}] - if {$max == 0} { - set sat 0 - } else { - set sat [expr {($max-$min)/$max}] - } - if {$sat == 0} { - set hue 0 - } else { - set rc [expr {($max - $red)/$range}] - set gc [expr {($max - $green)/$range}] - set bc [expr {($max - $blue)/$range}] - if {$red == $max} { - set hue [expr {($bc - $gc)/6.0}] - } elseif {$green == $max} { - set hue [expr {(2 + $rc - $bc)/6.0}] - } else { - set hue [expr {(4 + $gc - $rc)/6.0}] - } - if {$hue < 0.0} { - set hue [expr {$hue + 1.0}] - } - } - return [list $hue $sat [expr {$max/65535}]] -} - -# The procedure below converts an HSB value to RGB. It takes hue, saturation, -# and value components (floating-point, 0-1.0) as arguments, and returns a -# list containing RGB components (integers, 0-65535) as result. The code -# here is a copy of the code on page 616 of "Fundamentals of Interactive -# Computer Graphics" by Foley and Van Dam. - -proc hsbToRgb {hue sat value} { - set v [format %.0f [expr {65535.0*$value}]] - if {$sat == 0} { - return "$v $v $v" - } else { - set hue [expr {$hue*6.0}] - if {$hue >= 6.0} { - set hue 0.0 - } - scan $hue. %d i - set f [expr {$hue-$i}] - set p [format %.0f [expr {65535.0*$value*(1 - $sat)}]] - set q [format %.0f [expr {65535.0*$value*(1 - ($sat*$f))}]] - set t [format %.0f [expr {65535.0*$value*(1 - ($sat*(1 - $f)))}]] - switch $i { - 0 {return "$v $t $p"} - 1 {return "$q $v $p"} - 2 {return "$p $v $t"} - 3 {return "$p $q $v"} - 4 {return "$t $p $v"} - 5 {return "$v $p $q"} - default {error "i value $i is out of range"} - } - } -} - -# The procedure below is invoked when the "Update" button is pressed, -# and whenever the color changes if update mode is enabled. It -# propagates color information as determined by the command in the -# Command entry. - -proc doUpdate {} { - global color command - set newCmd $command - regsub -all %% $command $color newCmd - eval $newCmd -} - -changeColorSpace hsb - -# Local Variables: -# mode: tcl -# End: diff --git a/tcl/library/demos/text.tcl b/tcl/library/demos/text.tcl deleted file mode 100644 index 555b095413d..00000000000 --- a/tcl/library/demos/text.tcl +++ /dev/null @@ -1,88 +0,0 @@ -# text.tcl -- -# -# This demonstration script creates a text widget that describes -# the basic editing functions. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .text -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Basic Facilities" -wm iconname $w "text" -positionWindow $w - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" -setgrid 1 \ - -height 30 -undo 1 -autosep 1 -scrollbar $w.scroll -command "$w.text yview" -pack $w.scroll -side right -fill y -pack $w.text -expand yes -fill both -$w.text insert 0.0 \ -{This window is a text widget. It displays one or more lines of text -and allows you to edit the text. Here is a summary of the things you -can do to a text widget: - -1. Scrolling. Use the scrollbar to adjust the view in the text window. - -2. Scanning. Press mouse button 2 in the text window and drag up or down. -This will drag the text at high speed to allow you to scan its contents. - -3. Insert text. Press mouse button 1 to set the insertion cursor, then -type text. What you type will be added to the widget. - -4. Select. Press mouse button 1 and drag to select a range of characters. -Once you've released the button, you can adjust the selection by pressing -button 1 with the shift key down. This will reset the end of the -selection nearest the mouse cursor and you can drag that end of the -selection by dragging the mouse before releasing the mouse button. -You can double-click to select whole words or triple-click to select -whole lines. - -5. Delete and replace. To delete text, select the characters you'd like -to delete and type Backspace or Delete. Alternatively, you can type new -text, in which case it will replace the selected text. - -6. Copy the selection. To copy the selection into this window, select -what you want to copy (either here or in another application), then -click button 2 to copy the selection to the point of the mouse cursor. - -7. Edit. Text widgets support the standard Motif editing characters -plus many Emacs editing characters. Backspace and Control-h erase the -character to the left of the insertion cursor. Delete and Control-d -erase the character to the right of the insertion cursor. Meta-backspace -deletes the word to the left of the insertion cursor, and Meta-d deletes -the word to the right of the insertion cursor. Control-k deletes from -the insertion cursor to the end of the line, or it deletes the newline -character if that is the only thing left on the line. Control-o opens -a new line by inserting a newline character to the right of the insertion -cursor. Control-t transposes the two characters on either side of the -insertion cursor. Control-z undoes the last editing action performed, -and } - -switch $tcl_platform(platform) { - "unix" - "macintosh" { - $w.text insert end "Control-Shift-z" - } - "windows" { - $w.text insert end "Control-y" - } -} - -$w.text insert end { redoes undone edits. - -7. Resize the window. This widget has been configured with the "setGrid" -option on, so that if you resize the window it will always resize to an -even number of characters high and wide. Also, if you make the window -narrow you can see that long lines automatically wrap around onto -additional lines so that all the information is always visible.} -$w.text mark set insert 0.0 diff --git a/tcl/library/demos/timer b/tcl/library/demos/timer deleted file mode 100644 index 5241331f839..00000000000 --- a/tcl/library/demos/timer +++ /dev/null @@ -1,47 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish "$0" "$@" - -# timer -- -# This script generates a counter with start and stop buttons. -# -# RCS: @(#) $Id$ - -label .counter -text 0.00 -relief raised -width 10 -padx 2m -pady 1m -button .start -text Start -command { - if {$stopped} { - set stopped 0 - set startMoment [clock clicks -milliseconds] - tick - .stop configure -state normal - .start configure -state disabled - } -} -button .stop -text Stop -state disabled -command { - set stopped 1 - .stop configure -state disabled - .start configure -state normal -} -pack .counter -side bottom -fill both -pack .start -side left -fill both -expand yes -pack .stop -side right -fill both -expand yes - -set startMoment {} - -set stopped 1 - -proc tick {} { - global startMoment stopped - if {$stopped} {return} - after 50 tick - set elapsedMS [expr {[clock clicks -milliseconds] - $startMoment}] - .counter config -text [format "%.2f" [expr {double($elapsedMS)/1000}]] -} - -bind . <Control-c> {destroy .} -bind . <Control-q> {destroy .} -focus . - -# Local Variables: -# mode: tcl -# End: diff --git a/tcl/library/demos/twind.tcl b/tcl/library/demos/twind.tcl deleted file mode 100644 index 0a41c0d1e49..00000000000 --- a/tcl/library/demos/twind.tcl +++ /dev/null @@ -1,197 +0,0 @@ -# twind.tcl -- -# -# This demonstration script creates a text widget with a bunch of -# embedded windows. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .twind -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Embedded Windows" -wm iconname $w "Embedded Windows" -positionWindow $w - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken -set t $w.f.text -text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \ - -height 35 -wrap word -highlightthickness 0 -borderwidth 0 -pack $t -expand yes -fill both -scrollbar $w.scroll -command "$t yview" -pack $w.scroll -side right -fill y -pack $w.f -expand yes -fill both -$t tag configure center -justify center -spacing1 5m -spacing3 5m -$t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \ - -spacing1 3m -spacing2 0 -spacing3 0 - -button $t.on -text "Turn On" -command "textWindOn $w" \ - -cursor top_left_arrow -button $t.off -text "Turn Off" -command "textWindOff $w" \ - -cursor top_left_arrow -button $t.click -text "Click Here" -command "textWindPlot $t" \ - -cursor top_left_arrow -button $t.delete -text "Delete" -command "textWindDel $w" \ - -cursor top_left_arrow - -$t insert end "A text widget can contain other widgets embedded " -$t insert end "it. These are called \"embedded windows\", " -$t insert end "and they can consist of arbitrary widgets. " -$t insert end "For example, here are two embedded button " -$t insert end "widgets. You can click on the first button to " -$t window create end -window $t.on -$t insert end " horizontal scrolling, which also turns off " -$t insert end "word wrapping. Or, you can click on the second " -$t insert end "button to\n" -$t window create end -window $t.off -$t insert end " horizontal scrolling and turn back on word wrapping.\n\n" - -$t insert end "Or, here is another example. If you " -$t window create end -window $t.click -$t insert end " a canvas displaying an x-y plot will appear right here." -$t mark set plot insert -$t mark gravity plot left -$t insert end " You can drag the data points around with the mouse, " -$t insert end "or you can click here to " -$t window create end -window $t.delete -$t insert end " the plot again.\n\n" - -$t insert end "You may also find it useful to put embedded windows in " -$t insert end "a text without any actual text. In this case the " -$t insert end "text widget acts like a geometry manager. For " -$t insert end "example, here is a collection of buttons laid out " -$t insert end "neatly into rows by the text widget. These buttons " -$t insert end "can be used to change the background color of the " -$t insert end "text widget (\"Default\" restores the color to " -$t insert end "its default). If you click on the button labeled " -$t insert end "\"Short\", it changes to a longer string so that " -$t insert end "you can see how the text widget automatically " -$t insert end "changes the layout. Click on the button again " -$t insert end "to restore the short string.\n" - -button $t.default -text Default -command "embDefBg $t" \ - -cursor top_left_arrow -$t window create end -window $t.default -padx 3 -global embToggle -set embToggle Short -checkbutton $t.toggle -textvariable embToggle -indicatoron 0 \ - -variable embToggle -onvalue "A much longer string" \ - -offvalue "Short" -cursor top_left_arrow -pady 5 -padx 2 -$t window create end -window $t.toggle -padx 3 -pady 2 -set i 1 -foreach color {AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4 - SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3 LightBlue1 - DarkSlateGray1 Aquamarine2 DarkSeaGreen2 SeaGreen1 - Yellow1 IndianRed1 IndianRed2 Tan1 Tan4} { - button $t.color$i -text $color -cursor top_left_arrow -command \ - "$t configure -bg $color" - $t window create end -window $t.color$i -padx 3 -pady 2 - incr i -} -$t tag add buttons $t.default end - -proc textWindOn w { - catch {destroy $w.scroll2} - set t $w.f.text - scrollbar $w.scroll2 -orient horizontal -command "$t xview" - pack $w.scroll2 -after $w.buttons -side bottom -fill x - $t configure -xscrollcommand "$w.scroll2 set" -wrap none -} - -proc textWindOff w { - catch {destroy $w.scroll2} - set t $w.f.text - $t configure -xscrollcommand {} -wrap word -} - -proc textWindPlot t { - set c $t.c - if {[winfo exists $c]} { - return - } - canvas $c -relief sunken -width 450 -height 300 -cursor top_left_arrow - - set font {Helvetica 18} - - $c create line 100 250 400 250 -width 2 - $c create line 100 250 100 50 -width 2 - $c create text 225 20 -text "A Simple Plot" -font $font -fill brown - - for {set i 0} {$i <= 10} {incr i} { - set x [expr {100 + ($i*30)}] - $c create line $x 250 $x 245 -width 2 - $c create text $x 254 -text [expr {10*$i}] -anchor n -font $font - } - for {set i 0} {$i <= 5} {incr i} { - set y [expr {250 - ($i*40)}] - $c create line 100 $y 105 $y -width 2 - $c create text 96 $y -text [expr {$i*50}].0 -anchor e -font $font - } - - foreach point { - {12 56} {20 94} {33 98} {32 120} {61 180} {75 160} {98 223} - } { - set x [expr {100 + (3*[lindex $point 0])}] - set y [expr {250 - (4*[lindex $point 1])/5}] - set item [$c create oval [expr {$x-6}] [expr {$y-6}] \ - [expr {$x+6}] [expr {$y+6}] -width 1 -outline black \ - -fill SkyBlue2] - $c addtag point withtag $item - } - - $c bind point <Any-Enter> "$c itemconfig current -fill red" - $c bind point <Any-Leave> "$c itemconfig current -fill SkyBlue2" - $c bind point <1> "embPlotDown $c %x %y" - $c bind point <ButtonRelease-1> "$c dtag selected" - bind $c <B1-Motion> "embPlotMove $c %x %y" - while {[string first [$t get plot] " \t\n"] >= 0} { - $t delete plot - } - $t insert plot "\n" - $t window create plot -window $c - $t tag add center plot - $t insert plot "\n" -} - -set embPlot(lastX) 0 -set embPlot(lastY) 0 - -proc embPlotDown {w x y} { - global embPlot - $w dtag selected - $w addtag selected withtag current - $w raise current - set embPlot(lastX) $x - set embPlot(lastY) $y -} - -proc embPlotMove {w x y} { - global embPlot - $w move selected [expr {$x-$embPlot(lastX)}] [expr {$y-$embPlot(lastY)}] - set embPlot(lastX) $x - set embPlot(lastY) $y -} - -proc textWindDel w { - set t $w.f.text - if {[winfo exists $t.c]} { - $t delete $t.c - while {[string first [$t get plot] " \t\n"] >= 0} { - $t delete plot - } - $t insert plot " " - } -} - -proc embDefBg t { - $t configure -background [lindex [$t configure -background] 3] -} diff --git a/tcl/library/demos/vscale.tcl b/tcl/library/demos/vscale.tcl deleted file mode 100644 index 278e7d0a659..00000000000 --- a/tcl/library/demos/vscale.tcl +++ /dev/null @@ -1,48 +0,0 @@ -# vscale.tcl -- -# -# This demonstration script shows an example with a vertical scale. -# -# RCS: @(#) $Id$ - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -set w .vscale -catch {destroy $w} -toplevel $w -wm title $w "Vertical Scale Demonstration" -wm iconname $w "vscale" -positionWindow $w - -label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the size of the arrow." -pack $w.msg -side top -padx .5c - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - -frame $w.frame -borderwidth 10 -pack $w.frame - -scale $w.frame.scale -orient vertical -length 284 -from 0 -to 250 \ - -command "setHeight $w.frame.canvas" -tickinterval 50 -canvas $w.frame.canvas -width 50 -height 50 -bd 0 -highlightthickness 0 -$w.frame.canvas create polygon 0 0 1 1 2 2 -fill SeaGreen3 -tags poly -$w.frame.canvas create line 0 0 1 1 2 2 0 0 -fill black -tags line -frame $w.frame.right -borderwidth 15 -pack $w.frame.scale -side left -anchor ne -pack $w.frame.canvas -side left -anchor nw -fill y -$w.frame.scale set 75 - -proc setHeight {w height} { - incr height 21 - set y2 [expr {$height - 30}] - if {$y2 < 21} { - set y2 21 - } - $w coords poly 15 20 35 20 35 $y2 45 $y2 25 $height 5 $y2 15 $y2 15 20 - $w coords line 15 20 35 20 35 $y2 45 $y2 25 $height 5 $y2 15 $y2 15 20 -} diff --git a/tcl/library/demos/widget b/tcl/library/demos/widget deleted file mode 100644 index 8414aab3471..00000000000 --- a/tcl/library/demos/widget +++ /dev/null @@ -1,393 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish "$0" "$@" - -# widget -- -# This script demonstrates the various widgets provided by Tk, -# along with many of the features of the Tk toolkit. This file -# only contains code to generate the main window for the -# application, which invokes individual demonstrations. The -# code for the actual demonstrations is contained in separate -# ".tcl" files is this directory, which are sourced by this script -# as needed. -# -# RCS: @(#) $Id$ - -eval destroy [winfo child .] -wm title . "Widget Demonstration" -if {$tcl_platform(platform) eq "unix"} { - # This won't work everywhere, but there's no other way in core Tk - # at the moment to display a coloured icon. - image create photo TclPowered \ - -file [file join $tk_library images logo64.gif] - wm iconwindow . [toplevel ._iconWindow] - pack [label ._iconWindow.i -image TclPowered] - wm iconname . "tkWidgetDemo" -} - -array set widgetFont { - main {Helvetica 12} - bold {Helvetica 12 bold} - title {Helvetica 18 bold} - status {Helvetica 10} - vars {Helvetica 14} -} - -set widgetDemo 1 -set font $widgetFont(main) - -#---------------------------------------------------------------- -# The code below create the main window, consisting of a menu bar -# and a text widget that explains how to use the program, plus lists -# all of the demos as hypertext items. -#---------------------------------------------------------------- - -menu .menuBar -tearoff 0 -.menuBar add cascade -menu .menuBar.file -label "File" -underline 0 -menu .menuBar.file -tearoff 0 - -# On the Mac use the specia .apple menu for the about item -if {[string equal [tk windowingsystem] "classic"]} { - .menuBar add cascade -menu .menuBar.apple - menu .menuBar.apple -tearoff 0 - .menuBar.apple add command -label "About..." -command "aboutBox" -} else { - .menuBar.file add command -label "About..." -command "aboutBox" \ - -underline 0 -accelerator "<F1>" - .menuBar.file add sep -} - -.menuBar.file add command -label "Quit" -command "exit" -underline 0 \ - -accelerator "Meta-Q" -. configure -menu .menuBar -bind . <F1> aboutBox - -frame .statusBar -label .statusBar.lab -text " " -relief sunken -bd 1 \ - -font $widgetFont(status) -anchor w -label .statusBar.foo -width 8 -relief sunken -bd 1 \ - -font $widgetFont(status) -anchor w -pack .statusBar.lab -side left -padx 2 -expand yes -fill both -pack .statusBar.foo -side left -padx 2 -pack .statusBar -side bottom -fill x -pady 2 - -frame .textFrame -scrollbar .s -orient vertical -command {.t yview} -highlightthickness 0 \ - -takefocus 1 -pack .s -in .textFrame -side right -fill y -text .t -yscrollcommand {.s set} -wrap word -width 70 -height 30 \ - -font $widgetFont(main) -setgrid 1 -highlightthickness 0 \ - -padx 4 -pady 2 -takefocus 0 -pack .t -in .textFrame -expand y -fill both -padx 1 -pack .textFrame -expand yes -fill both - -# Create a bunch of tags to use in the text widget, such as those for -# section titles and demo descriptions. Also define the bindings for -# tags. - -.t tag configure title -font $widgetFont(title) -.t tag configure bold -font $widgetFont(bold) - -# We put some "space" characters to the left and right of each demo description -# so that the descriptions are highlighted only when the mouse cursor -# is right over them (but not when the cursor is to their left or right) -# -.t tag configure demospace -lmargin1 1c -lmargin2 1c - - -if {[winfo depth .] == 1} { - .t tag configure demo -lmargin1 1c -lmargin2 1c \ - -underline 1 - .t tag configure visited -lmargin1 1c -lmargin2 1c \ - -underline 1 - .t tag configure hot -background black -foreground white -} else { - .t tag configure demo -lmargin1 1c -lmargin2 1c \ - -foreground blue -underline 1 - .t tag configure visited -lmargin1 1c -lmargin2 1c \ - -foreground #303080 -underline 1 - .t tag configure hot -foreground red -underline 1 -} -.t tag bind demo <ButtonRelease-1> { - invoke [.t index {@%x,%y}] -} -set lastLine "" -.t tag bind demo <Enter> { - set lastLine [.t index {@%x,%y linestart}] - .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" - .t config -cursor hand2 - showStatus [.t index {@%x,%y}] -} -.t tag bind demo <Leave> { - .t tag remove hot 1.0 end - .t config -cursor xterm - .statusBar.lab config -text "" -} -.t tag bind demo <Motion> { - set newLine [.t index {@%x,%y linestart}] - if {[string compare $newLine $lastLine] != 0} { - .t tag remove hot 1.0 end - set lastLine $newLine - - set tags [.t tag names {@%x,%y}] - set i [lsearch -glob $tags demo-*] - if {$i >= 0} { - .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" - } - } - showStatus [.t index {@%x,%y}] -} - -# Create the text for the text widget. - -proc addDemoSection {title demos} { - .t insert end "\n" {} $title title " \n " demospace - set num 0 - foreach {name description} $demos { - .t insert end "[incr num]. $description." [list demo demo-$name] - .t insert end " \n " demospace - } -} - -.t insert end "Tk Widget Demonstrations\n" title -.t insert end "\nThis application provides a front end for several short\ - scripts that demonstrate what you can do with Tk widgets. Each of\ - the numbered lines below describes a demonstration; you can click\ - on it to invoke the demonstration. Once the demonstration window\ - appears, you can click the " {} "See Code" bold " button to see the\ - Tcl/Tk code that created the demonstration. If you wish, you can\ - edit the code and click the " {} "Rerun Demo" bold " button in the\ - code window to reinvoke the demonstration with the modified code.\n" - -addDemoSection "Labels, buttons, checkbuttons, and radiobuttons" { - label "Labels (text and bitmaps)" - button "Buttons" - check "Check-buttons (select any of a group)" - radio "Radio-buttons (select one of a group)" - puzzle "A 15-puzzle game made out of buttons" - icon "Iconic buttons that use bitmaps" - image1 "Two labels displaying images" - image2 "A simple user interface for viewing images" - labelframe "Labelled frames" -} -addDemoSection "Listboxes" { - states "The 50 states" - colors "Colors: change the color scheme for the application" - sayings "A collection of famous and infamous sayings" -} -addDemoSection "Entries and Spin-boxes" { - entry1 "Entries without scrollbars" - entry2 "Entries with scrollbars" - entry3 "Validated entries and password fields" - spin "Spin-boxes" - form "Simple Rolodex-like form" -} -addDemoSection "Text" { - text "Basic editable text" - style "Text display styles" - bind "Hypertext (tag bindings)" - twind "A text widget with embedded windows" - search "A search tool built with a text widget" -} -addDemoSection "Canvases" { - items "The canvas item types" - plot "A simple 2-D plot" - ctext "Text items in canvases" - arrow "An editor for arrowheads on canvas lines" - ruler "A ruler with adjustable tab stops" - floor "A building floor plan" - cscroll "A simple scrollable canvas" -} -addDemoSection "Scales" { - hscale "Horizontal scale" - vscale "Vertical scale" -} -addDemoSection "Paned Windows" { - paned1 "Horizontal paned window" - paned2 "Vertical paned window" -} -addDemoSection "Menus" { - menu "Menus and cascades (sub-menus)" - menubu "Menu-buttons" -} -addDemoSection "Common Dialogs" { - msgbox "Message boxes" - filebox "File selection dialog" - clrpick "Color picker" -} -addDemoSection "Miscellaneous" { - bitmap "The built-in bitmaps" - dialog1 "A dialog box with a local grab" - dialog2 "A dialog box with a global grab" -} - -.t configure -state disabled -focus .s - -# positionWindow -- -# This procedure is invoked by most of the demos to position a -# new demo window. -# -# Arguments: -# w - The name of the window to position. - -proc positionWindow w { - wm geometry $w +300+300 -} - -# showVars -- -# Displays the values of one or more variables in a window, and -# updates the display whenever any of the variables changes. -# -# Arguments: -# w - Name of new window to create for display. -# args - Any number of names of variables. - -proc showVars {w args} { - global widgetFont - catch {destroy $w} - toplevel $w - wm title $w "Variable values" - label $w.title -text "Variable values:" -width 20 -anchor center \ - -font $widgetFont(vars) - pack $w.title -side top -fill x - set len 1 - foreach i $args { - if {[string length $i] > $len} { - set len [string length $i] - } - } - foreach i $args { - frame $w.$i - label $w.$i.name -text "$i: " -width [expr $len + 2] -anchor w - label $w.$i.value -textvar $i -anchor w - pack $w.$i.name -side left - pack $w.$i.value -side left -expand 1 -fill x - pack $w.$i -side top -anchor w -fill x - } - button $w.ok -text OK -command "destroy $w" -default active - bind $w <Return> "tkButtonInvoke $w.ok" - pack $w.ok -side bottom -pady 2 -} - -# invoke -- -# This procedure is called when the user clicks on a demo description. -# It is responsible for invoking the demonstration. -# -# Arguments: -# index - The index of the character that the user clicked on. - -proc invoke index { - global tk_library - set tags [.t tag names $index] - set i [lsearch -glob $tags demo-*] - if {$i < 0} { - return - } - set cursor [.t cget -cursor] - .t configure -cursor watch - update - set demo [string range [lindex $tags $i] 5 end] - uplevel [list source [file join $tk_library demos $demo.tcl]] - update - .t configure -cursor $cursor - - .t tag add visited "$index linestart +1 chars" "$index lineend -1 chars" -} - -# showStatus -- -# -# Show the name of the demo program in the status bar. This procedure -# is called when the user moves the cursor over a demo description. -# -proc showStatus index { - global tk_library - set tags [.t tag names $index] - set i [lsearch -glob $tags demo-*] - set cursor [.t cget -cursor] - if {$i < 0} { - .statusBar.lab config -text " " - set newcursor xterm - } else { - set demo [string range [lindex $tags $i] 5 end] - .statusBar.lab config -text "Run the \"$demo\" sample program" - set newcursor hand2 - } - if [string compare $cursor $newcursor] { - .t config -cursor $newcursor - } -} - - -# showCode -- -# This procedure creates a toplevel window that displays the code for -# a demonstration and allows it to be edited and reinvoked. -# -# Arguments: -# w - The name of the demonstration's window, which can be -# used to derive the name of the file containing its code. - -proc showCode w { - global tk_library - set file [string range $w 1 end].tcl - if ![winfo exists .code] { - toplevel .code - frame .code.buttons - pack .code.buttons -side bottom -fill x - button .code.buttons.dismiss -text Dismiss \ - -default active -command "destroy .code" - button .code.buttons.rerun -text "Rerun Demo" -command { - eval [.code.text get 1.0 end] - } - pack .code.buttons.dismiss .code.buttons.rerun -side left \ - -expand 1 -pady 2 - frame .code.frame - pack .code.frame -expand yes -fill both -padx 1 -pady 1 - text .code.text -height 40 -wrap word\ - -xscrollcommand ".code.xscroll set" \ - -yscrollcommand ".code.yscroll set" \ - -setgrid 1 -highlightthickness 0 -pady 2 -padx 3 - scrollbar .code.xscroll -command ".code.text xview" \ - -highlightthickness 0 -orient horizontal - scrollbar .code.yscroll -command ".code.text yview" \ - -highlightthickness 0 -orient vertical - - grid .code.text -in .code.frame -padx 1 -pady 1 \ - -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news - grid .code.yscroll -in .code.frame -padx 1 -pady 1 \ - -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -# grid .code.xscroll -in .code.frame -padx 1 -pady 1 \ -# -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news - grid rowconfig .code.frame 0 -weight 1 -minsize 0 - grid columnconfig .code.frame 0 -weight 1 -minsize 0 - } else { - wm deiconify .code - raise .code - } - wm title .code "Demo code: [file join $tk_library demos $file]" - wm iconname .code $file - set id [open [file join $tk_library demos $file]] - .code.text delete 1.0 end - .code.text insert 1.0 [read $id] - .code.text mark set insert 1.0 - close $id -} - -# aboutBox -- -# -# Pops up a message box with an "about" message -# -proc aboutBox {} { - tk_messageBox -icon info -type ok -title "About Widget Demo" -message \ -"Tk widget demonstration - -Copyright (c) 1996-1997 Sun Microsystems, Inc. - -Copyright (c) 1997-2000 Ajuba Solutions, Inc. - -Copyright (c) 2001-2002 Donal K. Fellows" -} - -# Local Variables: -# mode: tcl -# End: diff --git a/tcl/library/dialog.tcl b/tcl/library/dialog.tcl deleted file mode 100644 index 2d5036a66be..00000000000 --- a/tcl/library/dialog.tcl +++ /dev/null @@ -1,199 +0,0 @@ -# dialog.tcl -- -# -# This file defines the procedure tk_dialog, which creates a dialog -# box containing a bitmap, a message, and one or more buttons. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1992-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# -# ::tk_dialog: -# -# This procedure displays a dialog box, waits for a button in the dialog -# to be invoked, then returns the index of the selected button. If the -# dialog somehow gets destroyed, -1 is returned. -# -# Arguments: -# w - Window to use for dialog top-level. -# title - Title to display in dialog's decorative frame. -# text - Message to display in dialog. -# bitmap - Bitmap to display in dialog (empty string means none). -# default - Index of button that is to display the default ring -# (-1 means none). -# args - One or more strings to display in buttons across the -# bottom of the dialog box. - -proc ::tk_dialog {w title text bitmap default args} { - global tcl_platform - variable ::tk::Priv - - # Check that $default was properly given - if {[string is int $default]} { - if {$default >= [llength $args]} { - return -code error "default button index greater than number of\ - buttons specified for tk_dialog" - } - } elseif {[string equal {} $default]} { - set default -1 - } else { - set default [lsearch -exact $args $default] - } - - # 1. Create the top-level window and divide it into top - # and bottom parts. - - catch {destroy $w} - toplevel $w -class Dialog - wm title $w $title - wm iconname $w Dialog - wm protocol $w WM_DELETE_WINDOW { } - - # Dialog boxes should be transient with respect to their parent, - # so that they will always stay on top of their parent window. However, - # some window managers will create the window as withdrawn if the parent - # window is withdrawn or iconified. Combined with the grab we put on the - # window, this can hang the entire application. Therefore we only make - # the dialog transient if the parent is viewable. - # - if {[winfo viewable [winfo toplevel [winfo parent $w]]] } { - wm transient $w [winfo toplevel [winfo parent $w]] - } - - if {[string equal $tcl_platform(platform) "macintosh"] - || [string equal [tk windowingsystem] "aqua"]} { - ::tk::unsupported::MacWindowStyle style $w dBoxProc - } - - frame $w.bot - frame $w.top - if {[string equal [tk windowingsystem] "x11"]} { - $w.bot configure -relief raised -bd 1 - $w.top configure -relief raised -bd 1 - } - pack $w.bot -side bottom -fill both - pack $w.top -side top -fill both -expand 1 - - # 2. Fill the top part with bitmap and message (use the option - # database for -wraplength and -font so that they can be - # overridden by the caller). - - option add *Dialog.msg.wrapLength 3i widgetDefault - if {[string equal $tcl_platform(platform) "macintosh"] - || [string equal [tk windowingsystem] "aqua"]} { - option add *Dialog.msg.font system widgetDefault - } else { - option add *Dialog.msg.font {Times 12} widgetDefault - } - - label $w.msg -justify left -text $text - pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m - if {[string compare $bitmap ""]} { - if {([string equal $tcl_platform(platform) "macintosh"] - || [string equal [tk windowingsystem] "aqua"]) &&\ - [string equal $bitmap "error"]} { - set bitmap "stop" - } - label $w.bitmap -bitmap $bitmap - pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m - } - - # 3. Create a row of buttons at the bottom of the dialog. - - set i 0 - foreach but $args { - button $w.button$i -text $but -command [list set ::tk::Priv(button) $i] - if {$i == $default} { - $w.button$i configure -default active - } else { - $w.button$i configure -default normal - } - grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew \ - -padx 10 -pady 4 - grid columnconfigure $w.bot $i - # We boost the size of some Mac buttons for l&f - if {[string equal $tcl_platform(platform) "macintosh"] - || [string equal [tk windowingsystem] "aqua"]} { - set tmp [string tolower $but] - if {[string equal $tmp "ok"] || [string equal $tmp "cancel"]} { - grid columnconfigure $w.bot $i -minsize [expr {59 + 20}] - } - } - incr i - } - - # 4. Create a binding for <Return> on the dialog if there is a - # default button. - - if {$default >= 0} { - bind $w <Return> " - [list $w.button$default] configure -state active -relief sunken - update idletasks - after 100 - set ::tk::Priv(button) $default - " - } - - # 5. Create a <Destroy> binding for the window that sets the - # button variable to -1; this is needed in case something happens - # that destroys the window, such as its parent window being destroyed. - - bind $w <Destroy> {set ::tk::Priv(button) -1} - - # 6. Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. - - wm withdraw $w - update idletasks - set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - - [winfo vrootx [winfo parent $w]]}] - set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - - [winfo vrooty [winfo parent $w]]}] - wm geom $w +$x+$y - wm deiconify $w - - # 7. Set a grab and claim the focus too. - - set oldFocus [focus] - set oldGrab [grab current $w] - if {[string compare $oldGrab ""]} { - set grabStatus [grab status $oldGrab] - } - grab $w - if {$default >= 0} { - focus $w.button$default - } else { - focus $w - } - - # 8. Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - - vwait ::tk::Priv(button) - catch {focus $oldFocus} - catch { - # It's possible that the window has already been destroyed, - # hence this "catch". Delete the Destroy handler so that - # Priv(button) doesn't get reset by it. - - bind $w <Destroy> {} - destroy $w - } - if {[string compare $oldGrab ""]} { - if {[string compare $grabStatus "global"]} { - grab $oldGrab - } else { - grab -global $oldGrab - } - } - return $Priv(button) -} diff --git a/tcl/library/entry.tcl b/tcl/library/entry.tcl deleted file mode 100644 index 5bc2ed381b0..00000000000 --- a/tcl/library/entry.tcl +++ /dev/null @@ -1,652 +0,0 @@ -# entry.tcl -- -# -# This file defines the default bindings for Tk entry widgets and provides -# procedures that help in implementing those bindings. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -#------------------------------------------------------------------------- -# Elements of tk::Priv that are used in this file: -# -# afterId - If non-null, it means that auto-scanning is underway -# and it gives the "after" id for the next auto-scan -# command to be executed. -# mouseMoved - Non-zero means the mouse has moved a significant -# amount since the button went down (so, for example, -# start dragging out a selection). -# pressX - X-coordinate at which the mouse button was pressed. -# selectMode - The style of selection currently underway: -# char, word, or line. -# x, y - Last known mouse coordinates for scanning -# and auto-scanning. -# data - Used for Cut and Copy -#------------------------------------------------------------------------- - -#------------------------------------------------------------------------- -# The code below creates the default class bindings for entries. -#------------------------------------------------------------------------- -bind Entry <<Cut>> { - if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} { - clipboard clear -displayof %W - clipboard append -displayof %W $tk::Priv(data) - %W delete sel.first sel.last - unset tk::Priv(data) - } -} -bind Entry <<Copy>> { - if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} { - clipboard clear -displayof %W - clipboard append -displayof %W $tk::Priv(data) - unset tk::Priv(data) - } -} -bind Entry <<Paste>> { - global tcl_platform - catch { - if {[string compare [tk windowingsystem] "x11"]} { - catch { - %W delete sel.first sel.last - } - } - %W insert insert [::tk::GetSelection %W CLIPBOARD] - tk::EntrySeeInsert %W - } -} -bind Entry <<Clear>> { - %W delete sel.first sel.last -} -bind Entry <<PasteSelection>> { - if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)] - || !$tk::Priv(mouseMoved)} { - tk::EntryPaste %W %x - } -} - -# Standard Motif bindings: - -bind Entry <1> { - tk::EntryButton1 %W %x - %W selection clear -} -bind Entry <B1-Motion> { - set tk::Priv(x) %x - tk::EntryMouseSelect %W %x -} -bind Entry <Double-1> { - set tk::Priv(selectMode) word - tk::EntryMouseSelect %W %x - catch {%W icursor sel.last} -} -bind Entry <Triple-1> { - set tk::Priv(selectMode) line - tk::EntryMouseSelect %W %x - catch {%W icursor sel.last} -} -bind Entry <Shift-1> { - set tk::Priv(selectMode) char - %W selection adjust @%x -} -bind Entry <Double-Shift-1> { - set tk::Priv(selectMode) word - tk::EntryMouseSelect %W %x -} -bind Entry <Triple-Shift-1> { - set tk::Priv(selectMode) line - tk::EntryMouseSelect %W %x -} -bind Entry <B1-Leave> { - set tk::Priv(x) %x - tk::EntryAutoScan %W -} -bind Entry <B1-Enter> { - tk::CancelRepeat -} -bind Entry <ButtonRelease-1> { - tk::CancelRepeat -} -bind Entry <Control-1> { - %W icursor @%x -} - -bind Entry <Left> { - tk::EntrySetCursor %W [expr {[%W index insert] - 1}] -} -bind Entry <Right> { - tk::EntrySetCursor %W [expr {[%W index insert] + 1}] -} -bind Entry <Shift-Left> { - tk::EntryKeySelect %W [expr {[%W index insert] - 1}] - tk::EntrySeeInsert %W -} -bind Entry <Shift-Right> { - tk::EntryKeySelect %W [expr {[%W index insert] + 1}] - tk::EntrySeeInsert %W -} -bind Entry <Control-Left> { - tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert] -} -bind Entry <Control-Right> { - tk::EntrySetCursor %W [tk::EntryNextWord %W insert] -} -bind Entry <Shift-Control-Left> { - tk::EntryKeySelect %W [tk::EntryPreviousWord %W insert] - tk::EntrySeeInsert %W -} -bind Entry <Shift-Control-Right> { - tk::EntryKeySelect %W [tk::EntryNextWord %W insert] - tk::EntrySeeInsert %W -} -bind Entry <Home> { - tk::EntrySetCursor %W 0 -} -bind Entry <Shift-Home> { - tk::EntryKeySelect %W 0 - tk::EntrySeeInsert %W -} -bind Entry <End> { - tk::EntrySetCursor %W end -} -bind Entry <Shift-End> { - tk::EntryKeySelect %W end - tk::EntrySeeInsert %W -} - -bind Entry <Delete> { - if {[%W selection present]} { - %W delete sel.first sel.last - } else { - %W delete insert - } -} -bind Entry <BackSpace> { - tk::EntryBackspace %W -} - -bind Entry <Control-space> { - %W selection from insert -} -bind Entry <Select> { - %W selection from insert -} -bind Entry <Control-Shift-space> { - %W selection adjust insert -} -bind Entry <Shift-Select> { - %W selection adjust insert -} -bind Entry <Control-slash> { - %W selection range 0 end -} -bind Entry <Control-backslash> { - %W selection clear -} -bind Entry <KeyPress> { - tk::EntryInsert %W %A -} - -# Ignore all Alt, Meta, and Control keypresses unless explicitly bound. -# Otherwise, if a widget binding for one of these is defined, the -# <KeyPress> class binding will also fire and insert the character, -# which is wrong. Ditto for Escape, Return, and Tab. - -bind Entry <Alt-KeyPress> {# nothing} -bind Entry <Meta-KeyPress> {# nothing} -bind Entry <Control-KeyPress> {# nothing} -bind Entry <Escape> {# nothing} -bind Entry <Return> {# nothing} -bind Entry <KP_Enter> {# nothing} -bind Entry <Tab> {# nothing} -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - bind Entry <Command-KeyPress> {# nothing} -} - -# On Windows, paste is done using Shift-Insert. Shift-Insert already -# generates the <<Paste>> event, so we don't need to do anything here. -if {[string compare $tcl_platform(platform) "windows"]} { - bind Entry <Insert> { - catch {tk::EntryInsert %W [::tk::GetSelection %W PRIMARY]} - } -} - -# Additional emacs-like bindings: - -bind Entry <Control-a> { - if {!$tk_strictMotif} { - tk::EntrySetCursor %W 0 - } -} -bind Entry <Control-b> { - if {!$tk_strictMotif} { - tk::EntrySetCursor %W [expr {[%W index insert] - 1}] - } -} -bind Entry <Control-d> { - if {!$tk_strictMotif} { - %W delete insert - } -} -bind Entry <Control-e> { - if {!$tk_strictMotif} { - tk::EntrySetCursor %W end - } -} -bind Entry <Control-f> { - if {!$tk_strictMotif} { - tk::EntrySetCursor %W [expr {[%W index insert] + 1}] - } -} -bind Entry <Control-h> { - if {!$tk_strictMotif} { - tk::EntryBackspace %W - } -} -bind Entry <Control-k> { - if {!$tk_strictMotif} { - %W delete insert end - } -} -bind Entry <Control-t> { - if {!$tk_strictMotif} { - tk::EntryTranspose %W - } -} -bind Entry <Meta-b> { - if {!$tk_strictMotif} { - tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert] - } -} -bind Entry <Meta-d> { - if {!$tk_strictMotif} { - %W delete insert [tk::EntryNextWord %W insert] - } -} -bind Entry <Meta-f> { - if {!$tk_strictMotif} { - tk::EntrySetCursor %W [tk::EntryNextWord %W insert] - } -} -bind Entry <Meta-BackSpace> { - if {!$tk_strictMotif} { - %W delete [tk::EntryPreviousWord %W insert] insert - } -} -bind Entry <Meta-Delete> { - if {!$tk_strictMotif} { - %W delete [tk::EntryPreviousWord %W insert] insert - } -} - -# A few additional bindings of my own. - -bind Entry <2> { - if {!$tk_strictMotif} { - ::tk::EntryScanMark %W %x - } -} -bind Entry <B2-Motion> { - if {!$tk_strictMotif} { - ::tk::EntryScanDrag %W %x - } -} - -# ::tk::EntryClosestGap -- -# 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. -# -# Arguments: -# w - The entry window. -# x - X-coordinate within the window. - -proc ::tk::EntryClosestGap {w x} { - set pos [$w index @$x] - set bbox [$w bbox $pos] - if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} { - return $pos - } - incr pos -} - -# ::tk::EntryButton1 -- -# 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. -# -# Arguments: -# w - The entry window in which the button was pressed. -# x - The x-coordinate of the button press. - -proc ::tk::EntryButton1 {w x} { - variable ::tk::Priv - - set Priv(selectMode) char - set Priv(mouseMoved) 0 - set Priv(pressX) $x - $w icursor [EntryClosestGap $w $x] - $w selection from insert - if {[string compare "disabled" [$w cget -state]]} {focus $w} -} - -# ::tk::EntryMouseSelect -- -# 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 -# ignores mouse motions initially until the mouse has moved from -# one character to another or until there have been multiple clicks. -# -# Arguments: -# w - The entry window in which the button was pressed. -# x - The x-coordinate of the mouse. - -proc ::tk::EntryMouseSelect {w x} { - variable ::tk::Priv - - set cur [EntryClosestGap $w $x] - set anchor [$w index anchor] - if {($cur != $anchor) || (abs($Priv(pressX) - $x) >= 3)} { - set Priv(mouseMoved) 1 - } - switch $Priv(selectMode) { - char { - if {$Priv(mouseMoved)} { - if {$cur < $anchor} { - $w selection range $cur $anchor - } elseif {$cur > $anchor} { - $w selection range $anchor $cur - } else { - $w selection clear - } - } - } - word { - if {$cur < [$w index anchor]} { - set before [tcl_wordBreakBefore [$w get] $cur] - set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]] - } else { - set before [tcl_wordBreakBefore [$w get] $anchor] - set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]] - } - if {$before < 0} { - set before 0 - } - if {$after < 0} { - set after end - } - $w selection range $before $after - } - line { - $w selection range 0 end - } - } - if {$Priv(mouseMoved)} { - $w icursor $cur - } - update idletasks -} - -# ::tk::EntryPaste -- -# This procedure sets the insertion cursor to the current mouse position, -# pastes the selection there, and sets the focus to the window. -# -# Arguments: -# w - The entry window. -# x - X position of the mouse. - -proc ::tk::EntryPaste {w x} { - $w icursor [EntryClosestGap $w $x] - catch {$w insert insert [::tk::GetSelection $w PRIMARY]} - if {[string compare "disabled" [$w cget -state]]} {focus $w} -} - -# ::tk::EntryAutoScan -- -# 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 -# "after" command so that the window continues to scroll until the -# mouse moves back into the window or the mouse button is released. -# -# Arguments: -# w - The entry window. - -proc ::tk::EntryAutoScan {w} { - variable ::tk::Priv - set x $Priv(x) - if {![winfo exists $w]} return - if {$x >= [winfo width $w]} { - $w xview scroll 2 units - EntryMouseSelect $w $x - } elseif {$x < 0} { - $w xview scroll -2 units - EntryMouseSelect $w $x - } - set Priv(afterId) [after 50 [list tk::EntryAutoScan $w]] -} - -# ::tk::EntryKeySelect -- -# This procedure is invoked when stroking out selections using the -# keyboard. It moves the cursor to a new position, then extends -# the selection to that position. -# -# Arguments: -# w - The entry window. -# new - A new position for the insertion cursor (the cursor hasn't -# actually been moved to this position yet). - -proc ::tk::EntryKeySelect {w new} { - if {![$w selection present]} { - $w selection from insert - $w selection to $new - } else { - $w selection adjust $new - } - $w icursor $new -} - -# ::tk::EntryInsert -- -# Insert a string into an entry at the point of the insertion cursor. -# If there is a selection in the entry, and it covers the point of the -# insertion cursor, then delete the selection before inserting. -# -# Arguments: -# w - The entry window in which to insert the string -# s - The string to insert (usually just a single character) - -proc ::tk::EntryInsert {w s} { - if {[string equal $s ""]} { - return - } - catch { - set insert [$w index insert] - if {([$w index sel.first] <= $insert) - && ([$w index sel.last] >= $insert)} { - $w delete sel.first sel.last - } - } - $w insert insert $s - EntrySeeInsert $w -} - -# ::tk::EntryBackspace -- -# Backspace over the character just before the insertion cursor. -# If backspacing would move the cursor off the left edge of the -# window, reposition the cursor at about the middle of the window. -# -# Arguments: -# w - The entry window in which to backspace. - -proc ::tk::EntryBackspace w { - if {[$w selection present]} { - $w delete sel.first sel.last - } else { - set x [expr {[$w index insert] - 1}] - if {$x >= 0} {$w delete $x} - if {[$w index @0] >= [$w index insert]} { - set range [$w xview] - set left [lindex $range 0] - set right [lindex $range 1] - $w xview moveto [expr {$left - ($right - $left)/2.0}] - } - } -} - -# ::tk::EntrySeeInsert -- -# Make sure that the insertion cursor is visible in the entry window. -# If not, adjust the view so that it is. -# -# Arguments: -# w - The entry window. - -proc ::tk::EntrySeeInsert w { - set c [$w index insert] - if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} { - $w xview $c - } -} - -# ::tk::EntrySetCursor - -# Move the insertion cursor to a given position in an entry. Also -# clears the selection, if there is one in the entry, and makes sure -# that the insertion cursor is visible. -# -# Arguments: -# w - The entry window. -# pos - The desired new position for the cursor in the window. - -proc ::tk::EntrySetCursor {w pos} { - $w icursor $pos - $w selection clear - EntrySeeInsert $w -} - -# ::tk::EntryTranspose - -# This procedure implements the "transpose" function for entry widgets. -# It tranposes the characters on either side of the insertion cursor, -# unless the cursor is at the end of the line. In this case it -# transposes the two characters to the left of the cursor. In either -# case, the cursor ends up to the right of the transposed characters. -# -# Arguments: -# w - The entry window. - -proc ::tk::EntryTranspose w { - set i [$w index insert] - if {$i < [$w index end]} { - incr i - } - set first [expr {$i-2}] - if {$first < 0} { - return - } - set data [$w get] - set new [string index $data [expr {$i-1}]][string index $data $first] - $w delete $first $i - $w insert insert $new - EntrySeeInsert $w -} - -# ::tk::EntryNextWord -- -# 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 -# end-of-word position. -# -# Arguments: -# w - The entry window in which the cursor is to move. -# start - Position at which to start search. - -if {[string equal $tcl_platform(platform) "windows"]} { - proc ::tk::EntryNextWord {w start} { - set pos [tcl_endOfWord [$w get] [$w index $start]] - if {$pos >= 0} { - set pos [tcl_startOfNextWord [$w get] $pos] - } - if {$pos < 0} { - return end - } - return $pos - } -} else { - proc ::tk::EntryNextWord {w start} { - set pos [tcl_endOfWord [$w get] [$w index $start]] - if {$pos < 0} { - return end - } - return $pos - } -} - -# ::tk::EntryPreviousWord -- -# -# Returns the index of the previous word position before a given -# position in the entry. -# -# Arguments: -# w - The entry window in which the cursor is to move. -# start - Position at which to start search. - -proc ::tk::EntryPreviousWord {w start} { - set pos [tcl_startOfPreviousWord [$w get] [$w index $start]] - if {$pos < 0} { - return 0 - } - return $pos -} - -# ::tk::EntryScanMark -- -# -# Marks the start of a possible scan drag operation -# -# Arguments: -# w - The entry window from which the text to get -# x - x location on screen - -proc ::tk::EntryScanMark {w x} { - $w scan mark $x - set ::tk::Priv(x) $x - set ::tk::Priv(y) 0 ; # not used - set ::tk::Priv(mouseMoved) 0 -} - -# ::tk::EntryScanDrag -- -# -# Marks the start of a possible scan drag operation -# -# Arguments: -# w - The entry window from which the text to get -# x - x location on screen - -proc ::tk::EntryScanDrag {w x} { - # Make sure these exist, as some weird situations can trigger the - # motion binding without the initial press. [Bug #220269] - if {![info exists ::tk::Priv(x)]} { set ::tk::Priv(x) $x } - # allow for a delta - if {abs($x-$::tk::Priv(x)) > 2} { - set ::tk::Priv(mouseMoved) 1 - } - $w scan dragto $x -} - -# ::tk::EntryGetSelection -- -# -# Returns the selected text of the entry with respect to the -show option. -# -# Arguments: -# w - The entry window from which the text to get - -proc ::tk::EntryGetSelection {w} { - set entryString [string range [$w get] [$w index sel.first] \ - [expr {[$w index sel.last] - 1}]] - if {[string compare [$w cget -show] ""]} { - return [string repeat [string index [$w cget -show] 0] \ - [string length $entryString]] - } - return $entryString -} diff --git a/tcl/library/focus.tcl b/tcl/library/focus.tcl deleted file mode 100644 index ea0f64de269..00000000000 --- a/tcl/library/focus.tcl +++ /dev/null @@ -1,181 +0,0 @@ -# focus.tcl -- -# -# This file defines several procedures for managing the input -# focus. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# ::tk_focusNext -- -# 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 -# of a top-level and its non-top-level descendants, with the stacking -# order determining the order of siblings. The "-takefocus" options -# on windows determine whether or not they should be skipped. -# -# Arguments: -# w - Name of a window. - -proc ::tk_focusNext w { - set cur $w - while {1} { - - # Descend to just before the first child of the current widget. - - set parent $cur - set children [winfo children $cur] - set i -1 - - # Look for the next sibling that isn't a top-level. - - while {1} { - incr i - if {$i < [llength $children]} { - set cur [lindex $children $i] - if {[string equal [winfo toplevel $cur] $cur]} { - continue - } else { - break - } - } - - # No more siblings, so go to the current widget's parent. - # If it's a top-level, break out of the loop, otherwise - # look for its next sibling. - - set cur $parent - if {[string equal [winfo toplevel $cur] $cur]} { - break - } - set parent [winfo parent $parent] - set children [winfo children $parent] - set i [lsearch -exact $children $cur] - } - if {[string equal $w $cur] || [tk::FocusOK $cur]} { - return $cur - } - } -} - -# ::tk_focusPrev -- -# 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 -# of a top-level and its non-top-level descendants, with the stacking -# order determining the order of siblings. The "-takefocus" options -# on windows determine whether or not they should be skipped. -# -# Arguments: -# w - Name of a window. - -proc ::tk_focusPrev w { - set cur $w - while {1} { - - # Collect information about the current window's position - # among its siblings. Also, if the window is a top-level, - # then reposition to just after the last child of the window. - - if {[string equal [winfo toplevel $cur] $cur]} { - set parent $cur - set children [winfo children $cur] - set i [llength $children] - } else { - set parent [winfo parent $cur] - set children [winfo children $parent] - set i [lsearch -exact $children $cur] - } - - # Go to the previous sibling, then descend to its last descendant - # (highest in stacking order. While doing this, ignore top-levels - # and their descendants. When we run out of descendants, go up - # one level to the parent. - - while {$i > 0} { - incr i -1 - set cur [lindex $children $i] - if {[string equal [winfo toplevel $cur] $cur]} { - continue - } - set parent $cur - set children [winfo children $parent] - set i [llength $children] - } - set cur $parent - if {[string equal $w $cur] || [tk::FocusOK $cur]} { - return $cur - } - } -} - -# ::tk::FocusOK -- -# -# 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, -# 0 if it's not OK. The code first checks whether the window is -# viewable. If not, then it never focuses on the window. Then it -# checks the -takefocus option for the window and uses it if it's -# set. If there's no -takefocus option, the procedure checks to -# see if (a) the widget isn't disabled, and (b) it has some key -# bindings. If all of these are true, then 1 is returned. -# -# Arguments: -# w - Name of a window. - -proc ::tk::FocusOK w { - set code [catch {$w cget -takefocus} value] - if {($code == 0) && ($value != "")} { - if {$value == 0} { - return 0 - } elseif {$value == 1} { - return [winfo viewable $w] - } else { - set value [uplevel #0 $value [list $w]] - if {$value != ""} { - return $value - } - } - } - if {![winfo viewable $w]} { - return 0 - } - set code [catch {$w cget -state} value] - if {($code == 0) && [string equal $value "disabled"]} { - return 0 - } - regexp Key|Focus "[bind $w] [bind [winfo class $w]]" -} - -# ::tk_focusFollowsMouse -- -# -# If this procedure is invoked, Tk will enter "focus-follows-mouse" -# mode, where the focus is always on whatever window contains the -# mouse. If this procedure isn't invoked, then the user typically -# has to click on a window to give it the focus. -# -# Arguments: -# None. - -proc ::tk_focusFollowsMouse {} { - set old [bind all <Enter>] - set script { - if {[string equal "%d" "NotifyAncestor"] \ - || [string equal "%d" "NotifyNonlinear"] \ - || [string equal "%d" "NotifyInferior"]} { - if {[tk::FocusOK %W]} { - focus %W - } - } - } - if {[string compare $old ""]} { - bind all <Enter> "$old; $script" - } else { - bind all <Enter> $script - } -} diff --git a/tcl/library/images/README b/tcl/library/images/README deleted file mode 100644 index 65101cd3797..00000000000 --- a/tcl/library/images/README +++ /dev/null @@ -1,12 +0,0 @@ -README - images directory - -RCS: @(#) $Id$ - - -This directory includes images for the Tcl Logo and the Tcl Powered -Logo. Please feel free to use the Tcl Powered Logo on any of your -products that employ the use of Tcl or Tk. The Tcl logo may also be -used to promote Tcl in your product documentation, web site or other -places you so desire. - - diff --git a/tcl/library/images/logo.eps b/tcl/library/images/logo.eps deleted file mode 100644 index 0d05d3404bd..00000000000 --- a/tcl/library/images/logo.eps +++ /dev/null @@ -1,2091 +0,0 @@ -%!PS-Adobe-3.0 EPSF-3.0 -%%Creator: Adobe Illustrator(TM) 5.5 -%%For: (Bud Northern) (Mark Anderson Design) -%%Title: (TCL/TK LOGO.ILLUS) -%%CreationDate: (8/1/96) (4:58 PM) -%%BoundingBox: 251 331 371 512 -%%HiResBoundingBox: 251.3386 331.5616 370.5213 511.775 -%%DocumentProcessColors: Cyan Magenta Yellow -%%DocumentSuppliedResources: procset Adobe_level2_AI5 1.0 0 -%%+ procset Adobe_IllustratorA_AI5 1.0 0 -%AI5_FileFormat 1.2 -%AI3_ColorUsage: Color -%%DocumentCustomColors: (TCL RED) -%%CMYKCustomColor: 0 0.45 1 0 (Orange) -%%+ 0 0.25 1 0 (Orange Yellow) -%%+ 0 0.79 0.91 0 (TCL RED) -%AI3_TemplateBox: 306 396 306 396 -%AI3_TileBox: 12 12 600 780 -%AI3_DocumentPreview: Macintosh_ColorPic -%AI5_ArtSize: 612 792 -%AI5_RulerUnits: 0 -%AI5_ArtFlags: 1 0 0 1 0 0 1 1 0 -%AI5_TargetResolution: 800 -%AI5_NumLayers: 1 -%AI5_OpenToView: 90 576 2 938 673 18 1 1 2 40 -%AI5_OpenViewLayers: 7 -%%EndComments -%%BeginProlog -%%BeginResource: procset Adobe_level2_AI5 1.0 0 -%%Title: (Adobe Illustrator (R) Version 5.0 Level 2 Emulation) -%%Version: 1.0 -%%CreationDate: (04/10/93) () -%%Copyright: ((C) 1987-1993 Adobe Systems Incorporated All Rights Reserved) -userdict /Adobe_level2_AI5 21 dict dup begin - put - /packedarray where not - { - userdict begin - /packedarray - { - array astore readonly - } bind def - /setpacking /pop load def - /currentpacking false def - end - 0 - } if - pop - userdict /defaultpacking currentpacking put true setpacking - /initialize - { - Adobe_level2_AI5 begin - } bind def - /terminate - { - currentdict Adobe_level2_AI5 eq - { - end - } if - } bind def - mark - /setcustomcolor where not - { - /findcmykcustomcolor - { - 5 packedarray - } bind def - /setcustomcolor - { - exch aload pop pop - 4 - { - 4 index mul 4 1 roll - } repeat - 5 -1 roll pop - setcmykcolor - } - def - } if - - /gt38? mark {version cvx exec} stopped {cleartomark true} {38 gt exch pop} ifelse def - userdict /deviceDPI 72 0 matrix defaultmatrix dtransform dup mul exch dup mul add sqrt put - userdict /level2? - systemdict /languagelevel known dup - { - pop systemdict /languagelevel get 2 ge - } if - put - level2? not - { - /setcmykcolor where not - { - /setcmykcolor - { - exch .11 mul add exch .59 mul add exch .3 mul add - 1 exch sub setgray - } def - } if - /currentcmykcolor where not - { - /currentcmykcolor - { - 0 0 0 1 currentgray sub - } def - } if - /setoverprint where not - { - /setoverprint /pop load def - } if - /selectfont where not - { - /selectfont - { - exch findfont exch - dup type /arraytype eq - { - makefont - } - { - scalefont - } ifelse - setfont - } bind def - } if - /cshow where not - { - /cshow - { - [ - 0 0 5 -1 roll aload pop - ] cvx bind forall - } bind def - } if - } if - cleartomark - /anyColor? - { - add add add 0 ne - } bind def - /testColor - { - gsave - setcmykcolor currentcmykcolor - grestore - } bind def - /testCMYKColorThrough - { - testColor anyColor? - } bind def - userdict /composite? - level2? - { - gsave 1 1 1 1 setcmykcolor currentcmykcolor grestore - add add add 4 eq - } - { - 1 0 0 0 testCMYKColorThrough - 0 1 0 0 testCMYKColorThrough - 0 0 1 0 testCMYKColorThrough - 0 0 0 1 testCMYKColorThrough - and and and - } ifelse - put - composite? not - { - userdict begin - gsave - /cyan? 1 0 0 0 testCMYKColorThrough def - /magenta? 0 1 0 0 testCMYKColorThrough def - /yellow? 0 0 1 0 testCMYKColorThrough def - /black? 0 0 0 1 testCMYKColorThrough def - grestore - /isCMYKSep? cyan? magenta? yellow? black? or or or def - /customColor? isCMYKSep? not def - end - } if - end defaultpacking setpacking -%%EndResource -%%BeginResource: procset Adobe_IllustratorA_AI5 1.1 0 -%%Title: (Adobe Illustrator (R) Version 5.0 Abbreviated Prolog) -%%Version: 1.1 -%%CreationDate: (3/7/1994) () -%%Copyright: ((C) 1987-1994 Adobe Systems Incorporated All Rights Reserved) -currentpacking true setpacking -userdict /Adobe_IllustratorA_AI5_vars 70 dict dup begin -put -/_lp /none def -/_pf -{ -} def -/_ps -{ -} def -/_psf -{ -} def -/_pss -{ -} def -/_pjsf -{ -} def -/_pjss -{ -} def -/_pola 0 def -/_doClip 0 def -/cf currentflat def -/_tm matrix def -/_renderStart -[ -/e0 /r0 /a0 /o0 /e1 /r1 /a1 /i0 -] def -/_renderEnd -[ -null null null null /i1 /i1 /i1 /i1 -] def -/_render -1 def -/_rise 0 def -/_ax 0 def -/_ay 0 def -/_cx 0 def -/_cy 0 def -/_leading -[ -0 0 -] def -/_ctm matrix def -/_mtx matrix def -/_sp 16#020 def -/_hyphen (-) def -/_fScl 0 def -/_cnt 0 def -/_hs 1 def -/_nativeEncoding 0 def -/_useNativeEncoding 0 def -/_tempEncode 0 def -/_pntr 0 def -/_tDict 2 dict def -/_wv 0 def -/Tx -{ -} def -/Tj -{ -} def -/CRender -{ -} def -/_AI3_savepage -{ -} def -/_gf null def -/_cf 4 array def -/_if null def -/_of false def -/_fc -{ -} def -/_gs null def -/_cs 4 array def -/_is null def -/_os false def -/_sc -{ -} def -/discardSave null def -/buffer 256 string def -/beginString null def -/endString null def -/endStringLength null def -/layerCnt 1 def -/layerCount 1 def -/perCent (%) 0 get def -/perCentSeen? false def -/newBuff null def -/newBuffButFirst null def -/newBuffLast null def -/clipForward? false def -end -userdict /Adobe_IllustratorA_AI5 74 dict dup begin -put -/initialize -{ - Adobe_IllustratorA_AI5 dup begin - Adobe_IllustratorA_AI5_vars begin - discardDict - { - bind pop pop - } forall - dup /nc get begin - { - dup xcheck 1 index type /operatortype ne and - { - bind - } if - pop pop - } forall - end - newpath -} def -/terminate -{ - end - end -} def -/_ -null def -/ddef -{ - Adobe_IllustratorA_AI5_vars 3 1 roll put -} def -/xput -{ - dup load dup length exch maxlength eq - { - dup dup load dup - length 2 mul dict copy def - } if - load begin - def - end -} def -/npop -{ - { - pop - } repeat -} def -/sw -{ - dup length exch stringwidth - exch 5 -1 roll 3 index mul add - 4 1 roll 3 1 roll mul add -} def -/swj -{ - dup 4 1 roll - dup length exch stringwidth - exch 5 -1 roll 3 index mul add - 4 1 roll 3 1 roll mul add - 6 2 roll /_cnt 0 ddef - { - 1 index eq - { - /_cnt _cnt 1 add ddef - } if - } forall - pop - exch _cnt mul exch _cnt mul 2 index add 4 1 roll 2 index add 4 1 roll pop pop -} def -/ss -{ - 4 1 roll - { - 2 npop - (0) exch 2 copy 0 exch put pop - gsave - false charpath currentpoint - 4 index setmatrix - stroke - grestore - moveto - 2 copy rmoveto - } exch cshow - 3 npop -} def -/jss -{ - 4 1 roll - { - 2 npop - (0) exch 2 copy 0 exch put - gsave - _sp eq - { - exch 6 index 6 index 6 index 5 -1 roll widthshow - currentpoint - } - { - false charpath currentpoint - 4 index setmatrix stroke - } ifelse - grestore - moveto - 2 copy rmoveto - } exch cshow - 6 npop -} def -/sp -{ - { - 2 npop (0) exch - 2 copy 0 exch put pop - false charpath - 2 copy rmoveto - } exch cshow - 2 npop -} def -/jsp -{ - { - 2 npop - (0) exch 2 copy 0 exch put - _sp eq - { - exch 5 index 5 index 5 index 5 -1 roll widthshow - } - { - false charpath - } ifelse - 2 copy rmoveto - } exch cshow - 5 npop -} def -/pl -{ - transform - 0.25 sub round 0.25 add exch - 0.25 sub round 0.25 add exch - itransform -} def -/setstrokeadjust where -{ - pop true setstrokeadjust - /c - { - curveto - } def - /C - /c load def - /v - { - currentpoint 6 2 roll curveto - } def - /V - /v load def - /y - { - 2 copy curveto - } def - /Y - /y load def - /l - { - lineto - } def - /L - /l load def - /m - { - moveto - } def -} -{ - /c - { - pl curveto - } def - /C - /c load def - /v - { - currentpoint 6 2 roll pl curveto - } def - /V - /v load def - /y - { - pl 2 copy curveto - } def - /Y - /y load def - /l - { - pl lineto - } def - /L - /l load def - /m - { - pl moveto - } def -} ifelse -/d -{ - setdash -} def -/cf -{ -} def -/i -{ - dup 0 eq - { - pop cf - } if - setflat -} def -/j -{ - setlinejoin -} def -/J -{ - setlinecap -} def -/M -{ - setmiterlimit -} def -/w -{ - setlinewidth -} def -/H -{ -} def -/h -{ - closepath -} def -/N -{ - _pola 0 eq - { - _doClip 1 eq - { - clip /_doClip 0 ddef - } if - newpath - } - { - /CRender - { - N - } ddef - } ifelse -} def -/n -{ - N -} def -/F -{ - _pola 0 eq - { - _doClip 1 eq - { - gsave _pf grestore clip newpath /_lp /none ddef _fc - /_doClip 0 ddef - } - { - _pf - } ifelse - } - { - /CRender - { - F - } ddef - } ifelse -} def -/f -{ - closepath - F -} def -/S -{ - _pola 0 eq - { - _doClip 1 eq - { - gsave _ps grestore clip newpath /_lp /none ddef _sc - /_doClip 0 ddef - } - { - _ps - } ifelse - } - { - /CRender - { - S - } ddef - } ifelse -} def -/s -{ - closepath - S -} def -/B -{ - _pola 0 eq - { - _doClip 1 eq - gsave F grestore - { - gsave S grestore clip newpath /_lp /none ddef _sc - /_doClip 0 ddef - } - { - S - } ifelse - } - { - /CRender - { - B - } ddef - } ifelse -} def -/b -{ - closepath - B -} def -/W -{ - /_doClip 1 ddef -} def -/* -{ - count 0 ne - { - dup type /stringtype eq - { - pop - } if - } if - newpath -} def -/u -{ -} def -/U -{ -} def -/q -{ - _pola 0 eq - { - gsave - } if -} def -/Q -{ - _pola 0 eq - { - grestore - } if -} def -/*u -{ - _pola 1 add /_pola exch ddef -} def -/*U -{ - _pola 1 sub /_pola exch ddef - _pola 0 eq - { - CRender - } if -} def -/D -{ - pop -} def -/*w -{ -} def -/*W -{ -} def -/` -{ - /_i save ddef - clipForward? - { - nulldevice - } if - 6 1 roll 4 npop - concat pop - userdict begin - /showpage - { - } def - 0 setgray - 0 setlinecap - 1 setlinewidth - 0 setlinejoin - 10 setmiterlimit - [] 0 setdash - /setstrokeadjust where {pop false setstrokeadjust} if - newpath - 0 setgray - false setoverprint -} def -/~ -{ - end - _i restore -} def -/O -{ - 0 ne - /_of exch ddef - /_lp /none ddef -} def -/R -{ - 0 ne - /_os exch ddef - /_lp /none ddef -} def -/g -{ - /_gf exch ddef - /_fc - { - _lp /fill ne - { - _of setoverprint - _gf setgray - /_lp /fill ddef - } if - } ddef - /_pf - { - _fc - fill - } ddef - /_psf - { - _fc - ashow - } ddef - /_pjsf - { - _fc - awidthshow - } ddef - /_lp /none ddef -} def -/G -{ - /_gs exch ddef - /_sc - { - _lp /stroke ne - { - _os setoverprint - _gs setgray - /_lp /stroke ddef - } if - } ddef - /_ps - { - _sc - stroke - } ddef - /_pss - { - _sc - ss - } ddef - /_pjss - { - _sc - jss - } ddef - /_lp /none ddef -} def -/k -{ - _cf astore pop - /_fc - { - _lp /fill ne - { - _of setoverprint - _cf aload pop setcmykcolor - /_lp /fill ddef - } if - } ddef - /_pf - { - _fc - fill - } ddef - /_psf - { - _fc - ashow - } ddef - /_pjsf - { - _fc - awidthshow - } ddef - /_lp /none ddef -} def -/K -{ - _cs astore pop - /_sc - { - _lp /stroke ne - { - _os setoverprint - _cs aload pop setcmykcolor - /_lp /stroke ddef - } if - } ddef - /_ps - { - _sc - stroke - } ddef - /_pss - { - _sc - ss - } ddef - /_pjss - { - _sc - jss - } ddef - /_lp /none ddef -} def -/x -{ - /_gf exch ddef - findcmykcustomcolor - /_if exch ddef - /_fc - { - _lp /fill ne - { - _of setoverprint - _if _gf 1 exch sub setcustomcolor - /_lp /fill ddef - } if - } ddef - /_pf - { - _fc - fill - } ddef - /_psf - { - _fc - ashow - } ddef - /_pjsf - { - _fc - awidthshow - } ddef - /_lp /none ddef -} def -/X -{ - /_gs exch ddef - findcmykcustomcolor - /_is exch ddef - /_sc - { - _lp /stroke ne - { - _os setoverprint - _is _gs 1 exch sub setcustomcolor - /_lp /stroke ddef - } if - } ddef - /_ps - { - _sc - stroke - } ddef - /_pss - { - _sc - ss - } ddef - /_pjss - { - _sc - jss - } ddef - /_lp /none ddef -} def -/A -{ - pop -} def -/annotatepage -{ -userdict /annotatepage 2 copy known {get exec} {pop pop} ifelse -} def -/discard -{ - save /discardSave exch store - discardDict begin - /endString exch store - gt38? - { - 2 add - } if - load - stopped - pop - end - discardSave restore -} bind def -userdict /discardDict 7 dict dup begin -put -/pre38Initialize -{ - /endStringLength endString length store - /newBuff buffer 0 endStringLength getinterval store - /newBuffButFirst newBuff 1 endStringLength 1 sub getinterval store - /newBuffLast newBuff endStringLength 1 sub 1 getinterval store -} def -/shiftBuffer -{ - newBuff 0 newBuffButFirst putinterval - newBuffLast 0 - currentfile read not - { - stop - } if - put -} def -0 -{ - pre38Initialize - mark - currentfile newBuff readstring exch pop - { - { - newBuff endString eq - { - cleartomark stop - } if - shiftBuffer - } loop - } - { - stop - } ifelse -} def -1 -{ - pre38Initialize - /beginString exch store - mark - currentfile newBuff readstring exch pop - { - { - newBuff beginString eq - { - /layerCount dup load 1 add store - } - { - newBuff endString eq - { - /layerCount dup load 1 sub store - layerCount 0 eq - { - cleartomark stop - } if - } if - } ifelse - shiftBuffer - } loop - } - { - stop - } ifelse -} def -2 -{ - mark - { - currentfile buffer readline not - { - stop - } if - endString eq - { - cleartomark stop - } if - } loop -} def -3 -{ - /beginString exch store - /layerCnt 1 store - mark - { - currentfile buffer readline not - { - stop - } if - dup beginString eq - { - pop /layerCnt dup load 1 add store - } - { - endString eq - { - layerCnt 1 eq - { - cleartomark stop - } - { - /layerCnt dup load 1 sub store - } ifelse - } if - } ifelse - } loop -} def -end -userdict /clipRenderOff 15 dict dup begin -put -{ - /n /N /s /S /f /F /b /B -} -{ - { - _doClip 1 eq - { - /_doClip 0 ddef clip - } if - newpath - } def -} forall -/Tr /pop load def -/Bb {} def -/BB /pop load def -/Bg {12 npop} def -/Bm {6 npop} def -/Bc /Bm load def -/Bh {4 npop} def -end -/Lb -{ - 4 npop - 6 1 roll - pop - 4 1 roll - pop pop pop - 0 eq - { - 0 eq - { - (%AI5_BeginLayer) 1 (%AI5_EndLayer--) discard - } - { - /clipForward? true def - - /Tx /pop load def - /Tj /pop load def - currentdict end clipRenderOff begin begin - } ifelse - } - { - 0 eq - { - save /discardSave exch store - } if - } ifelse -} bind def -/LB -{ - discardSave dup null ne - { - restore - } - { - pop - clipForward? - { - currentdict - end - end - begin - - /clipForward? false ddef - } if - } ifelse -} bind def -/Pb -{ - pop pop - 0 (%AI5_EndPalette) discard -} bind def -/Np -{ - 0 (%AI5_End_NonPrinting--) discard -} bind def -/Ln /pop load def -/Ap -/pop load def -/Ar -{ - 72 exch div - 0 dtransform dup mul exch dup mul add sqrt - dup 1 lt - { - pop 1 - } if - setflat -} def -/Mb -{ - q -} def -/Md -{ -} def -/MB -{ - Q -} def -/nc 3 dict def -nc begin -/setgray -{ - pop -} bind def -/setcmykcolor -{ - 4 npop -} bind def -/setcustomcolor -{ - 2 npop -} bind def -currentdict readonly pop -end -currentdict readonly pop -end -setpacking -%%EndResource -%%EndProlog -%%BeginSetup -Adobe_level2_AI5 /initialize get exec -Adobe_IllustratorA_AI5 /initialize get exec -%AI5_Begin_NonPrinting -Np -%AI3_BeginPattern: (Yellow Stripe) -(Yellow Stripe) 8.4499 4.6 80.4499 76.6 [ -%AI3_Tile -(0 O 0 R 0 0.4 1 0 k 0 0.4 1 0 K) @ -( -800 Ar -0 J 0 j 3.6 w 4 M []0 d -%AI3_Note: -0 D -8.1999 8.1999 m -80.6999 8.1999 L -S -8.1999 22.6 m -80.6999 22.6 L -S -8.1999 37.0001 m -80.6999 37.0001 L -S -8.1999 51.3999 m -80.6999 51.3999 L -S -8.1999 65.8 m -80.6999 65.8 L -S -8.1999 15.3999 m -80.6999 15.3999 L -S -8.1999 29.8 m -80.6999 29.8 L -S -8.1999 44.1999 m -80.6999 44.1999 L -S -8.1999 58.6 m -80.6999 58.6 L -S -8.1999 73.0001 m -80.6999 73.0001 L -S -) & -] E -%AI3_EndPattern -%AI5_End_NonPrinting-- -%AI5_Begin_NonPrinting -Np -3 Bn -%AI5_BeginGradient: (Black & White) -(Black & White) 0 2 Bd -[ -< -FFFEFDFCFBFAF9F8F7F6F5F4F3F2F1F0EFEEEDECEBEAE9E8E7E6E5E4E3E2E1E0DFDEDDDCDBDAD9D8 -D7D6D5D4D3D2D1D0CFCECDCCCBCAC9C8C7C6C5C4C3C2C1C0BFBEBDBCBBBAB9B8B7B6B5B4B3B2B1B0 -AFAEADACABAAA9A8A7A6A5A4A3A2A1A09F9E9D9C9B9A999897969594939291908F8E8D8C8B8A8988 -87868584838281807F7E7D7C7B7A797877767574737271706F6E6D6C6B6A69686766656463626160 -5F5E5D5C5B5A595857565554535251504F4E4D4C4B4A494847464544434241403F3E3D3C3B3A3938 -37363534333231302F2E2D2C2B2A292827262524232221201F1E1D1C1B1A19181716151413121110 -0F0E0D0C0B0A09080706050403020100 -> -0 %_Br -[ -0 0 50 100 %_Bs -1 0 50 0 %_Bs -BD -%AI5_EndGradient -%AI5_BeginGradient: (Red & Yellow) -(Red & Yellow) 0 2 Bd -[ -0 -< -000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F2021222324252627 -28292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F -505152535455565758595A5B5C5D5E5F606162636465666768696A6B6C6D6E6F7071727374757677 -78797A7B7C7D7E7F808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F -A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0C1C2C3C4C5C6C7 -C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF -F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF -> -< -FFFFFEFEFDFDFDFCFCFBFBFBFAFAF9F9F9F8F8F7F7F7F6F6F5F5F5F4F4F3F3F3F2F2F1F1F1F0F0EF -EFEFEEEEEDEDEDECECEBEBEBEAEAE9E9E9E8E8E7E7E7E6E6E5E5E5E4E4E3E3E3E2E2E1E1E1E0E0DF -DFDFDEDEDDDDDDDCDCDBDBDBDADAD9D9D9D8D8D7D7D7D6D6D5D5D5D4D4D3D3D3D2D2D1D1D1D0D0CF -CFCFCECECDCDCDCCCCCBCBCBCACAC9C9C9C8C8C7C7C7C6C6C5C5C5C4C4C3C3C3C2C2C1C1C1C0C0BF -BFBFBEBEBDBDBDBCBCBBBBBBBABAB9B9B9B8B8B7B7B7B6B6B5B5B5B4B4B3B3B3B2B2B1B1B1B0B0AF -AFAFAEAEADADADACACABABABAAAAA9A9A9A8A8A7A7A7A6A6A5A5A5A4A4A3A3A3A2A2A1A1A1A0A09F -9F9F9E9E9D9D9D9C9C9B9B9B9A9A9999 -> -0 -1 %_Br -[ -0 1 0.6 0 1 50 100 %_Bs -0 0 1 0 1 50 0 %_Bs -BD -%AI5_EndGradient -%AI5_BeginGradient: (Yellow & Blue Radial) -(Yellow & Blue Radial) 1 2 Bd -[ -< -000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F2021222324252627 -28292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F -505152535455565758595A5B5C5D5E5F606162636465666768696A6B6C6D6E6F7071727374757677 -78797A7B7C7D7E7F808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F -A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0C1C2C3C4C5C6C7 -C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF -F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF -> -< -1415161718191A1B1C1D1E1F1F202122232425262728292A2A2B2C2D2E2F30313233343536363738 -393A3B3C3D3E3F40414142434445464748494A4B4C4D4D4E4F50515253545556575858595A5B5C5D -5E5F60616263646465666768696A6B6C6D6E6F6F707172737475767778797A7B7B7C7D7E7F808182 -83848586868788898A8B8C8D8E8F90919292939495969798999A9B9C9D9D9E9FA0A1A2A3A4A5A6A7 -A8A9A9AAABACADAEAFB0B1B2B3B4B4B5B6B7B8B9BABBBCBDBEBFC0C0C1C2C3C4C5C6C7C8C9CACBCB -CCCDCECFD0D1D2D3D4D5D6D7D7D8D9DADBDCDDDEDFE0E1E2E2E3E4E5E6E7E8E9EAEBECEDEEEEEFF0 -F1F2F3F4F5F6F7F8F9F9FAFBFCFDFEFF -> -< -ABAAAAA9A8A7A7A6A5A5A4A3A3A2A1A1A09F9F9E9D9D9C9B9B9A9999989797969595949393929191 -908F8F8E8D8D8C8B8B8A8989888787868585848383828181807F7F7E7D7D7C7B7B7A797978777776 -7575747373727171706F6F6E6D6D6C6B6B6A6969686767666565646362626160605F5E5E5D5C5C5B -5A5A5958585756565554545352525150504F4E4E4D4C4C4B4A4A4948484746464544444342424140 -403F3E3E3D3C3C3B3A3A3938383736363534343332323130302F2E2E2D2C2C2B2A2A292828272626 -25242423222121201F1F1E1D1D1C1B1B1A1919181717161515141313121111100F0F0E0D0D0C0B0B -0A090908070706050504030302010100 -> -0 -1 %_Br -[ -0 0.08 0.67 0 1 50 14 %_Bs -1 1 0 0 1 50 100 %_Bs -BD -%AI5_EndGradient -%AI5_End_NonPrinting-- -%AI5_BeginPalette -144 170 Pb -Pn -Pc -1 g -Pc -0 g -Pc -0 0 0 0 k -Pc -0.75 g -Pc -0.5 g -Pc -0.25 g -Pc -0 g -Pc -Bb -2 (Black & White) -4014 4716 0 0 1 0 0 1 0 0 Bg -0 BB -Pc -0.25 0 0 0 k -Pc -0.5 0 0 0 k -Pc -0.75 0 0 0 k -Pc -1 0 0 0 k -Pc -0.25 0.25 0 0 k -Pc -0.5 0.5 0 0 k -Pc -0.75 0.75 0 0 k -Pc -1 1 0 0 k -Pc -Bb -2 (Red & Yellow) -4014 4716 0 0 1 0 0 1 0 0 Bg -0 BB -Pc -0 0.25 0 0 k -Pc -0 0.5 0 0 k -Pc -0 0.75 0 0 k -Pc -0 1 0 0 k -Pc -0 0.25 0.25 0 k -Pc -0 0.5 0.5 0 k -Pc -0 0.75 0.75 0 k -Pc -0 1 1 0 k -Pc -Bb -0 0 0 0 Bh -2 (Yellow & Blue Radial) -4014 4716 0 0 1 0 0 1 0 0 Bg -0 BB -Pc -0 0 0.25 0 k -Pc -0 0 0.5 0 k -Pc -0 0 0.75 0 k -Pc -0 0 1 0 k -Pc -0.25 0 0.25 0 k -Pc -0.5 0 0.5 0 k -Pc -0.75 0 0.75 0 k -Pc -1 0 1 0 k -Pc -(Yellow Stripe) 0 0 1 1 0 0 0 0 0 [1 0 0 1 0 0] p -Pc -0.25 0.125 0 0 k -Pc -0.5 0.25 0 0 k -Pc -0.75 0.375 0 0 k -Pc -1 0.5 0 0 k -Pc -0.125 0.25 0 0 k -Pc -0.25 0.5 0 0 k -Pc -0.375 0.75 0 0 k -Pc -0.5 1 0 0 k -Pc -0.375 0.375 0.75 0 k -Pc -0 0.25 0.125 0 k -Pc -0 0.5 0.25 0 k -Pc -0 0.75 0.375 0 k -Pc -0 1 0.5 0 k -Pc -0 0.125 0.25 0 k -Pc -0 0.25 0.5 0 k -Pc -0 0.375 0.75 0 k -Pc -0 0.5 1 0 k -Pc -0 0.79 0.91 0 (TCL RED) 0 x -Pc -0.125 0 0.25 0 k -Pc -0.25 0 0.5 0 k -Pc -0.375 0 0.75 0 k -Pc -0.5 0 1 0 k -Pc -0.25 0 0.125 0 k -Pc -0.5 0 0.25 0 k -Pc -0.75 0 0.375 0 k -Pc -1 0 0.5 0 k -Pc -0.5 1 0 0 k -Pc -0.25 0.125 0.125 0 k -Pc -0.5 0.25 0.25 0 k -Pc -0.75 0.375 0.375 0 k -Pc -1 0.5 0.5 0 k -Pc -0.25 0.25 0.125 0 k -Pc -0.5 0.5 0.25 0 k -Pc -0.75 0.75 0.375 0 k -Pc -1 1 0.5 0 k -Pc -0 1 0.5 0 k -Pc -0.125 0.25 0.125 0 k -Pc -0.25 0.5 0.25 0 k -Pc -0.375 0.75 0.375 0 k -Pc -0.5 1 0.5 0 k -Pc -0.125 0.25 0.25 0 k -Pc -0.25 0.5 0.5 0 k -Pc -0.375 0.75 0.75 0 k -Pc -0.5 1 1 0 k -Pc -0.75 0.75 0.375 0 k -Pc -0.125 0.125 0.25 0 k -Pc -0.25 0.25 0.5 0 k -Pc -0.375 0.375 0.75 0 k -Pc -0.5 0.5 1 0 k -Pc -0.25 0.125 0.25 0 k -Pc -0.5 0.25 0.5 0 k -Pc -0.75 0.375 0.75 0 k -Pc -1 0.5 1 0 k -Pc -0 0.79 0.91 0 (TCL RED) 0 x -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -1 0.5 0.5 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 0.25 1 0 (Orange Yellow) 0 x -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 1 0.5 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -1 0 0.5 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 0.45 1 0 (Orange) 0 x -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0.375 0.375 0.75 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 0.79 0.91 0 (TCL RED) 0 x -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -1 0.65 0 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 0 1 0 k -Pc -PB -%AI5_EndPalette -%%EndSetup -%AI5_BeginLayer -1 1 1 1 0 0 0 79 128 255 Lb -(Layer 1) Ln -0 A -u -1 Ap -0 O -0 0.79 0.91 0 (TCL RED) 0 x -800 Ar -0 J 0 j 1.25 w 4 M []0 d -%AI3_Note: -0 D -294.5207 335.3041 m -368.2181 333.001 L -363.6121 423.9713 L -370.5213 507.1689 L -336.5513 505.4417 L -320.7179 511.775 L -251.3386 508.0325 L -254.7931 425.9866 L -251.3386 331.5616 L -294.5207 335.3041 L -f -u -0 Ap -1 0.65 0 0 k -1 w -318.1366 400.9627 m -311.8663 399.2526 l -315.2864 407.5177 l -318.7064 430.6032 l -314.4314 431.4581 l -319.5616 438.5832 l -325.9526 462.6014 l -314.7164 460.2436 l -320.6412 471.0911 326.9284 478.1557 v -318.7064 484.469 l -292.2183 472.8011 299.3434 434.8954 v -293.8679 435.8542 l -299.1189 396.1175 l -294.6797 394.9775 l -299.2277 385.6974 305.5963 381.2973 v -306.1744 380.8979 297.6162 412.3629 306.7363 443.7133 c -307.5914 441.7183 l -300.3238 408.3015 307.5914 381.2973 v -307.9261 380.656 311.5598 381.0836 v -318.1366 393.4813 318.1366 400.9627 v -f -u -*u -1 g -271.4311 372.5074 m -272.7184 372.5074 L -272.7184 375.1913 L -273.2858 375.1913 273.8313 375.1913 274.3768 375.2786 c -274.3768 372.5074 L -276.2969 372.5074 L -276.2969 372.0056 L -274.3768 372.0056 L -274.3768 365.3286 L -274.3768 364.9359 274.3768 364.3467 275.2059 364.3467 c -275.7733 364.3467 276.0787 364.7395 276.4279 365.1541 c -276.777 364.9141 L -276.3624 364.0849 275.2932 363.583 274.4204 363.583 c -272.8494 363.583 272.6748 364.434 272.6748 365.4814 c -272.6748 372.0056 L -271.4311 372.0056 L -271.4311 372.5074 l -f -*U -*u -290.5617 366.5724 m -290.0598 365.0232 289.187 363.6703 286.9178 363.583 c -283.5356 363.583 282.5101 366.3978 282.5101 367.9034 c -282.5101 371.7874 285.6304 372.7256 286.8741 372.7256 c -288.2924 372.7256 290.2999 372.071 290.2999 370.3909 c -290.2999 369.8018 289.9289 369.2344 289.318 369.2344 c -288.7288 369.2344 288.2924 369.6272 288.2924 370.26 c -288.2924 371.111 288.9907 371.2201 288.9907 371.4601 c -288.9907 372.0492 287.616 372.2892 287.136 372.2892 c -285.0412 372.2892 284.4957 370.7618 284.4957 367.9034 c -284.4957 366.5942 284.823 365.5905 284.9539 365.285 c -285.2812 364.5649 285.9577 364.1067 287.0923 364.0413 c -288.3579 363.9758 289.5798 365.0013 290.1035 366.5724 C -290.5617 366.5724 l -f -*U -*u -296.6 363.8667 m -296.6 364.3686 L -298.2802 364.3686 L -298.2802 378.3989 L -296.6 378.3989 L -296.6 378.9007 L -297.5383 378.9007 L -298.3457 378.9007 299.1966 378.9444 299.9822 379.0971 c -299.9822 364.3686 L -301.6623 364.3686 L -301.6623 363.8667 L -296.6 363.8667 l -f -*U -*u -317.4527 372.5074 m -318.7401 372.5074 L -318.7401 375.1913 L -319.3074 375.1913 319.8529 375.1913 320.3984 375.2786 c -320.3984 372.5074 L -322.3186 372.5074 L -322.3186 372.0056 L -320.3984 372.0056 L -320.3984 365.3286 L -320.3984 364.9359 320.3984 364.3467 321.2276 364.3467 c -321.7949 364.3467 322.1004 364.7395 322.4495 365.1541 c -322.7986 364.9141 L -322.384 364.0849 321.3148 363.583 320.442 363.583 c -318.871 363.583 318.6964 364.434 318.6964 365.4814 c -318.6964 372.0056 L -317.4527 372.0056 L -317.4527 372.5074 l -f -*U -*u -333.7467 372.0056 m -333.7467 372.5074 L -337.3252 372.5074 L -337.3252 372.0056 L -335.9942 372.0056 L -332.983 369.3872 L -337.1288 364.3686 L -338.0453 364.3686 L -338.0453 363.8667 L -333.8995 363.8667 L -333.8995 364.3686 L -334.9905 364.3686 L -331.3465 368.798 L -335.0341 371.9401 L -335.0341 372.0056 L -333.7467 372.0056 l -f -328.4881 363.8667 m -328.4881 364.3686 L -329.6227 364.3686 L -329.6227 378.3989 L -328.4881 378.3989 L -328.4881 378.9007 L -328.8809 378.9007 L -329.6882 378.9007 330.5392 378.9444 331.3247 379.0971 c -331.3247 364.3686 L -332.6339 364.3686 L -332.6339 363.8667 L -328.4881 363.8667 l -f -*U -u -309.5341 446.5364 m -305.6878 429.3874 306.7947 401.5837 v -307.1266 393.2441 308.0387 385.5779 309.1527 378.9301 C -309.1587 378.9297 L -309.8832 373.0923 310.3679 370.9791 312.2568 363.9454 C -312.1466 359.4091 L -297.0216 407.7015 309.5341 446.5364 V -f -318.8187 461.4058 m -322.2203 463.1 327.0966 463.7165 v -332.427 453.9463 319.3087 437.2655 v -327.1346 454.735 325.2889 460.2079 v -323.225 461.4903 318.8187 461.4058 v -f -317.2065 432.0795 m -320.2613 431.3723 321.7279 432.5601 v -318.8383 421.2839 319.5958 415.0813 v -320.3533 408.8787 314.8881 404.9079 y -319.5435 410.7982 318.0802 415.5959 v -317.0657 418.9214 318.2006 427.4326 319.4809 430.1349 c -318.2853 430.3025 317.2065 432.0795 v -f -314.1861 402.3703 m -319.2343 402.9744 319.7646 405.5244 v -320.3824 390.2725 313.3689 383.9873 v -318.7204 392.3347 317.8807 400.9697 v -314.1861 402.3703 l -f -299.9864 396.0219 m -298.3586 394.1986 293.4739 398.2203 v -295.0301 387.9694 304.6978 383.2767 v -298.0444 388.2897 296.2519 393.7045 v -298.6029 394.3966 299.9864 396.0219 v -f -298.4281 399.9096 m -291.8229 416.6749 293.2382 439.3286 v -294.7808 435.2261 299.738 433.7875 v -297.4026 433.3101 296.0372 433.517 v -292.5816 423.9535 298.4281 399.9096 v -f -326.1736 477.812 m -323.6983 496.0028 308.2122 477.6066 v -295.8813 462.9582 297.3508 450.5217 298.1072 443.5831 c -298.3007 441.8079 295.8131 462.1138 309.3231 475.4768 c -322.8328 488.8398 325.8846 478.5879 326.1736 477.812 c -f -U -0 0 1 0 k -303.3623 493.3274 m -291.211 496.7978 287.3437 456.5222 v -284.3599 468.9535 292.0777 486.5353 v -299.7955 504.1172 303.3623 493.3274 y -f -288.2873 496.2718 m -282.0897 486.9502 283.4958 477.0213 v -278.7953 495.712 288.2873 496.2718 v -f -333.8987 470.1328 m -341.2276 472.8361 330.7334 445.5571 v -336.1654 453.5292 339.5844 466.0531 v -341.7789 474.0903 333.8987 470.1328 y -f -345.752 472.2583 m -350.9334 467.5681 347.2615 461.3636 v -356.4779 471.0481 345.752 472.2583 v -f -U -*u -273.1765 354.3318 m -273.1765 353.7507 273.1305 353.2908 272.5159 353.2908 c -271.8846 353.2908 271.8554 353.7674 271.8554 354.3318 c -271.8554 356.485 L -272.148 356.485 L -272.148 354.3486 L -272.148 353.8259 272.1773 353.5751 272.5159 353.5751 c -272.8504 353.5751 272.8839 353.8259 272.8839 354.3486 c -272.8839 356.485 L -273.1765 356.485 L -273.1765 354.3318 l -f -*U -*u -277.1612 356.485 m -276.9062 356.485 L -276.9062 354.3862 l -276.9062 354.2482 276.9271 354.1061 276.9355 353.9681 C -276.9229 353.9681 l -276.8937 354.0768 276.8644 354.1855 276.8268 354.2942 C -276.1035 356.485 L -275.8484 356.485 L -275.8484 353.3326 L -276.1035 353.3326 L -276.1035 355.2474 l -276.1035 355.4523 276.0826 355.653 276.07 355.8579 C -276.0867 355.8579 l -276.1244 355.7241 276.1495 355.5819 276.1954 355.4523 C -276.9062 353.3326 L -277.1612 353.3326 l -277.1612 356.485 L -f -*U -*u -280.1421 353.3326 m -279.8494 353.3326 L -279.8494 356.485 L -280.1421 356.485 L -280.1421 353.3326 l -f -*U -*u -283.5141 353.3326 m -283.2549 353.3326 L -282.6194 356.485 L -282.9205 356.485 L -283.3344 354.1897 L -283.3511 354.1102 283.3678 353.9054 283.3845 353.7632 c -283.4013 353.7632 L -283.4138 353.9054 283.4305 354.1144 283.4431 354.1897 c -283.8528 356.485 L -284.1496 356.485 L -283.5141 353.3326 l -f -*U -*u -287.6238 356.2174 m -286.9256 356.2174 L -286.9256 355.1053 L -287.6029 355.1053 L -287.6029 354.8377 L -286.9256 354.8377 L -286.9256 353.6002 L -287.6238 353.6002 L -287.6238 353.3326 L -286.6329 353.3326 L -286.6329 356.485 L -287.6238 356.485 L -287.6238 356.2174 l -f -*U -*u -290.2278 353.3326 m -290.2278 356.485 L -290.5414 356.485 L -290.9804 356.485 291.4026 356.4515 291.4026 355.6823 c -291.4026 355.2809 291.3148 354.8879 290.8089 354.8712 c -291.5072 353.3326 L -291.1978 353.3326 L -290.5288 354.8753 L -290.5205 354.8753 L -290.5205 353.3326 L -290.2278 353.3326 l -f -290.5205 355.1137 m -290.625 355.1137 L -291.0347 355.1137 291.1016 355.2558 291.1016 355.6697 c -291.1016 356.1672 290.9511 356.2174 290.579 356.2174 c -290.5205 356.2174 L -290.5205 355.1137 l -f -*U -*u -295.0981 355.9875 m -294.9727 356.1296 294.8347 356.2425 294.634 356.2425 c -294.3414 356.2425 294.1783 356 294.1783 355.7324 c -294.1783 355.3645 294.4459 355.1931 294.7176 355.0091 c -294.9852 354.821 295.2528 354.6203 295.2528 354.1855 c -295.2528 353.7256 294.9559 353.2908 294.4626 353.2908 c -294.287 353.2908 294.1072 353.341 293.9651 353.4497 c -293.9651 353.8301 L -294.0989 353.688 294.2745 353.5751 294.4751 353.5751 c -294.7845 353.5751 294.9559 353.8468 294.9518 354.1311 c -294.9559 354.4991 294.6842 354.6621 294.4166 354.8503 c -294.149 355.0342 293.8773 355.2391 293.8773 355.6906 c -293.8773 356.1129 294.1365 356.5268 294.6006 356.5268 c -294.7887 356.5268 294.9476 356.4641 295.0981 356.3596 C -295.0981 355.9875 l -f -*U -*u -299.0865 353.3326 m -298.773 353.3326 L -298.6559 353.9806 L -297.9869 353.9806 L -297.8741 353.3326 L -297.5605 353.3326 L -298.1793 356.485 L -298.4552 356.485 L -299.0865 353.3326 l -f -298.6099 354.2357 m -298.4009 355.444 L -298.3632 355.6572 298.3465 355.8746 298.3214 356.0878 c -298.3047 356.0878 L -298.2754 355.8746 298.2545 355.6572 298.2211 355.444 c -298.0371 354.2357 L -298.6099 354.2357 l -f -*U -*u -301.8124 353.6002 m -302.4981 353.6002 L -302.4981 353.3326 L -301.5198 353.3326 L -301.5198 356.485 L -301.8124 356.485 L -301.8124 353.6002 l -f -*U -*u -309.0754 355.9875 m -308.95 356.1296 308.812 356.2425 308.6114 356.2425 c -308.3187 356.2425 308.1556 356 308.1556 355.7324 c -308.1556 355.3645 308.4232 355.1931 308.695 355.0091 c -308.9626 354.821 309.2301 354.6203 309.2301 354.1855 c -309.2301 353.7256 308.9333 353.2908 308.4399 353.2908 c -308.2643 353.2908 308.0846 353.341 307.9424 353.4497 c -307.9424 353.8301 L -308.0762 353.688 308.2518 353.5751 308.4525 353.5751 c -308.7619 353.5751 308.9333 353.8468 308.9291 354.1311 c -308.9333 354.4991 308.6615 354.6621 308.3939 354.8503 c -308.1264 355.0342 307.8546 355.2391 307.8546 355.6906 c -307.8546 356.1129 308.1138 356.5268 308.5779 356.5268 c -308.766 356.5268 308.9249 356.4641 309.0754 356.3596 C -309.0754 355.9875 l -f -*U -*u -312.9468 353.7172 m -312.8339 353.6378 312.7001 353.5751 312.558 353.5751 c -311.9977 353.5751 311.9977 354.5492 311.9977 354.9172 c -311.9977 355.5025 312.0688 356.2425 312.5789 356.2425 c -312.7252 356.2425 312.8297 356.184 312.9468 356.1045 C -312.9468 356.4265 l -312.8506 356.4975 312.6918 356.5268 312.5747 356.5268 c -311.7134 356.5268 311.6967 355.306 311.6967 354.7959 c -311.6967 354.2566 311.8054 353.2908 312.5454 353.2908 c -312.6834 353.2908 312.8381 353.3451 312.9468 353.4204 c -312.9468 353.7172 L -f -*U -*u -315.5053 353.3326 m -315.5053 356.485 L -315.8188 356.485 L -316.2578 356.485 316.6801 356.4515 316.6801 355.6823 c -316.6801 355.2809 316.5923 354.8879 316.0864 354.8712 c -316.7846 353.3326 L -316.4752 353.3326 L -315.8063 354.8753 L -315.7979 354.8753 L -315.7979 353.3326 L -315.5053 353.3326 l -f -315.7979 355.1137 m -315.9025 355.1137 L -316.3122 355.1137 316.3791 355.2558 316.3791 355.6697 c -316.3791 356.1672 316.2286 356.2174 315.8565 356.2174 c -315.7979 356.2174 L -315.7979 355.1137 l -f -*U -*u -319.5728 353.3326 m -319.2802 353.3326 L -319.2802 356.485 L -319.5728 356.485 L -319.5728 353.3326 l -f -*U -*u -322.2551 353.3326 m -322.2551 356.485 L -322.5812 356.485 L -323.0327 356.485 323.4341 356.4432 323.4341 355.6655 c -323.4341 355.0551 323.2209 354.8419 322.623 354.8419 c -322.5477 354.8419 L -322.5477 353.3326 L -322.2551 353.3326 l -f -322.5477 355.1095 m -322.6606 355.1095 L -323.0703 355.1095 323.1205 355.26 323.1331 355.6655 c -323.1331 356.1004 323.016 356.2174 322.6063 356.2174 c -322.5477 356.2174 L -322.5477 355.1095 l -f -*U -*u -326.9539 356.485 m -325.7164 356.485 L -325.7164 356.2174 L -326.1888 356.2174 L -326.1888 353.3326 L -326.4815 353.3326 L -326.4815 356.2174 L -326.9539 356.2174 l -326.9539 356.485 L -f -*U -*u -329.7077 353.3326 m -329.4151 353.3326 L -329.4151 356.485 L -329.7077 356.485 L -329.7077 353.3326 l -f -*U -*u -333.7028 353.3326 m -333.4477 353.3326 L -332.737 355.4523 L -332.691 355.5819 332.6659 355.7241 332.6283 355.8579 c -332.6116 355.8579 L -332.6241 355.653 332.645 355.4523 332.645 355.2474 c -332.645 353.3326 L -332.39 353.3326 L -332.39 356.485 L -332.645 356.485 L -333.3683 354.2942 L -333.4059 354.1855 333.4352 354.0768 333.4645 353.9681 c -333.477 353.9681 L -333.4686 354.1061 333.4477 354.2482 333.4477 354.3862 c -333.4477 356.485 L -333.7028 356.485 L -333.7028 353.3326 l -f -*U -*u -336.9846 354.9966 m -337.7037 354.9966 L -337.7037 354.4154 L -337.7037 353.9179 337.6787 353.2908 337.0264 353.2908 c -336.3617 353.2908 336.299 353.989 336.299 354.9841 c -336.299 355.7283 336.3868 356.5268 337.0557 356.5268 c -337.432 356.5268 337.6201 356.276 337.6996 355.9331 c -337.4111 355.8202 L -337.3776 356.0084 337.2982 356.2425 337.0682 356.2425 c -336.6334 356.2383 336.6 355.5652 336.6 355.0091 c -336.6 353.8427 336.7463 353.5751 337.0515 353.5751 c -337.3818 353.5751 337.4111 353.8176 337.4111 354.4907 c -337.4111 354.729 L -336.9846 354.729 L -336.9846 354.9966 l -f -*U -U -U -337.6667 -3924 m -(N) * -337.6667 4716 m -(N) * -LB -%AI5_EndLayer-- -%%PageTrailer -gsave annotatepage grestore showpage -%%Trailer -Adobe_IllustratorA_AI5 /terminate get exec -Adobe_level2_AI5 /terminate get exec -%%EOF diff --git a/tcl/library/images/logo100.gif b/tcl/library/images/logo100.gif Binary files differdeleted file mode 100644 index 4603d4ff417..00000000000 --- a/tcl/library/images/logo100.gif +++ /dev/null diff --git a/tcl/library/images/logo64.gif b/tcl/library/images/logo64.gif Binary files differdeleted file mode 100644 index 749d55bdd21..00000000000 --- a/tcl/library/images/logo64.gif +++ /dev/null diff --git a/tcl/library/images/logoLarge.gif b/tcl/library/images/logoLarge.gif Binary files differdeleted file mode 100644 index bd7530a9e18..00000000000 --- a/tcl/library/images/logoLarge.gif +++ /dev/null diff --git a/tcl/library/images/logoMed.gif b/tcl/library/images/logoMed.gif Binary files differdeleted file mode 100644 index d41801a41f4..00000000000 --- a/tcl/library/images/logoMed.gif +++ /dev/null diff --git a/tcl/library/images/pwrdLogo.eps b/tcl/library/images/pwrdLogo.eps deleted file mode 100644 index e11d9e96451..00000000000 --- a/tcl/library/images/pwrdLogo.eps +++ /dev/null @@ -1,1897 +0,0 @@ -%!PS-Adobe-3.0 EPSF-3.0 -%%Creator: Adobe Illustrator(TM) 5.5 -%%For: (Bud Northern) (Mark Anderson Design) -%%Title: (TCL PWRD LOGO.ILLUS) -%%CreationDate: (8/1/96) (4:59 PM) -%%BoundingBox: 242 302 377 513 -%%HiResBoundingBox: 242.0523 302.5199 376.3322 512.5323 -%%DocumentProcessColors: Cyan Magenta Yellow -%%DocumentSuppliedResources: procset Adobe_level2_AI5 1.0 0 -%%+ procset Adobe_IllustratorA_AI5 1.0 0 -%AI5_FileFormat 1.2 -%AI3_ColorUsage: Color -%%CMYKCustomColor: 0 0.45 1 0 (Orange) -%%+ 0 0.25 1 0 (Orange Yellow) -%%+ 0 0.79 0.91 0 (PANTONE Warm Red CV) -%%+ 0 0.79 0.91 0 (TCL RED) -%AI3_TemplateBox: 306 396 306 396 -%AI3_TileBox: 12 12 600 780 -%AI3_DocumentPreview: Macintosh_ColorPic -%AI5_ArtSize: 612 792 -%AI5_RulerUnits: 0 -%AI5_ArtFlags: 1 0 0 1 0 0 1 1 0 -%AI5_TargetResolution: 800 -%AI5_NumLayers: 1 -%AI5_OpenToView: 102 564 2 938 673 18 1 1 2 40 -%AI5_OpenViewLayers: 7 -%%EndComments -%%BeginProlog -%%BeginResource: procset Adobe_level2_AI5 1.0 0 -%%Title: (Adobe Illustrator (R) Version 5.0 Level 2 Emulation) -%%Version: 1.0 -%%CreationDate: (04/10/93) () -%%Copyright: ((C) 1987-1993 Adobe Systems Incorporated All Rights Reserved) -userdict /Adobe_level2_AI5 21 dict dup begin - put - /packedarray where not - { - userdict begin - /packedarray - { - array astore readonly - } bind def - /setpacking /pop load def - /currentpacking false def - end - 0 - } if - pop - userdict /defaultpacking currentpacking put true setpacking - /initialize - { - Adobe_level2_AI5 begin - } bind def - /terminate - { - currentdict Adobe_level2_AI5 eq - { - end - } if - } bind def - mark - /setcustomcolor where not - { - /findcmykcustomcolor - { - 5 packedarray - } bind def - /setcustomcolor - { - exch aload pop pop - 4 - { - 4 index mul 4 1 roll - } repeat - 5 -1 roll pop - setcmykcolor - } - def - } if - - /gt38? mark {version cvx exec} stopped {cleartomark true} {38 gt exch pop} ifelse def - userdict /deviceDPI 72 0 matrix defaultmatrix dtransform dup mul exch dup mul add sqrt put - userdict /level2? - systemdict /languagelevel known dup - { - pop systemdict /languagelevel get 2 ge - } if - put - level2? not - { - /setcmykcolor where not - { - /setcmykcolor - { - exch .11 mul add exch .59 mul add exch .3 mul add - 1 exch sub setgray - } def - } if - /currentcmykcolor where not - { - /currentcmykcolor - { - 0 0 0 1 currentgray sub - } def - } if - /setoverprint where not - { - /setoverprint /pop load def - } if - /selectfont where not - { - /selectfont - { - exch findfont exch - dup type /arraytype eq - { - makefont - } - { - scalefont - } ifelse - setfont - } bind def - } if - /cshow where not - { - /cshow - { - [ - 0 0 5 -1 roll aload pop - ] cvx bind forall - } bind def - } if - } if - cleartomark - /anyColor? - { - add add add 0 ne - } bind def - /testColor - { - gsave - setcmykcolor currentcmykcolor - grestore - } bind def - /testCMYKColorThrough - { - testColor anyColor? - } bind def - userdict /composite? - level2? - { - gsave 1 1 1 1 setcmykcolor currentcmykcolor grestore - add add add 4 eq - } - { - 1 0 0 0 testCMYKColorThrough - 0 1 0 0 testCMYKColorThrough - 0 0 1 0 testCMYKColorThrough - 0 0 0 1 testCMYKColorThrough - and and and - } ifelse - put - composite? not - { - userdict begin - gsave - /cyan? 1 0 0 0 testCMYKColorThrough def - /magenta? 0 1 0 0 testCMYKColorThrough def - /yellow? 0 0 1 0 testCMYKColorThrough def - /black? 0 0 0 1 testCMYKColorThrough def - grestore - /isCMYKSep? cyan? magenta? yellow? black? or or or def - /customColor? isCMYKSep? not def - end - } if - end defaultpacking setpacking -%%EndResource -%%BeginResource: procset Adobe_IllustratorA_AI5 1.1 0 -%%Title: (Adobe Illustrator (R) Version 5.0 Abbreviated Prolog) -%%Version: 1.1 -%%CreationDate: (3/7/1994) () -%%Copyright: ((C) 1987-1994 Adobe Systems Incorporated All Rights Reserved) -currentpacking true setpacking -userdict /Adobe_IllustratorA_AI5_vars 70 dict dup begin -put -/_lp /none def -/_pf -{ -} def -/_ps -{ -} def -/_psf -{ -} def -/_pss -{ -} def -/_pjsf -{ -} def -/_pjss -{ -} def -/_pola 0 def -/_doClip 0 def -/cf currentflat def -/_tm matrix def -/_renderStart -[ -/e0 /r0 /a0 /o0 /e1 /r1 /a1 /i0 -] def -/_renderEnd -[ -null null null null /i1 /i1 /i1 /i1 -] def -/_render -1 def -/_rise 0 def -/_ax 0 def -/_ay 0 def -/_cx 0 def -/_cy 0 def -/_leading -[ -0 0 -] def -/_ctm matrix def -/_mtx matrix def -/_sp 16#020 def -/_hyphen (-) def -/_fScl 0 def -/_cnt 0 def -/_hs 1 def -/_nativeEncoding 0 def -/_useNativeEncoding 0 def -/_tempEncode 0 def -/_pntr 0 def -/_tDict 2 dict def -/_wv 0 def -/Tx -{ -} def -/Tj -{ -} def -/CRender -{ -} def -/_AI3_savepage -{ -} def -/_gf null def -/_cf 4 array def -/_if null def -/_of false def -/_fc -{ -} def -/_gs null def -/_cs 4 array def -/_is null def -/_os false def -/_sc -{ -} def -/discardSave null def -/buffer 256 string def -/beginString null def -/endString null def -/endStringLength null def -/layerCnt 1 def -/layerCount 1 def -/perCent (%) 0 get def -/perCentSeen? false def -/newBuff null def -/newBuffButFirst null def -/newBuffLast null def -/clipForward? false def -end -userdict /Adobe_IllustratorA_AI5 74 dict dup begin -put -/initialize -{ - Adobe_IllustratorA_AI5 dup begin - Adobe_IllustratorA_AI5_vars begin - discardDict - { - bind pop pop - } forall - dup /nc get begin - { - dup xcheck 1 index type /operatortype ne and - { - bind - } if - pop pop - } forall - end - newpath -} def -/terminate -{ - end - end -} def -/_ -null def -/ddef -{ - Adobe_IllustratorA_AI5_vars 3 1 roll put -} def -/xput -{ - dup load dup length exch maxlength eq - { - dup dup load dup - length 2 mul dict copy def - } if - load begin - def - end -} def -/npop -{ - { - pop - } repeat -} def -/sw -{ - dup length exch stringwidth - exch 5 -1 roll 3 index mul add - 4 1 roll 3 1 roll mul add -} def -/swj -{ - dup 4 1 roll - dup length exch stringwidth - exch 5 -1 roll 3 index mul add - 4 1 roll 3 1 roll mul add - 6 2 roll /_cnt 0 ddef - { - 1 index eq - { - /_cnt _cnt 1 add ddef - } if - } forall - pop - exch _cnt mul exch _cnt mul 2 index add 4 1 roll 2 index add 4 1 roll pop pop -} def -/ss -{ - 4 1 roll - { - 2 npop - (0) exch 2 copy 0 exch put pop - gsave - false charpath currentpoint - 4 index setmatrix - stroke - grestore - moveto - 2 copy rmoveto - } exch cshow - 3 npop -} def -/jss -{ - 4 1 roll - { - 2 npop - (0) exch 2 copy 0 exch put - gsave - _sp eq - { - exch 6 index 6 index 6 index 5 -1 roll widthshow - currentpoint - } - { - false charpath currentpoint - 4 index setmatrix stroke - } ifelse - grestore - moveto - 2 copy rmoveto - } exch cshow - 6 npop -} def -/sp -{ - { - 2 npop (0) exch - 2 copy 0 exch put pop - false charpath - 2 copy rmoveto - } exch cshow - 2 npop -} def -/jsp -{ - { - 2 npop - (0) exch 2 copy 0 exch put - _sp eq - { - exch 5 index 5 index 5 index 5 -1 roll widthshow - } - { - false charpath - } ifelse - 2 copy rmoveto - } exch cshow - 5 npop -} def -/pl -{ - transform - 0.25 sub round 0.25 add exch - 0.25 sub round 0.25 add exch - itransform -} def -/setstrokeadjust where -{ - pop true setstrokeadjust - /c - { - curveto - } def - /C - /c load def - /v - { - currentpoint 6 2 roll curveto - } def - /V - /v load def - /y - { - 2 copy curveto - } def - /Y - /y load def - /l - { - lineto - } def - /L - /l load def - /m - { - moveto - } def -} -{ - /c - { - pl curveto - } def - /C - /c load def - /v - { - currentpoint 6 2 roll pl curveto - } def - /V - /v load def - /y - { - pl 2 copy curveto - } def - /Y - /y load def - /l - { - pl lineto - } def - /L - /l load def - /m - { - pl moveto - } def -} ifelse -/d -{ - setdash -} def -/cf -{ -} def -/i -{ - dup 0 eq - { - pop cf - } if - setflat -} def -/j -{ - setlinejoin -} def -/J -{ - setlinecap -} def -/M -{ - setmiterlimit -} def -/w -{ - setlinewidth -} def -/H -{ -} def -/h -{ - closepath -} def -/N -{ - _pola 0 eq - { - _doClip 1 eq - { - clip /_doClip 0 ddef - } if - newpath - } - { - /CRender - { - N - } ddef - } ifelse -} def -/n -{ - N -} def -/F -{ - _pola 0 eq - { - _doClip 1 eq - { - gsave _pf grestore clip newpath /_lp /none ddef _fc - /_doClip 0 ddef - } - { - _pf - } ifelse - } - { - /CRender - { - F - } ddef - } ifelse -} def -/f -{ - closepath - F -} def -/S -{ - _pola 0 eq - { - _doClip 1 eq - { - gsave _ps grestore clip newpath /_lp /none ddef _sc - /_doClip 0 ddef - } - { - _ps - } ifelse - } - { - /CRender - { - S - } ddef - } ifelse -} def -/s -{ - closepath - S -} def -/B -{ - _pola 0 eq - { - _doClip 1 eq - gsave F grestore - { - gsave S grestore clip newpath /_lp /none ddef _sc - /_doClip 0 ddef - } - { - S - } ifelse - } - { - /CRender - { - B - } ddef - } ifelse -} def -/b -{ - closepath - B -} def -/W -{ - /_doClip 1 ddef -} def -/* -{ - count 0 ne - { - dup type /stringtype eq - { - pop - } if - } if - newpath -} def -/u -{ -} def -/U -{ -} def -/q -{ - _pola 0 eq - { - gsave - } if -} def -/Q -{ - _pola 0 eq - { - grestore - } if -} def -/*u -{ - _pola 1 add /_pola exch ddef -} def -/*U -{ - _pola 1 sub /_pola exch ddef - _pola 0 eq - { - CRender - } if -} def -/D -{ - pop -} def -/*w -{ -} def -/*W -{ -} def -/` -{ - /_i save ddef - clipForward? - { - nulldevice - } if - 6 1 roll 4 npop - concat pop - userdict begin - /showpage - { - } def - 0 setgray - 0 setlinecap - 1 setlinewidth - 0 setlinejoin - 10 setmiterlimit - [] 0 setdash - /setstrokeadjust where {pop false setstrokeadjust} if - newpath - 0 setgray - false setoverprint -} def -/~ -{ - end - _i restore -} def -/O -{ - 0 ne - /_of exch ddef - /_lp /none ddef -} def -/R -{ - 0 ne - /_os exch ddef - /_lp /none ddef -} def -/g -{ - /_gf exch ddef - /_fc - { - _lp /fill ne - { - _of setoverprint - _gf setgray - /_lp /fill ddef - } if - } ddef - /_pf - { - _fc - fill - } ddef - /_psf - { - _fc - ashow - } ddef - /_pjsf - { - _fc - awidthshow - } ddef - /_lp /none ddef -} def -/G -{ - /_gs exch ddef - /_sc - { - _lp /stroke ne - { - _os setoverprint - _gs setgray - /_lp /stroke ddef - } if - } ddef - /_ps - { - _sc - stroke - } ddef - /_pss - { - _sc - ss - } ddef - /_pjss - { - _sc - jss - } ddef - /_lp /none ddef -} def -/k -{ - _cf astore pop - /_fc - { - _lp /fill ne - { - _of setoverprint - _cf aload pop setcmykcolor - /_lp /fill ddef - } if - } ddef - /_pf - { - _fc - fill - } ddef - /_psf - { - _fc - ashow - } ddef - /_pjsf - { - _fc - awidthshow - } ddef - /_lp /none ddef -} def -/K -{ - _cs astore pop - /_sc - { - _lp /stroke ne - { - _os setoverprint - _cs aload pop setcmykcolor - /_lp /stroke ddef - } if - } ddef - /_ps - { - _sc - stroke - } ddef - /_pss - { - _sc - ss - } ddef - /_pjss - { - _sc - jss - } ddef - /_lp /none ddef -} def -/x -{ - /_gf exch ddef - findcmykcustomcolor - /_if exch ddef - /_fc - { - _lp /fill ne - { - _of setoverprint - _if _gf 1 exch sub setcustomcolor - /_lp /fill ddef - } if - } ddef - /_pf - { - _fc - fill - } ddef - /_psf - { - _fc - ashow - } ddef - /_pjsf - { - _fc - awidthshow - } ddef - /_lp /none ddef -} def -/X -{ - /_gs exch ddef - findcmykcustomcolor - /_is exch ddef - /_sc - { - _lp /stroke ne - { - _os setoverprint - _is _gs 1 exch sub setcustomcolor - /_lp /stroke ddef - } if - } ddef - /_ps - { - _sc - stroke - } ddef - /_pss - { - _sc - ss - } ddef - /_pjss - { - _sc - jss - } ddef - /_lp /none ddef -} def -/A -{ - pop -} def -/annotatepage -{ -userdict /annotatepage 2 copy known {get exec} {pop pop} ifelse -} def -/discard -{ - save /discardSave exch store - discardDict begin - /endString exch store - gt38? - { - 2 add - } if - load - stopped - pop - end - discardSave restore -} bind def -userdict /discardDict 7 dict dup begin -put -/pre38Initialize -{ - /endStringLength endString length store - /newBuff buffer 0 endStringLength getinterval store - /newBuffButFirst newBuff 1 endStringLength 1 sub getinterval store - /newBuffLast newBuff endStringLength 1 sub 1 getinterval store -} def -/shiftBuffer -{ - newBuff 0 newBuffButFirst putinterval - newBuffLast 0 - currentfile read not - { - stop - } if - put -} def -0 -{ - pre38Initialize - mark - currentfile newBuff readstring exch pop - { - { - newBuff endString eq - { - cleartomark stop - } if - shiftBuffer - } loop - } - { - stop - } ifelse -} def -1 -{ - pre38Initialize - /beginString exch store - mark - currentfile newBuff readstring exch pop - { - { - newBuff beginString eq - { - /layerCount dup load 1 add store - } - { - newBuff endString eq - { - /layerCount dup load 1 sub store - layerCount 0 eq - { - cleartomark stop - } if - } if - } ifelse - shiftBuffer - } loop - } - { - stop - } ifelse -} def -2 -{ - mark - { - currentfile buffer readline not - { - stop - } if - endString eq - { - cleartomark stop - } if - } loop -} def -3 -{ - /beginString exch store - /layerCnt 1 store - mark - { - currentfile buffer readline not - { - stop - } if - dup beginString eq - { - pop /layerCnt dup load 1 add store - } - { - endString eq - { - layerCnt 1 eq - { - cleartomark stop - } - { - /layerCnt dup load 1 sub store - } ifelse - } if - } ifelse - } loop -} def -end -userdict /clipRenderOff 15 dict dup begin -put -{ - /n /N /s /S /f /F /b /B -} -{ - { - _doClip 1 eq - { - /_doClip 0 ddef clip - } if - newpath - } def -} forall -/Tr /pop load def -/Bb {} def -/BB /pop load def -/Bg {12 npop} def -/Bm {6 npop} def -/Bc /Bm load def -/Bh {4 npop} def -end -/Lb -{ - 4 npop - 6 1 roll - pop - 4 1 roll - pop pop pop - 0 eq - { - 0 eq - { - (%AI5_BeginLayer) 1 (%AI5_EndLayer--) discard - } - { - /clipForward? true def - - /Tx /pop load def - /Tj /pop load def - currentdict end clipRenderOff begin begin - } ifelse - } - { - 0 eq - { - save /discardSave exch store - } if - } ifelse -} bind def -/LB -{ - discardSave dup null ne - { - restore - } - { - pop - clipForward? - { - currentdict - end - end - begin - - /clipForward? false ddef - } if - } ifelse -} bind def -/Pb -{ - pop pop - 0 (%AI5_EndPalette) discard -} bind def -/Np -{ - 0 (%AI5_End_NonPrinting--) discard -} bind def -/Ln /pop load def -/Ap -/pop load def -/Ar -{ - 72 exch div - 0 dtransform dup mul exch dup mul add sqrt - dup 1 lt - { - pop 1 - } if - setflat -} def -/Mb -{ - q -} def -/Md -{ -} def -/MB -{ - Q -} def -/nc 3 dict def -nc begin -/setgray -{ - pop -} bind def -/setcmykcolor -{ - 4 npop -} bind def -/setcustomcolor -{ - 2 npop -} bind def -currentdict readonly pop -end -currentdict readonly pop -end -setpacking -%%EndResource -%%EndProlog -%%BeginSetup -Adobe_level2_AI5 /initialize get exec -Adobe_IllustratorA_AI5 /initialize get exec -%AI5_Begin_NonPrinting -Np -%AI3_BeginPattern: (Yellow Stripe) -(Yellow Stripe) 8.4499 4.6 80.4499 76.6 [ -%AI3_Tile -(0 O 0 R 0 0.4 1 0 k 0 0.4 1 0 K) @ -( -800 Ar -0 J 0 j 3.6 w 4 M []0 d -%AI3_Note: -0 D -8.1999 8.1999 m -80.6999 8.1999 L -S -8.1999 22.6 m -80.6999 22.6 L -S -8.1999 37.0001 m -80.6999 37.0001 L -S -8.1999 51.3999 m -80.6999 51.3999 L -S -8.1999 65.8 m -80.6999 65.8 L -S -8.1999 15.3999 m -80.6999 15.3999 L -S -8.1999 29.8 m -80.6999 29.8 L -S -8.1999 44.1999 m -80.6999 44.1999 L -S -8.1999 58.6 m -80.6999 58.6 L -S -8.1999 73.0001 m -80.6999 73.0001 L -S -) & -] E -%AI3_EndPattern -%AI5_End_NonPrinting-- -%AI5_Begin_NonPrinting -Np -3 Bn -%AI5_BeginGradient: (Black & White) -(Black & White) 0 2 Bd -[ -< -FFFEFDFCFBFAF9F8F7F6F5F4F3F2F1F0EFEEEDECEBEAE9E8E7E6E5E4E3E2E1E0DFDEDDDCDBDAD9D8 -D7D6D5D4D3D2D1D0CFCECDCCCBCAC9C8C7C6C5C4C3C2C1C0BFBEBDBCBBBAB9B8B7B6B5B4B3B2B1B0 -AFAEADACABAAA9A8A7A6A5A4A3A2A1A09F9E9D9C9B9A999897969594939291908F8E8D8C8B8A8988 -87868584838281807F7E7D7C7B7A797877767574737271706F6E6D6C6B6A69686766656463626160 -5F5E5D5C5B5A595857565554535251504F4E4D4C4B4A494847464544434241403F3E3D3C3B3A3938 -37363534333231302F2E2D2C2B2A292827262524232221201F1E1D1C1B1A19181716151413121110 -0F0E0D0C0B0A09080706050403020100 -> -0 %_Br -[ -0 0 50 100 %_Bs -1 0 50 0 %_Bs -BD -%AI5_EndGradient -%AI5_BeginGradient: (Red & Yellow) -(Red & Yellow) 0 2 Bd -[ -0 -< -000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F2021222324252627 -28292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F -505152535455565758595A5B5C5D5E5F606162636465666768696A6B6C6D6E6F7071727374757677 -78797A7B7C7D7E7F808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F -A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0C1C2C3C4C5C6C7 -C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF -F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF -> -< -FFFFFEFEFDFDFDFCFCFBFBFBFAFAF9F9F9F8F8F7F7F7F6F6F5F5F5F4F4F3F3F3F2F2F1F1F1F0F0EF -EFEFEEEEEDEDEDECECEBEBEBEAEAE9E9E9E8E8E7E7E7E6E6E5E5E5E4E4E3E3E3E2E2E1E1E1E0E0DF -DFDFDEDEDDDDDDDCDCDBDBDBDADAD9D9D9D8D8D7D7D7D6D6D5D5D5D4D4D3D3D3D2D2D1D1D1D0D0CF -CFCFCECECDCDCDCCCCCBCBCBCACAC9C9C9C8C8C7C7C7C6C6C5C5C5C4C4C3C3C3C2C2C1C1C1C0C0BF -BFBFBEBEBDBDBDBCBCBBBBBBBABAB9B9B9B8B8B7B7B7B6B6B5B5B5B4B4B3B3B3B2B2B1B1B1B0B0AF -AFAFAEAEADADADACACABABABAAAAA9A9A9A8A8A7A7A7A6A6A5A5A5A4A4A3A3A3A2A2A1A1A1A0A09F -9F9F9E9E9D9D9D9C9C9B9B9B9A9A9999 -> -0 -1 %_Br -[ -0 1 0.6 0 1 50 100 %_Bs -0 0 1 0 1 50 0 %_Bs -BD -%AI5_EndGradient -%AI5_BeginGradient: (Yellow & Blue Radial) -(Yellow & Blue Radial) 1 2 Bd -[ -< -000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F2021222324252627 -28292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F -505152535455565758595A5B5C5D5E5F606162636465666768696A6B6C6D6E6F7071727374757677 -78797A7B7C7D7E7F808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F -A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0C1C2C3C4C5C6C7 -C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF -F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF -> -< -1415161718191A1B1C1D1E1F1F202122232425262728292A2A2B2C2D2E2F30313233343536363738 -393A3B3C3D3E3F40414142434445464748494A4B4C4D4D4E4F50515253545556575858595A5B5C5D -5E5F60616263646465666768696A6B6C6D6E6F6F707172737475767778797A7B7B7C7D7E7F808182 -83848586868788898A8B8C8D8E8F90919292939495969798999A9B9C9D9D9E9FA0A1A2A3A4A5A6A7 -A8A9A9AAABACADAEAFB0B1B2B3B4B4B5B6B7B8B9BABBBCBDBEBFC0C0C1C2C3C4C5C6C7C8C9CACBCB -CCCDCECFD0D1D2D3D4D5D6D7D7D8D9DADBDCDDDEDFE0E1E2E2E3E4E5E6E7E8E9EAEBECEDEEEEEFF0 -F1F2F3F4F5F6F7F8F9F9FAFBFCFDFEFF -> -< -ABAAAAA9A8A7A7A6A5A5A4A3A3A2A1A1A09F9F9E9D9D9C9B9B9A9999989797969595949393929191 -908F8F8E8D8D8C8B8B8A8989888787868585848383828181807F7F7E7D7D7C7B7B7A797978777776 -7575747373727171706F6F6E6D6D6C6B6B6A6969686767666565646362626160605F5E5E5D5C5C5B -5A5A5958585756565554545352525150504F4E4E4D4C4C4B4A4A4948484746464544444342424140 -403F3E3E3D3C3C3B3A3A3938383736363534343332323130302F2E2E2D2C2C2B2A2A292828272626 -25242423222121201F1F1E1D1D1C1B1B1A1919181717161515141313121111100F0F0E0D0D0C0B0B -0A090908070706050504030302010100 -> -0 -1 %_Br -[ -0 0.08 0.67 0 1 50 14 %_Bs -1 1 0 0 1 50 100 %_Bs -BD -%AI5_EndGradient -%AI5_End_NonPrinting-- -%AI5_BeginPalette -144 161 Pb -Pn -Pc -1 g -Pc -0 g -Pc -0 0 0 0 k -Pc -0.75 g -Pc -0.5 g -Pc -0.25 g -Pc -0 g -Pc -Bb -2 (Black & White) -4014 4716 0 0 1 0 0 1 0 0 Bg -0 BB -Pc -0.25 0 0 0 k -Pc -0.5 0 0 0 k -Pc -0.75 0 0 0 k -Pc -1 0 0 0 k -Pc -0.25 0.25 0 0 k -Pc -0.5 0.5 0 0 k -Pc -0.75 0.75 0 0 k -Pc -1 1 0 0 k -Pc -Bb -2 (Red & Yellow) -4014 4716 0 0 1 0 0 1 0 0 Bg -0 BB -Pc -0 0.25 0 0 k -Pc -0 0.5 0 0 k -Pc -0 0.75 0 0 k -Pc -0 1 0 0 k -Pc -0 0.25 0.25 0 k -Pc -0 0.5 0.5 0 k -Pc -0 0.75 0.75 0 k -Pc -0 1 1 0 k -Pc -Bb -0 0 0 0 Bh -2 (Yellow & Blue Radial) -4014 4716 0 0 1 0 0 1 0 0 Bg -0 BB -Pc -0 0 0.25 0 k -Pc -0 0 0.5 0 k -Pc -0 0 0.75 0 k -Pc -0 0 1 0 k -Pc -0.25 0 0.25 0 k -Pc -0.5 0 0.5 0 k -Pc -0.75 0 0.75 0 k -Pc -1 0 1 0 k -Pc -(Yellow Stripe) 0 0 1 1 0 0 0 0 0 [1 0 0 1 0 0] p -Pc -0.25 0.125 0 0 k -Pc -0.5 0.25 0 0 k -Pc -0.75 0.375 0 0 k -Pc -1 0.5 0 0 k -Pc -0.125 0.25 0 0 k -Pc -0.25 0.5 0 0 k -Pc -0.375 0.75 0 0 k -Pc -0.5 1 0 0 k -Pc -0.375 0.375 0.75 0 k -Pc -0 0.25 0.125 0 k -Pc -0 0.5 0.25 0 k -Pc -0 0.75 0.375 0 k -Pc -0 1 0.5 0 k -Pc -0 0.125 0.25 0 k -Pc -0 0.25 0.5 0 k -Pc -0 0.375 0.75 0 k -Pc -0 0.5 1 0 k -Pc -0 0.79 0.91 0 (PANTONE Warm Red CV) 0 x -Pc -0.125 0 0.25 0 k -Pc -0.25 0 0.5 0 k -Pc -0.375 0 0.75 0 k -Pc -0.5 0 1 0 k -Pc -0.25 0 0.125 0 k -Pc -0.5 0 0.25 0 k -Pc -0.75 0 0.375 0 k -Pc -1 0 0.5 0 k -Pc -0.5 1 0 0 k -Pc -0.25 0.125 0.125 0 k -Pc -0.5 0.25 0.25 0 k -Pc -0.75 0.375 0.375 0 k -Pc -1 0.5 0.5 0 k -Pc -0.25 0.25 0.125 0 k -Pc -0.5 0.5 0.25 0 k -Pc -0.75 0.75 0.375 0 k -Pc -1 1 0.5 0 k -Pc -0 1 0.5 0 k -Pc -0.125 0.25 0.125 0 k -Pc -0.25 0.5 0.25 0 k -Pc -0.375 0.75 0.375 0 k -Pc -0.5 1 0.5 0 k -Pc -0.125 0.25 0.25 0 k -Pc -0.25 0.5 0.5 0 k -Pc -0.375 0.75 0.75 0 k -Pc -0.5 1 1 0 k -Pc -0.75 0.75 0.375 0 k -Pc -0.125 0.125 0.25 0 k -Pc -0.25 0.25 0.5 0 k -Pc -0.375 0.375 0.75 0 k -Pc -0.5 0.5 1 0 k -Pc -0.25 0.125 0.25 0 k -Pc -0.5 0.25 0.5 0 k -Pc -0.75 0.375 0.75 0 k -Pc -1 0.5 1 0 k -Pc -0 0.79 0.91 0 (PANTONE Warm Red CV) 0 x -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -1 0.5 0.5 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 0.25 1 0 (Orange Yellow) 0 x -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 1 0.5 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -1 0 0.5 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 0.45 1 0 (Orange) 0 x -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0.375 0.375 0.75 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 0.79 0.91 0 (PANTONE Warm Red CV) 0 x -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -1 0.65 0 0 k -Pc -0 0 0 0 k -Pc -Pc -Pc -Pc -Pc -Pc -Pc -Pc -0 0 1 0 k -Pc -PB -%AI5_EndPalette -%%EndSetup -%AI5_BeginLayer -1 1 1 1 0 0 0 79 128 255 Lb -(Layer 1) Ln -0 A -1 Ap -0 O -1 0.65 0 0 k -800 Ar -0 J 0 j 1 w 4 M []0 d -%AI3_Note: -0 D -285.0121 311.7976 m -357.5043 302.5199 L -361.6071 392.7105 L -376.3322 474.1377 L -342.6527 475.6628 L -327.6333 483.4165 L -258.8269 486.3189 L -254.4361 405.0427 L -242.0523 312.2099 L -285.0121 311.7976 L -f -0 0.79 0.91 0 k -1.25 w -295.4466 337.6172 m -368.4943 335.3343 L -363.9288 425.5026 L -370.7771 507.9667 L -337.1066 506.2547 L -321.4128 512.5323 L -252.6452 508.8228 L -256.0692 427.5002 L -252.6452 333.9077 L -295.4466 337.6172 L -f -u -0 Ap -1 0.65 0 0 k -1 w -320.532 390.6149 m -312.9017 388.534 l -317.0637 398.5921 l -321.2256 426.6854 l -316.0232 427.7258 l -322.2662 436.3965 l -330.0436 465.6249 l -316.3701 462.7557 l -323.5798 475.9563 331.2311 484.5534 v -321.2256 492.2363 l -288.9913 478.0373 297.6622 431.9088 v -290.9988 433.0755 l -297.3888 384.7188 l -291.9867 383.3315 l -297.5214 372.0383 305.2714 366.6837 v -305.9749 366.1976 295.5601 404.4882 306.6587 442.6395 c -307.6992 440.2117 l -298.855 399.5459 307.6992 366.6837 v -308.1064 365.9033 312.5286 366.4235 v -320.532 381.5106 320.532 390.6149 v -f -u -*u -1 g -263.6948 355.9856 m -265.2612 355.9856 L -265.2612 359.2513 L -265.9515 359.2513 266.6153 359.2513 267.2791 359.3575 c -267.2791 355.9856 L -269.6155 355.9856 L -269.6155 355.3749 L -267.2791 355.3749 L -267.2791 347.2505 L -267.2791 346.7726 267.2791 346.0558 268.288 346.0558 c -268.9783 346.0558 269.35 346.5337 269.7748 347.0381 c -270.1996 346.7461 L -269.6951 345.7372 268.3942 345.1265 267.3322 345.1265 c -265.4205 345.1265 265.2081 346.162 265.2081 347.4364 c -265.2081 355.3749 L -263.6948 355.3749 L -263.6948 355.9856 l -f -*U -*u -285.7796 348.7639 m -285.1689 346.8788 284.1069 345.2327 281.3457 345.1265 c -277.2304 345.1265 275.9825 348.5515 275.9825 350.3835 c -275.9825 355.1094 279.7792 356.2511 281.2926 356.2511 c -283.0184 356.2511 285.461 355.4546 285.461 353.4102 c -285.461 352.6934 285.0096 352.003 284.2662 352.003 c -283.5494 352.003 283.0184 352.481 283.0184 353.2509 c -283.0184 354.2864 283.868 354.4191 283.868 354.7112 c -283.868 355.428 282.1953 355.7201 281.6112 355.7201 c -279.0624 355.7201 278.3986 353.8616 278.3986 350.3835 c -278.3986 348.7905 278.7969 347.5691 278.9562 347.1974 c -279.3544 346.3213 280.1775 345.7637 281.5581 345.6841 c -283.098 345.6044 284.5848 346.8523 285.222 348.7639 C -285.7796 348.7639 l -f -*U -*u -291.9344 345.4717 m -291.9344 346.0823 L -293.9788 346.0823 L -293.9788 363.1542 L -291.9344 363.1542 L -291.9344 363.7648 L -293.0761 363.7648 L -294.0585 363.7648 295.0939 363.8179 296.0497 364.0038 c -296.0497 346.0823 L -298.0941 346.0823 L -298.0941 345.4717 L -291.9344 345.4717 l -f -*U -u -310.0634 446.075 m -305.3828 425.2059 306.7298 391.3708 v -307.1338 381.222 308.2436 371.8929 309.5993 363.8029 C -309.6066 363.8025 L -310.4883 356.6987 311.0781 354.1272 313.3768 345.5676 C -313.2426 340.0473 L -294.8367 398.8155 310.0634 446.075 V -f -321.3622 464.1699 m -325.5016 466.2317 331.4359 466.9819 v -337.9224 455.0924 321.9584 434.793 v -331.4821 456.0522 329.2358 462.7122 v -326.7243 464.2727 321.3622 464.1699 v -f -319.4002 428.4819 m -323.1177 427.6214 324.9024 429.0668 v -321.386 415.3445 322.3077 407.7964 v -323.2297 400.2483 316.5788 395.4159 y -322.2441 402.584 320.4635 408.4226 v -319.2289 412.4694 320.6101 422.8271 322.1681 426.1155 c -320.7131 426.3196 319.4002 428.4819 v -f -315.7246 392.3281 m -321.8677 393.0631 322.5131 396.1662 v -323.265 377.6058 314.7299 369.9571 v -321.2425 380.1152 320.2206 390.6235 v -315.7246 392.3281 l -f -298.4445 384.6023 m -296.4635 382.3836 290.5192 387.2778 v -292.4131 374.803 304.1781 369.0924 v -296.0814 375.1928 293.9 381.7824 v -296.7611 382.6245 298.4445 384.6023 v -f -296.5483 389.3335 m -288.5102 409.7356 290.2325 437.3036 v -292.1098 432.3112 298.1424 430.5604 v -295.3003 429.9794 293.6387 430.2313 v -289.4335 418.5932 296.5483 389.3335 v -f -330.3126 484.1353 m -327.3003 506.2722 308.4549 483.8853 v -293.4491 466.0592 295.2373 450.9247 296.1578 442.4811 c -296.3932 440.3206 293.366 465.0316 309.8067 481.2933 c -326.2471 497.5553 329.9609 485.0794 330.3126 484.1353 c -f -U -0 0 1 0 k -302.5528 503.0164 m -287.7656 507.2395 283.0593 458.227 v -279.4282 473.3549 288.8204 494.7509 v -298.2122 516.1468 302.5528 503.0164 y -f -284.2076 506.5994 m -276.6655 495.2557 278.3767 483.1729 v -272.6565 505.9183 284.2076 506.5994 v -f -339.7135 474.7902 m -348.6321 478.0799 335.8615 444.8834 v -342.4718 454.5848 346.6326 469.8253 v -349.303 479.6062 339.7135 474.7902 y -f -354.1382 477.3767 m -360.4435 471.669 355.9752 464.1187 v -367.1908 475.904 354.1382 477.3767 v -f -U -U -*u -1 g -258.2029 317.4593 m -256.6821 317.4593 L -256.6821 325.2598 L -258.7512 325.2598 L -260.3858 325.2598 261.4514 324.608 261.4514 322.839 c -261.4514 321.1837 260.5513 320.3767 258.9581 320.3767 c -258.2029 320.3767 L -258.2029 317.4593 l -f -1 D -258.2029 321.6389 m -258.5132 321.6389 L -259.4133 321.6389 259.8995 321.8354 259.8995 322.8493 c -259.8995 323.8528 259.3202 323.9976 258.4719 323.9976 c -258.2029 323.9976 L -258.2029 321.6389 l -f -*U -*u -0 D -269.0694 321.3699 m -269.0694 323.5528 270.6523 325.4667 272.9283 325.4667 c -275.2043 325.4667 276.7871 323.5528 276.7871 321.3699 c -276.7871 319.1353 275.2043 317.2524 272.9283 317.2524 c -270.6523 317.2524 269.0694 319.1353 269.0694 321.3699 c -f -1 D -270.6419 321.432 m -270.6419 320.2526 271.6351 318.7525 272.9283 318.7525 c -274.2215 318.7525 275.2146 320.2526 275.2146 321.432 c -275.2146 322.6941 274.2628 323.9666 272.9283 323.9666 c -271.5937 323.9666 270.6419 322.6941 270.6419 321.432 c -f -*U -*u -0 D -287.2943 319.9422 m -287.315 319.9422 L -288.8668 325.3632 L -289.7668 325.3632 L -291.3807 319.9422 L -291.4014 319.9422 L -292.9326 325.2598 L -294.5258 325.2598 L -291.8877 317.3041 L -290.7704 317.3041 L -289.2185 322.4044 L -289.1978 322.4044 L -287.7288 317.3041 L -286.6115 317.3041 L -284.1286 325.2598 L -285.7218 325.2598 L -287.2943 319.9422 l -f -*U -*u -303.7595 323.9356 m -303.7595 322.2182 L -306.1803 322.2182 L -306.1803 320.894 L -303.7595 320.894 L -303.7595 318.7835 L -306.2734 318.7835 L -306.2734 317.4593 L -302.2387 317.4593 L -302.2387 325.2598 L -306.2734 325.2598 L -306.2734 323.9356 L -303.7595 323.9356 l -f -*U -*u -319.8602 317.4593 m -318.0187 317.4593 L -316.1255 320.6043 L -316.1048 320.6043 L -316.1048 317.4593 L -314.5841 317.4593 L -314.5841 325.2598 L -316.6428 325.2598 L -318.1843 325.2598 319.2499 324.577 319.2499 322.9114 c -319.2499 321.9182 318.7015 320.925 317.6567 320.7492 C -319.8602 317.4593 l -f -1 D -316.1048 321.6699 m -316.3014 321.6699 L -317.1394 321.6699 317.7291 321.9182 317.7291 322.87 c -317.7291 323.8321 317.1187 324.0183 316.3117 324.0183 c -316.1048 324.0183 L -316.1048 321.6699 l -f -*U -*u -0 D -329.1754 323.9356 m -329.1754 322.2182 L -331.5962 322.2182 L -331.5962 320.894 L -329.1754 320.894 L -329.1754 318.7835 L -331.6894 318.7835 L -331.6894 317.4593 L -327.6546 317.4593 L -327.6546 325.2598 L -331.6894 325.2598 L -331.6894 323.9356 L -329.1754 323.9356 l -f -*U -*u -340 325.2598 m -342.1725 325.2598 L -344.4279 325.2598 345.9383 323.5735 345.9383 321.3492 c -345.9383 319.156 344.3865 317.4593 342.1622 317.4593 c -340 317.4593 L -340 325.2598 l -f -1 D -341.5208 318.7835 m -341.7691 318.7835 L -343.6416 318.7835 344.3658 319.8181 344.3658 321.3596 c -344.3658 323.0562 343.4968 323.9356 341.7691 323.9356 c -341.5208 323.9356 L -341.5208 318.7835 l -f -*U -LB -%AI5_EndLayer-- -%%PageTrailer -gsave annotatepage grestore showpage -%%Trailer -Adobe_IllustratorA_AI5 /terminate get exec -Adobe_level2_AI5 /terminate get exec -%%EOF diff --git a/tcl/library/images/pwrdLogo100.gif b/tcl/library/images/pwrdLogo100.gif Binary files differdeleted file mode 100644 index d2f8cbb65d2..00000000000 --- a/tcl/library/images/pwrdLogo100.gif +++ /dev/null diff --git a/tcl/library/images/pwrdLogo150.gif b/tcl/library/images/pwrdLogo150.gif Binary files differdeleted file mode 100644 index 89eec7ca7b3..00000000000 --- a/tcl/library/images/pwrdLogo150.gif +++ /dev/null diff --git a/tcl/library/images/pwrdLogo175.gif b/tcl/library/images/pwrdLogo175.gif Binary files differdeleted file mode 100644 index 02dcd92dca4..00000000000 --- a/tcl/library/images/pwrdLogo175.gif +++ /dev/null diff --git a/tcl/library/images/pwrdLogo200.gif b/tcl/library/images/pwrdLogo200.gif Binary files differdeleted file mode 100644 index 66426bfd846..00000000000 --- a/tcl/library/images/pwrdLogo200.gif +++ /dev/null diff --git a/tcl/library/images/pwrdLogo75.gif b/tcl/library/images/pwrdLogo75.gif Binary files differdeleted file mode 100644 index e75925c1894..00000000000 --- a/tcl/library/images/pwrdLogo75.gif +++ /dev/null diff --git a/tcl/library/images/tai-ku.gif b/tcl/library/images/tai-ku.gif Binary files differdeleted file mode 100644 index a5aea47599b..00000000000 --- a/tcl/library/images/tai-ku.gif +++ /dev/null diff --git a/tcl/library/listbox.tcl b/tcl/library/listbox.tcl deleted file mode 100644 index c48e9823743..00000000000 --- a/tcl/library/listbox.tcl +++ /dev/null @@ -1,505 +0,0 @@ -# listbox.tcl -- -# -# This file defines the default bindings for Tk listbox widgets -# and provides procedures that help in implementing those bindings. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -#-------------------------------------------------------------------------- -# tk::Priv elements used in this file: -# -# afterId - Token returned by "after" for autoscanning. -# listboxPrev - The last element to be selected or deselected -# during a selection operation. -# listboxSelection - All of the items that were selected before the -# current selection operation (such as a mouse -# drag) started; used to cancel an operation. -#-------------------------------------------------------------------------- - -#------------------------------------------------------------------------- -# The code below creates the default class bindings for listboxes. -#------------------------------------------------------------------------- - -# Note: the check for existence of %W below is because this binding -# is sometimes invoked after a window has been deleted (e.g. because -# there is a double-click binding on the widget that deletes it). Users -# can put "break"s in their bindings to avoid the error, but this check -# makes that unnecessary. - -bind Listbox <1> { - if {[winfo exists %W]} { - tk::ListboxBeginSelect %W [%W index @%x,%y] - } -} - -# Ignore double clicks so that users can define their own behaviors. -# Among other things, this prevents errors if the user deletes the -# listbox on a double click. - -bind Listbox <Double-1> { - # Empty script -} - -bind Listbox <B1-Motion> { - set tk::Priv(x) %x - set tk::Priv(y) %y - tk::ListboxMotion %W [%W index @%x,%y] -} -bind Listbox <ButtonRelease-1> { - tk::CancelRepeat - %W activate @%x,%y -} -bind Listbox <Shift-1> { - tk::ListboxBeginExtend %W [%W index @%x,%y] -} -bind Listbox <Control-1> { - tk::ListboxBeginToggle %W [%W index @%x,%y] -} -bind Listbox <B1-Leave> { - set tk::Priv(x) %x - set tk::Priv(y) %y - tk::ListboxAutoScan %W -} -bind Listbox <B1-Enter> { - tk::CancelRepeat -} - -bind Listbox <Up> { - tk::ListboxUpDown %W -1 -} -bind Listbox <Shift-Up> { - tk::ListboxExtendUpDown %W -1 -} -bind Listbox <Down> { - tk::ListboxUpDown %W 1 -} -bind Listbox <Shift-Down> { - tk::ListboxExtendUpDown %W 1 -} -bind Listbox <Left> { - %W xview scroll -1 units -} -bind Listbox <Control-Left> { - %W xview scroll -1 pages -} -bind Listbox <Right> { - %W xview scroll 1 units -} -bind Listbox <Control-Right> { - %W xview scroll 1 pages -} -bind Listbox <Prior> { - %W yview scroll -1 pages - %W activate @0,0 -} -bind Listbox <Next> { - %W yview scroll 1 pages - %W activate @0,0 -} -bind Listbox <Control-Prior> { - %W xview scroll -1 pages -} -bind Listbox <Control-Next> { - %W xview scroll 1 pages -} -bind Listbox <Home> { - %W xview moveto 0 -} -bind Listbox <End> { - %W xview moveto 1 -} -bind Listbox <Control-Home> { - %W activate 0 - %W see 0 - %W selection clear 0 end - %W selection set 0 - event generate %W <<ListboxSelect>> -} -bind Listbox <Shift-Control-Home> { - tk::ListboxDataExtend %W 0 -} -bind Listbox <Control-End> { - %W activate end - %W see end - %W selection clear 0 end - %W selection set end - event generate %W <<ListboxSelect>> -} -bind Listbox <Shift-Control-End> { - tk::ListboxDataExtend %W [%W index end] -} -bind Listbox <<Copy>> { - if {[string equal [selection own -displayof %W] "%W"]} { - clipboard clear -displayof %W - clipboard append -displayof %W [selection get -displayof %W] - } -} -bind Listbox <space> { - tk::ListboxBeginSelect %W [%W index active] -} -bind Listbox <Select> { - tk::ListboxBeginSelect %W [%W index active] -} -bind Listbox <Control-Shift-space> { - tk::ListboxBeginExtend %W [%W index active] -} -bind Listbox <Shift-Select> { - tk::ListboxBeginExtend %W [%W index active] -} -bind Listbox <Escape> { - tk::ListboxCancel %W -} -bind Listbox <Control-slash> { - tk::ListboxSelectAll %W -} -bind Listbox <Control-backslash> { - if {[string compare [%W cget -selectmode] "browse"]} { - %W selection clear 0 end - event generate %W <<ListboxSelect>> - } -} - -# Additional Tk bindings that aren't part of the Motif look and feel: - -bind Listbox <2> { - %W scan mark %x %y -} -bind Listbox <B2-Motion> { - %W scan dragto %x %y -} - -# The MouseWheel will typically only fire on Windows. However, -# someone could use the "event generate" command to produce one -# on other platforms. - -bind Listbox <MouseWheel> { - %W yview scroll [expr {- (%D / 120) * 4}] units -} - -if {[string equal "x11" [tk windowingsystem]]} { - # Support for mousewheels on Linux/Unix commonly comes through mapping - # the wheel to the extended buttons. If you have a mousewheel, find - # Linux configuration info at: - # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ - bind Listbox <4> { - if {!$tk_strictMotif} { - %W yview scroll -5 units - } - } - bind Listbox <5> { - if {!$tk_strictMotif} { - %W yview scroll 5 units - } - } -} - -# ::tk::ListboxBeginSelect -- -# -# This procedure is typically invoked on button-1 presses. It begins -# the process of making a selection in the listbox. Its exact behavior -# depends on the selection mode currently in effect for the listbox; -# see the Motif documentation for details. -# -# Arguments: -# w - The listbox widget. -# el - The element for the selection operation (typically the -# one under the pointer). Must be in numerical form. - -proc ::tk::ListboxBeginSelect {w el} { - variable ::tk::Priv - if {[string equal [$w cget -selectmode] "multiple"]} { - if {[$w selection includes $el]} { - $w selection clear $el - } else { - $w selection set $el - } - } else { - $w selection clear 0 end - $w selection set $el - $w selection anchor $el - set Priv(listboxSelection) {} - set Priv(listboxPrev) $el - } - event generate $w <<ListboxSelect>> -} - -# ::tk::ListboxMotion -- -# -# This procedure is called to process mouse motion events while -# button 1 is down. It may move or extend the selection, depending -# on the listbox's selection mode. -# -# Arguments: -# w - The listbox widget. -# el - The element under the pointer (must be a number). - -proc ::tk::ListboxMotion {w el} { - variable ::tk::Priv - if {$el == $Priv(listboxPrev)} { - return - } - set anchor [$w index anchor] - switch [$w cget -selectmode] { - browse { - $w selection clear 0 end - $w selection set $el - set Priv(listboxPrev) $el - event generate $w <<ListboxSelect>> - } - extended { - set i $Priv(listboxPrev) - if {[string equal {} $i]} { - set i $el - $w selection set $el - } - if {[$w selection includes anchor]} { - $w selection clear $i $el - $w selection set anchor $el - } else { - $w selection clear $i $el - $w selection clear anchor $el - } - if {![info exists Priv(listboxSelection)]} { - set Priv(listboxSelection) [$w curselection] - } - while {($i < $el) && ($i < $anchor)} { - if {[lsearch $Priv(listboxSelection) $i] >= 0} { - $w selection set $i - } - incr i - } - while {($i > $el) && ($i > $anchor)} { - if {[lsearch $Priv(listboxSelection) $i] >= 0} { - $w selection set $i - } - incr i -1 - } - set Priv(listboxPrev) $el - event generate $w <<ListboxSelect>> - } - } -} - -# ::tk::ListboxBeginExtend -- -# -# This procedure is typically invoked on shift-button-1 presses. It -# begins the process of extending a selection in the listbox. Its -# exact behavior depends on the selection mode currently in effect -# for the listbox; see the Motif documentation for details. -# -# Arguments: -# w - The listbox widget. -# el - The element for the selection operation (typically the -# one under the pointer). Must be in numerical form. - -proc ::tk::ListboxBeginExtend {w el} { - if {[string equal [$w cget -selectmode] "extended"]} { - if {[$w selection includes anchor]} { - ListboxMotion $w $el - } else { - # No selection yet; simulate the begin-select operation. - ListboxBeginSelect $w $el - } - } -} - -# ::tk::ListboxBeginToggle -- -# -# This procedure is typically invoked on control-button-1 presses. It -# begins the process of toggling a selection in the listbox. Its -# exact behavior depends on the selection mode currently in effect -# for the listbox; see the Motif documentation for details. -# -# Arguments: -# w - The listbox widget. -# el - The element for the selection operation (typically the -# one under the pointer). Must be in numerical form. - -proc ::tk::ListboxBeginToggle {w el} { - variable ::tk::Priv - if {[string equal [$w cget -selectmode] "extended"]} { - set Priv(listboxSelection) [$w curselection] - set Priv(listboxPrev) $el - $w selection anchor $el - if {[$w selection includes $el]} { - $w selection clear $el - } else { - $w selection set $el - } - event generate $w <<ListboxSelect>> - } -} - -# ::tk::ListboxAutoScan -- -# This procedure is invoked when the mouse leaves an entry window -# with button 1 down. It scrolls the window up, down, left, or -# right, depending on where the mouse left the window, and reschedules -# itself as an "after" command so that the window continues to scroll until -# the mouse moves back into the window or the mouse button is released. -# -# Arguments: -# w - The entry window. - -proc ::tk::ListboxAutoScan {w} { - variable ::tk::Priv - if {![winfo exists $w]} return - set x $Priv(x) - set y $Priv(y) - if {$y >= [winfo height $w]} { - $w yview scroll 1 units - } elseif {$y < 0} { - $w yview scroll -1 units - } elseif {$x >= [winfo width $w]} { - $w xview scroll 2 units - } elseif {$x < 0} { - $w xview scroll -2 units - } else { - return - } - ListboxMotion $w [$w index @$x,$y] - set Priv(afterId) [after 50 [list tk::ListboxAutoScan $w]] -} - -# ::tk::ListboxUpDown -- -# -# Moves the location cursor (active element) up or down by one element, -# and changes the selection if we're in browse or extended selection -# mode. -# -# Arguments: -# w - The listbox widget. -# amount - +1 to move down one item, -1 to move back one item. - -proc ::tk::ListboxUpDown {w amount} { - variable ::tk::Priv - $w activate [expr {[$w index active] + $amount}] - $w see active - switch [$w cget -selectmode] { - browse { - $w selection clear 0 end - $w selection set active - event generate $w <<ListboxSelect>> - } - extended { - $w selection clear 0 end - $w selection set active - $w selection anchor active - set Priv(listboxPrev) [$w index active] - set Priv(listboxSelection) {} - event generate $w <<ListboxSelect>> - } - } -} - -# ::tk::ListboxExtendUpDown -- -# -# Does nothing unless we're in extended selection mode; in this -# case it moves the location cursor (active element) up or down by -# one element, and extends the selection to that point. -# -# Arguments: -# w - The listbox widget. -# amount - +1 to move down one item, -1 to move back one item. - -proc ::tk::ListboxExtendUpDown {w amount} { - variable ::tk::Priv - if {[string compare [$w cget -selectmode] "extended"]} { - return - } - set active [$w index active] - if {![info exists Priv(listboxSelection)]} { - $w selection set $active - set Priv(listboxSelection) [$w curselection] - } - $w activate [expr {$active + $amount}] - $w see active - ListboxMotion $w [$w index active] -} - -# ::tk::ListboxDataExtend -# -# This procedure is called for key-presses such as Shift-KEndData. -# If the selection mode isn't multiple or extend then it does nothing. -# Otherwise it moves the active element to el and, if we're in -# extended mode, extends the selection to that point. -# -# Arguments: -# w - The listbox widget. -# el - An integer element number. - -proc ::tk::ListboxDataExtend {w el} { - set mode [$w cget -selectmode] - if {[string equal $mode "extended"]} { - $w activate $el - $w see $el - if {[$w selection includes anchor]} { - ListboxMotion $w $el - } - } elseif {[string equal $mode "multiple"]} { - $w activate $el - $w see $el - } -} - -# ::tk::ListboxCancel -# -# This procedure is invoked to cancel an extended selection in -# progress. If there is an extended selection in progress, it -# restores all of the items between the active one and the anchor -# to their previous selection state. -# -# Arguments: -# w - The listbox widget. - -proc ::tk::ListboxCancel w { - variable ::tk::Priv - if {[string compare [$w cget -selectmode] "extended"]} { - return - } - set first [$w index anchor] - set last $Priv(listboxPrev) - if { [string equal $last ""] } { - # Not actually doing any selection right now - return - } - if {$first > $last} { - set tmp $first - set first $last - set last $tmp - } - $w selection clear $first $last - while {$first <= $last} { - if {[lsearch $Priv(listboxSelection) $first] >= 0} { - $w selection set $first - } - incr first - } - event generate $w <<ListboxSelect>> -} - -# ::tk::ListboxSelectAll -# -# This procedure is invoked to handle the "select all" operation. -# For single and browse mode, it just selects the active element. -# Otherwise it selects everything in the widget. -# -# Arguments: -# w - The listbox widget. - -proc ::tk::ListboxSelectAll w { - set mode [$w cget -selectmode] - if {[string equal $mode "single"] || [string equal $mode "browse"]} { - $w selection clear 0 end - $w selection set active - } else { - $w selection set 0 end - } - event generate $w <<ListboxSelect>> -} diff --git a/tcl/library/menu.tcl b/tcl/library/menu.tcl deleted file mode 100644 index 1fe2710b7ab..00000000000 --- a/tcl/library/menu.tcl +++ /dev/null @@ -1,1295 +0,0 @@ -# menu.tcl -- -# -# This file defines the default bindings for Tk menus and menubuttons. -# It also implements keyboard traversal of menus and implements a few -# other utility procedures related to menus. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -#------------------------------------------------------------------------- -# Elements of tk::Priv that are used in this file: -# -# cursor - Saves the -cursor option for the posted menubutton. -# focus - Saves the focus during a menu selection operation. -# Focus gets restored here when the menu is unposted. -# grabGlobal - Used in conjunction with tk::Priv(oldGrab): if -# tk::Priv(oldGrab) is non-empty, then tk::Priv(grabGlobal) -# contains either an empty string or "-global" to -# indicate whether the old grab was a local one or -# a global one. -# inMenubutton - The name of the menubutton widget containing -# the mouse, or an empty string if the mouse is -# not over any menubutton. -# menuBar - The name of the menubar that is the root -# of the cascade hierarchy which is currently -# posted. This is null when there is no menu currently -# being pulled down from a menu bar. -# oldGrab - Window that had the grab before a menu was posted. -# Used to restore the grab state after the menu -# is unposted. Empty string means there was no -# grab previously set. -# popup - If a menu has been popped up via tk_popup, this -# gives the name of the menu. Otherwise this -# value is empty. -# postedMb - Name of the menubutton whose menu is currently -# posted, or an empty string if nothing is posted -# A grab is set on this widget. -# relief - Used to save the original relief of the current -# menubutton. -# window - When the mouse is over a menu, this holds the -# name of the menu; it's cleared when the mouse -# leaves the menu. -# tearoff - Whether the last menu posted was a tearoff or not. -# This is true always for unix, for tearoffs for Mac -# and Windows. -# activeMenu - This is the last active menu for use -# with the <<MenuSelect>> virtual event. -# activeItem - This is the last active menu item for -# use with the <<MenuSelect>> virtual event. -#------------------------------------------------------------------------- - -#------------------------------------------------------------------------- -# Overall note: -# This file is tricky because there are five different ways that menus -# can be used: -# -# 1. As a pulldown from a menubutton. In this style, the variable -# tk::Priv(postedMb) identifies the posted menubutton. -# 2. As a torn-off menu copied from some other menu. In this style -# tk::Priv(postedMb) is empty, and menu's type is "tearoff". -# 3. As an option menu, triggered from an option menubutton. In this -# style tk::Priv(postedMb) identifies the posted menubutton. -# 4. As a popup menu. In this style tk::Priv(postedMb) is empty and -# the top-level menu's type is "normal". -# 5. As a pulldown from a menubar. The variable tk::Priv(menubar) has -# the owning menubar, and the menu itself is of type "normal". -# -# The various binding procedures use the state described above to -# distinguish the various cases and take different actions in each -# case. -#------------------------------------------------------------------------- - -#------------------------------------------------------------------------- -# The code below creates the default class bindings for menus -# and menubuttons. -#------------------------------------------------------------------------- - -bind Menubutton <FocusIn> {} -bind Menubutton <Enter> { - tk::MbEnter %W -} -bind Menubutton <Leave> { - tk::MbLeave %W -} -bind Menubutton <1> { - if {$tk::Priv(inMenubutton) ne ""} { - tk::MbPost $tk::Priv(inMenubutton) %X %Y - } -} -bind Menubutton <Motion> { - tk::MbMotion %W up %X %Y -} -bind Menubutton <B1-Motion> { - tk::MbMotion %W down %X %Y -} -bind Menubutton <ButtonRelease-1> { - tk::MbButtonUp %W -} -bind Menubutton <space> { - tk::MbPost %W - tk::MenuFirstEntry [%W cget -menu] -} - -# Must set focus when mouse enters a menu, in order to allow -# mixed-mode processing using both the mouse and the keyboard. -# Don't set the focus if the event comes from a grab release, -# though: such an event can happen after as part of unposting -# a cascaded chain of menus, after the focus has already been -# restored to wherever it was before menu selection started. - -bind Menu <FocusIn> {} - -bind Menu <Enter> { - set tk::Priv(window) %W - if {[%W cget -type] eq "tearoff"} { - if {"%m" ne "NotifyUngrab"} { - if {[tk windowingsystem] eq "x11"} { - tk_menuSetFocus %W - } - } - } - tk::MenuMotion %W %x %y %s -} - -bind Menu <Leave> { - tk::MenuLeave %W %X %Y %s -} -bind Menu <Motion> { - tk::MenuMotion %W %x %y %s -} -bind Menu <ButtonPress> { - tk::MenuButtonDown %W -} -bind Menu <ButtonRelease> { - tk::MenuInvoke %W 1 -} -bind Menu <space> { - tk::MenuInvoke %W 0 -} -bind Menu <Return> { - tk::MenuInvoke %W 0 -} -bind Menu <Escape> { - tk::MenuEscape %W -} -bind Menu <Left> { - tk::MenuLeftArrow %W -} -bind Menu <Right> { - tk::MenuRightArrow %W -} -bind Menu <Up> { - tk::MenuUpArrow %W -} -bind Menu <Down> { - tk::MenuDownArrow %W -} -bind Menu <KeyPress> { - tk::TraverseWithinMenu %W %A -} - -# The following bindings apply to all windows, and are used to -# implement keyboard menu traversal. - -if {[string equal [tk windowingsystem] "x11"]} { - bind all <Alt-KeyPress> { - tk::TraverseToMenu %W %A - } - - bind all <F10> { - tk::FirstMenu %W - } -} else { - bind Menubutton <Alt-KeyPress> { - tk::TraverseToMenu %W %A - } - - bind Menubutton <F10> { - tk::FirstMenu %W - } -} - -# ::tk::MbEnter -- -# This procedure is invoked when the mouse enters a menubutton -# widget. It activates the widget unless it is disabled. Note: -# this procedure is only invoked when mouse button 1 is *not* down. -# The procedure ::tk::MbB1Enter is invoked if the button is down. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::MbEnter w { - variable ::tk::Priv - - if {[string compare $Priv(inMenubutton) ""]} { - MbLeave $Priv(inMenubutton) - } - set Priv(inMenubutton) $w - if {[string compare [$w cget -state] "disabled"]} { - $w configure -state active - } -} - -# ::tk::MbLeave -- -# This procedure is invoked when the mouse leaves a menubutton widget. -# It de-activates the widget, if the widget still exists. -# -# Arguments: -# w - The name of the widget. - -proc ::tk::MbLeave w { - variable ::tk::Priv - - set Priv(inMenubutton) {} - if {![winfo exists $w]} { - return - } - if {[string equal [$w cget -state] "active"]} { - $w configure -state normal - } -} - -# ::tk::MbPost -- -# Given a menubutton, this procedure does all the work of posting -# its associated menu and unposting any other menu that is currently -# posted. -# -# Arguments: -# w - The name of the menubutton widget whose menu -# is to be posted. -# x, y - Root coordinates of cursor, used for positioning -# option menus. If not specified, then the center -# of the menubutton is used for an option menu. - -proc ::tk::MbPost {w {x {}} {y {}}} { - global errorInfo - variable ::tk::Priv - global tcl_platform - - if {[$w cget -state] eq "disabled" || $w eq $Priv(postedMb)} { - return - } - set menu [$w cget -menu] - if {[string equal $menu ""]} { - return - } - set tearoff [expr {[tk windowingsystem] eq "x11" \ - || [$menu cget -type] eq "tearoff"}] - if {[string first $w $menu] != 0} { - error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)" - } - set cur $Priv(postedMb) - if {[string compare $cur ""]} { - MenuUnpost {} - } - set Priv(cursor) [$w cget -cursor] - set Priv(relief) [$w cget -relief] - $w configure -cursor arrow - $w configure -relief raised - - set Priv(postedMb) $w - set Priv(focus) [focus] - $menu activate none - GenerateMenuSelect $menu - - # If this looks like an option menubutton then post the menu so - # that the current entry is on top of the mouse. Otherwise post - # the menu just below the menubutton, as for a pull-down. - - update idletasks - if {[catch { - switch [$w cget -direction] { - above { - set x [winfo rootx $w] - set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}] - PostOverPoint $menu $x $y - } - below { - set x [winfo rootx $w] - set y [expr {[winfo rooty $w] + [winfo height $w]}] - PostOverPoint $menu $x $y - } - left { - set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}] - set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}] - set entry [MenuFindName $menu [$w cget -text]] - if {[$w cget -indicatoron]} { - if {$entry == [$menu index last]} { - incr y [expr {-([$menu yposition $entry] \ - + [winfo reqheight $menu])/2}] - } else { - incr y [expr {-([$menu yposition $entry] \ - + [$menu yposition [expr {$entry+1}]])/2}] - } - } - PostOverPoint $menu $x $y - if {$entry ne "" \ - && [$menu entrycget $entry -state] ne "disabled"} { - $menu activate $entry - GenerateMenuSelect $menu - } - } - right { - set x [expr {[winfo rootx $w] + [winfo width $w]}] - set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}] - set entry [MenuFindName $menu [$w cget -text]] - if {[$w cget -indicatoron]} { - if {$entry == [$menu index last]} { - incr y [expr {-([$menu yposition $entry] \ - + [winfo reqheight $menu])/2}] - } else { - incr y [expr {-([$menu yposition $entry] \ - + [$menu yposition [expr {$entry+1}]])/2}] - } - } - PostOverPoint $menu $x $y - if {$entry ne "" \ - && [$menu entrycget $entry -state] ne "disabled"} { - $menu activate $entry - GenerateMenuSelect $menu - } - } - default { - if {[$w cget -indicatoron]} { - if {[string equal $y {}]} { - set x [expr {[winfo rootx $w] + [winfo width $w]/2}] - set y [expr {[winfo rooty $w] + [winfo height $w]/2}] - } - PostOverPoint $menu $x $y [MenuFindName $menu [$w cget -text]] - } else { - PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}] - } - } - } - } msg]} { - # Error posting menu (e.g. bogus -postcommand). Unpost it and - # reflect the error. - - set savedInfo $errorInfo - MenuUnpost {} - error $msg $savedInfo - - } - - set Priv(tearoff) $tearoff - if {$tearoff != 0} { - focus $menu - if {[winfo viewable $w]} { - SaveGrabInfo $w - grab -global $w - } - } -} - -# ::tk::MenuUnpost -- -# This procedure unposts a given menu, plus all of its ancestors up -# to (and including) a menubutton, if any. It also restores various -# values to what they were before the menu was posted, and releases -# a grab if there's a menubutton involved. Special notes: -# 1. It's important to unpost all menus before releasing the grab, so -# that any Enter-Leave events (e.g. from menu back to main -# application) have mode NotifyGrab. -# 2. Be sure to enclose various groups of commands in "catch" so that -# the procedure will complete even if the menubutton or the menu -# or the grab window has been deleted. -# -# Arguments: -# menu - Name of a menu to unpost. Ignored if there -# is a posted menubutton. - -proc ::tk::MenuUnpost menu { - global tcl_platform - variable ::tk::Priv - set mb $Priv(postedMb) - - # Restore focus right away (otherwise X will take focus away when - # the menu is unmapped and under some window managers (e.g. olvwm) - # we'll lose the focus completely). - - catch {focus $Priv(focus)} - set Priv(focus) "" - - # Unpost menu(s) and restore some stuff that's dependent on - # what was posted. - - catch { - if {[string compare $mb ""]} { - set menu [$mb cget -menu] - $menu unpost - set Priv(postedMb) {} - $mb configure -cursor $Priv(cursor) - $mb configure -relief $Priv(relief) - } elseif {[string compare $Priv(popup) ""]} { - $Priv(popup) unpost - set Priv(popup) {} - } 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. - # Unpost all the menus up to the toplevel one (but not - # including the top-level torn-off one) and deactivate the - # top-level torn off menu if there is one. - - while {1} { - set parent [winfo parent $menu] - if {[string compare [winfo class $parent] "Menu"] \ - || ![winfo ismapped $parent]} { - break - } - $parent activate none - $parent postcascade none - GenerateMenuSelect $parent - set type [$parent cget -type] - if {[string equal $type "menubar"] || \ - [string equal $type "tearoff"]} { - break - } - set menu $parent - } - if {[string compare [$menu cget -type] "menubar"]} { - $menu unpost - } - } - } - - if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} { - # Release grab, if any, and restore the previous grab, if there - # was one. - if {[string compare $menu ""]} { - set grab [grab current $menu] - if {[string compare $grab ""]} { - grab release $grab - } - } - RestoreOldGrab - if {$Priv(menuBar) ne ""} { - $Priv(menuBar) configure -cursor $Priv(cursor) - set Priv(menuBar) {} - } - if {[tk windowingsystem] ne "x11"} { - set Priv(tearoff) 0 - } - } -} - -# ::tk::MbMotion -- -# This procedure handles mouse motion events inside menubuttons, and -# also outside menubuttons when a menubutton has a grab (e.g. when a -# menu selection operation is in progress). -# -# Arguments: -# w - The name of the menubutton widget. -# upDown - "down" means button 1 is pressed, "up" means -# it isn't. -# rootx, rooty - Coordinates of mouse, in (virtual?) root window. - -proc ::tk::MbMotion {w upDown rootx rooty} { - variable ::tk::Priv - - if {[string equal $Priv(inMenubutton) $w]} { - return - } - set new [winfo containing $rootx $rooty] - if {[string compare $new $Priv(inMenubutton)] \ - && ([string equal $new ""] \ - || [string equal [winfo toplevel $new] [winfo toplevel $w]])} { - if {[string compare $Priv(inMenubutton) ""]} { - MbLeave $Priv(inMenubutton) - } - if {[string compare $new ""] \ - && [string equal [winfo class $new] "Menubutton"] \ - && ([$new cget -indicatoron] == 0) \ - && ([$w cget -indicatoron] == 0)} { - if {[string equal $upDown "down"]} { - MbPost $new $rootx $rooty - } else { - MbEnter $new - } - } - } -} - -# ::tk::MbButtonUp -- -# This procedure is invoked to handle button 1 releases for menubuttons. -# If the release happens inside the menubutton then leave its menu -# posted with element 0 activated. Otherwise, unpost the menu. -# -# Arguments: -# w - The name of the menubutton widget. - -proc ::tk::MbButtonUp w { - variable ::tk::Priv - global tcl_platform - - set menu [$w cget -menu] - set tearoff [expr {[tk windowingsystem] eq "x11" || \ - ($menu ne "" && [$menu cget -type] eq "tearoff")}] - if {($tearoff != 0) && $Priv(postedMb) eq $w \ - && $Priv(inMenubutton) eq $w} { - MenuFirstEntry [$Priv(postedMb) cget -menu] - } else { - MenuUnpost {} - } -} - -# ::tk::MenuMotion -- -# This procedure is called to handle mouse motion events for menus. -# It does two things. First, it resets the active element in the -# menu, if the mouse is over the menu. Second, if a mouse button -# is down, it posts and unposts cascade entries to match the mouse -# position. -# -# Arguments: -# menu - The menu window. -# x - The x position of the mouse. -# y - The y position of the mouse. -# state - Modifier state (tells whether buttons are down). - -proc ::tk::MenuMotion {menu x y state} { - variable ::tk::Priv - if {[string equal $menu $Priv(window)]} { - if {[string equal [$menu cget -type] "menubar"]} { - if {[info exists Priv(focus)] && \ - [string compare $menu $Priv(focus)]} { - $menu activate @$x,$y - GenerateMenuSelect $menu - } - } else { - $menu activate @$x,$y - GenerateMenuSelect $menu - } - } - if {($state & 0x1f00) != 0} { - $menu postcascade active - } -} - -# ::tk::MenuButtonDown -- -# Handles button presses in menus. There are a couple of tricky things -# here: -# 1. Change the posted cascade entry (if any) to match the mouse position. -# 2. If there is a posted menubutton, must grab to the menubutton; this -# overrrides the implicit grab on button press, so that the menu -# button can track mouse motions over other menubuttons and change -# the posted menu. -# 3. If there's no posted menubutton (e.g. because we're a torn-off menu -# or one of its descendants) must grab to the top-level menu so that -# we can track mouse motions across the entire menu hierarchy. -# -# Arguments: -# menu - The menu window. - -proc ::tk::MenuButtonDown menu { - variable ::tk::Priv - global tcl_platform - - if {![winfo viewable $menu]} { - return - } - $menu postcascade active - if {[string compare $Priv(postedMb) ""] && \ - [winfo viewable $Priv(postedMb)]} { - grab -global $Priv(postedMb) - } else { - while {[string equal [$menu cget -type] "normal"] \ - && [string equal [winfo class [winfo parent $menu]] "Menu"] \ - && [winfo ismapped [winfo parent $menu]]} { - set menu [winfo parent $menu] - } - - if {[string equal $Priv(menuBar) {}]} { - set Priv(menuBar) $menu - set Priv(cursor) [$menu cget -cursor] - $menu configure -cursor arrow - } - - # Don't update grab information if the grab window isn't changing. - # Otherwise, we'll get an error when we unpost the menus and - # restore the grab, since the old grab window will not be viewable - # anymore. - - if {[string compare $menu [grab current $menu]]} { - SaveGrabInfo $menu - } - - # Must re-grab even if the grab window hasn't changed, in order - # to release the implicit grab from the button press. - - if {[string equal [tk windowingsystem] "x11"]} { - grab -global $menu - } - } -} - -# ::tk::MenuLeave -- -# This procedure is invoked to handle Leave events for a menu. It -# deactivates everything unless the active element is a cascade element -# and the mouse is now over the submenu. -# -# Arguments: -# menu - The menu window. -# rootx, rooty - Root coordinates of mouse. -# state - Modifier state. - -proc ::tk::MenuLeave {menu rootx rooty state} { - variable ::tk::Priv - set Priv(window) {} - if {[string equal [$menu index active] "none"]} { - return - } - if {[string equal [$menu type active] "cascade"] - && [string equal [winfo containing $rootx $rooty] \ - [$menu entrycget active -menu]]} { - return - } - $menu activate none - GenerateMenuSelect $menu -} - -# ::tk::MenuInvoke -- -# This procedure is invoked when button 1 is released over a menu. -# It invokes the appropriate menu action and unposts the menu if -# it came from a menubutton. -# -# Arguments: -# w - Name of the menu widget. -# buttonRelease - 1 means this procedure is called because of -# a button release; 0 means because of keystroke. - -proc ::tk::MenuInvoke {w buttonRelease} { - variable ::tk::Priv - - if {$buttonRelease && [string equal $Priv(window) {}]} { - # Mouse was pressed over a menu without a menu button, then - # dragged off the menu (possibly with a cascade posted) and - # released. Unpost everything and quit. - - $w postcascade none - $w activate none - event generate $w <<MenuSelect>> - MenuUnpost $w - return - } - if {[string equal [$w type active] "cascade"]} { - $w postcascade active - set menu [$w entrycget active -menu] - MenuFirstEntry $menu - } elseif {[string equal [$w type active] "tearoff"]} { - ::tk::TearOffMenu $w - MenuUnpost $w - } elseif {[string equal [$w cget -type] "menubar"]} { - $w postcascade none - set active [$w index active] - set isCascade [string equal [$w type $active] "cascade"] - - # Only de-activate the active item if it's a cascade; this prevents - # the annoying "activation flicker" you otherwise get with - # checkbuttons/commands/etc. on menubars - - if { $isCascade } { - $w activate none - event generate $w <<MenuSelect>> - } - - MenuUnpost $w - - # If the active item is not a cascade, invoke it. This enables - # the use of checkbuttons/commands/etc. on menubars (which is legal, - # but not recommended) - - if { !$isCascade } { - uplevel #0 [list $w invoke $active] - } - } else { - MenuUnpost $w - uplevel #0 [list $w invoke active] - } -} - -# ::tk::MenuEscape -- -# This procedure is invoked for the Cancel (or Escape) key. It unposts -# the given menu and, if it is the top-level menu for a menu button, -# unposts the menu button as well. -# -# Arguments: -# menu - Name of the menu window. - -proc ::tk::MenuEscape menu { - set parent [winfo parent $menu] - if {[string compare [winfo class $parent] "Menu"]} { - MenuUnpost $menu - } elseif {[string equal [$parent cget -type] "menubar"]} { - MenuUnpost $menu - RestoreOldGrab - } else { - MenuNextMenu $menu left - } -} - -# The following routines handle arrow keys. Arrow keys behave -# differently depending on whether the menu is a menu bar or not. - -proc ::tk::MenuUpArrow {menu} { - if {[string equal [$menu cget -type] "menubar"]} { - MenuNextMenu $menu left - } else { - MenuNextEntry $menu -1 - } -} - -proc ::tk::MenuDownArrow {menu} { - if {[string equal [$menu cget -type] "menubar"]} { - MenuNextMenu $menu right - } else { - MenuNextEntry $menu 1 - } -} - -proc ::tk::MenuLeftArrow {menu} { - if {[string equal [$menu cget -type] "menubar"]} { - MenuNextEntry $menu -1 - } else { - MenuNextMenu $menu left - } -} - -proc ::tk::MenuRightArrow {menu} { - if {[string equal [$menu cget -type] "menubar"]} { - MenuNextEntry $menu 1 - } else { - MenuNextMenu $menu right - } -} - -# ::tk::MenuNextMenu -- -# This procedure is invoked to handle "left" and "right" traversal -# motions in menus. It traverses to the next menu in a menu bar, -# or into or out of a cascaded menu. -# -# Arguments: -# menu - The menu that received the keyboard -# event. -# direction - Direction in which to move: "left" or "right" - -proc ::tk::MenuNextMenu {menu direction} { - variable ::tk::Priv - - # First handle traversals into and out of cascaded menus. - - if {[string equal $direction "right"]} { - set count 1 - set parent [winfo parent $menu] - set class [winfo class $parent] - if {[string equal [$menu type active] "cascade"]} { - $menu postcascade active - set m2 [$menu entrycget active -menu] - if {[string compare $m2 ""]} { - MenuFirstEntry $m2 - } - return - } else { - set parent [winfo parent $menu] - while {[string compare $parent "."]} { - if {[string equal [winfo class $parent] "Menu"] \ - && [string equal [$parent cget -type] "menubar"]} { - tk_menuSetFocus $parent - MenuNextEntry $parent 1 - return - } - set parent [winfo parent $parent] - } - } - } else { - set count -1 - set m2 [winfo parent $menu] - if {[string equal [winfo class $m2] "Menu"]} { - $menu activate none - GenerateMenuSelect $menu - tk_menuSetFocus $m2 - - $m2 postcascade none - - if {[string compare [$m2 cget -type] "menubar"]} { - return - } - } - } - - # Can't traverse into or out of a cascaded menu. Go to the next - # or previous menubutton, if that makes sense. - - set m2 [winfo parent $menu] - if {[string equal [winfo class $m2] "Menu"]} { - if {[string equal [$m2 cget -type] "menubar"]} { - tk_menuSetFocus $m2 - MenuNextEntry $m2 -1 - return - } - } - - set w $Priv(postedMb) - if {[string equal $w ""]} { - return - } - set buttons [winfo children [winfo parent $w]] - set length [llength $buttons] - set i [expr {[lsearch -exact $buttons $w] + $count}] - while {1} { - while {$i < 0} { - incr i $length - } - while {$i >= $length} { - incr i -$length - } - set mb [lindex $buttons $i] - if {[string equal [winfo class $mb] "Menubutton"] \ - && [string compare [$mb cget -state] "disabled"] \ - && [string compare [$mb cget -menu] ""] \ - && [string compare [[$mb cget -menu] index last] "none"]} { - break - } - if {[string equal $mb $w]} { - return - } - incr i $count - } - MbPost $mb - MenuFirstEntry [$mb cget -menu] -} - -# ::tk::MenuNextEntry -- -# Activate the next higher or lower entry in the posted menu, -# wrapping around at the ends. Disabled entries are skipped. -# -# Arguments: -# menu - Menu window that received the keystroke. -# count - 1 means go to the next lower entry, -# -1 means go to the next higher entry. - -proc ::tk::MenuNextEntry {menu count} { - - if {[string equal [$menu index last] "none"]} { - return - } - set length [expr {[$menu index last]+1}] - set quitAfter $length - set active [$menu index active] - if {[string equal $active "none"]} { - set i 0 - } else { - set i [expr {$active + $count}] - } - while {1} { - if {$quitAfter <= 0} { - # We've tried every entry in the menu. Either there are - # none, or they're all disabled. Just give up. - - return - } - while {$i < 0} { - incr i $length - } - while {$i >= $length} { - incr i -$length - } - if {[catch {$menu entrycget $i -state} state] == 0} { - if {$state ne "disabled" && \ - ($i!=0 || [$menu cget -type] ne "tearoff" \ - || [$menu type 0] ne "tearoff")} { - break - } - } - if {$i == $active} { - return - } - incr i $count - incr quitAfter -1 - } - $menu activate $i - GenerateMenuSelect $menu - - if {[string equal [$menu type $i] "cascade"] \ - && [string equal [$menu cget -type] "menubar"]} { - set cascade [$menu entrycget $i -menu] - if {[string compare $cascade ""]} { - # Here we auto-post a cascade. This is necessary when - # we traverse left/right in the menubar, but undesirable when - # we traverse up/down in a menu. - $menu postcascade $i - MenuFirstEntry $cascade - } - } -} - -# ::tk::MenuFind -- -# 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 -# underlined character is "char". -# It returns the name of that window, if found, or an -# empty string if no matching window was found. If "char" is an -# empty string then the procedure returns the name of the first -# menubutton found that isn't disabled. -# -# Arguments: -# w - Name of window where key was typed. -# char - Underlined character to search for; -# may be either upper or lower case, and -# will match either upper or lower case. - -proc ::tk::MenuFind {w char} { - set char [string tolower $char] - set windowlist [winfo child $w] - - foreach child $windowlist { - # Don't descend into other toplevels. - if {[string compare [winfo toplevel $w] [winfo toplevel $child]]} { - continue - } - if {[string equal [winfo class $child] "Menu"] && \ - [string equal [$child cget -type] "menubar"]} { - if {[string equal $char ""]} { - return $child - } - set last [$child index last] - for {set i [$child cget -tearoff]} {$i <= $last} {incr i} { - if {[string equal [$child type $i] "separator"]} { - continue - } - set char2 [string index [$child entrycget $i -label] \ - [$child entrycget $i -underline]] - if {[string equal $char [string tolower $char2]] \ - || [string equal $char ""]} { - if {[string compare [$child entrycget $i -state] "disabled"]} { - return $child - } - } - } - } - } - - foreach child $windowlist { - # Don't descend into other toplevels. - if {[string compare [winfo toplevel $w] [winfo toplevel $child]]} { - continue - } - switch [winfo class $child] { - Menubutton { - set char2 [string index [$child cget -text] \ - [$child cget -underline]] - if {[string equal $char [string tolower $char2]] \ - || [string equal $char ""]} { - if {[string compare [$child cget -state] "disabled"]} { - return $child - } - } - } - - default { - set match [MenuFind $child $char] - if {[string compare $match ""]} { - return $match - } - } - } - } - return {} -} - -# ::tk::TraverseToMenu -- -# This procedure implements keyboard traversal of menus. Given an -# ASCII character "char", it looks for a menubutton with that character -# underlined. If one is found, it posts the menubutton's menu -# -# Arguments: -# w - Window in which the key was typed (selects -# a toplevel window). -# char - Character that selects a menu. The case -# is ignored. If an empty string, nothing -# happens. - -proc ::tk::TraverseToMenu {w char} { - variable ::tk::Priv - if {[string equal $char ""]} { - return - } - while {[string equal [winfo class $w] "Menu"]} { - if {[string compare [$w cget -type] "menubar"] \ - && [string equal $Priv(postedMb) ""]} { - return - } - if {[string equal [$w cget -type] "menubar"]} { - break - } - set w [winfo parent $w] - } - set w [MenuFind [winfo toplevel $w] $char] - if {[string compare $w ""]} { - if {[string equal [winfo class $w] "Menu"]} { - tk_menuSetFocus $w - set Priv(window) $w - SaveGrabInfo $w - grab -global $w - TraverseWithinMenu $w $char - } else { - MbPost $w - MenuFirstEntry [$w cget -menu] - } - } -} - -# ::tk::FirstMenu -- -# This procedure traverses to the first menubutton in the toplevel -# for a given window, and posts that menubutton's menu. -# -# Arguments: -# w - Name of a window. Selects which toplevel -# to search for menubuttons. - -proc ::tk::FirstMenu w { - variable ::tk::Priv - set w [MenuFind [winfo toplevel $w] ""] - if {[string compare $w ""]} { - if {[string equal [winfo class $w] "Menu"]} { - tk_menuSetFocus $w - set Priv(window) $w - SaveGrabInfo $w - grab -global $w - MenuFirstEntry $w - } else { - MbPost $w - MenuFirstEntry [$w cget -menu] - } - } -} - -# ::tk::TraverseWithinMenu -# This procedure implements keyboard traversal within a menu. It -# searches for an entry in the menu that has "char" underlined. If -# such an entry is found, it is invoked and the menu is unposted. -# -# Arguments: -# w - The name of the menu widget. -# char - The character to look for; case is -# ignored. If the string is empty then -# nothing happens. - -proc ::tk::TraverseWithinMenu {w char} { - if {[string equal $char ""]} { - return - } - set char [string tolower $char] - set last [$w index last] - if {[string equal $last "none"]} { - return - } - for {set i 0} {$i <= $last} {incr i} { - if {[catch {set char2 [string index \ - [$w entrycget $i -label] [$w entrycget $i -underline]]}]} { - continue - } - if {[string equal $char [string tolower $char2]]} { - if {[string equal [$w type $i] "cascade"]} { - $w activate $i - $w postcascade active - event generate $w <<MenuSelect>> - set m2 [$w entrycget $i -menu] - if {[string compare $m2 ""]} { - MenuFirstEntry $m2 - } - } else { - MenuUnpost $w - uplevel #0 [list $w invoke $i] - } - return - } - } -} - -# ::tk::MenuFirstEntry -- -# Given a menu, this procedure finds the first entry that isn't -# disabled or a tear-off or separator, and activates that entry. -# However, if there is already an active entry in the menu (e.g., -# because of a previous call to tk::PostOverPoint) then the active -# entry isn't changed. This procedure also sets the input focus -# to the menu. -# -# Arguments: -# menu - Name of the menu window (possibly empty). - -proc ::tk::MenuFirstEntry menu { - if {[string equal $menu ""]} { - return - } - tk_menuSetFocus $menu - if {[string compare [$menu index active] "none"]} { - return - } - set last [$menu index last] - if {[string equal $last "none"]} { - return - } - for {set i 0} {$i <= $last} {incr i} { - if {([catch {set state [$menu entrycget $i -state]}] == 0) \ - && [string compare $state "disabled"] \ - && [string compare [$menu type $i] "tearoff"]} { - $menu activate $i - GenerateMenuSelect $menu - # 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 - # menus getting posted (bug 676) - if {[string equal [$menu type $i] "cascade"] && \ - [string equal [$menu cget -type] "menubar"]} { - set cascade [$menu entrycget $i -menu] - if {[string compare $cascade ""]} { - $menu postcascade $i - MenuFirstEntry $cascade - } - } - return - } - } -} - -# ::tk::MenuFindName -- -# Given a menu and a text string, return the index of the menu entry -# that displays the string as its label. If there is no such entry, -# return an empty string. This procedure is tricky because some names -# like "active" have a special meaning in menu commands, so we can't -# always use the "index" widget command. -# -# Arguments: -# menu - Name of the menu widget. -# s - String to look for. - -proc ::tk::MenuFindName {menu s} { - set i "" - if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} { - catch {set i [$menu index $s]} - return $i - } - set last [$menu index last] - if {[string equal $last "none"]} { - return - } - for {set i 0} {$i <= $last} {incr i} { - if {![catch {$menu entrycget $i -label} label]} { - if {[string equal $label $s]} { - return $i - } - } - } - return "" -} - -# ::tk::PostOverPoint -- -# This procedure posts a given menu such that a given entry in the -# menu is centered over a given point in the root window. It also -# activates the given entry. -# -# Arguments: -# menu - Menu to post. -# x, y - Root coordinates of point. -# entry - Index of entry within menu to center over (x,y). -# If omitted or specified as {}, then the menu's -# upper-left corner goes at (x,y). - -proc ::tk::PostOverPoint {menu x y {entry {}}} { - global tcl_platform - - if {[string compare $entry {}]} { - if {$entry == [$menu index last]} { - incr y [expr {-([$menu yposition $entry] \ - + [winfo reqheight $menu])/2}] - } else { - incr y [expr {-([$menu yposition $entry] \ - + [$menu yposition [expr {$entry+1}]])/2}] - } - incr x [expr {-[winfo reqwidth $menu]/2}] - } - if {$tcl_platform(platform) == "windows"} { - # We need to fix some problems with menu posting on Windows. - set yoffset [expr {[winfo screenheight $menu] \ - - $y - [winfo reqheight $menu]}] - if {$yoffset < 0} { - # The bottom of the menu is offscreen, so adjust upwards - incr y $yoffset - if {$y < 0} { set y 0 } - } - # If we're off the top of the screen (either because we were - # originally or because we just adjusted too far upwards), - # then make the menu popup on the top edge. - if {$y < 0} { - set y 0 - } - } - $menu post $x $y - if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} { - $menu activate $entry - GenerateMenuSelect $menu - } -} - -# ::tk::SaveGrabInfo -- -# Sets the variables tk::Priv(oldGrab) and tk::Priv(grabStatus) to record -# the state of any existing grab on the w's display. -# -# Arguments: -# w - Name of a window; used to select the display -# whose grab information is to be recorded. - -proc tk::SaveGrabInfo w { - variable ::tk::Priv - set Priv(oldGrab) [grab current $w] - if {$Priv(oldGrab) ne ""} { - set Priv(grabStatus) [grab status $Priv(oldGrab)] - } -} - -# ::tk::RestoreOldGrab -- -# Restores the grab to what it was before TkSaveGrabInfo was called. -# - -proc ::tk::RestoreOldGrab {} { - variable ::tk::Priv - - if {$Priv(oldGrab) ne ""} { - # Be careful restoring the old grab, since it's window may not - # be visible anymore. - - catch { - if {[string equal $Priv(grabStatus) "global"]} { - grab set -global $Priv(oldGrab) - } else { - grab set $Priv(oldGrab) - } - } - set Priv(oldGrab) "" - } -} - -proc ::tk_menuSetFocus {menu} { - variable ::tk::Priv - if {![info exists Priv(focus)] || [string equal $Priv(focus) {}]} { - set Priv(focus) [focus] - } - focus $menu -} - -proc ::tk::GenerateMenuSelect {menu} { - variable ::tk::Priv - - if {[string equal $Priv(activeMenu) $menu] \ - && [string equal $Priv(activeItem) [$menu index active]]} { - return - } - - set Priv(activeMenu) $menu - set Priv(activeItem) [$menu index active] - event generate $menu <<MenuSelect>> -} - -# ::tk_popup -- -# This procedure pops up a menu and sets things up for traversing -# the menu and its submenus. -# -# Arguments: -# menu - Name of the menu to be popped up. -# x, y - Root coordinates at which to pop up the -# menu. -# entry - Index of a menu entry to center over (x,y). -# If omitted or specified as {}, then menu's -# upper-left corner goes at (x,y). - -proc ::tk_popup {menu x y {entry {}}} { - variable ::tk::Priv - global tcl_platform - if {$Priv(popup) ne "" || $Priv(postedMb) ne ""} { - tk::MenuUnpost {} - } - tk::PostOverPoint $menu $x $y $entry - if {[tk windowingsystem] eq "x11" && [winfo viewable $menu]} { - tk::SaveGrabInfo $menu - grab -global $menu - set Priv(popup) $menu - tk_menuSetFocus $menu - } -} diff --git a/tcl/library/mkpsenc.tcl b/tcl/library/mkpsenc.tcl deleted file mode 100644 index c1cf4129232..00000000000 --- a/tcl/library/mkpsenc.tcl +++ /dev/null @@ -1,1367 +0,0 @@ -# mkpsenc.tcl -- -# -# Creates Postscript encoding vector for given encoding -# - -proc ::tk::CreatePostscriptEncoding {encoding} { - # now check for known. Even if it is known, it can be other - # than we need. GhostScript seems to be happy with such approach - set result "/CurrentEncoding \[\n" - for {set i 0} {$i<256} {incr i 8} { - for {set j 0} {$j<8} {incr j} { - set enc [encoding convertfrom $encoding [format %c [expr {$i+$j}]]] - if {[catch {format %04X [scan $enc %c]} hexcode]} {set hexcode {}} - if [info exists ::tk::psglyphs($hexcode)] { - append result "/$::tk::psglyphs($hexcode)" - } else { - append result "/space" - } - } - append result "\n" - } - append result "\] def\n" - return $result -} - -# List of adobe glyph names. Converted from glyphlist.txt, downloaded -# from Adobe - -namespace eval ::tk { -array set psglyphs { - 0020 space - 0021 exclam - 0022 quotedbl - 0023 numbersign - 0024 dollar - 0025 percent - 0026 ampersand - 0027 quotesingle - 0028 parenleft - 0029 parenright - 002A asterisk - 002B plus - 002C comma - 002D hyphen - 002E period - 002F slash - 0030 zero - 0031 one - 0032 two - 0033 three - 0034 four - 0035 five - 0036 six - 0037 seven - 0038 eight - 0039 nine - 003A colon - 003B semicolon - 003C less - 003D equal - 003E greater - 003F question - 0040 at - 0041 A - 0042 B - 0043 C - 0044 D - 0045 E - 0046 F - 0047 G - 0048 H - 0049 I - 004A J - 004B K - 004C L - 004D M - 004E N - 004F O - 0050 P - 0051 Q - 0052 R - 0053 S - 0054 T - 0055 U - 0056 V - 0057 W - 0058 X - 0059 Y - 005A Z - 005B bracketleft - 005C backslash - 005D bracketright - 005E asciicircum - 005F underscore - 0060 grave - 0061 a - 0062 b - 0063 c - 0064 d - 0065 e - 0066 f - 0067 g - 0068 h - 0069 i - 006A j - 006B k - 006C l - 006D m - 006E n - 006F o - 0070 p - 0071 q - 0072 r - 0073 s - 0074 t - 0075 u - 0076 v - 0077 w - 0078 x - 0079 y - 007A z - 007B braceleft - 007C bar - 007D braceright - 007E asciitilde - 00A0 space - 00A1 exclamdown - 00A2 cent - 00A3 sterling - 00A4 currency - 00A5 yen - 00A6 brokenbar - 00A7 section - 00A8 dieresis - 00A9 copyright - 00AA ordfeminine - 00AB guillemotleft - 00AC logicalnot - 00AD hyphen - 00AE registered - 00AF macron - 00B0 degree - 00B1 plusminus - 00B2 twosuperior - 00B3 threesuperior - 00B4 acute - 00B5 mu - 00B6 paragraph - 00B7 periodcentered - 00B8 cedilla - 00B9 onesuperior - 00BA ordmasculine - 00BB guillemotright - 00BC onequarter - 00BD onehalf - 00BE threequarters - 00BF questiondown - 00C0 Agrave - 00C1 Aacute - 00C2 Acircumflex - 00C3 Atilde - 00C4 Adieresis - 00C5 Aring - 00C6 AE - 00C7 Ccedilla - 00C8 Egrave - 00C9 Eacute - 00CA Ecircumflex - 00CB Edieresis - 00CC Igrave - 00CD Iacute - 00CE Icircumflex - 00CF Idieresis - 00D0 Eth - 00D1 Ntilde - 00D2 Ograve - 00D3 Oacute - 00D4 Ocircumflex - 00D5 Otilde - 00D6 Odieresis - 00D7 multiply - 00D8 Oslash - 00D9 Ugrave - 00DA Uacute - 00DB Ucircumflex - 00DC Udieresis - 00DD Yacute - 00DE Thorn - 00DF germandbls - 00E0 agrave - 00E1 aacute - 00E2 acircumflex - 00E3 atilde - 00E4 adieresis - 00E5 aring - 00E6 ae - 00E7 ccedilla - 00E8 egrave - 00E9 eacute - 00EA ecircumflex - 00EB edieresis - 00EC igrave - 00ED iacute - 00EE icircumflex - 00EF idieresis - 00F0 eth - 00F1 ntilde - 00F2 ograve - 00F3 oacute - 00F4 ocircumflex - 00F5 otilde - 00F6 odieresis - 00F7 divide - 00F8 oslash - 00F9 ugrave - 00FA uacute - 00FB ucircumflex - 00FC udieresis - 00FD yacute - 00FE thorn - 00FF ydieresis - 0100 Amacron - 0101 amacron - 0102 Abreve - 0103 abreve - 0104 Aogonek - 0105 aogonek - 0106 Cacute - 0107 cacute - 0108 Ccircumflex - 0109 ccircumflex - 010A Cdotaccent - 010B cdotaccent - 010C Ccaron - 010D ccaron - 010E Dcaron - 010F dcaron - 0110 Dcroat - 0111 dcroat - 0112 Emacron - 0113 emacron - 0114 Ebreve - 0115 ebreve - 0116 Edotaccent - 0117 edotaccent - 0118 Eogonek - 0119 eogonek - 011A Ecaron - 011B ecaron - 011C Gcircumflex - 011D gcircumflex - 011E Gbreve - 011F gbreve - 0120 Gdotaccent - 0121 gdotaccent - 0122 Gcommaaccent - 0123 gcommaaccent - 0124 Hcircumflex - 0125 hcircumflex - 0126 Hbar - 0127 hbar - 0128 Itilde - 0129 itilde - 012A Imacron - 012B imacron - 012C Ibreve - 012D ibreve - 012E Iogonek - 012F iogonek - 0130 Idotaccent - 0131 dotlessi - 0132 IJ - 0133 ij - 0134 Jcircumflex - 0135 jcircumflex - 0136 Kcommaaccent - 0137 kcommaaccent - 0138 kgreenlandic - 0139 Lacute - 013A lacute - 013B Lcommaaccent - 013C lcommaaccent - 013D Lcaron - 013E lcaron - 013F Ldot - 0140 ldot - 0141 Lslash - 0142 lslash - 0143 Nacute - 0144 nacute - 0145 Ncommaaccent - 0146 ncommaaccent - 0147 Ncaron - 0148 ncaron - 0149 napostrophe - 014A Eng - 014B eng - 014C Omacron - 014D omacron - 014E Obreve - 014F obreve - 0150 Ohungarumlaut - 0151 ohungarumlaut - 0152 OE - 0153 oe - 0154 Racute - 0155 racute - 0156 Rcommaaccent - 0157 rcommaaccent - 0158 Rcaron - 0159 rcaron - 015A Sacute - 015B sacute - 015C Scircumflex - 015D scircumflex - 015E Scedilla - 015F scedilla - 0160 Scaron - 0161 scaron - 0162 Tcommaaccent - 0163 tcommaaccent - 0164 Tcaron - 0165 tcaron - 0166 Tbar - 0167 tbar - 0168 Utilde - 0169 utilde - 016A Umacron - 016B umacron - 016C Ubreve - 016D ubreve - 016E Uring - 016F uring - 0170 Uhungarumlaut - 0171 uhungarumlaut - 0172 Uogonek - 0173 uogonek - 0174 Wcircumflex - 0175 wcircumflex - 0176 Ycircumflex - 0177 ycircumflex - 0178 Ydieresis - 0179 Zacute - 017A zacute - 017B Zdotaccent - 017C zdotaccent - 017D Zcaron - 017E zcaron - 017F longs - 0192 florin - 01A0 Ohorn - 01A1 ohorn - 01AF Uhorn - 01B0 uhorn - 01E6 Gcaron - 01E7 gcaron - 01FA Aringacute - 01FB aringacute - 01FC AEacute - 01FD aeacute - 01FE Oslashacute - 01FF oslashacute - 0218 Scommaaccent - 0219 scommaaccent - 021A Tcommaaccent - 021B tcommaaccent - 02BC afii57929 - 02BD afii64937 - 02C6 circumflex - 02C7 caron - 02C9 macron - 02D8 breve - 02D9 dotaccent - 02DA ring - 02DB ogonek - 02DC tilde - 02DD hungarumlaut - 0300 gravecomb - 0301 acutecomb - 0303 tildecomb - 0309 hookabovecomb - 0323 dotbelowcomb - 0384 tonos - 0385 dieresistonos - 0386 Alphatonos - 0387 anoteleia - 0388 Epsilontonos - 0389 Etatonos - 038A Iotatonos - 038C Omicrontonos - 038E Upsilontonos - 038F Omegatonos - 0390 iotadieresistonos - 0391 Alpha - 0392 Beta - 0393 Gamma - 0394 Delta - 0395 Epsilon - 0396 Zeta - 0397 Eta - 0398 Theta - 0399 Iota - 039A Kappa - 039B Lambda - 039C Mu - 039D Nu - 039E Xi - 039F Omicron - 03A0 Pi - 03A1 Rho - 03A3 Sigma - 03A4 Tau - 03A5 Upsilon - 03A6 Phi - 03A7 Chi - 03A8 Psi - 03A9 Omega - 03AA Iotadieresis - 03AB Upsilondieresis - 03AC alphatonos - 03AD epsilontonos - 03AE etatonos - 03AF iotatonos - 03B0 upsilondieresistonos - 03B1 alpha - 03B2 beta - 03B3 gamma - 03B4 delta - 03B5 epsilon - 03B6 zeta - 03B7 eta - 03B8 theta - 03B9 iota - 03BA kappa - 03BB lambda - 03BC mu - 03BD nu - 03BE xi - 03BF omicron - 03C0 pi - 03C1 rho - 03C2 sigma1 - 03C3 sigma - 03C4 tau - 03C5 upsilon - 03C6 phi - 03C7 chi - 03C8 psi - 03C9 omega - 03CA iotadieresis - 03CB upsilondieresis - 03CC omicrontonos - 03CD upsilontonos - 03CE omegatonos - 03D1 theta1 - 03D2 Upsilon1 - 03D5 phi1 - 03D6 omega1 - 0401 afii10023 - 0402 afii10051 - 0403 afii10052 - 0404 afii10053 - 0405 afii10054 - 0406 afii10055 - 0407 afii10056 - 0408 afii10057 - 0409 afii10058 - 040A afii10059 - 040B afii10060 - 040C afii10061 - 040E afii10062 - 040F afii10145 - 0410 afii10017 - 0411 afii10018 - 0412 afii10019 - 0413 afii10020 - 0414 afii10021 - 0415 afii10022 - 0416 afii10024 - 0417 afii10025 - 0418 afii10026 - 0419 afii10027 - 041A afii10028 - 041B afii10029 - 041C afii10030 - 041D afii10031 - 041E afii10032 - 041F afii10033 - 0420 afii10034 - 0421 afii10035 - 0422 afii10036 - 0423 afii10037 - 0424 afii10038 - 0425 afii10039 - 0426 afii10040 - 0427 afii10041 - 0428 afii10042 - 0429 afii10043 - 042A afii10044 - 042B afii10045 - 042C afii10046 - 042D afii10047 - 042E afii10048 - 042F afii10049 - 0430 afii10065 - 0431 afii10066 - 0432 afii10067 - 0433 afii10068 - 0434 afii10069 - 0435 afii10070 - 0436 afii10072 - 0437 afii10073 - 0438 afii10074 - 0439 afii10075 - 043A afii10076 - 043B afii10077 - 043C afii10078 - 043D afii10079 - 043E afii10080 - 043F afii10081 - 0440 afii10082 - 0441 afii10083 - 0442 afii10084 - 0443 afii10085 - 0444 afii10086 - 0445 afii10087 - 0446 afii10088 - 0447 afii10089 - 0448 afii10090 - 0449 afii10091 - 044A afii10092 - 044B afii10093 - 044C afii10094 - 044D afii10095 - 044E afii10096 - 044F afii10097 - 0451 afii10071 - 0452 afii10099 - 0453 afii10100 - 0454 afii10101 - 0455 afii10102 - 0456 afii10103 - 0457 afii10104 - 0458 afii10105 - 0459 afii10106 - 045A afii10107 - 045B afii10108 - 045C afii10109 - 045E afii10110 - 045F afii10193 - 0462 afii10146 - 0463 afii10194 - 0472 afii10147 - 0473 afii10195 - 0474 afii10148 - 0475 afii10196 - 0490 afii10050 - 0491 afii10098 - 04D9 afii10846 - 05B0 afii57799 - 05B1 afii57801 - 05B2 afii57800 - 05B3 afii57802 - 05B4 afii57793 - 05B5 afii57794 - 05B6 afii57795 - 05B7 afii57798 - 05B8 afii57797 - 05B9 afii57806 - 05BB afii57796 - 05BC afii57807 - 05BD afii57839 - 05BE afii57645 - 05BF afii57841 - 05C0 afii57842 - 05C1 afii57804 - 05C2 afii57803 - 05C3 afii57658 - 05D0 afii57664 - 05D1 afii57665 - 05D2 afii57666 - 05D3 afii57667 - 05D4 afii57668 - 05D5 afii57669 - 05D6 afii57670 - 05D7 afii57671 - 05D8 afii57672 - 05D9 afii57673 - 05DA afii57674 - 05DB afii57675 - 05DC afii57676 - 05DD afii57677 - 05DE afii57678 - 05DF afii57679 - 05E0 afii57680 - 05E1 afii57681 - 05E2 afii57682 - 05E3 afii57683 - 05E4 afii57684 - 05E5 afii57685 - 05E6 afii57686 - 05E7 afii57687 - 05E8 afii57688 - 05E9 afii57689 - 05EA afii57690 - 05F0 afii57716 - 05F1 afii57717 - 05F2 afii57718 - 060C afii57388 - 061B afii57403 - 061F afii57407 - 0621 afii57409 - 0622 afii57410 - 0623 afii57411 - 0624 afii57412 - 0625 afii57413 - 0626 afii57414 - 0627 afii57415 - 0628 afii57416 - 0629 afii57417 - 062A afii57418 - 062B afii57419 - 062C afii57420 - 062D afii57421 - 062E afii57422 - 062F afii57423 - 0630 afii57424 - 0631 afii57425 - 0632 afii57426 - 0633 afii57427 - 0634 afii57428 - 0635 afii57429 - 0636 afii57430 - 0637 afii57431 - 0638 afii57432 - 0639 afii57433 - 063A afii57434 - 0640 afii57440 - 0641 afii57441 - 0642 afii57442 - 0643 afii57443 - 0644 afii57444 - 0645 afii57445 - 0646 afii57446 - 0647 afii57470 - 0648 afii57448 - 0649 afii57449 - 064A afii57450 - 064B afii57451 - 064C afii57452 - 064D afii57453 - 064E afii57454 - 064F afii57455 - 0650 afii57456 - 0651 afii57457 - 0652 afii57458 - 0660 afii57392 - 0661 afii57393 - 0662 afii57394 - 0663 afii57395 - 0664 afii57396 - 0665 afii57397 - 0666 afii57398 - 0667 afii57399 - 0668 afii57400 - 0669 afii57401 - 066A afii57381 - 066D afii63167 - 0679 afii57511 - 067E afii57506 - 0686 afii57507 - 0688 afii57512 - 0691 afii57513 - 0698 afii57508 - 06A4 afii57505 - 06AF afii57509 - 06BA afii57514 - 06D2 afii57519 - 06D5 afii57534 - 1E80 Wgrave - 1E81 wgrave - 1E82 Wacute - 1E83 wacute - 1E84 Wdieresis - 1E85 wdieresis - 1EF2 Ygrave - 1EF3 ygrave - 200C afii61664 - 200D afii301 - 200E afii299 - 200F afii300 - 2012 figuredash - 2013 endash - 2014 emdash - 2015 afii00208 - 2017 underscoredbl - 2018 quoteleft - 2019 quoteright - 201A quotesinglbase - 201B quotereversed - 201C quotedblleft - 201D quotedblright - 201E quotedblbase - 2020 dagger - 2021 daggerdbl - 2022 bullet - 2024 onedotenleader - 2025 twodotenleader - 2026 ellipsis - 202C afii61573 - 202D afii61574 - 202E afii61575 - 2030 perthousand - 2032 minute - 2033 second - 2039 guilsinglleft - 203A guilsinglright - 203C exclamdbl - 2044 fraction - 2070 zerosuperior - 2074 foursuperior - 2075 fivesuperior - 2076 sixsuperior - 2077 sevensuperior - 2078 eightsuperior - 2079 ninesuperior - 207D parenleftsuperior - 207E parenrightsuperior - 207F nsuperior - 2080 zeroinferior - 2081 oneinferior - 2082 twoinferior - 2083 threeinferior - 2084 fourinferior - 2085 fiveinferior - 2086 sixinferior - 2087 seveninferior - 2088 eightinferior - 2089 nineinferior - 208D parenleftinferior - 208E parenrightinferior - 20A1 colonmonetary - 20A3 franc - 20A4 lira - 20A7 peseta - 20AA afii57636 - 20AB dong - 20AC Euro - 2105 afii61248 - 2111 Ifraktur - 2113 afii61289 - 2116 afii61352 - 2118 weierstrass - 211C Rfraktur - 211E prescription - 2122 trademark - 2126 Omega - 212E estimated - 2135 aleph - 2153 onethird - 2154 twothirds - 215B oneeighth - 215C threeeighths - 215D fiveeighths - 215E seveneighths - 2190 arrowleft - 2191 arrowup - 2192 arrowright - 2193 arrowdown - 2194 arrowboth - 2195 arrowupdn - 21A8 arrowupdnbse - 21B5 carriagereturn - 21D0 arrowdblleft - 21D1 arrowdblup - 21D2 arrowdblright - 21D3 arrowdbldown - 21D4 arrowdblboth - 2200 universal - 2202 partialdiff - 2203 existential - 2205 emptyset - 2206 Delta - 2207 gradient - 2208 element - 2209 notelement - 220B suchthat - 220F product - 2211 summation - 2212 minus - 2215 fraction - 2217 asteriskmath - 2219 periodcentered - 221A radical - 221D proportional - 221E infinity - 221F orthogonal - 2220 angle - 2227 logicaland - 2228 logicalor - 2229 intersection - 222A union - 222B integral - 2234 therefore - 223C similar - 2245 congruent - 2248 approxequal - 2260 notequal - 2261 equivalence - 2264 lessequal - 2265 greaterequal - 2282 propersubset - 2283 propersuperset - 2284 notsubset - 2286 reflexsubset - 2287 reflexsuperset - 2295 circleplus - 2297 circlemultiply - 22A5 perpendicular - 22C5 dotmath - 2302 house - 2310 revlogicalnot - 2320 integraltp - 2321 integralbt - 2329 angleleft - 232A angleright - 2500 SF100000 - 2502 SF110000 - 250C SF010000 - 2510 SF030000 - 2514 SF020000 - 2518 SF040000 - 251C SF080000 - 2524 SF090000 - 252C SF060000 - 2534 SF070000 - 253C SF050000 - 2550 SF430000 - 2551 SF240000 - 2552 SF510000 - 2553 SF520000 - 2554 SF390000 - 2555 SF220000 - 2556 SF210000 - 2557 SF250000 - 2558 SF500000 - 2559 SF490000 - 255A SF380000 - 255B SF280000 - 255C SF270000 - 255D SF260000 - 255E SF360000 - 255F SF370000 - 2560 SF420000 - 2561 SF190000 - 2562 SF200000 - 2563 SF230000 - 2564 SF470000 - 2565 SF480000 - 2566 SF410000 - 2567 SF450000 - 2568 SF460000 - 2569 SF400000 - 256A SF540000 - 256B SF530000 - 256C SF440000 - 2580 upblock - 2584 dnblock - 2588 block - 258C lfblock - 2590 rtblock - 2591 ltshade - 2592 shade - 2593 dkshade - 25A0 filledbox - 25A1 H22073 - 25AA H18543 - 25AB H18551 - 25AC filledrect - 25B2 triagup - 25BA triagrt - 25BC triagdn - 25C4 triaglf - 25CA lozenge - 25CB circle - 25CF H18533 - 25D8 invbullet - 25D9 invcircle - 25E6 openbullet - 263A smileface - 263B invsmileface - 263C sun - 2640 female - 2642 male - 2660 spade - 2663 club - 2665 heart - 2666 diamond - 266A musicalnote - 266B musicalnotedbl - F6BE dotlessj - F6BF LL - F6C0 ll - F6C1 Scedilla - F6C2 scedilla - F6C3 commaaccent - F6C4 afii10063 - F6C5 afii10064 - F6C6 afii10192 - F6C7 afii10831 - F6C8 afii10832 - F6C9 Acute - F6CA Caron - F6CB Dieresis - F6CC DieresisAcute - F6CD DieresisGrave - F6CE Grave - F6CF Hungarumlaut - F6D0 Macron - F6D1 cyrBreve - F6D2 cyrFlex - F6D3 dblGrave - F6D4 cyrbreve - F6D5 cyrflex - F6D6 dblgrave - F6D7 dieresisacute - F6D8 dieresisgrave - F6D9 copyrightserif - F6DA registerserif - F6DB trademarkserif - F6DC onefitted - F6DD rupiah - F6DE threequartersemdash - F6DF centinferior - F6E0 centsuperior - F6E1 commainferior - F6E2 commasuperior - F6E3 dollarinferior - F6E4 dollarsuperior - F6E5 hypheninferior - F6E6 hyphensuperior - F6E7 periodinferior - F6E8 periodsuperior - F6E9 asuperior - F6EA bsuperior - F6EB dsuperior - F6EC esuperior - F6ED isuperior - F6EE lsuperior - F6EF msuperior - F6F0 osuperior - F6F1 rsuperior - F6F2 ssuperior - F6F3 tsuperior - F6F4 Brevesmall - F6F5 Caronsmall - F6F6 Circumflexsmall - F6F7 Dotaccentsmall - F6F8 Hungarumlautsmall - F6F9 Lslashsmall - F6FA OEsmall - F6FB Ogoneksmall - F6FC Ringsmall - F6FD Scaronsmall - F6FE Tildesmall - F6FF Zcaronsmall - F721 exclamsmall - F724 dollaroldstyle - F726 ampersandsmall - F730 zerooldstyle - F731 oneoldstyle - F732 twooldstyle - F733 threeoldstyle - F734 fouroldstyle - F735 fiveoldstyle - F736 sixoldstyle - F737 sevenoldstyle - F738 eightoldstyle - F739 nineoldstyle - F73F questionsmall - F760 Gravesmall - F761 Asmall - F762 Bsmall - F763 Csmall - F764 Dsmall - F765 Esmall - F766 Fsmall - F767 Gsmall - F768 Hsmall - F769 Ismall - F76A Jsmall - F76B Ksmall - F76C Lsmall - F76D Msmall - F76E Nsmall - F76F Osmall - F770 Psmall - F771 Qsmall - F772 Rsmall - F773 Ssmall - F774 Tsmall - F775 Usmall - F776 Vsmall - F777 Wsmall - F778 Xsmall - F779 Ysmall - F77A Zsmall - F7A1 exclamdownsmall - F7A2 centoldstyle - F7A8 Dieresissmall - F7AF Macronsmall - F7B4 Acutesmall - F7B8 Cedillasmall - F7BF questiondownsmall - F7E0 Agravesmall - F7E1 Aacutesmall - F7E2 Acircumflexsmall - F7E3 Atildesmall - F7E4 Adieresissmall - F7E5 Aringsmall - F7E6 AEsmall - F7E7 Ccedillasmall - F7E8 Egravesmall - F7E9 Eacutesmall - F7EA Ecircumflexsmall - F7EB Edieresissmall - F7EC Igravesmall - F7ED Iacutesmall - F7EE Icircumflexsmall - F7EF Idieresissmall - F7F0 Ethsmall - F7F1 Ntildesmall - F7F2 Ogravesmall - F7F3 Oacutesmall - F7F4 Ocircumflexsmall - F7F5 Otildesmall - F7F6 Odieresissmall - F7F8 Oslashsmall - F7F9 Ugravesmall - F7FA Uacutesmall - F7FB Ucircumflexsmall - F7FC Udieresissmall - F7FD Yacutesmall - F7FE Thornsmall - F7FF Ydieresissmall - F8E5 radicalex - F8E6 arrowvertex - F8E7 arrowhorizex - F8E8 registersans - F8E9 copyrightsans - F8EA trademarksans - F8EB parenlefttp - F8EC parenleftex - F8ED parenleftbt - F8EE bracketlefttp - F8EF bracketleftex - F8F0 bracketleftbt - F8F1 bracelefttp - F8F2 braceleftmid - F8F3 braceleftbt - F8F4 braceex - F8F5 integralex - F8F6 parenrighttp - F8F7 parenrightex - F8F8 parenrightbt - F8F9 bracketrighttp - F8FA bracketrightex - F8FB bracketrightbt - F8FC bracerighttp - F8FD bracerightmid - F8FE bracerightbt - FB00 ff - FB01 fi - FB02 fl - FB03 ffi - FB04 ffl - FB1F afii57705 - FB2A afii57694 - FB2B afii57695 - FB35 afii57723 - FB4B afii57700 -} - -# precalculate entire prolog when this file is loaded -# (to speed things up) -set ps_preamable "%%BeginProlog\n" -append ps_preamable [CreatePostscriptEncoding [encoding system]] -append ps_preamable { -50 dict begin -% This is a standard prolog for Postscript generated by Tk's canvas -% widget. -% RCS: @(#) $Id$ - -% The definitions below just define all of the variables used in -% any of the procedures here. This is needed for obscure reasons -% explained on p. 716 of the Postscript manual (Section H.2.7, -% "Initializing Variables," in the section on Encapsulated Postscript). - -/baseline 0 def -/stipimage 0 def -/height 0 def -/justify 0 def -/lineLength 0 def -/spacing 0 def -/stipple 0 def -/strings 0 def -/xoffset 0 def -/yoffset 0 def -/tmpstip null def - - -/cstringshow { - { - dup type /stringtype eq - { show } { glyphshow } - ifelse - } - forall -} bind def - - - -/cstringwidth { - 0 exch 0 exch - { - dup type /stringtype eq - { stringwidth } { - currentfont /Encoding get exch 1 exch put (\001) stringwidth - } - ifelse - exch 3 1 roll add 3 1 roll add exch - } - forall -} bind def - -% font ISOEncode font -% This procedure changes the encoding of a font from the default -% Postscript encoding to current system encoding. It's typically invoked just -% before invoking "setfont". The body of this procedure comes from -% Section 5.6.1 of the Postscript book. - -/ISOEncode { - dup length dict begin - {1 index /FID ne {def} {pop pop} ifelse} forall - /Encoding CurrentEncoding def - currentdict - end - - % I'm not sure why it's necessary to use "definefont" on this new - % font, but it seems to be important; just use the name "Temporary" - % for the font. - - /Temporary exch definefont -} bind def - -% StrokeClip -% -% This procedure converts the current path into a clip area under -% the assumption of stroking. It's a bit tricky because some Postscript -% interpreters get errors during strokepath for dashed lines. If -% this happens then turn off dashes and try again. - -/StrokeClip { - {strokepath} stopped { - (This Postscript printer gets limitcheck overflows when) = - (stippling dashed lines; lines will be printed solid instead.) = - [] 0 setdash strokepath} if - clip -} bind def - -% desiredSize EvenPixels closestSize -% -% The procedure below is used for stippling. Given the optimal size -% of a dot in a stipple pattern in the current user coordinate system, -% compute the closest size that is an exact multiple of the device's -% pixel size. This allows stipple patterns to be displayed without -% aliasing effects. - -/EvenPixels { - % Compute exact number of device pixels per stipple dot. - dup 0 matrix currentmatrix dtransform - dup mul exch dup mul add sqrt - - % Round to an integer, make sure the number is at least 1, and compute - % user coord distance corresponding to this. - dup round dup 1 lt {pop 1} if - exch div mul -} bind def - -% width height string StippleFill -- -% -% Given a path already set up and a clipping region generated from -% it, this procedure will fill the clipping region with a stipple -% pattern. "String" contains a proper image description of the -% stipple pattern and "width" and "height" give its dimensions. Each -% stipple dot is assumed to be about one unit across in the current -% user coordinate system. This procedure trashes the graphics state. - -/StippleFill { - % The following code is needed to work around a NeWSprint bug. - - /tmpstip 1 index def - - % Change the scaling so that one user unit in user coordinates - % corresponds to the size of one stipple dot. - 1 EvenPixels dup scale - - % Compute the bounding box occupied by the path (which is now - % the clipping region), and round the lower coordinates down - % to the nearest starting point for the stipple pattern. Be - % careful about negative numbers, since the rounding works - % differently on them. - - pathbbox - 4 2 roll - 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll - 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll - - % Stack now: width height string y1 y2 x1 x2 - % Below is a doubly-nested for loop to iterate across this area - % in units of the stipple pattern size, going up columns then - % across rows, blasting out a stipple-pattern-sized rectangle at - % each position - - 6 index exch { - 2 index 5 index 3 index { - % Stack now: width height string y1 y2 x y - - gsave - 1 index exch translate - 5 index 5 index true matrix tmpstip imagemask - grestore - } for - pop - } for - pop pop pop pop pop -} bind def - -% -- AdjustColor -- -% Given a color value already set for output by the caller, adjusts -% that value to a grayscale or mono value if requested by the CL -% variable. - -/AdjustColor { - CL 2 lt { - currentgray - CL 0 eq { - .5 lt {0} {1} ifelse - } if - setgray - } if -} bind def - -% x y strings spacing xoffset yoffset justify stipple DrawText -- -% This procedure does all of the real work of drawing text. The -% color and font must already have been set by the caller, and the -% following arguments must be on the stack: -% -% x, y - Coordinates at which to draw text. -% strings - An array of strings, one for each line of the text item, -% in order from top to bottom. -% spacing - Spacing between lines. -% xoffset - Horizontal offset for text bbox relative to x and y: 0 for -% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se. -% yoffset - Vertical offset for text bbox relative to x and y: 0 for -% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se. -% justify - 0 for left justification, 0.5 for center, 1 for right justify. -% stipple - Boolean value indicating whether or not text is to be -% drawn in stippled fashion. If text is stippled, -% procedure StippleText must have been defined to call -% StippleFill in the right way. -% -% Also, when this procedure is invoked, the color and font must already -% have been set for the text. - -/DrawText { - /stipple exch def - /justify exch def - /yoffset exch def - /xoffset exch def - /spacing exch def - /strings exch def - - % First scan through all of the text to find the widest line. - - /lineLength 0 def - strings { - cstringwidth pop - dup lineLength gt {/lineLength exch def} {pop} ifelse - newpath - } forall - - % Compute the baseline offset and the actual font height. - - 0 0 moveto (TXygqPZ) false charpath - pathbbox dup /baseline exch def - exch pop exch sub /height exch def pop - newpath - - % Translate coordinates first so that the origin is at the upper-left - % corner of the text's bounding box. Remember that x and y for - % positioning are still on the stack. - - translate - lineLength xoffset mul - strings length 1 sub spacing mul height add yoffset mul translate - - % Now use the baseline and justification information to translate so - % that the origin is at the baseline and positioning point for the - % first line of text. - - justify lineLength mul baseline neg translate - - % Iterate over each of the lines to output it. For each line, - % compute its width again so it can be properly justified, then - % display it. - - strings { - dup cstringwidth pop - justify neg mul 0 moveto - stipple { - - - % The text is stippled, so turn it into a path and print - % by calling StippledText, which in turn calls StippleFill. - % Unfortunately, many Postscript interpreters will get - % overflow errors if we try to do the whole string at - % once, so do it a character at a time. - - gsave - /char (X) def - { - dup type /stringtype eq { - % This segment is a string. - { - char 0 3 -1 roll put - currentpoint - gsave - char true charpath clip StippleText - grestore - char stringwidth translate - moveto - } forall - } { - % This segment is glyph name - % Temporary override - currentfont /Encoding get exch 1 exch put - currentpoint - gsave (\001) true charpath clip StippleText - grestore - (\001) stringwidth translate - moveto - } ifelse - } forall - grestore - } {cstringshow} ifelse - 0 spacing neg translate - } forall -} bind def - -%%EndProlog -} - -} - -proc tk::ensure_psenc_is_loaded {} { -} diff --git a/tcl/library/msgbox.tcl b/tcl/library/msgbox.tcl deleted file mode 100644 index 20862b5b117..00000000000 --- a/tcl/library/msgbox.tcl +++ /dev/null @@ -1,419 +0,0 @@ -# msgbox.tcl -- -# -# Implements messageboxes for platforms that do not have native -# messagebox support. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# Ensure existence of ::tk::dialog namespace -# -namespace eval ::tk::dialog {} - -image create bitmap ::tk::dialog::b1 -foreground black \ --data "#define b1_width 32\n#define b1_height 32 -static unsigned char q1_bits[] = { - 0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03, - 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, - 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40, - 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, - 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, - 0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40, - 0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08, - 0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00, - 0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, - 0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" -image create bitmap ::tk::dialog::b2 -foreground white \ --data "#define b2_width 32\n#define b2_height 32 -static unsigned char b2_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00, - 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, - 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f, - 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, - 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, - 0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f, - 0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07, - 0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00, - 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, - 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" -image create bitmap ::tk::dialog::q -foreground blue \ --data "#define q_width 32\n#define q_height 32 -static unsigned char q_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00, - 0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00, - 0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00, - 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00, - 0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" -image create bitmap ::tk::dialog::i -foreground blue \ --data "#define i_width 32\n#define i_height 32 -static unsigned char i_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, - 0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, - 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, - 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00, - 0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" -image create bitmap ::tk::dialog::w1 -foreground black \ --data "#define w1_width 32\n#define w1_height 32 -static unsigned char w1_bits[] = { - 0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00, - 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00, - 0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00, - 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00, - 0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01, - 0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, - 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, - 0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, - 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40, - 0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, - 0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};" -image create bitmap ::tk::dialog::w2 -foreground yellow \ --data "#define w2_width 32\n#define w2_height 32 -static unsigned char w2_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00, - 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00, - 0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00, - 0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00, - 0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00, - 0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01, - 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, - 0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f, - 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f, - 0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" -image create bitmap ::tk::dialog::w3 -foreground black \ --data "#define w3_width 32\n#define w3_height 32 -static unsigned char w3_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, - 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, - 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, - 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00, - 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" - -# ::tk::MessageBox -- -# -# Pops up a messagebox with an application-supplied message with -# an icon and a list of buttons. This procedure will be called -# by tk_messageBox if the platform does not have native -# messagebox support, or if the particular type of messagebox is -# not supported natively. -# -# Color icons are used on Unix displays that have a color -# depth of 4 or more and $tk_strictMotif is not on. -# -# This procedure is a private procedure shouldn't be called -# directly. Call tk_messageBox instead. -# -# See the user documentation for details on what tk_messageBox does. -# -proc ::tk::MessageBox {args} { - global tcl_platform tk_strictMotif - variable ::tk::Priv - - set w ::tk::PrivMsgBox - upvar $w data - - # - # The default value of the title is space (" ") not the empty string - # because for some window managers, a - # wm title .foo "" - # causes the window title to be "foo" instead of the empty string. - # - set specs { - {-default "" "" ""} - {-icon "" "" "info"} - {-message "" "" ""} - {-parent "" "" .} - {-title "" "" " "} - {-type "" "" "ok"} - } - - tclParseConfigSpec $w $specs "" $args - - if {[lsearch -exact {info warning error question} $data(-icon)] == -1} { - error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning" - } - if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - switch -- $data(-icon) { - "error" {set data(-icon) "stop"} - "warning" {set data(-icon) "caution"} - "info" {set data(-icon) "note"} - } - } - - if {![winfo exists $data(-parent)]} { - error "bad window path name \"$data(-parent)\"" - } - - switch -- $data(-type) { - abortretryignore { - set names [list abort retry ignore] - set labels [list &Abort &Retry &Ignore] - } - ok { - set names [list ok] - set labels {&OK} - } - okcancel { - set names [list ok cancel] - set labels [list &OK &Cancel] - } - retrycancel { - set names [list retry cancel] - set labels [list &Retry &Cancel] - } - yesno { - set names [list yes no] - set labels [list &Yes &No] - } - yesnocancel { - set names [list yes no cancel] - set labels [list &Yes &No &Cancel] - } - default { - error "bad -type value \"$data(-type)\": must be\ - abortretryignore, ok, okcancel, retrycancel,\ - yesno, or yesnocancel" - } - } - - set maxWidth [eval mcmaxamp $labels] - if {$maxWidth <6} { - set maxWidth 6 - } - - set buttons {} - foreach name $names lab $labels { - lappend buttons [list $name -width $maxWidth -text [mc $lab]] - } - - # If no default button was specified, the default default is the - # first button (Bug: 2218). - - if {$data(-default) == ""} { - set data(-default) [lindex [lindex $buttons 0] 0] - } - - set valid 0 - foreach btn $buttons { - if {[string equal [lindex $btn 0] $data(-default)]} { - set valid 1 - break - } - } - if {!$valid} { - error "invalid default button \"$data(-default)\"" - } - - # 2. Set the dialog to be a child window of $parent - # - # - if {[string compare $data(-parent) .]} { - set w $data(-parent).__tk__messagebox - } else { - set w .__tk__messagebox - } - - # 3. Create the top-level window and divide it into top - # and bottom parts. - - catch {destroy $w} - toplevel $w -class Dialog - wm title $w $data(-title) - wm iconname $w Dialog - wm protocol $w WM_DELETE_WINDOW { } - # There is only one background colour for the whole dialog - set bg [$w cget -background] - - # Message boxes should be transient with respect to their parent so that - # they always stay on top of the parent window. But some window managers - # will simply create the child window as withdrawn if the parent is not - # viewable (because it is withdrawn or iconified). This is not good for - # "grab"bed windows. So only make the message box transient if the parent - # is viewable. - # - if {[winfo viewable [winfo toplevel $data(-parent)]] } { - wm transient $w $data(-parent) - } - - if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - unsupported::MacWindowStyle style $w dBoxProc - } - - frame $w.bot -background $bg - pack $w.bot -side bottom -fill both - frame $w.top -background $bg - pack $w.top -side top -fill both -expand 1 - if {![string equal [tk windowingsystem] "classic"] - && ![string equal [tk windowingsystem] "aqua"]} { - $w.bot configure -relief raised -bd 1 - $w.top configure -relief raised -bd 1 - } - - # 4. Fill the top part with bitmap and message (use the option - # database for -wraplength and -font so that they can be - # overridden by the caller). - - option add *Dialog.msg.wrapLength 3i widgetDefault - if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - option add *Dialog.msg.font system widgetDefault - } else { - option add *Dialog.msg.font {Times 18} widgetDefault - } - - label $w.msg -anchor nw -justify left -text $data(-message) \ - -background $bg - if {[string compare $data(-icon) ""]} { - if {([string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]) - || ([winfo depth $w] < 4) || $tk_strictMotif} { - label $w.bitmap -bitmap $data(-icon) -background $bg - } else { - canvas $w.bitmap -width 32 -height 32 -highlightthickness 0 \ - -background $bg - switch $data(-icon) { - error { - $w.bitmap create oval 0 0 31 31 -fill red -outline black - $w.bitmap create line 9 9 23 23 -fill white -width 4 - $w.bitmap create line 9 23 23 9 -fill white -width 4 - } - info { - $w.bitmap create image 0 0 -anchor nw \ - -image ::tk::dialog::b1 - $w.bitmap create image 0 0 -anchor nw \ - -image ::tk::dialog::b2 - $w.bitmap create image 0 0 -anchor nw \ - -image ::tk::dialog::i - } - question { - $w.bitmap create image 0 0 -anchor nw \ - -image ::tk::dialog::b1 - $w.bitmap create image 0 0 -anchor nw \ - -image ::tk::dialog::b2 - $w.bitmap create image 0 0 -anchor nw \ - -image ::tk::dialog::q - } - default { - $w.bitmap create image 0 0 -anchor nw \ - -image ::tk::dialog::w1 - $w.bitmap create image 0 0 -anchor nw \ - -image ::tk::dialog::w2 - $w.bitmap create image 0 0 -anchor nw \ - -image ::tk::dialog::w3 - } - } - } - } - grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m - grid columnconfigure $w.top 1 -weight 1 - grid rowconfigure $w.top 0 -weight 1 - - # 5. Create a row of buttons at the bottom of the dialog. - - set i 0 - foreach but $buttons { - set name [lindex $but 0] - set opts [lrange $but 1 end] - if {![llength $opts]} { - # Capitalize the first letter of $name - set capName [string toupper $name 0] - set opts [list -text $capName] - } - - eval [list tk::AmpWidget button $w.$name] $opts \ - [list -command [list set tk::Priv(button) $name]] - - if {[string equal $name $data(-default)]} { - $w.$name configure -default active - } else { - $w.$name configure -default normal - } - pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m - - # create the binding for the key accelerator, based on the underline - # - # set underIdx [$w.$name cget -under] - # if {$underIdx >= 0} { - # set key [string index [$w.$name cget -text] $underIdx] - # bind $w <Alt-[string tolower $key]> [list $w.$name invoke] - # bind $w <Alt-[string toupper $key]> [list $w.$name invoke] - # } - # incr i - } - bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A] - - if {[string compare {} $data(-default)]} { - bind $w <FocusIn> { - if {[string equal Button [winfo class %W]]} { - %W configure -default active - } - } - bind $w <FocusOut> { - if {[string equal Button [winfo class %W]]} { - %W configure -default normal - } - } - } - - # 6. Create a binding for <Return> on the dialog - - bind $w <Return> { - if {[string equal Button [winfo class %W]]} { - tk::ButtonInvoke %W - } - } - - # 7. Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. - - ::tk::PlaceWindow $w widget $data(-parent) - - # 8. Set a grab and claim the focus too. - - if {[string compare $data(-default) ""]} { - set focus $w.$data(-default) - } else { - set focus $w - } - ::tk::SetFocusGrab $w $focus - - # 9. Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - - vwait ::tk::Priv(button) - - ::tk::RestoreFocusGrab $w $focus - - return $Priv(button) -} diff --git a/tcl/library/msgcat1.0/msgcat.tcl b/tcl/library/msgcat1.0/msgcat.tcl deleted file mode 100644 index 2bd31ec7883..00000000000 --- a/tcl/library/msgcat1.0/msgcat.tcl +++ /dev/null @@ -1,202 +0,0 @@ -# msgcat.tcl -- -# -# This file defines various procedures which implement a -# message catalog facility for Tcl programs. It should be -# loaded with the command "package require msgcat". -# -# Copyright (c) 1998 by Scriptics Corporation. -# Copyright (c) 1998 by Mark Harrison. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id$ - -package provide msgcat 1.1 - -namespace eval msgcat { - namespace export mc mcset mclocale mcpreferences mcunknown - - # Records the current locale as passed to mclocale - variable locale "" - - # Records the list of locales to search - variable loclist {} - - # Records the mapping between source strings and translated strings. The - # array key is of the form "<locale>,<namespace>,<src>" and the value is - # the translated string. - array set msgs {} -} - -# msgcat::mc -- -# -# Find the translation for the given string based on the current -# locale setting. Check the local namespace first, then look in each -# parent namespace until the source is found. If additional args are -# specified, use the format command to work them into the traslated -# string. -# -# Arguments: -# src The string to translate. -# args Args to pass to the format command -# -# Results: -# Returns the translatd string. Propagates errors thrown by the -# format command. - -proc msgcat::mc {src args} { - # Check for the src in each namespace starting from the local and - # ending in the global. - - set ns [uplevel {namespace current}] - - while {$ns != ""} { - foreach loc $::msgcat::loclist { - if {[info exists ::msgcat::msgs($loc,$ns,$src)]} { - if {[llength $args] == 0} { - return $::msgcat::msgs($loc,$ns,$src) - } else { - return [eval \ - [list format $::msgcat::msgs($loc,$ns,$src)] \ - $args] - } - } - } - set ns [namespace parent $ns] - } - # we have not found the translation - return [uplevel 1 [list [namespace origin mcunknown] \ - $::msgcat::locale $src] $args] -} - -# msgcat::mclocale -- -# -# Query or set the current locale. -# -# Arguments: -# newLocale (Optional) The new locale string. Locale strings -# should be composed of one or more sublocale parts -# separated by underscores (e.g. en_US). -# -# Results: -# Returns the current locale. - -proc msgcat::mclocale {args} { - set len [llength $args] - - if {$len > 1} { - error {wrong # args: should be "mclocale ?newLocale?"} - } - - set args [string tolower $args] - if {$len == 1} { - set ::msgcat::locale $args - set ::msgcat::loclist {} - set word "" - foreach part [split $args _] { - set word [string trimleft "${word}_${part}" _] - set ::msgcat::loclist [linsert $::msgcat::loclist 0 $word] - } - } - return $::msgcat::locale -} - -# msgcat::mcpreferences -- -# -# Fetch the list of locales used to look up strings, ordered from -# most preferred to least preferred. -# -# Arguments: -# None. -# -# Results: -# Returns an ordered list of the locales preferred by the user. - -proc msgcat::mcpreferences {} { - return $::msgcat::loclist -} - -# msgcat::mcload -- -# -# Attempt to load message catalogs for each locale in the -# preference list from the specified directory. -# -# Arguments: -# langdir The directory to search. -# -# Results: -# Returns the number of message catalogs that were loaded. - -proc msgcat::mcload {langdir} { - set x 0 - foreach p [::msgcat::mcpreferences] { - set langfile [file join $langdir $p.msg] - if {[file exists $langfile]} { - incr x - uplevel [list source $langfile] - } - } - return $x -} - -# msgcat::mcset -- -# -# Set the translation for a given string in a specified locale. -# -# Arguments: -# locale The locale to use. -# src The source string. -# dest (Optional) The translated string. If omitted, -# the source string is used. -# -# Results: -# Returns the new locale. - -proc msgcat::mcset {locale src {dest ""}} { - if {[string equal $dest ""]} { - set dest $src - } - - set ns [uplevel {namespace current}] - - set ::msgcat::msgs([string tolower $locale],$ns,$src) $dest - return $dest -} - -# msgcat::mcunknown -- -# -# This routine is called by msgcat::mc if a translation cannot -# be found for a string. This routine is intended to be replaced -# by an application specific routine for error reporting -# purposes. The default behavior is to return the source string. -# If additional args are specified, the format command will be used -# to work them into the traslated string. -# -# Arguments: -# locale The current locale. -# src The string to be translated. -# args Args to pass to the format command -# -# Results: -# Returns the translated value. - -proc msgcat::mcunknown {locale src args} { - if {[llength $args]} { - return [eval [list format $src] $args] - } else { - return $src - } -} - -# Initialize the default locale - -namespace eval msgcat { - # set default locale, try to get from environment - if {[info exists ::env(LANG)]} { - mclocale $::env(LANG) - } else { - mclocale "C" - } -} - diff --git a/tcl/library/msgcat1.0/pkgIndex.tcl b/tcl/library/msgcat1.0/pkgIndex.tcl deleted file mode 100644 index 7bee508d939..00000000000 --- a/tcl/library/msgcat1.0/pkgIndex.tcl +++ /dev/null @@ -1 +0,0 @@ -package ifneeded msgcat 1.1 [list source [file join $dir msgcat.tcl]] diff --git a/tcl/library/msgs/cs.msg b/tcl/library/msgs/cs.msg deleted file mode 100644 index e4014a334a9..00000000000 --- a/tcl/library/msgs/cs.msg +++ /dev/null @@ -1,70 +0,0 @@ -namespace eval ::tk { - ::msgcat::mcset cs "&Abort" "&P\u0159eru\u0161it" - ::msgcat::mcset cs "About..." "O programu..." - ::msgcat::mcset cs "All Files" "V\u0161echny soubory" - ::msgcat::mcset cs "Application Error" "Chyba programu" - ::msgcat::mcset cs "&Blue" "&Modr\341" - ::msgcat::mcset cs "&Cancel" "&Zru\u0161it" - ::msgcat::mcset cs "Cannot change to the directory \"%1\$s\".\nPermission denied." "Nemohu zm\u011bnit atku\341ln\355 adres\341\u0159 na \"%1\$s\".\nP\u0159\355stup odm\355tnut." - ::msgcat::mcset cs "Choose Directory" "V\375b\u011br adres\341\u0159e" - ::msgcat::mcset cs "Clear" "Smazat" - ::msgcat::mcset cs "Color" "Barva" - ::msgcat::mcset cs "Console" "Konzole" - ::msgcat::mcset cs "Copy" "Kop\355rovat" - ::msgcat::mcset cs "Cut" "Vy\u0159\355znout" - ::msgcat::mcset cs "Delete" "Smazat" - ::msgcat::mcset cs "Details >>" "Detaily >>" - ::msgcat::mcset cs "Directory \"%1\$s\" does not exist." "Adres\341\u0159 \"%1\$s\" neexistuje." - ::msgcat::mcset cs "&Directory:" "&Adres\341\u0159:" - ::msgcat::mcset cs "Error: %1\$s" "Chyba: %1\$s" - ::msgcat::mcset cs "Exit" "Konec" - ::msgcat::mcset cs "File \"%1\$s\" already exists.\n\n" "Soubor \"%1\$s\" ji\u017e existuje.\n\n" - ::msgcat::mcset cs "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Soubor \"%1\$s\" ji\u017e existuje.\nChcete jej p\u0159epsat?" - ::msgcat::mcset cs "File \"%1\$s\" does not exist." "Soubor \"%1\$s\" neexistuje." - ::msgcat::mcset cs "File &name:" "&Jm\351no souboru:" - ::msgcat::mcset cs "File &names:" "&Jm\351na soubor\u016f:" - ::msgcat::mcset cs "Files of &type:" "&Typy soubor\u016f:" - ::msgcat::mcset cs "Fi&les:" "Sou&bory:" - ::msgcat::mcset cs "&Filter" "&Filtr" - ::msgcat::mcset cs "Fil&ter:" "Fil&tr:" - ::msgcat::mcset cs "&Green" "Ze&len\341" - ::msgcat::mcset cs "Hi" - ::msgcat::mcset cs "Hide Console" "Skr\375t konsolu" - ::msgcat::mcset cs "&Ignore" "&Ignorovat" - ::msgcat::mcset cs "Invalid file name \"%1\$s\"." "\u0160patn\351 jm\351no souboru \"%1\$s\"." - ::msgcat::mcset cs "Log Files" "Log soubory" - ::msgcat::mcset cs "&No" "&Ne" - ::msgcat::mcset cs "&OK" - ::msgcat::mcset cs "Ok" - ::msgcat::mcset cs "Open" "Otev\u0159\355t" - ::msgcat::mcset cs "&Open" "&Otev\u0159\355t" - ::msgcat::mcset cs "Open Multiple Files" "Otev\u0159\355t v\355ce soubor\u016f" - ::msgcat::mcset cs "Paste" "Vlo\u017eit" - ::msgcat::mcset cs "Quit" "Skon\u010dit" - ::msgcat::mcset cs "&Red" " \u010ce&rven\341" - ::msgcat::mcset cs "Replace existing file?" "Nahradit st\341vaj\355c\355 soubor?" - ::msgcat::mcset cs "&Retry" "Z&novu" - ::msgcat::mcset cs "&Save" "&Ulo\u017eit" - ::msgcat::mcset cs "Save As" "Ulo\u017eit jako" - ::msgcat::mcset cs "Save To Log" "Ulo\u017eit do logu" - ::msgcat::mcset cs "Select Log File" "Vybrat log soubor" - ::msgcat::mcset cs "Select a file to source" "Vybrat soubor k nahr\341n\355" - ::msgcat::mcset cs "&Selection:" "&V\375b\u011br:" - ::msgcat::mcset cs "Skip Messages" "P\u0159esko\u010dit zpr\341vy" - ::msgcat::mcset cs "Source..." "Nahr\341t..." - ::msgcat::mcset cs "Tcl Scripts" "Tcl skripty" - ::msgcat::mcset cs "Tcl for Windows" "Tcl pro Windows" - ::msgcat::mcset cs "Text Files" "Textov\351 soubory" - ::msgcat::mcset cs "&Yes" "&Ano" - ::msgcat::mcset cs "abort" "p\u0159eru\u0161it" - ::msgcat::mcset cs "blue" "modr\341" - ::msgcat::mcset cs "cancel" "zru\u0161it" - ::msgcat::mcset cs "extension" "p\u0159\355pona" - ::msgcat::mcset cs "extensions" "p\u0159\355pony" - ::msgcat::mcset cs "green" "zelen\341" - ::msgcat::mcset cs "ignore" "ignorovat" - ::msgcat::mcset cs "ok" - ::msgcat::mcset cs "red" "\u010derven\341" - ::msgcat::mcset cs "retry" "znovu" - ::msgcat::mcset cs "yes" "ano" -} diff --git a/tcl/library/msgs/de.msg b/tcl/library/msgs/de.msg deleted file mode 100644 index c5ae6893d98..00000000000 --- a/tcl/library/msgs/de.msg +++ /dev/null @@ -1,70 +0,0 @@ -namespace eval ::tk { - ::msgcat::mcset de "&Abort" "&Abbruch" - ::msgcat::mcset de "About..." "\u00dcber..." - ::msgcat::mcset de "All Files" "Alle Dateien" - ::msgcat::mcset de "Application Error" "Applikationsfehler" - ::msgcat::mcset de "&Blue" "&Blau" - ::msgcat::mcset de "&Cancel" "&Abbruch" - ::msgcat::mcset de "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kann nicht in das Verzeichnis \"%1\$s\" wechseln.\nKeine Rechte vorhanden." - ::msgcat::mcset de "Choose Directory" "W\u00e4hle Verzeichnis" - ::msgcat::mcset de "Clear" "R\u00fccksetzen" - ::msgcat::mcset de "Color" "Farbe" - ::msgcat::mcset de "Console" "Konsole" - ::msgcat::mcset de "Copy" "Kopieren" - ::msgcat::mcset de "Cut" "Ausschneiden" - ::msgcat::mcset de "Delete" "L\u00f6schen" - ::msgcat::mcset de "Details >>" - ::msgcat::mcset de "Directory \"%1\$s\" does not exist." "Das Verzeichnis \"%1\$s\" existiert nicht." - ::msgcat::mcset de "&Directory:" "&Verzeichnis:" - ::msgcat::mcset de "Error: %1\$s" "Fehler: %1\$s" - ::msgcat::mcset de "Exit" "Ende" - ::msgcat::mcset de "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Die Datei \"%1\$s\" ist bereits vorhanden.\nWollen sie diese Datei \u00fcberschreiben ?" - ::msgcat::mcset de "File \"%1\$s\" already exists.\n\n" "Die Datei \"%1\$s\" ist bereits vorhanden.\n\n" - ::msgcat::mcset de "File \"%1\$s\" does not exist." "Die Datei \"%1\$s\" existiert nicht." - ::msgcat::mcset de "File &name:" "Datei&name:" - ::msgcat::mcset de "File &names:" "Datei&namen:" - ::msgcat::mcset de "Files of &type:" "Dateien des &Typs:" - ::msgcat::mcset de "Fi&les:" "Dat&eien:" - ::msgcat::mcset de "&Filter" - ::msgcat::mcset de "Fil&ter:" - ::msgcat::mcset de "&Green" "&Gr\u00fcn" - ::msgcat::mcset de "Hi" "Hallo" - ::msgcat::mcset de "Hide Console" "Konsole unsichtbar machen" - ::msgcat::mcset de "&Ignore" "&Ignorieren" - ::msgcat::mcset de "Invalid file name \"%1\$s\"." "Ung\u00fcltiger Dateiname \"%1\$s\"." - ::msgcat::mcset de "Log Files" "Protokolldatei" - ::msgcat::mcset de "&No" "&Nein" - ::msgcat::mcset de "OK" - ::msgcat::mcset de "Ok" - ::msgcat::mcset de "Open" "\u00d6ffnen" - ::msgcat::mcset de "&Open" "\u00d6&ffnen" - ::msgcat::mcset de "Open Multiple Files" - ::msgcat::mcset de "Paste" "Einf\u00fcgen" - ::msgcat::mcset de "Quit" "Beenden" - ::msgcat::mcset de "&Red" "&Rot" - ::msgcat::mcset de "Replace existing file?" "Existierende Datei ersetzen?" - ::msgcat::mcset de "&Retry" "&Wiederholen" - ::msgcat::mcset de "&Save" "&Speichern" - ::msgcat::mcset de "Save As" "Speichern unter" - ::msgcat::mcset de "Save To Log" "In Protokoll speichern" - ::msgcat::mcset de "Select Log File" "Protokolldatei ausw\u00e4hlen" - ::msgcat::mcset de "Select a file to source" "Auszuf\u00fchrende Datei ausw\u00e4hlen" - ::msgcat::mcset de "&Selection:" "Auswah&l:" - ::msgcat::mcset de "Skip Messages" "Weitere Nachrichten \u00fcberspringen" - ::msgcat::mcset de "Source..." "Ausf\u00fchren..." - ::msgcat::mcset de "Tcl Scripts" "Tcl-Skripte" - ::msgcat::mcset de "Tcl for Windows" "Tcl f\u00fcr Windows" - ::msgcat::mcset de "Text Files" "Textdateien" - ::msgcat::mcset de "&Yes" "&Ja" - ::msgcat::mcset de "abort" "abbrechen" - ::msgcat::mcset de "blue" "blau" - ::msgcat::mcset de "cancel" "abbrechen" - ::msgcat::mcset de "extension" "Erweiterung" - ::msgcat::mcset de "extensions" "Erweiterungen" - ::msgcat::mcset de "green" "gr\u00fcn" - ::msgcat::mcset de "ignore" "ignorieren" - ::msgcat::mcset de "ok" - ::msgcat::mcset de "red" "rot" - ::msgcat::mcset de "retry" "wiederholen" - ::msgcat::mcset de "yes" "ja" -} diff --git a/tcl/library/msgs/el.msg b/tcl/library/msgs/el.msg deleted file mode 100644 index 2e96cd96043..00000000000 --- a/tcl/library/msgs/el.msg +++ /dev/null @@ -1,86 +0,0 @@ -## Messages for the Greek (Hellenic - "el") language. -## Please report any changes/suggestions to: -## petasis@iit.demokritos.gr - -namespace eval ::tk { - ::msgcat::mcset el "&Abort" "\u03a4\u03b5\u03c1\u03bc\u03b1\u03c4\u03b9\u03c3\u03bc\u03cc\u03c2" - ::msgcat::mcset el "About..." "\u03a3\u03c7\u03b5\u03c4\u03b9\u03ba\u03ac..." - ::msgcat::mcset el "All Files" "\u038c\u03bb\u03b1 \u03c4\u03b1 \u0391\u03c1\u03c7\u03b5\u03af\u03b1" - ::msgcat::mcset el "Application Error" "\u039b\u03ac\u03b8\u03bf\u03c2 \u0395\u03c6\u03b1\u03c1\u03bc\u03bf\u03b3\u03ae\u03c2" - ::msgcat::mcset el "&Blue" "\u039c\u03c0\u03bb\u03b5" - ::msgcat::mcset el "&Cancel" "\u0391\u03ba\u03cd\u03c1\u03c9\u03c3\u03b7" - ::msgcat::mcset el \ -"Cannot change to the directory \"%1\$s\".\nPermission denied." \ -"\u0394\u03b5\u03bd \u03b5\u03af\u03bd\u03b1\u03b9 \u03b4\u03c5\u03bd\u03b1\u03c4\u03ae \u03b7 \u03b1\u03bb\u03bb\u03b1\u03b3\u03ae \u03ba\u03b1\u03c4\u03b1\u03bb\u03cc\u03b3\u03bf\u03c5 \u03c3\u03b5 \"%1\$s\".\n\u0397 \u03c0\u03c1\u03cc\u03c3\u03b2\u03b1\u03c3\u03b7 \u03b4\u03b5\u03bd \u03b5\u03c0\u03b9\u03c4\u03c1\u03ad\u03c0\u03b5\u03c4\u03b1\u03b9." - ::msgcat::mcset el "Choose Directory" "\u0395\u03c0\u03b9\u03bb\u03bf\u03b3\u03ae \u039a\u03b1\u03c4\u03b1\u03bb\u03cc\u03b3\u03bf\u03c5" - ::msgcat::mcset el "Clear" "\u039a\u03b1\u03b8\u03b1\u03c1\u03b9\u03c3\u03bc\u03cc\u03c2" - ::msgcat::mcset el "Color" "\u03a7\u03c1\u03ce\u03bc\u03b1" - ::msgcat::mcset el "Console" "\u039a\u03bf\u03bd\u03c3\u03cc\u03bb\u03b1" - ::msgcat::mcset el "Copy" "\u0391\u03bd\u03c4\u03b9\u03b3\u03c1\u03b1\u03c6\u03ae" - ::msgcat::mcset el "Cut" "\u0391\u03c0\u03bf\u03ba\u03bf\u03c0\u03ae" - ::msgcat::mcset el "Delete" "\u0394\u03b9\u03b1\u03b3\u03c1\u03b1\u03c6\u03ae" - ::msgcat::mcset el "Details >>" "\u039b\u03b5\u03c0\u03c4\u03bf\u03bc\u03ad\u03c1\u03b5\u03b9\u03b5\u03c2 >>" - ::msgcat::mcset el "Directory \"%1\$s\" does not exist." \ - "\u039f \u03ba\u03b1\u03c4\u03ac\u03bb\u03bf\u03b3\u03bf\u03c2 \"%1\$s\" \u03b4\u03b5\u03bd \u03c5\u03c0\u03ac\u03c1\u03c7\u03b5\u03b9." - ::msgcat::mcset el "&Directory:" "&\u039a\u03b1\u03c4\u03ac\u03bb\u03bf\u03b3\u03bf\u03c2:" - ::msgcat::mcset el "Error: %1\$s" "\u039b\u03ac\u03b8\u03bf\u03c2: %1\$s" - ::msgcat::mcset el "Exit" "\u0388\u03be\u03bf\u03b4\u03bf\u03c2" - ::msgcat::mcset el \ - "File \"%1\$s\" already exists.\nDo you want to overwrite it?" \ - "\u03a4\u03bf \u03b1\u03c1\u03c7\u03b5\u03af\u03bf \"%1\$s\" \u03ae\u03b4\u03b7 \u03c5\u03c0\u03ac\u03c1\u03c7\u03b5\u03b9.\n\u0398\u03ad\u03bb\u03b5\u03c4\u03b5 \u03bd\u03b1 \u03b5\u03c0\u03b9\u03ba\u03b1\u03bb\u03c5\u03c6\u03b8\u03b5\u03af;" - ::msgcat::mcset el "File \"%1\$s\" already exists.\n\n" \ - "\u03a4\u03bf \u03b1\u03c1\u03c7\u03b5\u03af\u03bf \"%1\$s\" \u03ae\u03b4\u03b7 \u03c5\u03c0\u03ac\u03c1\u03c7\u03b5\u03b9.\n\n" - ::msgcat::mcset el "File \"%1\$s\" does not exist." \ - "\u03a4\u03bf \u03b1\u03c1\u03c7\u03b5\u03af\u03bf \"%1\$s\" \u03b4\u03b5\u03bd \u03c5\u03c0\u03ac\u03c1\u03c7\u03b5\u03b9." - ::msgcat::mcset el "File &name:" "\u038c&\u03bd\u03bf\u03bc\u03b1 \u03b1\u03c1\u03c7\u03b5\u03af\u03bf\u03c5:" - ::msgcat::mcset el "File &names:" "\u038c&\u03bd\u03bf\u03bc\u03b1 \u03b1\u03c1\u03c7\u03b5\u03af\u03c9\u03bd:" - ::msgcat::mcset el "Files of &type:" "\u0391\u03c1\u03c7\u03b5\u03af\u03b1 \u03c4\u03bf\u03c5 &\u03c4\u03cd\u03c0\u03bf\u03c5:" - ::msgcat::mcset el "Fi&les:" "\u0391\u03c1\u03c7\u03b5\u03af\u03b1:" - ::msgcat::mcset el "&Filter" "\u03a6\u03af\u03bb\u03c4\u03c1\u03bf" - ::msgcat::mcset el "Fil&ter:" "\u03a6\u03af\u03bb\u03c4\u03c1\u03bf:" - ::msgcat::mcset el "&Green" "\u03a0\u03c1\u03ac\u03c3\u03b9\u03bd\u03bf" - ::msgcat::mcset el "Hi" "\u0393\u03b5\u03b9\u03b1" - ::msgcat::mcset el "Hide Console" "\u0391\u03c0\u03cc\u03ba\u03c1\u03c5\u03c8\u03b7 \u03ba\u03bf\u03bd\u03c3\u03cc\u03bb\u03b1\u03c2" - ::msgcat::mcset el "&Ignore" "\u0391\u03b3\u03bd\u03cc\u03b7\u03c3\u03b7" - ::msgcat::mcset el "Invalid file name \"%1\$s\"." \ - "\u0386\u03ba\u03c5\u03c1\u03bf \u03cc\u03bd\u03bf\u03bc\u03b1 \u03b1\u03c1\u03c7\u03b5\u03af\u03bf\u03c5 \"%1\$s\"." - ::msgcat::mcset el "Log Files" "\u0391\u03c1\u03c7\u03b5\u03af\u03b1 \u039a\u03b1\u03c4\u03b1\u03b3\u03c1\u03b1\u03c6\u03ae\u03c2" - ::msgcat::mcset el "&No" "\u038c\u03c7\u03b9" - ::msgcat::mcset el "&OK" "\u0395\u03bd\u03c4\u03ac\u03be\u03b5\u03b9" - ::msgcat::mcset el "&Ok" "\u0395\u03bd\u03c4\u03ac\u03be\u03b5\u03b9" - ::msgcat::mcset el "Open" "\u0386\u03bd\u03bf\u03b9\u03b3\u03bc\u03b1" - ::msgcat::mcset el "&Open" "\u0386\u03bd\u03bf\u03b9\u03b3\u03bc\u03b1" - ::msgcat::mcset el "Open Multiple Files" \ - "\u0386\u03bd\u03bf\u03b9\u03b3\u03bc\u03b1 \u03c0\u03bf\u03bb\u03bb\u03b1\u03c0\u03bb\u03ce\u03bd \u03b1\u03c1\u03c7\u03b5\u03af\u03c9\u03bd" - ::msgcat::mcset el "Paste" "\u0395\u03c0\u03b9\u03ba\u03cc\u03bb\u03bb\u03b7\u03c3\u03b7" - ::msgcat::mcset el "Quit" "\u0388\u03be\u03bf\u03b4\u03bf\u03c2" - ::msgcat::mcset el "&Red" "\u039a\u03cc\u03ba\u03ba\u03b9\u03bd\u03bf" - ::msgcat::mcset el "Replace existing file?" \ - "\u0395\u03c0\u03b9\u03ba\u03ac\u03bb\u03c5\u03c8\u03b7 \u03c5\u03c0\u03ac\u03c1\u03c7\u03bf\u03bd\u03c4\u03bf\u03c2 \u03b1\u03c1\u03c7\u03b5\u03af\u03bf\u03c5;" - ::msgcat::mcset el "&Retry" "\u03a0\u03c1\u03bf\u03c3\u03c0\u03ac\u03b8\u03b7\u03c3\u03b5 \u03be\u03b1\u03bd\u03ac" - ::msgcat::mcset el "&Save" "\u0391\u03c0\u03bf\u03b8\u03ae\u03ba\u03b5\u03c5\u03c3\u03b7" - ::msgcat::mcset el "Save As" "\u0391\u03c0\u03bf\u03b8\u03ae\u03ba\u03b5\u03c5\u03c3\u03b7 \u03c3\u03b1\u03bd" - ::msgcat::mcset el "Save To Log" "\u0391\u03c0\u03bf\u03b8\u03ae\u03ba\u03b5\u03c5\u03c3\u03b7 \u03c3\u03c4\u03bf \u03b1\u03c1\u03c7\u03b5\u03af\u03bf \u03ba\u03b1\u03c4\u03b1\u03b3\u03c1\u03b1\u03c6\u03ae\u03c2" - ::msgcat::mcset el "Select Log File" "\u0395\u03c0\u03b9\u03bb\u03bf\u03b3\u03ae \u03b1\u03c1\u03c7\u03b5\u03af\u03bf\u03c5 \u03ba\u03b1\u03c4\u03b1\u03b3\u03c1\u03b1\u03c6\u03ae\u03c2" - ::msgcat::mcset el "Select a file to source" \ - "\u0395\u03c0\u03b9\u03bb\u03ad\u03be\u03c4\u03b5 \u03b1\u03c1\u03c7\u03b5\u03af\u03bf \u03b3\u03b9\u03b1 \u03b5\u03ba\u03c4\u03ad\u03bb\u03b5\u03c3\u03b7" - ::msgcat::mcset el "&Selection:" "\u0395\u03c0\u03b9\u03bb\u03bf\u03b3\u03ae:" - ::msgcat::mcset el "Skip Messages" "\u0391\u03c0\u03bf\u03c6\u03c5\u03b3\u03ae \u03bc\u03c5\u03bd\u03b7\u03bc\u03ac\u03c4\u03c9\u03bd" - ::msgcat::mcset el "Source..." "\u0395\u03ba\u03c4\u03ad\u03bb\u03b5\u03c3\u03b7..." - ::msgcat::mcset el "Tcl Scripts" "Tcl Scripts" - ::msgcat::mcset el "Tcl for Windows" "Tcl \u03b3\u03b9\u03b1 Windows" - ::msgcat::mcset el "Text Files" "\u0391\u03c1\u03c7\u03b5\u03af\u03b1 \u039a\u03b5\u03b9\u03bc\u03ad\u03bd\u03bf\u03c5" - ::msgcat::mcset el "&Yes" "\u039d\u03b1\u03b9" - ::msgcat::mcset el "abort" "\u03c4\u03b5\u03c1\u03bc\u03b1\u03c4\u03b9\u03c3\u03bc\u03cc\u03c2" - ::msgcat::mcset el "blue" "\u03bc\u03c0\u03bb\u03b5" - ::msgcat::mcset el "cancel" "\u03b1\u03ba\u03cd\u03c1\u03c9\u03c3\u03b7" - ::msgcat::mcset el "extension" "\u03b5\u03c0\u03ad\u03ba\u03c4\u03b1\u03c3\u03b7" - ::msgcat::mcset el "extensions" "\u03b5\u03c0\u03b5\u03ba\u03c4\u03ac\u03c3\u03b5\u03b9\u03c2" - ::msgcat::mcset el "green" "\u03c0\u03c1\u03ac\u03c3\u03b9\u03bd\u03bf" - ::msgcat::mcset el "ignore" "\u03b1\u03b3\u03bd\u03cc\u03b7\u03c3\u03b7" - ::msgcat::mcset el "ok" "\u03b5\u03bd\u03c4\u03ac\u03be\u03b5\u03b9" - ::msgcat::mcset el "red" "\u03ba\u03cc\u03ba\u03ba\u03b9\u03bd\u03bf" - ::msgcat::mcset el "retry" "\u03c0\u03c1\u03bf\u03c3\u03c0\u03ac\u03b8\u03b7\u03c3\u03b5 \u03be\u03b1\u03bd\u03ac" - ::msgcat::mcset el "yes" "\u03bd\u03b1\u03b9" -} - diff --git a/tcl/library/msgs/en.msg b/tcl/library/msgs/en.msg deleted file mode 100644 index 7242f913ce2..00000000000 --- a/tcl/library/msgs/en.msg +++ /dev/null @@ -1,70 +0,0 @@ -namespace eval ::tk { - ::msgcat::mcset en "&Abort" - ::msgcat::mcset en "About..." - ::msgcat::mcset en "All Files" - ::msgcat::mcset en "Application Error" - ::msgcat::mcset en "&Blue" - ::msgcat::mcset en "&Cancel" - ::msgcat::mcset en "Cannot change to the directory \"%1\$s\".\nPermission denied." - ::msgcat::mcset en "Choose Directory" - ::msgcat::mcset en "Clear" - ::msgcat::mcset en "Color" - ::msgcat::mcset en "Console" - ::msgcat::mcset en "Copy" - ::msgcat::mcset en "Cut" - ::msgcat::mcset en "Delete" - ::msgcat::mcset en "Details >>" - ::msgcat::mcset en "Directory \"%1\$s\" does not exist." - ::msgcat::mcset en "&Directory:" - ::msgcat::mcset en "Error: %1\$s" - ::msgcat::mcset en "Exit" - ::msgcat::mcset en "File \"%1\$s\" already exists.\nDo you want to overwrite it?" - ::msgcat::mcset en "File \"%1\$s\" already exists.\n\n" - ::msgcat::mcset en "File \"%1\$s\" does not exist." - ::msgcat::mcset en "File &name:" - ::msgcat::mcset en "File &names:" - ::msgcat::mcset en "Files of &type:" - ::msgcat::mcset en "Fi&les:" - ::msgcat::mcset en "&Filter" - ::msgcat::mcset en "Fil&ter:" - ::msgcat::mcset en "&Green" - ::msgcat::mcset en "Hi" - ::msgcat::mcset en "Hide Console" - ::msgcat::mcset en "&Ignore" - ::msgcat::mcset en "Invalid file name \"%1\$s\"." - ::msgcat::mcset en "Log Files" - ::msgcat::mcset en "&No" - ::msgcat::mcset en "&OK" - ::msgcat::mcset en "Ok" - ::msgcat::mcset en "Open" - ::msgcat::mcset en "&Open" - ::msgcat::mcset en "Open Multiple Files" - ::msgcat::mcset en "Paste" - ::msgcat::mcset en "Quit" - ::msgcat::mcset en "&Red" - ::msgcat::mcset en "Replace existing file?" - ::msgcat::mcset en "&Retry" - ::msgcat::mcset en "&Save" - ::msgcat::mcset en "Save As" - ::msgcat::mcset en "Save To Log" - ::msgcat::mcset en "Select Log File" - ::msgcat::mcset en "Select a file to source" - ::msgcat::mcset en "&Selection:" - ::msgcat::mcset en "Skip Messages" - ::msgcat::mcset en "Source..." - ::msgcat::mcset en "Tcl Scripts" - ::msgcat::mcset en "Tcl for Windows" - ::msgcat::mcset en "Text Files" - ::msgcat::mcset en "&Yes" - ::msgcat::mcset en "abort" - ::msgcat::mcset en "blue" - ::msgcat::mcset en "cancel" - ::msgcat::mcset en "extension" - ::msgcat::mcset en "extensions" - ::msgcat::mcset en "green" - ::msgcat::mcset en "ignore" - ::msgcat::mcset en "ok" - ::msgcat::mcset en "red" - ::msgcat::mcset en "retry" - ::msgcat::mcset en "yes" -} diff --git a/tcl/library/msgs/en_gb.msg b/tcl/library/msgs/en_gb.msg deleted file mode 100644 index efafa38c6d7..00000000000 --- a/tcl/library/msgs/en_gb.msg +++ /dev/null @@ -1,3 +0,0 @@ -namespace eval ::tk { - ::msgcat::mcset en_gb Color Colour -} diff --git a/tcl/library/msgs/es.msg b/tcl/library/msgs/es.msg deleted file mode 100644 index 7de0faef215..00000000000 --- a/tcl/library/msgs/es.msg +++ /dev/null @@ -1,70 +0,0 @@ -namespace eval ::tk { - ::msgcat::mcset es "&Abort" "&Abortar" - ::msgcat::mcset es "About..." "Acerca de ..." - ::msgcat::mcset es "All Files" "Todos los archivos" - ::msgcat::mcset es "Application Error" "Error de la aplicaci\u00f3n" - ::msgcat::mcset es "&Blue" "&Azul" - ::msgcat::mcset es "&Cancel" "&Cancelar" - ::msgcat::mcset es "Cannot change to the directory \"%1\$s\".\nPermission denied." "No es posible acceder al directorio \"%1\$s\".\nPermiso denegado." - ::msgcat::mcset es "Choose Directory" "Elegir directorio" - ::msgcat::mcset es "Clear" "Borrar" - ::msgcat::mcset es "Color" "Color" - ::msgcat::mcset es "Console" "Consola" - ::msgcat::mcset es "Copy" "Copiar" - ::msgcat::mcset es "Cut" "Cortar" - ::msgcat::mcset es "Delete" "Borrar" - ::msgcat::mcset es "Details >>" "Detalles >>" - ::msgcat::mcset es "Directory \"%1\$s\" does not exist." "El directorio \"%1\$s\" no existe." - ::msgcat::mcset es "&Directory:" "&Directorio:" - ::msgcat::mcset es "Error: %1\$s" "Error: %1\$s" - ::msgcat::mcset es "Exit" "Salir" - ::msgcat::mcset es "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "El archivo \"%1\$s\" ya existe.\nDesea sobreescribirlo?" - ::msgcat::mcset es "File \"%1\$s\" already exists.\n\n" "El archivo \"%1\$s\" ya existe.\n\n" - ::msgcat::mcset es "File \"%1\$s\" does not exist." "El archivo \"%1\$s\" no existe." - ::msgcat::mcset es "File &name:" "&Nombre de archivo:" - ::msgcat::mcset es "File &names:" "&Nombres de archivo:" - ::msgcat::mcset es "Files of &type:" "Archivos de &tipo:" - ::msgcat::mcset es "Fi&les:" "&Archivos:" - ::msgcat::mcset es "&Filter" "&Filtro" - ::msgcat::mcset es "Fil&ter:" "Fil&tro:" - ::msgcat::mcset es "&Green" "&Verde" - ::msgcat::mcset es "Hi" "Hola" - ::msgcat::mcset es "Hide Console" "Esconder la consola" - ::msgcat::mcset es "&Ignore" "&Ignorar" - ::msgcat::mcset es "Invalid file name \"%1\$s\"." "Nombre de archivo inv\u00e1lido \"%1\$s\"." - ::msgcat::mcset es "Log Files" "Ficheros de traza" - ::msgcat::mcset es "&No" "&No" - ::msgcat::mcset es "&OK" "&OK" - ::msgcat::mcset es "Ok" "Ok" - ::msgcat::mcset es "Open" "Abrir" - ::msgcat::mcset es "&Open" "&Abrir" - ::msgcat::mcset es "Open Multiple Files" "Abrir m\u00faltiples archivos" - ::msgcat::mcset es "Paste" "Pegar" - ::msgcat::mcset es "Quit" "Abandonar" - ::msgcat::mcset es "&Red" "&Rojo" - ::msgcat::mcset es "Replace existing file?" "Reemplazar el archivo existente?" - ::msgcat::mcset es "&Retry" "&Reintentar" - ::msgcat::mcset es "&Save" "&Salvar" - ::msgcat::mcset es "Save As" "Salvar como" - ::msgcat::mcset es "Save To Log" "Salvar al archivo de traza" - ::msgcat::mcset es "Select Log File" "Elegir un archivo de traza" - ::msgcat::mcset es "Select a file to source" "Seleccionar un archivo a evaluar" - ::msgcat::mcset es "&Selection:" "&Selecci\u00f3n:" - ::msgcat::mcset es "Skip Messages" "Omitir los mensajes" - ::msgcat::mcset es "Source..." "Evaluar..." - ::msgcat::mcset es "Tcl Scripts" "Scripts Tcl" - ::msgcat::mcset es "Tcl for Windows" "Tcl para Windows" - ::msgcat::mcset es "Text Files" "Archivos de texto" - ::msgcat::mcset es "&Yes" "&S\u00ed" - ::msgcat::mcset es "abort" "abortar" - ::msgcat::mcset es "blue" "azul" - ::msgcat::mcset es "cancel" "cancelar" - ::msgcat::mcset es "extension" "extensi\u00f3n" - ::msgcat::mcset es "extensions" "extensiones" - ::msgcat::mcset es "green" "verde" - ::msgcat::mcset es "ignore" "ignorar" - ::msgcat::mcset es "ok" "ok" - ::msgcat::mcset es "red" "rojo" - ::msgcat::mcset es "retry" "reintentar" - ::msgcat::mcset es "yes" "s\u00ed" -} diff --git a/tcl/library/msgs/fr.msg b/tcl/library/msgs/fr.msg deleted file mode 100644 index 6dba60afbea..00000000000 --- a/tcl/library/msgs/fr.msg +++ /dev/null @@ -1,70 +0,0 @@ -namespace eval ::tk { - ::msgcat::mcset fr "&Abort" "&Annuler" - ::msgcat::mcset fr "About..." "\u00c0 propos..." - ::msgcat::mcset fr "All Files" "Tous les fichiers" - ::msgcat::mcset fr "Application Error" "Erreur d'application" - ::msgcat::mcset fr "&Blue" "&Bleu" - ::msgcat::mcset fr "&Cancel" "&Annuler" - ::msgcat::mcset fr "Cannot change to the directory \"%1\$s\".\nPermission denied." "Impossible d'acc\u00e9der au r\u00e9pertoire \"%1\$s\".\nPermission refus\u00e9e." - ::msgcat::mcset fr "Choose Directory" "Choisir r\u00e9pertoire" - ::msgcat::mcset fr "Clear" "Effacer" - ::msgcat::mcset fr "Color" "Couleur" - ::msgcat::mcset fr "Console" - ::msgcat::mcset fr "Copy" "Copier" - ::msgcat::mcset fr "Cut" "Couper" - ::msgcat::mcset fr "Delete" "Effacer" - ::msgcat::mcset fr "Details >>" "D\u00e9tails >>" - ::msgcat::mcset fr "Directory \"%1\$s\" does not exist." - ::msgcat::mcset fr "&Directory:" "&R\u00e9pertoire:" - ::msgcat::mcset fr "Error: %1\$s" - ::msgcat::mcset fr "Exit" - ::msgcat::mcset fr "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Le fichier \"%1\$s\" existe d\u00e9j\u00e0.\nVoulez-vous l'\u00e9craser?" - ::msgcat::mcset fr "File \"%1\$s\" already exists.\n\n" "Le fichier \"%1\$s\" existe d\u00e9j\u00e0.\n\n" - ::msgcat::mcset fr "File \"%1\$s\" does not exist." "Le fichier \"%1\$s\" n'existe pas." - ::msgcat::mcset fr "File &name:" "&Nom de fichier:" - ::msgcat::mcset fr "File &names:" "&Noms de fichiers:" - ::msgcat::mcset fr "Files of &type:" "&Type de fichiers:" - ::msgcat::mcset fr "Fi&les:" "Fich&iers:" - ::msgcat::mcset fr "&Filter" "&Filtre" - ::msgcat::mcset fr "Fil&ter:" "Fil&tre:" - ::msgcat::mcset fr "&Green" "&Vert" - ::msgcat::mcset fr "Hi" "All\u00f4" - ::msgcat::mcset fr "Hide Console" "Cacher la Console" - ::msgcat::mcset fr "&Ignore" "&Ignorer" - ::msgcat::mcset fr "Invalid file name \"%1\$s\"." "Nom de fichier invalide \"%1\$s\"." - ::msgcat::mcset fr "Log Files" "Fichiers de trace" - ::msgcat::mcset fr "&No" "&Non" - ::msgcat::mcset fr "&OK" - ::msgcat::mcset fr "Ok" - ::msgcat::mcset fr "Open" "Ouvrir" - ::msgcat::mcset fr "&Open" "&Ouvrir" - ::msgcat::mcset fr "Open Multiple Files" "Ouvrir plusieurs fichiers" - ::msgcat::mcset fr "Paste" "Coller" - ::msgcat::mcset fr "Quit" "Abandonner" - ::msgcat::mcset fr "&Red" "&Rouge" - ::msgcat::mcset fr "Replace existing file?" "Remplacer fichier existant?" - ::msgcat::mcset fr "&Retry" "&R\u00e9-essayer" - ::msgcat::mcset fr "&Save" "&Sauvegarder" - ::msgcat::mcset fr "Save As" "Sauvegarder sous" - ::msgcat::mcset fr "Save To Log" "Sauvegarde au fichier de trace" - ::msgcat::mcset fr "Select Log File" "Choisir un fichier de trace" - ::msgcat::mcset fr "Select a file to source" "Choisir un fichier \u00e0 \u00e9valuer" - ::msgcat::mcset fr "&Selection:" "&S\u00e9lection:" - ::msgcat::mcset fr "Skip Messages" "Omettre les messages" - ::msgcat::mcset fr "Source..." "\u00c9valuer..." - ::msgcat::mcset fr "Tcl Scripts" "Scripts Tcl" - ::msgcat::mcset fr "Tcl for Windows" "Tcl pour Windows" - ::msgcat::mcset fr "Text Files" "Fichiers texte" - ::msgcat::mcset fr "&Yes" "&Oui" - ::msgcat::mcset fr "abort" "annuler" - ::msgcat::mcset fr "blue" "bleu" - ::msgcat::mcset fr "cancel" "annuler" - ::msgcat::mcset fr "extension" - ::msgcat::mcset fr "extensions" - ::msgcat::mcset fr "green" "vert" - ::msgcat::mcset fr "ignore" "ignorer" - ::msgcat::mcset fr "ok" - ::msgcat::mcset fr "red" "rouge" - ::msgcat::mcset fr "retry" "r\u00e9-essayer" - ::msgcat::mcset fr "yes" "oui" -} diff --git a/tcl/library/msgs/it.msg b/tcl/library/msgs/it.msg deleted file mode 100644 index 9e6298b8d79..00000000000 --- a/tcl/library/msgs/it.msg +++ /dev/null @@ -1,70 +0,0 @@ -namespace eval ::tk { - ::msgcat::mcset it "&Abort" "&Interrompi" - ::msgcat::mcset it "About..." "Informazioni ..." - ::msgcat::mcset it "All Files" "Tutti i file" - ::msgcat::mcset it "Application Error" "Errore dell' applicazione" - ::msgcat::mcset it "&Blue" "&Blu" - ::msgcat::mcset it "&Cancel" "&Annulla" - ::msgcat::mcset it "Cannot change to the directory \"%1\$s\".\nPermission denied." "Impossibile accedere alla directory \"%1\$s\".\nPermesso negato." - ::msgcat::mcset it "Choose Directory" "Scegli directory" - ::msgcat::mcset it "Clear" "Azzera" - ::msgcat::mcset it "Color" "Colore" - ::msgcat::mcset it "Console" - ::msgcat::mcset it "Copy" "Copia" - ::msgcat::mcset it "Cut" "Taglia" - ::msgcat::mcset it "Delete" "Incolla" - ::msgcat::mcset it "Details >>" "Dettagli >>" - ::msgcat::mcset it "Directory \"%1\$s\" does not exist." "La directory \"%1\$s\" non esiste." - ::msgcat::mcset it "&Directory:" - ::msgcat::mcset it "Error: %1\$s" "Errore: %1\$s" - ::msgcat::mcset it "Exit" "Esci" - ::msgcat::mcset it "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Il file \"%1\$s\" esiste gi\u00e0.\nVuoi sovrascriverlo?" - ::msgcat::mcset it "File \"%1\$s\" already exists.\n\n" "Il file \"%1\$s\" esiste gi\u00e0.\n\n" - ::msgcat::mcset it "File \"%1\$s\" does not exist." "Il file \"%1\$s\" non esiste." - ::msgcat::mcset it "File &name:" "&Nome del file:" - ::msgcat::mcset it "File &names:" "&Nomi dei file:" - ::msgcat::mcset it "Files of &type:" "File di &tipo:" - ::msgcat::mcset it "Fi&les:" "Fi&le:" - ::msgcat::mcset it "&Filter" "&Filtro" - ::msgcat::mcset it "Fil&ter:" "Fil&tro:" - ::msgcat::mcset it "&Green" "&Verde" - ::msgcat::mcset it "Hi" "Salve" - ::msgcat::mcset it "Hide Console" "Nascondi la console" - ::msgcat::mcset it "&Ignore" "&Ignora" - ::msgcat::mcset it "Invalid file name \"%1\$s\"." "Nome di file non valido \"%1\$s\"." - ::msgcat::mcset it "Log Files" "File di log" - ::msgcat::mcset it "&No" - ::msgcat::mcset it "&OK" - ::msgcat::mcset it "Ok" - ::msgcat::mcset it "&Open" "A&pri" - ::msgcat::mcset it "Open" "Apri" - ::msgcat::mcset it "Open Multiple Files" "Apri file multipli" - ::msgcat::mcset it "Paste" "Incolla" - ::msgcat::mcset it "Quit" "Esci" - ::msgcat::mcset it "&Red" "&Rosso" - ::msgcat::mcset it "Replace existing file?" "Sostituisci il file esistente?" - ::msgcat::mcset it "&Retry" "&Riprova" - ::msgcat::mcset it "&Save" "&Salva" - ::msgcat::mcset it "Save As" "Salva come" - ::msgcat::mcset it "Save To Log" "Salva il log" - ::msgcat::mcset it "Select Log File" "Scegli un file di log" - ::msgcat::mcset it "Select a file to source" "Scegli un file da eseguire" - ::msgcat::mcset it "&Selection:" "&Selezione:" - ::msgcat::mcset it "Skip Messages" "Salta i messaggi" - ::msgcat::mcset it "Source..." "Esegui..." - ::msgcat::mcset it "Tcl Scripts" "Scripts Tcl" - ::msgcat::mcset it "Tcl for Windows" "Tcl per Windows" - ::msgcat::mcset it "Text Files" "File di testo" - ::msgcat::mcset it "&Yes" "&Si" - ::msgcat::mcset it "abort" "interrompi" - ::msgcat::mcset it "blue" "blu" - ::msgcat::mcset it "cancel" "annulla" - ::msgcat::mcset it "extension" "estensione" - ::msgcat::mcset it "extensions" "estensioni" - ::msgcat::mcset it "green" "verde" - ::msgcat::mcset it "ignore" "ignora" - ::msgcat::mcset it "ok" - ::msgcat::mcset it "red" "rosso" - ::msgcat::mcset it "retry" "riprova" - ::msgcat::mcset it "yes" "si" -} diff --git a/tcl/library/msgs/nl.msg b/tcl/library/msgs/nl.msg deleted file mode 100644 index daad8474bf0..00000000000 --- a/tcl/library/msgs/nl.msg +++ /dev/null @@ -1,106 +0,0 @@ -namespace eval ::tk { - ::msgcat::mcset nl "\"%1\$s\" must be an absolute pathname" "\"%1\$s\" moet een absolute pad-naam zijn" - ::msgcat::mcset nl "%1\$s is not a toplevel window" "%1\$s is geen toplevel window" - ::msgcat::mcset nl ", or" ", of" - ::msgcat::mcset nl "-default, -icon, -message, -parent, -title, or -type" "-default, -icon, -message, -parent, -title, of -type" - ::msgcat::mcset nl "-initialdir, -mustexist, -parent, or -title" "-initialdir, -mustexist, -parent, of -title" - ::msgcat::mcset nl "&Abort" "&Afbreken" - ::msgcat::mcset nl "About..." "Over..." - ::msgcat::mcset nl "All Files" "Alle Bestanden" - ::msgcat::mcset nl "Application Error" "Toepassingsfout" - ::msgcat::mcset nl "&Blue" "&Blauw" - ::msgcat::mcset nl "&Cancel" "&Annuleren" - ::msgcat::mcset nl "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kan niet naar map \"%1\$s\" gaan.\nU heeft geen toestemming hiervoor." - ::msgcat::mcset nl "Choose Directory" "Kies map" - ::msgcat::mcset nl "Clear" "Wissen" - ::msgcat::mcset nl "Clear entry, Press OK; Enter %1\$s, press OK" "Wis veld, Druk op OK; Geef %1\$s in, druk op OK" - ::msgcat::mcset nl "Color" "Kleur" - ::msgcat::mcset nl "Console" - ::msgcat::mcset nl "Copy" "Copi\u00ebren" - ::msgcat::mcset nl "Cut" "Knippen" - ::msgcat::mcset nl "Delete" "Wissen" - ::msgcat::mcset nl "Details" - ::msgcat::mcset nl "Details >>" - ::msgcat::mcset nl "Directory \"%1\$s\" does not exist." "Map \"%1\$s\" bestaat niet." - ::msgcat::mcset nl "&Directory:" "&Map:" - ::msgcat::mcset nl "Enter \"%1\$s\", press OK" "Toets \"%1\$s\", druk op OK" - ::msgcat::mcset nl "Enter \"%1\$s\", press OK, enter \"%2\$s\", press OK" "Toets \"%1\$s\", druk op OK, toets \"%2\$s\", druk op OK" - ::msgcat::mcset nl "Error: %1\$s" "Fout: %1\$s" - ::msgcat::mcset nl "Exit" "Be\u00ebindigen" - ::msgcat::mcset nl "File \"%1\$s\" already exists.\n\n" "Bestand \"%1\$s\" bestaat al.\n\n" - ::msgcat::mcset nl "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Bestand \"%1\$s\" bestaat al.\nWilt u het overschrijven?" - ::msgcat::mcset nl "File \"%1\$s\" does not exist." "Bestand \"%1\$s\" bestaat niet." - ::msgcat::mcset nl "File &name:" "Bestands&naam:" - ::msgcat::mcset nl "File &names:" "Bestands&namen:" - ::msgcat::mcset nl "Files of &type:" "Bestanden van het &type:" - ::msgcat::mcset nl "Fi&les:" "&Bestanden:" - ::msgcat::mcset nl "&Filter" - ::msgcat::mcset nl "Fil&ter:" - ::msgcat::mcset nl "&Green" "&Groen" - ::msgcat::mcset nl "Hi" "H\u00e9" - ::msgcat::mcset nl "Hide Console" "Verberg Console" - ::msgcat::mcset nl "&Ignore" - ::msgcat::mcset nl "Invalid file name \"%1\$s\"." "Ongeldige bestandsnaam \"%1\$s\"." - ::msgcat::mcset nl "Log Files" "Log Bestanden" - ::msgcat::mcset nl "&No" "&Nee" - ::msgcat::mcset nl "&OK" - ::msgcat::mcset nl "Ok" - ::msgcat::mcset nl "&Open" "&Openen" - ::msgcat::mcset nl "Open" "Openen" - ::msgcat::mcset nl "Open Multiple Files" "Open meerdere bestanden" - ::msgcat::mcset nl "Paste" "Plakken" - ::msgcat::mcset nl "Please press %1\$s" "Druk op %1\$s, A.U.B." - ::msgcat::mcset nl "Please press ok" "Druk op ok, A.U.B." - ::msgcat::mcset nl "Press Cancel" "Druk op Annuleren" - ::msgcat::mcset nl "Press Ok" "Druk op Ok" - ::msgcat::mcset nl "Quit" "Stoppen" - ::msgcat::mcset nl "&Red" "&Rood" - ::msgcat::mcset nl "Replace existing file?" "Vervang bestaand bestand?" - ::msgcat::mcset nl "&Retry" "O&nieuw" - ::msgcat::mcset nl "&Save" "Op&slaan" - ::msgcat::mcset nl "Save As" "Opslaan als" - ::msgcat::mcset nl "Save To Log" "Opslaan naar Log" - ::msgcat::mcset nl "Select Log File" "Selecteer Log bestand" - ::msgcat::mcset nl "Select a file to source" "Selecteer bronbestand" - ::msgcat::mcset nl "&Selection:" "&Selectie:" - ::msgcat::mcset nl "Skip Messages" "Berichten overslaan" - ::msgcat::mcset nl "Source..." "Bron..." - ::msgcat::mcset nl "Tcl Scripts" - ::msgcat::mcset nl "Tcl for Windows" "Tcl voor Windows" - ::msgcat::mcset nl "Text Files" "Tekst Bestanden" - ::msgcat::mcset nl "&Yes" "&Ja" - ::msgcat::mcset nl "abort" "afbreken" - ::msgcat::mcset nl "abort, retry, ignore, ok, cancel, no, or yes" "afbreken, opnieuw, negeren, ok, annuleren, nee, of ja" - ::msgcat::mcset nl "abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel" "abortretryignore, ok, okcancel, retrycancel, yesno, of yesnocancel" - ::msgcat::mcset nl "bad %1\$s value \"%2\$s\": must be %3\$s" "foutieve %1\$s waarde \"%2\$s\": moet zijn %3\$s" - ::msgcat::mcset nl "bad file type \"%1\$s\", should be" "foutief bestandstype \"%1\$s\", moet zijn" - ::msgcat::mcset nl "bad option \"%1\$s\": should be %2\$s" "foutieve optie \"%1\$s\": moet zijn %2\$s" - ::msgcat::mcset nl "bad window path name \"%1\$s\"" "foutieve window pad naam \"%1\$s\"" - ::msgcat::mcset nl "blue" "blauw" - ::msgcat::mcset nl "can't post %1\$s: it isn't a descendant of %2\$s (this is a new requirement in Tk versions 3.0 and later)" "kan %1\$s niet verzenden: het is geen afstammeling van %2\$s (dit is een niewe verplichting in Tk versies 3.0 en later)" - ::msgcat::mcset nl "cancel" "annuleren" - ::msgcat::mcset nl "default button index greater than number of buttons specified for tk_dialog" "default knop index is groter dan het aantal knoppen beschikbaar voor tk_dialog" - ::msgcat::mcset nl "display name to use (current one otherwise)" "te gebruiken schermnaam (anders huidige scherm)" - ::msgcat::mcset nl "error, info, question, or warning" "error, info, question, of warning" - ::msgcat::mcset nl "extension" - ::msgcat::mcset nl "extensions" - ::msgcat::mcset nl "focus group \"%1\$s\" doesn't exist" "focus groep \"%1\$s\" bestaat niet" - ::msgcat::mcset nl "green" "groen" - ::msgcat::mcset nl "history event %1\$s" - ::msgcat::mcset nl "ignore" "negeren" - ::msgcat::mcset nl "invalid default button \"%1\$s\"" "ongeldige default knop \"%1\$s\"" - ::msgcat::mcset nl "macType" - ::msgcat::mcset nl "macTypes" - ::msgcat::mcset nl "must specify a background color" "een achtergrondkleur is verplicht" - ::msgcat::mcset nl "name of the slave interpreter" "naam van de slaaf interpreter" - ::msgcat::mcset nl "no winfo screen . nor env(DISPLAY)" "geen winfo scherm . noch env(DISPLAY)" - ::msgcat::mcset nl "ok" - ::msgcat::mcset nl "red" "rood" - ::msgcat::mcset nl "retry" "opnieuw" - ::msgcat::mcset nl "should contain 5 or 4 elements" "moet 4 of 5 elementen bevatten" - ::msgcat::mcset nl "spec" - ::msgcat::mcset nl "tk_chooseDirectory command" "tk_chooseDirectory commando" - ::msgcat::mcset nl "tk_chooseDirectory command, cancel gives null" "tk_chooseDirectory commando, annuleren geeft lege waarde" - ::msgcat::mcset nl "tk_chooseDirectory command, initialdir" "tk_chooseDirectory commando, initi\u00eble map" - ::msgcat::mcset nl "yes" "ja" -} diff --git a/tcl/library/msgs/ru.msg b/tcl/library/msgs/ru.msg deleted file mode 100644 index 9f6aa807e0a..00000000000 --- a/tcl/library/msgs/ru.msg +++ /dev/null @@ -1,73 +0,0 @@ -namespace eval ::tk { - ::msgcat::mcset ru "&Abort" "&\u041e\u0442\u043c\u0435\u043d\u0438\u0442\u044c" - ::msgcat::mcset ru "About..." "\u041f\u0440\u043e..." - ::msgcat::mcset ru "All Files" "\u0412\u0441\u0435 \u0444\u0430\u0439\u043b\u044b" - ::msgcat::mcset ru "Application Error" "\u041e\u0448\u0438\u0431\u043a\u0430 \u0432 \u043f\u0440\u043e\u0433\u0440\u0430\u043c\u043c\u0435" - ::msgcat::mcset ru "&Blue" " &\u0413\u043e\u043b\u0443\u0431\u043e\u0439" - ::msgcat::mcset ru "&Cancel" "\u041e\u0442&\u043c\u0435\u043d\u0430" - ::msgcat::mcset ru "Cannot change to the directory \"%1\$s\".\nPermission denied." \ - "\u041d\u0435 \u043c\u043e\u0433\u0443 \u043f\u0435\u0440\u0435\u0439\u0442\u0438 \u0432 \u043a\u0430\u0442\u0430\u043b\u043e\u0433 \"%1\$s\".\n\u041d\u0435\u0434\u043e\u0441\u0442\u0430\u0442\u043e\u0447\u043d\u043e \u043f\u0440\u0430\u0432 \u0434\u043e\u0441\u0442\u0443\u043f\u0430" - ::msgcat::mcset ru "Choose Directory" "\u0412\u044b\u0431\u0435\u0440\u0438\u0442\u0435 \u043a\u0430\u0442\u0430\u043b\u043e\u0433" - ::msgcat::mcset ru "Clear" "\u041e\u0447\u0438\u0441\u0442\u0438\u0442\u044c" - ::msgcat::mcset ru "Color" "\u0426\u0432\u0435\u0442" - ::msgcat::mcset ru "Console" "\u041a\u043e\u043d\u0441\u043e\u043b\u044c" - ::msgcat::mcset ru "Copy" "\u041a\u043e\u043f\u0438\u0440\u043e\u0432\u0430\u0442\u044c" - ::msgcat::mcset ru "Cut" "\u0412\u044b\u0440\u0435\u0437\u0430\u0442\u044c" - ::msgcat::mcset ru "Delete" "\u0423\u0434\u0430\u043b\u0438\u0442\u044c" - ::msgcat::mcset ru "Details >>" "\u041f\u043e\u0434\u0440\u043e\u0431\u043d\u0435\u0435 >>" - ::msgcat::mcset ru "Directory \"%1\$s\" does not exist." "\u041a\u0430\u0442\u0430\u043b\u043e\u0433\u0430 \"%1\$s\" \u043d\u0435 \u0441\u0443\u0449\u0435\u0441\u0442\u0432\u0443\u0435\u0442." - ::msgcat::mcset ru "&Directory:" "&\u041a\u0430\u0442\u0430\u043b\u043e\u0433:" - ::msgcat::mcset ru "Error: %1\$s" "\u041e\u0448\u0438\u0431\u043a\u0430: %1\$s" - ::msgcat::mcset ru "Exit" "\u0412\u044b\u0445\u043e\u0434" - ::msgcat::mcset ru "File \"%1\$s\" already exists.\nDo you want to overwrite it?" \ - "\u0424\u0430\u0439\u043b \"%1\$s\" \u0443\u0436\u0435 \u0441\u0443\u0449\u0435\u0441\u0442\u0432\u0443\u0435\u0442.\n\u0417\u0430\u043c\u0435\u043d\u0438\u0442\u044c \u0435\u0433\u043e?" - ::msgcat::mcset ru "File \"%1\$s\" already exists.\n\n" "\u0424\u0430\u0439\u043b \"%1\$s\" \u0443\u0436\u0435 \u0441\u0443\u0449\u0435\u0441\u0442\u0432\u0443\u0435\u0442.\n\n" - ::msgcat::mcset ru "File \"%1\$s\" does not exist." "\u0424\u0430\u0439\u043b \"%1\$s\" \u043d\u0435 \u043d\u0430\u0439\u0434\u0435\u043d." - ::msgcat::mcset ru "File &name:" "&\u0418\u043c\u044f \u0444\u0430\u0439\u043b\u0430:" - ::msgcat::mcset ru "File &names:" "&\u0418\u043c\u0435\u043d\u0430 \u0444\u0430\u0439\u043b\u043e\u0432:" - ::msgcat::mcset ru "Files of &type:" "&\u0422\u0438\u043f \u0444\u0430\u0439\u043b\u043e\u0432:" - ::msgcat::mcset ru "Fi&les:" "\u0424\u0430\u0439&\u043b\u044b:" - ::msgcat::mcset ru "&Filter" "&\u0424\u0438\u043b\u044c\u0442\u0440" - ::msgcat::mcset ru "Fil&ter:" "\u0424\u0438\u043b\u044c&\u0442\u0440:" - ::msgcat::mcset ru "&Green" " &\u0417\u0435\u043b\u0435\u043d\u044b\u0439" - ::msgcat::mcset ru "Hi" "\u041f\u0440\u0438\u0432\u0435\u0442" - ::msgcat::mcset ru "Hide Console" "\u0421\u043f\u0440\u044f\u0442\u0430\u0442\u044c \u043a\u043e\u043d\u0441\u043e\u043b\u044c" - ::msgcat::mcset ru "&Ignore" "&\u0418\u0433\u043d\u043e\u0440\u0438\u0440\u043e\u0432\u0430\u0442\u044c" - ::msgcat::mcset ru "Invalid file name \"%1\$s\"." "\u041d\u0435\u0432\u0435\u0440\u043d\u043e\u0435 \u0438\u043c\u044f \u0444\u0430\u0439\u043b\u0430 \"%1\$s\"." - ::msgcat::mcset ru "Log Files" "\u0424\u0430\u0439\u043b\u044b \u0436\u0443\u0440\u043d\u0430\u043b\u0430" - ::msgcat::mcset ru "&No" "&\u041d\u0435\u0442" - ::msgcat::mcset ru "&OK" "&\u041e\u041a" - ::msgcat::mcset ru "Ok" "\u0414\u0430" - ::msgcat::mcset ru "Open" "\u041e\u0442\u043a\u0440\u044b\u0442\u044c" - ::msgcat::mcset ru "&Open" "&\u041e\u0442\u043a\u0440\u044b\u0442\u044c" - ::msgcat::mcset ru "Open Multiple Files" "\u041e\u0442\u043a\u0440\u044b\u0442\u044c \u043d\u0435\u0441\u043a\u043e\u043b\u044c\u043a\u043e \u0444\u0430\u0439\u043b\u043e\u0432" - ::msgcat::mcset ru "Paste" "\u0412\u0441\u0442\u0430\u0432\u0438\u0442\u044c" - ::msgcat::mcset ru "Quit" "\u0412\u044b\u0445\u043e\u0434" - ::msgcat::mcset ru "&Red" " &\u041a\u0440\u0430\u0441\u043d\u044b\u0439" - ::msgcat::mcset ru "Replace existing file?" "\u0417\u0430\u043c\u0435\u043d\u0438\u0442\u044c \u0441\u0443\u0449\u0435\u0441\u0442\u0432\u0443\u044e\u0449\u0438\u0439 \u0444\u0430\u0439\u043b?" - ::msgcat::mcset ru "&Retry" "&\u041f\u043e\u0432\u0442\u043e\u0440\u0438\u0442\u044c" - ::msgcat::mcset ru "&Save" "&\u0421\u043e\u0445\u0440\u0430\u043d\u0438\u0442\u044c" - ::msgcat::mcset ru "Save As" "\u0421\u043e\u0445\u0440\u0430\u043d\u0438\u0442\u044c \u043a\u0430\u043a" - ::msgcat::mcset ru "Save To Log" "\u0421\u043e\u0445\u0440\u0430\u043d\u0438\u0442\u044c \u0432 \u0436\u0443\u0440\u043d\u0430\u043b" - ::msgcat::mcset ru "Select Log File" "\u0412\u044b\u0431\u0440\u0430\u0442\u044c \u0436\u0443\u0440\u043d\u0430\u043b" - ::msgcat::mcset ru "Select a file to source" "\u0412\u044b\u0431\u0435\u0440\u0438\u0442\u0435 \u0444\u0430\u0439\u043b \u0434\u043b\u044f \u0438\u043d\u0442\u0435\u0440\u043f\u0440\u0435\u0442\u0430\u0446\u0438\u0438" - ::msgcat::mcset ru "&Selection:" "&Selection:" - ::msgcat::mcset ru "Skip Messages" "\u041f\u0440\u043e\u043f\u0443\u0441\u0442\u0438\u0442\u044c \u0441\u043e\u043e\u0431\u0449\u0435\u043d\u0438\u044f" - ::msgcat::mcset ru "Source..." "\u0418\u043d\u0442\u0435\u0440\u043f\u0440\u0435\u0442\u0438\u0440\u043e\u0432\u0430\u0442\u044c \u0444\u0430\u0439\u043b..." - ::msgcat::mcset ru "Tcl Scripts" "\u041f\u0440\u043e\u0433\u0440\u0430\u043c\u043c\u0430 \u043d\u0430 \u044f\u0437\u044b\u043a\u0435 TCL" - ::msgcat::mcset ru "Tcl for Windows" "TCL \u0434\u043b\u044f Windows" - ::msgcat::mcset ru "Text Files" "\u0422\u0435\u043a\u0441\u0442\u043e\u0432\u044b\u0435 \u0444\u0430\u0439\u043b\u044b" - ::msgcat::mcset ru "&Yes" "&\u0414\u0430" - ::msgcat::mcset ru "abort" "\u043e\u0442\u043c\u0435\u043d\u0430" - ::msgcat::mcset ru "blue" " \u0433\u043e\u043b\u0443\u0431\u043e\u0439" - ::msgcat::mcset ru "cancel" "\u043e\u0442\u043c\u0435\u043d\u0430" - ::msgcat::mcset ru "extension" "\u0440\u0430\u0441\u0448\u0438\u0440\u0435\u043d\u0438\u0435" - ::msgcat::mcset ru "extensions" "\u0440\u0430\u0441\u0448\u0438\u0440\u0435\u043d\u0438\u044f" - ::msgcat::mcset ru "green" " \u0437\u0435\u043b\u0435\u043d\u044b\u0439" - ::msgcat::mcset ru "ignore" "\u043f\u0440\u043e\u043f\u0443\u0441\u0442\u0438\u0442\u044c" - ::msgcat::mcset ru "ok" "\u043e\u043a" - ::msgcat::mcset ru "red" " \u043a\u0440\u0430\u0441\u043d\u044b\u0439" - ::msgcat::mcset ru "retry" "\u043f\u043e\u0432\u0442\u043e\u0440\u0438\u0442\u044c" - ::msgcat::mcset ru "yes" "\u0434\u0430" -} - diff --git a/tcl/library/obsolete.tcl b/tcl/library/obsolete.tcl deleted file mode 100644 index 587e2dd0b71..00000000000 --- a/tcl/library/obsolete.tcl +++ /dev/null @@ -1,21 +0,0 @@ -# obsolete.tcl -- -# -# This file contains obsolete procedures that people really shouldn't -# be using anymore, but which are kept around for backward compatibility. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# The procedures below are here strictly for backward compatibility with -# Tk version 3.6 and earlier. The procedures are no longer needed, so -# they are no-ops. You should not use these procedures anymore, since -# they may be removed in some future release. - -proc tk_menuBar args {} -proc tk_bindForTraversal args {} diff --git a/tcl/library/opt0.4/optparse.tcl b/tcl/library/opt0.4/optparse.tcl deleted file mode 100644 index 96877dcce29..00000000000 --- a/tcl/library/opt0.4/optparse.tcl +++ /dev/null @@ -1,1090 +0,0 @@ -# optparse.tcl -- -# -# (private) Option parsing package -# Primarily used internally by the safe:: code. -# -# WARNING: This code will go away in a future release -# of Tcl. It is NOT supported and you should not rely -# on it. If your code does rely on this package you -# may directly incorporate this code into your application. -# -# RCS: @(#) $Id$ - -package provide opt 0.4.1 - -namespace eval ::tcl { - - # Exported APIs - namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ - OptProc OptProcArgGiven OptParse \ - Lempty Lget \ - Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \ - SetMax SetMin - - -################# Example of use / 'user documentation' ################### - - proc OptCreateTestProc {} { - - # Defines ::tcl::OptParseTest as a test proc with parsed arguments - # (can't be defined before the code below is loaded (before "OptProc")) - - # Every OptProc give usage information on "procname -help". - # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and - # then other arguments. - # - # example of 'valid' call: - # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\ - # -nostatics false ch1 - OptProc OptParseTest { - {subcommand -choice {save print} "sub command"} - {arg1 3 "some number"} - {-aflag} - {-intflag 7} - {-weirdflag "help string"} - {-noStatics "Not ok to load static packages"} - {-nestedloading1 true "OK to load into nested slaves"} - {-nestedloading2 -boolean true "OK to load into nested slaves"} - {-libsOK -choice {Tk SybTcl} - "List of packages that can be loaded"} - {-precision -int 12 "Number of digits of precision"} - {-intval 7 "An integer"} - {-scale -float 1.0 "Scale factor"} - {-zoom 1.0 "Zoom factor"} - {-arbitrary foobar "Arbitrary string"} - {-random -string 12 "Random string"} - {-listval -list {} "List value"} - {-blahflag -blah abc "Funny type"} - {arg2 -boolean "a boolean"} - {arg3 -choice "ch1 ch2"} - {?optarg? -list {} "optional argument"} - } { - foreach v [info locals] { - puts stderr [format "%14s : %s" $v [set $v]] - } - } - } - -################### No User serviceable part below ! ############### -# You should really not look any further : -# The following is private unexported undocumented unblessed... code -# time to hit "q" ;-) ! - -# Hmmm... ok, you really want to know ? - -# You've been warned... Here it is... - - # Array storing the parsed descriptions - variable OptDesc; - array set OptDesc {}; - # Next potentially free key id (numeric) - variable OptDescN 0; - -# Inside algorithm/mechanism description: -# (not for the faint hearted ;-) -# -# The argument description is parsed into a "program tree" -# It is called a "program" because it is the program used by -# the state machine interpreter that use that program to -# actually parse the arguments at run time. -# -# The general structure of a "program" is -# notation (pseudo bnf like) -# name :== definition defines "name" as being "definition" -# { x y z } means list of x, y, and z -# x* means x repeated 0 or more time -# x+ means "x x*" -# x? means optionally x -# x | y means x or y -# "cccc" means the literal string -# -# program :== { programCounter programStep* } -# -# programStep :== program | singleStep -# -# programCounter :== {"P" integer+ } -# -# singleStep :== { instruction parameters* } -# -# instruction :== single element list -# -# (the difference between singleStep and program is that \ -# llength [lindex $program 0] >= 2 -# while -# llength [lindex $singleStep 0] == 1 -# ) -# -# And for this application: -# -# singleStep :== { instruction varname {hasBeenSet currentValue} type -# typeArgs help } -# instruction :== "flags" | "value" -# type :== knowType | anyword -# knowType :== "string" | "int" | "boolean" | "boolflag" | "float" -# | "choice" -# -# for type "choice" typeArgs is a list of possible choices, the first one -# is the default value. for all other types the typeArgs is the default value -# -# a "boolflag" is the type for a flag whose presence or absence, without -# additional arguments means respectively true or false (default flag type). -# -# programCounter is the index in the list of the currently processed -# programStep (thus starting at 1 (0 is {"P" prgCounterValue}). -# If it is a list it points toward each currently selected programStep. -# (like for "flags", as they are optional, form a set and programStep). - -# Performance/Implementation issues -# --------------------------------- -# We use tcl lists instead of arrays because with tcl8.0 -# they should start to be much faster. -# But this code use a lot of helper procs (like Lvarset) -# which are quite slow and would be helpfully optimized -# for instance by being written in C. Also our struture -# is complex and there is maybe some places where the -# string rep might be calculated at great exense. to be checked. - -# -# Parse a given description and saves it here under the given key -# generate a unused keyid if not given -# -proc ::tcl::OptKeyRegister {desc {key ""}} { - variable OptDesc; - variable OptDescN; - if {[string compare $key ""] == 0} { - # in case a key given to us as a parameter was a number - while {[info exists OptDesc($OptDescN)]} {incr OptDescN} - set key $OptDescN; - incr OptDescN; - } - # program counter - set program [list [list "P" 1]]; - - # are we processing flags (which makes a single program step) - set inflags 0; - - set state {}; - - # flag used to detect that we just have a single (flags set) subprogram. - set empty 1; - - foreach item $desc { - if {$state == "args"} { - # more items after 'args'... - return -code error "'args' special argument must be the last one"; - } - set res [OptNormalizeOne $item]; - set state [lindex $res 0]; - if {$inflags} { - if {$state == "flags"} { - # add to 'subprogram' - lappend flagsprg $res; - } else { - # put in the flags - # structure for flag programs items is a list of - # {subprgcounter {prg flag 1} {prg flag 2} {...}} - lappend program $flagsprg; - # put the other regular stuff - lappend program $res; - set inflags 0; - set empty 0; - } - } else { - if {$state == "flags"} { - set inflags 1; - # sub program counter + first sub program - set flagsprg [list [list "P" 1] $res]; - } else { - lappend program $res; - set empty 0; - } - } - } - if {$inflags} { - if {$empty} { - # We just have the subprogram, optimize and remove - # unneeded level: - set program $flagsprg; - } else { - lappend program $flagsprg; - } - } - - set OptDesc($key) $program; - - return $key; -} - -# -# Free the storage for that given key -# -proc ::tcl::OptKeyDelete {key} { - variable OptDesc; - unset OptDesc($key); -} - - # Get the parsed description stored under the given key. - proc OptKeyGetDesc {descKey} { - variable OptDesc; - if {![info exists OptDesc($descKey)]} { - return -code error "Unknown option description key \"$descKey\""; - } - set OptDesc($descKey); - } - -# Parse entry point for ppl who don't want to register with a key, -# for instance because the description changes dynamically. -# (otherwise one should really use OptKeyRegister once + OptKeyParse -# as it is way faster or simply OptProc which does it all) -# Assign a temporary key, call OptKeyParse and then free the storage -proc ::tcl::OptParse {desc arglist} { - set tempkey [OptKeyRegister $desc]; - set ret [catch {uplevel [list ::tcl::OptKeyParse $tempkey $arglist]} res]; - OptKeyDelete $tempkey; - return -code $ret $res; -} - -# Helper function, replacement for proc that both -# register the description under a key which is the name of the proc -# (and thus unique to that code) -# and add a first line to the code to call the OptKeyParse proc -# Stores the list of variables that have been actually given by the user -# (the other will be sets to their default value) -# into local variable named "Args". -proc ::tcl::OptProc {name desc body} { - set namespace [uplevel namespace current]; - if { ([string match "::*" $name]) - || ([string compare $namespace "::"]==0)} { - # absolute name or global namespace, name is the key - set key $name; - } else { - # we are relative to some non top level namespace: - set key "${namespace}::${name}"; - } - OptKeyRegister $desc $key; - uplevel [list proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]; - return $key; -} -# Check that a argument has been given -# assumes that "OptProc" has been used as it will check in "Args" list -proc ::tcl::OptProcArgGiven {argname} { - upvar Args alist; - expr {[lsearch $alist $argname] >=0} -} - - ####### - # Programs/Descriptions manipulation - - # Return the instruction word/list of a given step/(sub)program - proc OptInstr {lst} { - lindex $lst 0; - } - # Is a (sub) program or a plain instruction ? - proc OptIsPrg {lst} { - expr {[llength [OptInstr $lst]]>=2} - } - # Is this instruction a program counter or a real instr - proc OptIsCounter {item} { - expr {[lindex $item 0]=="P"} - } - # Current program counter (2nd word of first word) - proc OptGetPrgCounter {lst} { - Lget $lst {0 1} - } - # Current program counter (2nd word of first word) - proc OptSetPrgCounter {lstName newValue} { - upvar $lstName lst; - set lst [lreplace $lst 0 0 [concat "P" $newValue]]; - } - # returns a list of currently selected items. - proc OptSelection {lst} { - set res {}; - foreach idx [lrange [lindex $lst 0] 1 end] { - lappend res [Lget $lst $idx]; - } - return $res; - } - - # Advance to next description - proc OptNextDesc {descName} { - uplevel [list Lvarincr $descName {0 1}]; - } - - # Get the current description, eventually descend - proc OptCurDesc {descriptions} { - lindex $descriptions [OptGetPrgCounter $descriptions]; - } - # get the current description, eventually descend - # through sub programs as needed. - proc OptCurDescFinal {descriptions} { - set item [OptCurDesc $descriptions]; - # Descend untill we get the actual item and not a sub program - while {[OptIsPrg $item]} { - set item [OptCurDesc $item]; - } - return $item; - } - # Current final instruction adress - proc OptCurAddr {descriptions {start {}}} { - set adress [OptGetPrgCounter $descriptions]; - lappend start $adress; - set item [lindex $descriptions $adress]; - if {[OptIsPrg $item]} { - return [OptCurAddr $item $start]; - } else { - return $start; - } - } - # Set the value field of the current instruction - proc OptCurSetValue {descriptionsName value} { - upvar $descriptionsName descriptions - # get the current item full adress - set adress [OptCurAddr $descriptions]; - # use the 3th field of the item (see OptValue / OptNewInst) - lappend adress 2 - Lvarset descriptions $adress [list 1 $value]; - # ^hasBeenSet flag - } - - # empty state means done/paste the end of the program - proc OptState {item} { - lindex $item 0 - } - - # current state - proc OptCurState {descriptions} { - OptState [OptCurDesc $descriptions]; - } - - ####### - # Arguments manipulation - - # Returns the argument that has to be processed now - proc OptCurrentArg {lst} { - lindex $lst 0; - } - # Advance to next argument - proc OptNextArg {argsName} { - uplevel [list Lvarpop1 $argsName]; - } - ####### - - - - - - # Loop over all descriptions, calling OptDoOne which will - # eventually eat all the arguments. - proc OptDoAll {descriptionsName argumentsName} { - upvar $descriptionsName descriptions - upvar $argumentsName arguments; -# puts "entered DoAll"; - # Nb: the places where "state" can be set are tricky to figure - # because DoOne sets the state to flagsValue and return -continue - # when needed... - set state [OptCurState $descriptions]; - # We'll exit the loop in "OptDoOne" or when state is empty. - while 1 { - set curitem [OptCurDesc $descriptions]; - # Do subprograms if needed, call ourselves on the sub branch - while {[OptIsPrg $curitem]} { - OptDoAll curitem arguments -# puts "done DoAll sub"; - # Insert back the results in current tree; - Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\ - $curitem; - OptNextDesc descriptions; - set curitem [OptCurDesc $descriptions]; - set state [OptCurState $descriptions]; - } -# puts "state = \"$state\" - arguments=($arguments)"; - if {[Lempty $state]} { - # Nothing left to do, we are done in this branch: - break; - } - # The following statement can make us terminate/continue - # as it use return -code {break, continue, return and error} - # codes - OptDoOne descriptions state arguments; - # If we are here, no special return code where issued, - # we'll step to next instruction : -# puts "new state = \"$state\""; - OptNextDesc descriptions; - set state [OptCurState $descriptions]; - } - } - - # Process one step for the state machine, - # eventually consuming the current argument. - proc OptDoOne {descriptionsName stateName argumentsName} { - upvar $argumentsName arguments; - upvar $descriptionsName descriptions; - upvar $stateName state; - - # the special state/instruction "args" eats all - # the remaining args (if any) - if {($state == "args")} { - if {![Lempty $arguments]} { - # If there is no additional arguments, leave the default value - # in. - OptCurSetValue descriptions $arguments; - set arguments {}; - } -# puts "breaking out ('args' state: consuming every reminding args)" - return -code break; - } - - if {[Lempty $arguments]} { - if {$state == "flags"} { - # no argument and no flags : we're done -# puts "returning to previous (sub)prg (no more args)"; - return -code return; - } elseif {$state == "optValue"} { - set state next; # not used, for debug only - # go to next state - return ; - } else { - return -code error [OptMissingValue $descriptions]; - } - } else { - set arg [OptCurrentArg $arguments]; - } - - switch $state { - flags { - # A non-dash argument terminates the options, as does -- - - # Still a flag ? - if {![OptIsFlag $arg]} { - # don't consume the argument, return to previous prg - return -code return; - } - # consume the flag - OptNextArg arguments; - if {[string compare "--" $arg] == 0} { - # return from 'flags' state - return -code return; - } - - set hits [OptHits descriptions $arg]; - if {$hits > 1} { - return -code error [OptAmbigous $descriptions $arg] - } elseif {$hits == 0} { - return -code error [OptFlagUsage $descriptions $arg] - } - set item [OptCurDesc $descriptions]; - if {[OptNeedValue $item]} { - # we need a value, next state is - set state flagValue; - } else { - OptCurSetValue descriptions 1; - } - # continue - return -code continue; - } - flagValue - - value { - set item [OptCurDesc $descriptions]; - # Test the values against their required type - if {[catch {OptCheckType $arg\ - [OptType $item] [OptTypeArgs $item]} val]} { - return -code error [OptBadValue $item $arg $val] - } - # consume the value - OptNextArg arguments; - # set the value - OptCurSetValue descriptions $val; - # go to next state - if {$state == "flagValue"} { - set state flags - return -code continue; - } else { - set state next; # not used, for debug only - return ; # will go on next step - } - } - optValue { - set item [OptCurDesc $descriptions]; - # Test the values against their required type - if {![catch {OptCheckType $arg\ - [OptType $item] [OptTypeArgs $item]} val]} { - # right type, so : - # consume the value - OptNextArg arguments; - # set the value - OptCurSetValue descriptions $val; - } - # go to next state - set state next; # not used, for debug only - return ; # will go on next step - } - } - # If we reach this point: an unknown - # state as been entered ! - return -code error "Bug! unknown state in DoOne \"$state\"\ - (prg counter [OptGetPrgCounter $descriptions]:\ - [OptCurDesc $descriptions])"; - } - -# Parse the options given the key to previously registered description -# and arguments list -proc ::tcl::OptKeyParse {descKey arglist} { - - set desc [OptKeyGetDesc $descKey]; - - # make sure -help always give usage - if {[string compare "-help" [string tolower $arglist]] == 0} { - return -code error [OptError "Usage information:" $desc 1]; - } - - OptDoAll desc arglist; - - if {![Lempty $arglist]} { - return -code error [OptTooManyArgs $desc $arglist]; - } - - # Analyse the result - # Walk through the tree: - OptTreeVars $desc "#[expr {[info level]-1}]" ; -} - - # determine string length for nice tabulated output - proc OptTreeVars {desc level {vnamesLst {}}} { - foreach item $desc { - if {[OptIsCounter $item]} continue; - if {[OptIsPrg $item]} { - set vnamesLst [OptTreeVars $item $level $vnamesLst]; - } else { - set vname [OptVarName $item]; - upvar $level $vname var - if {[OptHasBeenSet $item]} { -# puts "adding $vname" - # lets use the input name for the returned list - # it is more usefull, for instance you can check that - # no flags at all was given with expr - # {![string match "*-*" $Args]} - lappend vnamesLst [OptName $item]; - set var [OptValue $item]; - } else { - set var [OptDefaultValue $item]; - } - } - } - return $vnamesLst - } - - -# Check the type of a value -# and emit an error if arg is not of the correct type -# otherwise returns the canonical value of that arg (ie 0/1 for booleans) -proc ::tcl::OptCheckType {arg type {typeArgs ""}} { -# puts "checking '$arg' against '$type' ($typeArgs)"; - - # only types "any", "choice", and numbers can have leading "-" - - switch -exact -- $type { - int { - if {![regexp {^(-+)?[0-9]+$} $arg]} { - error "not an integer" - } - return $arg; - } - float { - return [expr {double($arg)}] - } - script - - list { - # if llength fail : malformed list - if {[llength $arg]==0} { - if {[OptIsFlag $arg]} { - error "no values with leading -" - } - } - return $arg; - } - boolean { - if {![regexp -nocase {^(true|false|0|1)$} $arg]} { - error "non canonic boolean" - } - # convert true/false because expr/if is broken with "!,... - if {$arg} { - return 1 - } else { - return 0 - } - } - choice { - if {[lsearch -exact $typeArgs $arg] < 0} { - error "invalid choice" - } - return $arg; - } - any { - return $arg; - } - string - - default { - if {[OptIsFlag $arg]} { - error "no values with leading -" - } - return $arg - } - } - return neverReached; -} - - # internal utilities - - # returns the number of flags matching the given arg - # sets the (local) prg counter to the list of matches - proc OptHits {descName arg} { - upvar $descName desc; - set hits 0 - set hitems {} - set i 1; - - set larg [string tolower $arg]; - set len [string length $larg]; - set last [expr {$len-1}]; - - foreach item [lrange $desc 1 end] { - set flag [OptName $item] - # lets try to match case insensitively - # (string length ought to be cheap) - set lflag [string tolower $flag]; - if {$len == [string length $lflag]} { - if {[string compare $larg $lflag]==0} { - # Exact match case - OptSetPrgCounter desc $i; - return 1; - } - } else { - if {[string compare $larg [string range $lflag 0 $last]]==0} { - lappend hitems $i; - incr hits; - } - } - incr i; - } - if {$hits} { - OptSetPrgCounter desc $hitems; - } - return $hits - } - - # Extract fields from the list structure: - - proc OptName {item} { - lindex $item 1; - } - # - proc OptHasBeenSet {item} { - Lget $item {2 0}; - } - # - proc OptValue {item} { - Lget $item {2 1}; - } - - proc OptIsFlag {name} { - string match "-*" $name; - } - proc OptIsOpt {name} { - string match {\?*} $name; - } - proc OptVarName {item} { - set name [OptName $item]; - if {[OptIsFlag $name]} { - return [string range $name 1 end]; - } elseif {[OptIsOpt $name]} { - return [string trim $name "?"]; - } else { - return $name; - } - } - proc OptType {item} { - lindex $item 3 - } - proc OptTypeArgs {item} { - lindex $item 4 - } - proc OptHelp {item} { - lindex $item 5 - } - proc OptNeedValue {item} { - string compare [OptType $item] boolflag - } - proc OptDefaultValue {item} { - set val [OptTypeArgs $item] - switch -exact -- [OptType $item] { - choice {return [lindex $val 0]} - boolean - - boolflag { - # convert back false/true to 0/1 because expr !$bool - # is broken.. - if {$val} { - return 1 - } else { - return 0 - } - } - } - return $val - } - - # Description format error helper - proc OptOptUsage {item {what ""}} { - return -code error "invalid description format$what: $item\n\ - should be a list of {varname|-flagname ?-type? ?defaultvalue?\ - ?helpstring?}"; - } - - - # Generate a canonical form single instruction - proc OptNewInst {state varname type typeArgs help} { - list $state $varname [list 0 {}] $type $typeArgs $help; - # ^ ^ - # | | - # hasBeenSet=+ +=currentValue - } - - # Translate one item to canonical form - proc OptNormalizeOne {item} { - set lg [Lassign $item varname arg1 arg2 arg3]; -# puts "called optnormalizeone '$item' v=($varname), lg=$lg"; - set isflag [OptIsFlag $varname]; - set isopt [OptIsOpt $varname]; - if {$isflag} { - set state "flags"; - } elseif {$isopt} { - set state "optValue"; - } elseif {[string compare $varname "args"]} { - set state "value"; - } else { - set state "args"; - } - - # apply 'smart' 'fuzzy' logic to try to make - # description writer's life easy, and our's difficult : - # let's guess the missing arguments :-) - - switch $lg { - 1 { - if {$isflag} { - return [OptNewInst $state $varname boolflag false ""]; - } else { - return [OptNewInst $state $varname any "" ""]; - } - } - 2 { - # varname default - # varname help - set type [OptGuessType $arg1] - if {[string compare $type "string"] == 0} { - if {$isflag} { - set type boolflag - set def false - } else { - set type any - set def "" - } - set help $arg1 - } else { - set help "" - set def $arg1 - } - return [OptNewInst $state $varname $type $def $help]; - } - 3 { - # varname type value - # varname value comment - - if {[regexp {^-(.+)$} $arg1 x type]} { - # flags/optValue as they are optional, need a "value", - # on the contrary, for a variable (non optional), - # default value is pointless, 'cept for choices : - if {$isflag || $isopt || ($type == "choice")} { - return [OptNewInst $state $varname $type $arg2 ""]; - } else { - return [OptNewInst $state $varname $type "" $arg2]; - } - } else { - return [OptNewInst $state $varname\ - [OptGuessType $arg1] $arg1 $arg2] - } - } - 4 { - if {[regexp {^-(.+)$} $arg1 x type]} { - return [OptNewInst $state $varname $type $arg2 $arg3]; - } else { - return -code error [OptOptUsage $item]; - } - } - default { - return -code error [OptOptUsage $item]; - } - } - } - - # Auto magic lasy type determination - proc OptGuessType {arg} { - if {[regexp -nocase {^(true|false)$} $arg]} { - return boolean - } - if {[regexp {^(-+)?[0-9]+$} $arg]} { - return int - } - if {![catch {expr {double($arg)}}]} { - return float - } - return string - } - - # Error messages front ends - - proc OptAmbigous {desc arg} { - OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc] - } - proc OptFlagUsage {desc arg} { - OptError "bad flag \"$arg\", must be one of" $desc; - } - proc OptTooManyArgs {desc arguments} { - OptError "too many arguments (unexpected argument(s): $arguments),\ - usage:"\ - $desc 1 - } - proc OptParamType {item} { - if {[OptIsFlag $item]} { - return "flag"; - } else { - return "parameter"; - } - } - proc OptBadValue {item arg {err {}}} { -# puts "bad val err = \"$err\""; - OptError "bad value \"$arg\" for [OptParamType $item]"\ - [list $item] - } - proc OptMissingValue {descriptions} { -# set item [OptCurDescFinal $descriptions]; - set item [OptCurDesc $descriptions]; - OptError "no value given for [OptParamType $item] \"[OptName $item]\"\ - (use -help for full usage) :"\ - [list $item] - } - -proc ::tcl::OptKeyError {prefix descKey {header 0}} { - OptError $prefix [OptKeyGetDesc $descKey] $header; -} - - # determine string length for nice tabulated output - proc OptLengths {desc nlName tlName dlName} { - upvar $nlName nl; - upvar $tlName tl; - upvar $dlName dl; - foreach item $desc { - if {[OptIsCounter $item]} continue; - if {[OptIsPrg $item]} { - OptLengths $item nl tl dl - } else { - SetMax nl [string length [OptName $item]] - SetMax tl [string length [OptType $item]] - set dv [OptTypeArgs $item]; - if {[OptState $item] != "header"} { - set dv "($dv)"; - } - set l [string length $dv]; - # limit the space allocated to potentially big "choices" - if {([OptType $item] != "choice") || ($l<=12)} { - SetMax dl $l - } else { - if {![info exists dl]} { - set dl 0 - } - } - } - } - } - # output the tree - proc OptTree {desc nl tl dl} { - set res ""; - foreach item $desc { - if {[OptIsCounter $item]} continue; - if {[OptIsPrg $item]} { - append res [OptTree $item $nl $tl $dl]; - } else { - set dv [OptTypeArgs $item]; - if {[OptState $item] != "header"} { - set dv "($dv)"; - } - append res [format "\n %-*s %-*s %-*s %s" \ - $nl [OptName $item] $tl [OptType $item] \ - $dl $dv [OptHelp $item]] - } - } - return $res; - } - -# Give nice usage string -proc ::tcl::OptError {prefix desc {header 0}} { - # determine length - if {$header} { - # add faked instruction - set h [list [OptNewInst header Var/FlagName Type Value Help]]; - lappend h [OptNewInst header ------------ ---- ----- ----]; - lappend h [OptNewInst header {( -help} "" "" {gives this help )}] - set desc [concat $h $desc] - } - OptLengths $desc nl tl dl - # actually output - return "$prefix[OptTree $desc $nl $tl $dl]" -} - - -################ General Utility functions ####################### - -# -# List utility functions -# Naming convention: -# "Lvarxxx" take the list VARiable name as argument -# "Lxxxx" take the list value as argument -# (which is not costly with Tcl8 objects system -# as it's still a reference and not a copy of the values) -# - -# Is that list empty ? -proc ::tcl::Lempty {list} { - expr {[llength $list]==0} -} - -# Gets the value of one leaf of a lists tree -proc ::tcl::Lget {list indexLst} { - if {[llength $indexLst] <= 1} { - return [lindex $list $indexLst]; - } - Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end]; -} -# Sets the value of one leaf of a lists tree -# (we use the version that does not create the elements because -# it would be even slower... needs to be written in C !) -# (nb: there is a non trivial recursive problem with indexes 0, -# which appear because there is no difference between a list -# of 1 element and 1 element alone : [list "a"] == "a" while -# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1 -# and [listp "a b"] maybe 0. listp does not exist either...) -proc ::tcl::Lvarset {listName indexLst newValue} { - upvar $listName list; - if {[llength $indexLst] <= 1} { - Lvarset1nc list $indexLst $newValue; - } else { - set idx [lindex $indexLst 0]; - set targetList [lindex $list $idx]; - # reduce refcount on targetList (not really usefull now, - # could be with optimizing compiler) -# Lvarset1 list $idx {}; - # recursively replace in targetList - Lvarset targetList [lrange $indexLst 1 end] $newValue; - # put updated sub list back in the tree - Lvarset1nc list $idx $targetList; - } -} -# Set one cell to a value, eventually create all the needed elements -# (on level-1 of lists) -variable emptyList {} -proc ::tcl::Lvarset1 {listName index newValue} { - upvar $listName list; - if {$index < 0} {return -code error "invalid negative index"} - set lg [llength $list]; - if {$index >= $lg} { - variable emptyList; - for {set i $lg} {$i<$index} {incr i} { - lappend list $emptyList; - } - lappend list $newValue; - } else { - set list [lreplace $list $index $index $newValue]; - } -} -# same as Lvarset1 but no bound checking / creation -proc ::tcl::Lvarset1nc {listName index newValue} { - upvar $listName list; - set list [lreplace $list $index $index $newValue]; -} -# Increments the value of one leaf of a lists tree -# (which must exists) -proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} { - upvar $listName list; - if {[llength $indexLst] <= 1} { - Lvarincr1 list $indexLst $howMuch; - } else { - set idx [lindex $indexLst 0]; - set targetList [lindex $list $idx]; - # reduce refcount on targetList - Lvarset1nc list $idx {}; - # recursively replace in targetList - Lvarincr targetList [lrange $indexLst 1 end] $howMuch; - # put updated sub list back in the tree - Lvarset1nc list $idx $targetList; - } -} -# Increments the value of one cell of a list -proc ::tcl::Lvarincr1 {listName index {howMuch 1}} { - upvar $listName list; - set newValue [expr {[lindex $list $index]+$howMuch}]; - set list [lreplace $list $index $index $newValue]; - return $newValue; -} -# Removes the first element of a list -# and returns the new list value -proc ::tcl::Lvarpop1 {listName} { - upvar $listName list; - set list [lrange $list 1 end]; -} -# Same but returns the removed element -# (Like the tclX version) -proc ::tcl::Lvarpop {listName} { - upvar $listName list; - set el [lindex $list 0]; - set list [lrange $list 1 end]; - return $el; -} -# Assign list elements to variables and return the length of the list -proc ::tcl::Lassign {list args} { - # faster than direct blown foreach (which does not byte compile) - set i 0; - set lg [llength $list]; - foreach vname $args { - if {$i>=$lg} break - uplevel [list set $vname [lindex $list $i]]; - incr i; - } - return $lg; -} - -# Misc utilities - -# Set the varname to value if value is greater than varname's current value -# or if varname is undefined -proc ::tcl::SetMax {varname value} { - upvar 1 $varname var - if {![info exists var] || $value > $var} { - set var $value - } -} - -# Set the varname to value if value is smaller than varname's current value -# or if varname is undefined -proc ::tcl::SetMin {varname value} { - upvar 1 $varname var - if {![info exists var] || $value < $var} { - set var $value - } -} - - - # everything loaded fine, lets create the test proc: - # OptCreateTestProc - # Don't need the create temp proc anymore: - # rename OptCreateTestProc {} -} - diff --git a/tcl/library/opt0.4/pkgIndex.tcl b/tcl/library/opt0.4/pkgIndex.tcl deleted file mode 100644 index 260e5729104..00000000000 --- a/tcl/library/opt0.4/pkgIndex.tcl +++ /dev/null @@ -1,11 +0,0 @@ -# Tcl package index file, version 1.1 -# This file is generated by the "pkg_mkIndex -direct" command -# and sourced either when an application starts up or -# by a "package unknown" script. It invokes the -# "package ifneeded" command to set up package-related -# information so that packages will be loaded automatically -# in response to "package require" commands. When this -# script is sourced, the variable $dir must contain the -# full path name of this file's directory. - -package ifneeded opt 0.4.1 [list source [file join $dir optparse.tcl]] diff --git a/tcl/library/optMenu.tcl b/tcl/library/optMenu.tcl deleted file mode 100644 index 15e981852df..00000000000 --- a/tcl/library/optMenu.tcl +++ /dev/null @@ -1,45 +0,0 @@ -# optMenu.tcl -- -# -# This file defines the procedure tk_optionMenu, which creates -# an option button and its associated menu. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# ::tk_optionMenu -- -# This procedure creates an option button named $w and an associated -# menu. Together they provide the functionality of Motif option menus: -# they can be used to select one of many values, and the current value -# appears in the global variable varName, as well as in the text of -# the option menubutton. The name of the menu is returned as the -# procedure's result, so that the caller can use it to change configuration -# options on the menu or otherwise manipulate it. -# -# Arguments: -# w - The name to use for the menubutton. -# varName - Global variable to hold the currently selected value. -# firstValue - First of legal values for option (must be >= 1). -# args - Any number of additional values. - -proc ::tk_optionMenu {w varName firstValue args} { - upvar #0 $varName var - - if {![info exists var]} { - set var $firstValue - } - menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \ - -relief raised -bd 2 -highlightthickness 2 -anchor c \ - -direction flush - menu $w.menu -tearoff 0 - $w.menu add radiobutton -label $firstValue -variable $varName - foreach i $args { - $w.menu add radiobutton -label $i -variable $varName - } - return $w.menu -} diff --git a/tcl/library/palette.tcl b/tcl/library/palette.tcl deleted file mode 100644 index 443c7da7139..00000000000 --- a/tcl/library/palette.tcl +++ /dev/null @@ -1,242 +0,0 @@ -# palette.tcl -- -# -# This file contains procedures that change the color palette used -# by Tk. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1995-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# ::tk_setPalette -- -# Changes the default color scheme for a Tk application by setting -# default colors in the option database and by modifying all of the -# color options for existing widgets that have the default value. -# -# Arguments: -# The arguments consist of either a single color name, which -# will be used as the new background color (all other colors will -# be computed from this) or an even number of values consisting of -# option names and values. The name for an option is the one used -# for the option database, such as activeForeground, not -activeforeground. - -proc ::tk_setPalette {args} { - 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. - - if {[llength $args] == 1} { - set new(background) [lindex $args 0] - } else { - array set new $args - } - if {![info exists new(background)]} { - error "must specify a background color" - } - set bg [winfo rgb . $new(background)] - if {![info exists new(foreground)]} { - # Note that the range of each value in the triple returned by - # [winfo rgb] is 0-65535, and your eyes are more sensitive to - # green than to red, and more to red than to blue. - foreach {r g b} $bg {break} - if {$r+1.5*$g+0.5*$b > 100000} { - set new(foreground) black - } else { - set new(foreground) white - } - } - set fg [winfo rgb . $new(foreground)] - set darkerBg [format #%02x%02x%02x [expr {(9*[lindex $bg 0])/2560}] \ - [expr {(9*[lindex $bg 1])/2560}] [expr {(9*[lindex $bg 2])/2560}]] - foreach i {activeForeground insertBackground selectForeground \ - highlightColor} { - if {![info exists new($i)]} { - set new($i) $new(foreground) - } - } - if {![info exists new(disabledForeground)]} { - set new(disabledForeground) [format #%02x%02x%02x \ - [expr {(3*[lindex $bg 0] + [lindex $fg 0])/1024}] \ - [expr {(3*[lindex $bg 1] + [lindex $fg 1])/1024}] \ - [expr {(3*[lindex $bg 2] + [lindex $fg 2])/1024}]] - } - if {![info exists new(highlightBackground)]} { - set new(highlightBackground) $new(background) - } - if {![info exists new(activeBackground)]} { - # Pick a default active background that islighter than the - # normal background. To do this, round each color component - # up by 15% or 1/3 of the way to full white, whichever is - # greater. - - foreach i {0 1 2} { - set light($i) [expr {[lindex $bg $i]/256}] - set inc1 [expr {($light($i)*15)/100}] - set inc2 [expr {(255-$light($i))/3}] - if {$inc1 > $inc2} { - incr light($i) $inc1 - } else { - incr light($i) $inc2 - } - if {$light($i) > 255} { - set light($i) 255 - } - } - set new(activeBackground) [format #%02x%02x%02x $light(0) \ - $light(1) $light(2)] - } - if {![info exists new(selectBackground)]} { - set new(selectBackground) $darkerBg - } - if {![info exists new(troughColor)]} { - set new(troughColor) $darkerBg - } - if {![info exists new(selectColor)]} { - set new(selectColor) #b03060 - } - - # let's make one of each of the widgets so we know what the - # defaults are currently for this platform. - toplevel .___tk_set_palette - wm withdraw .___tk_set_palette - foreach q { - button canvas checkbutton entry frame label labelframe - listbox menubutton menu message radiobutton scale scrollbar - spinbox text - } { - $q .___tk_set_palette.$q - } - - # 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 - # we are changing colors...so, ::tk::RecolorTree now returns the - # 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 - # relying on the widgets we've created above to do the work - # because different extensions may provide other kinds - # of widgets that we don't currently know about, so we'll - # walk the whole hierarchy just in case. - - eval [tk::RecolorTree . new] - - catch {destroy .___tk_set_palette} - - # Change the option database so that future windows will get the - # same colors. - - foreach option [array names new] { - option add *$option $new($option) widgetDefault - } - - # Save the options in the variable ::tk::Palette, for use the - # next time we change the options. - - array set ::tk::Palette [array get new] -} - -# ::tk::RecolorTree -- -# 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 -# database, if it exists, and if not, then it looks at the default -# value of the widget itself. -# -# Arguments: -# w - The name of a window. This window and all its -# descendants are recolored. -# colors - The name of an array variable in the caller, -# which contains color information. Each element -# is named after a widget configuration option, and -# each value is the value for that option. - -proc ::tk::RecolorTree {w colors} { - upvar $colors c - set result {} - set prototype .___tk_set_palette.[string tolower [winfo class $w]] - if {![winfo exists $prototype]} { - unset prototype - } - foreach dbOption [array names c] { - set option -[string tolower $dbOption] - set class [string replace $dbOption 0 0 [string toupper \ - [string index $dbOption 0]]] - if {![catch {$w config $option} value]} { - # if the option database has a preference for this - # dbOption, then use it, otherwise use the defaults - # for the widget. - set defaultcolor [option get $w $dbOption $class] - if {[string match {} $defaultcolor] || \ - ([info exists prototype] && \ - [$prototype cget $option] ne "$defaultcolor")} { - set defaultcolor [winfo rgb . [lindex $value 3]] - } else { - set defaultcolor [winfo rgb . $defaultcolor] - } - set chosencolor [winfo rgb . [lindex $value 4]] - if {[string match $defaultcolor $chosencolor]} { - # Change the option database so that future windows will get - # the same colors. - append result ";\noption add [list \ - *[winfo class $w].$dbOption $c($dbOption) 60]" - $w configure $option $c($dbOption) - } - } - } - foreach child [winfo children $w] { - append result ";\n[::tk::RecolorTree $child c]" - } - return $result -} - -# ::tk::Darken -- -# Given a color name, computes a new color value that darkens (or -# brightens) the given color by a given percent. -# -# Arguments: -# color - Name of starting color. -# perecent - Integer telling how much to brighten or darken as a -# percent: 50 means darken by 50%, 110 means brighten -# by 10%. - -proc ::tk::Darken {color percent} { - foreach {red green blue} [winfo rgb . $color] { - set red [expr {($red/256)*$percent/100}] - set green [expr {($green/256)*$percent/100}] - set blue [expr {($blue/256)*$percent/100}] - break - } - if {$red > 255} { - set red 255 - } - if {$green > 255} { - set green 255 - } - if {$blue > 255} { - set blue 255 - } - return [format "#%02x%02x%02x" $red $green $blue] -} - -# ::tk_bisque -- -# Reset the Tk color palette to the old "bisque" colors. -# -# Arguments: -# None. - -proc ::tk_bisque {} { - tk_setPalette activeBackground #e6ceb1 activeForeground black \ - background #ffe4c4 disabledForeground #b0b0b0 foreground black \ - highlightBackground #ffe4c4 highlightColor black \ - insertBackground black selectColor #b03060 \ - selectBackground #e6ceb1 selectForeground black \ - troughColor #cdb79e -} diff --git a/tcl/library/panedwindow.tcl b/tcl/library/panedwindow.tcl deleted file mode 100644 index c52bfa39910..00000000000 --- a/tcl/library/panedwindow.tcl +++ /dev/null @@ -1,181 +0,0 @@ -# panedwindow.tcl -- -# -# This file defines the default bindings for Tk panedwindow widgets and -# provides procedures that help in implementing those bindings. -# -# RCS: @(#) $Id$ -# - -bind Panedwindow <Button-1> { ::tk::panedwindow::MarkSash %W %x %y 1 } -bind Panedwindow <Button-2> { ::tk::panedwindow::MarkSash %W %x %y 0 } - -bind Panedwindow <B1-Motion> { ::tk::panedwindow::DragSash %W %x %y 1 } -bind Panedwindow <B2-Motion> { ::tk::panedwindow::DragSash %W %x %y 0 } - -bind Panedwindow <ButtonRelease-1> {::tk::panedwindow::ReleaseSash %W 1} -bind Panedwindow <ButtonRelease-2> {::tk::panedwindow::ReleaseSash %W 0} - -bind Panedwindow <Motion> { ::tk::panedwindow::Motion %W %x %y } - -bind Panedwindow <Leave> { ::tk::panedwindow::Leave %W } - -# Initialize namespace -namespace eval ::tk::panedwindow {} - -# ::tk::panedwindow::MarkSash -- -# -# Handle marking the correct sash for possible dragging -# -# Arguments: -# w the widget -# x widget local x coord -# y widget local y coord -# proxy whether this should be a proxy sash -# Results: -# None -# -proc ::tk::panedwindow::MarkSash {w x y proxy} { - set what [$w identify $x $y] - if { [llength $what] == 2 } { - foreach {index which} $what break - if { !$::tk_strictMotif || [string equal $which "handle"] } { - if {!$proxy} { $w sash mark $index $x $y } - set ::tk::Priv(sash) $index - foreach {sx sy} [$w sash coord $index] break - set ::tk::Priv(dx) [expr {$sx-$x}] - set ::tk::Priv(dy) [expr {$sy-$y}] - } - } -} - -# ::tk::panedwindow::DragSash -- -# -# Handle dragging of the correct sash -# -# Arguments: -# w the widget -# x widget local x coord -# y widget local y coord -# proxy whether this should be a proxy sash -# Results: -# Moves sash -# -proc ::tk::panedwindow::DragSash {w x y proxy} { - if { [info exists ::tk::Priv(sash)] } { - if {$proxy} { - $w proxy place \ - [expr {$x+$::tk::Priv(dx)}] [expr {$y+$::tk::Priv(dy)}] - } else { - $w sash place $::tk::Priv(sash) \ - [expr {$x+$::tk::Priv(dx)}] [expr {$y+$::tk::Priv(dy)}] - } - } -} - -# ::tk::panedwindow::ReleaseSash -- -# -# Handle releasing of the sash -# -# Arguments: -# w the widget -# proxy whether this should be a proxy sash -# Results: -# Returns ... -# -proc ::tk::panedwindow::ReleaseSash {w proxy} { - if { [info exists ::tk::Priv(sash)] } { - if {$proxy} { - foreach {x y} [$w proxy coord] break - $w sash place $::tk::Priv(sash) $x $y - $w proxy forget - } - unset ::tk::Priv(sash) ::tk::Priv(dx) ::tk::Priv(dy) - } -} - -# ::tk::panedwindow::Motion -- -# -# Handle motion on the widget. This is used to change the cursor -# when the user moves over the sash area. -# -# Arguments: -# w the widget -# x widget local x coord -# y widget local y coord -# Results: -# May change the cursor. Sets up a timer to verify that we are still -# over the widget. -# -proc ::tk::panedwindow::Motion {w x y} { - variable ::tk::Priv - set id [$w identify $x $y] - if {([llength $id] == 2) && \ - (!$::tk_strictMotif || [string equal [lindex $id 1] "handle"])} { - if { ![info exists Priv(panecursor)] } { - set Priv(panecursor) [$w cget -cursor] - if { [string equal [$w cget -sashcursor] ""] } { - if { [string equal [$w cget -orient] "horizontal"] } { - $w configure -cursor sb_h_double_arrow - } else { - $w configure -cursor sb_v_double_arrow - } - } else { - $w configure -cursor [$w cget -sashcursor] - } - if {[info exists Priv(pwAfterId)]} { - after cancel $Priv(pwAfterId) - } - set Priv(pwAfterId) [after 150 \ - [list ::tk::panedwindow::Cursor $w]] - } - return - } - if { [info exists Priv(panecursor)] } { - $w configure -cursor $Priv(panecursor) - unset Priv(panecursor) - } -} - -# ::tk::panedwindow::Cursor -- -# -# Handles returning the normal cursor when we are no longer over the -# sash area. This needs to be done this way, because the panedwindow -# won't see Leave events when the mouse moves from the sash to a -# paned child, although the child does receive an Enter event. -# -# Arguments: -# w the widget -# Results: -# May restore the default cursor, or schedule a timer to do it. -# -proc ::tk::panedwindow::Cursor {w} { - variable ::tk::Priv - if {[info exists Priv(panecursor)]} { - if {[winfo containing [winfo pointerx $w] [winfo pointery $w]] == $w} { - set Priv(pwAfterId) [after 150 [list ::tk::panedwindow::Cursor $w]] - } else { - $w configure -cursor $Priv(panecursor) - unset Priv(panecursor) - if {[info exists Priv(pwAfterId)]} { - after cancel $Priv(pwAfterId) - unset Priv(pwAfterId) - } - } - } -} - -# ::tk::panedwindow::Leave -- -# -# Return to default cursor when leaving the pw widget. -# -# Arguments: -# w the widget -# Results: -# Restores the default cursor -# -proc ::tk::panedwindow::Leave {w} { - if {[info exists ::tk::Priv(panecursor)]} { - $w configure -cursor $::tk::Priv(panecursor) - unset ::tk::Priv(panecursor) - } -} diff --git a/tcl/library/reg1.0/pkgIndex.tcl b/tcl/library/reg1.0/pkgIndex.tcl deleted file mode 100755 index d3e39ddff48..00000000000 --- a/tcl/library/reg1.0/pkgIndex.tcl +++ /dev/null @@ -1,7 +0,0 @@ -if {[info exists tcl_platform(debug)]} { - package ifneeded registry 1.0 \ - [list load [file join $dir tclreg83d.dll] registry] -} else { - package ifneeded registry 1.0 \ - [list load [file join $dir tclreg83.dll] registry] -} diff --git a/tcl/library/safeinit.tcl b/tcl/library/safeinit.tcl deleted file mode 100644 index e1ce1a03959..00000000000 --- a/tcl/library/safeinit.tcl +++ /dev/null @@ -1,461 +0,0 @@ -# safeinit.tcl -- -# -# This code runs in a master to manage a safe slave with Safe Tcl. -# See the safe.n man page for details. -# -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# SCCS: @(#) safeinit.tcl 1.38 97/06/20 12:57:39 - -# This procedure creates a safe slave, initializes it with the -# safe base and installs the aliases for the security policy mechanism. - -proc tcl_safeCreateInterp {slave} { - global auto_path - - # Create the slave. - interp create -safe $slave - - # Set its auto_path - interp eval $slave [list set auto_path $auto_path] - - # And initialize it. - return [tcl_safeInitInterp $slave] -} - -# This procedure applies the initializations to an already existing -# interpreter. It is useful when you want to enable an interpreter -# created with "interp create -safe" to use security policies. - -proc tcl_safeInitInterp {slave} { - upvar #0 tclSafe$slave state - global tcl_library tk_library auto_path tcl_platform - - # These aliases let the slave load files to define new commands - - interp alias $slave source {} tclSafeAliasSource $slave - interp alias $slave load {} tclSafeAliasLoad $slave - - # This alias lets the slave have access to a subset of the 'file' - # command functionality. - tclAliasSubset $slave file file dir.* join root.* ext.* tail \ - path.* split - - # This alias interposes on the 'exit' command and cleanly terminates - # the slave. - interp alias $slave exit {} tcl_safeDeleteInterp $slave - - # Source init.tcl into the slave, to get auto_load and other - # procedures defined: - - if {$tcl_platform(platform) == "macintosh"} { - if {[catch {interp eval $slave [list source -rsrc Init]}]} { - if {[catch {interp eval $slave \ - [list source [file join $tcl_library init.tcl]]}]} { - error "can't source init.tcl into slave $slave" - } - } - } else { - if {[catch {interp eval $slave \ - [list source [file join $tcl_library init.tcl]]}]} { - error "can't source init.tcl into slave $slave" - } - } - - # Loading packages into slaves is handled by their master. - # This is overloaded to deal with regular packages and security policies - - interp alias $slave tclPkgUnknown {} tclSafeAliasPkgUnknown $slave - interp eval $slave {package unknown tclPkgUnknown} - - # We need a helper procedure to define a $dir variable and then - # do a source of the pkgIndex.tcl file - interp eval $slave \ - [list proc tclPkgSource {dir args} { - if {[llength $args] == 2} { - source [lindex $args 0] [lindex $args 1] - } else { - source [lindex $args 0] - } - }] - - # Let the slave inherit a few variables - foreach varName \ - {tcl_library tcl_version tcl_patchLevel \ - tcl_platform(platform) auto_path} { - upvar #0 $varName var - interp eval $slave [list set $varName $var] - } - - # Other variables are predefined with set values - foreach {varName value} { - auto_noexec 1 - errorCode {} - errorInfo {} - env() {} - argv0 {} - argv {} - argc 0 - tcl_interactive 0 - } { - interp eval $slave [list set $varName $value] - } - - # If auto_path is not set in the slave, set it to empty so it has - # a value and exists. Otherwise auto_loading and package require - # will complain. - - interp eval $slave { - if {![info exists auto_path]} { - set auto_path {} - } - } - - # If we have Tk, make the slave have the same library as us: - - if {[info exists tk_library]} { - interp eval $slave [list set tk_library $tk_library] - } - - # Stub out auto-exec mechanism in slave - interp eval $slave [list proc auto_execok {name} {return {}}] - - return $slave -} - -# This procedure deletes a safe slave managed by Safe Tcl and -# cleans up associated state: - -proc tcl_safeDeleteInterp {slave args} { - upvar #0 tclSafe$slave state - - # If the slave has a policy loaded, clean it up now. - if {[info exists state(policyLoaded)]} { - set policy $state(policyLoaded) - set proc ${policy}_PolicyCleanup - if {[string compare [info proc $proc] $proc] == 0} { - $proc $slave - } - } - - # Discard the global array of state associated with the slave, and - # delete the interpreter. - catch {unset state} - catch {interp delete $slave} - - return -} - -# This procedure computes the global security policy search path. - -proc tclSafeComputePolicyPath {} { - global auto_path tclSafeAutoPathComputed tclSafePolicyPath - - set recompute 0 - if {(![info exists tclSafePolicyPath]) || - ("$tclSafePolicyPath" == "")} { - set tclSafePolicyPath "" - set tclSafeAutoPathComputed "" - set recompute 1 - } - if {"$tclSafeAutoPathComputed" != "$auto_path"} { - set recompute 1 - set tclSafeAutoPathComputed $auto_path - } - if {$recompute == 1} { - set tclSafePolicyPath "" - foreach i $auto_path { - lappend tclSafePolicyPath [file join $i policies] - } - } - return $tclSafePolicyPath -} - -# --------------------------------------------------------------------------- -# --------------------------------------------------------------------------- - -# tclSafeAliasSource is the target of the "source" alias in safe interpreters. - -proc tclSafeAliasSource {slave args} { - global auto_path errorCode errorInfo - - if {[llength $args] == 2} { - if {[string compare "-rsrc" [lindex $args 0]] != 0} { - return -code error "incorrect arguments to source" - } - if {[catch {interp invokehidden $slave source -rsrc [lindex $args 1]} \ - msg]} { - return -code error $msg - } - } else { - set file [lindex $args 0] - if {[catch {tclFileInPath $file $auto_path $slave} msg]} { - return -code error "permission denied" - } - set errorInfo "" - if {[catch {interp invokehidden $slave source $file} msg]} { - return -code error $msg - } - } - return $msg -} - -# tclSafeAliasLoad is the target of the "load" alias in safe interpreters. - -proc tclSafeAliasLoad {slave file args} { - global auto_path - - if {[llength $args] == 2} { - # Trying to load into another interpreter - # Allow this for a child of the slave, or itself - set other [lindex $args 1] - foreach x $slave y $other { - if {[string length $x] == 0} { - break - } elseif {[string compare $x $y] != 0} { - return -code error "permission denied" - } - } - set slave $other - } - - if {[string length $file] && \ - [catch {tclFileInPath $file $auto_path $slave} msg]} { - return -code error "permission denied" - } - if {[catch { - switch [llength $args] { - 0 { - interp invokehidden $slave load $file - } - 1 - - 2 { - interp invokehidden $slave load $file [lindex $args 0] - } - default { - error "too many arguments to load" - } - } - } msg]} { - return -code error $msg - } - return $msg -} - -# tclFileInPath raises an error if the file is not found in -# the list of directories contained in path. - -proc tclFileInPath {file path slave} { - set realcheckpath [tclSafeCheckAutoPath $path $slave] - set pwd [pwd] - if {[file isdirectory $file]} { - error "$file: not found" - } - set parent [file dirname $file] - if {[catch {cd $parent} msg]} { - error "$file: not found" - } - set realfilepath [file split [pwd]] - foreach dir $realcheckpath { - set match 1 - foreach a [file split $dir] b $realfilepath { - if {[string length $a] == 0} { - break - } elseif {[string compare $a $b] != 0} { - set match 0 - break - } - } - if {$match} { - cd $pwd - return 1 - } - } - cd $pwd - error "$file: not found" -} - -# This procedure computes our expanded copy of the path, as needed. -# It returns the path after expanding out all aliases. - -proc tclSafeCheckAutoPath {path slave} { - global auto_path - upvar #0 tclSafe$slave state - - if {![info exists state(expanded_auto_path)]} { - # Compute for the first time: - set state(cached_auto_path) $path - } elseif {"$state(cached_auto_path)" != "$path"} { - # The value of our path changed, so recompute: - set state(cached_auto_path) $path - } else { - # No change: no need to recompute. - return $state(expanded_auto_path) - } - - set pwd [pwd] - set state(expanded_auto_path) "" - foreach dir $state(cached_auto_path) { - if {![catch {cd $dir}]} { - lappend state(expanded_auto_path) [pwd] - } - } - cd $pwd - return $state(expanded_auto_path) -} - -proc tclSafeAliasPkgUnknown {slave package version {exact {}}} { - tclSafeLoadPkg $slave $package $version $exact -} - -proc tclSafeLoadPkg {slave package version exact} { - if {[string length $version] == 0} { - set version 1.0 - } - tclSafeLoadPkgInternal $slave $package $version $exact 0 -} - -proc tclSafeLoadPkgInternal {slave package version exact round} { - global auto_path - upvar #0 tclSafe$slave state - - # Search the policy path again; it might have changed in the meantime. - - if {$round == 1} { - tclSafeResearchPolicyPath - - if {[tclSafeLoadPolicy $slave $package $version]} { - return - } - } - - # Try to load as a policy. - - if [tclSafeLoadPolicy $slave $package $version] { - return - } - - # The package is not a security policy, so do the regular setup. - - # Here we run tclPkgUnknown in the master, but we hijack - # the source command so the setup ends up happening in the slave. - - rename source source.orig - proc source {args} "upvar dir dir - interp eval [list $slave] tclPkgSource \[list \$dir\] \$args" - - if [catch {tclPkgUnknown $package $version $exact} err] { - global errorInfo - - rename source {} - rename source.orig source - - error "$err\n$errorInfo" - } - rename source {} - rename source.orig source - - # If we are in the first round, check if the package - # is now known in the slave: - - if {$round == 0} { - set ifneeded \ - [interp eval $slave [list package ifneeded $package $version]] - - if {"$ifneeded" == ""} { - return [tclSafeLoadPkgInternal $slave $package $version $exact 1] - } - } -} - -proc tclSafeResearchPolicyPath {} { - global tclSafePolicyPath auto_index auto_path - - # If there was no change, do not search again. - - if {![info exists tclSafePolicyPath]} { - set tclSafePolicyPath "" - } - set oldPolicyPath $tclSafePolicyPath - set newPolicyPath [tclSafeComputePolicyPath] - if {"$newPolicyPath" == "$oldPolicyPath"} { - return - } - - # Loop through the path from back to front so early directories - # end up overriding later directories. This code is like auto_load, - # but only new-style tclIndex files (version 2) are supported. - - for {set i [expr [llength $newPolicyPath] - 1]} \ - {$i >= 0} \ - {incr i -1} { - set dir [lindex $newPolicyPath $i] - set file [file join $dir tclIndex] - if {[file exists $file]} { - if {[catch {source $file} msg]} { - puts stderr "error sourcing $file: $msg" - } - } - foreach file [lsort [glob -nocomplain [file join $dir *]]] { - if {[file isdir $file]} { - set dir $file - set file [file join $file tclIndex] - if {[file exists $file]} { - if {[catch {source $file} msg]} { - puts stderr "error sourcing $file: $msg" - } - } - } - } - } -} - -proc tclSafeLoadPolicy {slave package version} { - upvar #0 tclSafe$slave state - global auto_index - - set proc ${package}_PolicyInit - - if {[info command $proc] == "$proc" || - [info exists auto_index($proc)]} { - if [info exists state(policyLoaded)] { - error "security policy $state(policyLoaded) already loaded" - } - $proc $slave $version - interp eval $slave [list package provide $package $version] - set state(policyLoaded) $package - return 1 - } else { - return 0 - } -} -# This procedure enables access from a safe interpreter to only a subset of -# the subcommands of a command: - -proc tclSafeSubset {command okpat args} { - set subcommand [lindex $args 0] - if {[regexp $okpat $subcommand]} { - return [eval {$command $subcommand} [lrange $args 1 end]] - } - error "not allowed to invoke subcommand $subcommand of $command" -} - -# This procedure installs an alias in a slave that invokes "safesubset" -# in the master to execute allowed subcommands. It precomputes the pattern -# of allowed subcommands; you can use wildcards in the pattern if you wish -# to allow subcommand abbreviation. -# -# Syntax is: tclAliasSubset slave alias target subcommand1 subcommand2... - -proc tclAliasSubset {slave alias target args} { - set pat ^(; set sep "" - foreach sub $args { - append pat $sep$sub - set sep | - } - append pat )\$ - interp alias $slave $alias {} tclSafeSubset $target $pat -} diff --git a/tcl/library/safetk.tcl b/tcl/library/safetk.tcl deleted file mode 100644 index 8c0a12bea10..00000000000 --- a/tcl/library/safetk.tcl +++ /dev/null @@ -1,277 +0,0 @@ -# safetk.tcl -- -# -# Support procs to use Tk in safe interpreters. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -# see safetk.n for documentation - -# -# -# Note: It is now ok to let untrusted code being executed -# between the creation of the interp and the actual loading -# of Tk in that interp because the C side Tk_Init will -# now look up the master interp and ask its safe::TkInit -# for the actual parameters to use for it's initialization (if allowed), -# not relying on the slave state. -# - -# We use opt (optional arguments parsing) -package require opt 0.4.1; - -namespace eval ::safe { - - # counter for safe toplevels - variable tkSafeId 0; - - # - # tkInterpInit : prepare the slave interpreter for tk loading - # most of the real job is done by loadTk - # returns the slave name (tkInterpInit does) - # - proc ::safe::tkInterpInit {slave argv} { - global env tk_library - - # We have to make sure that the tk_library variable uses a file - # pathname that works better in Tk (of the style returned by - # [file join], ie C:/path/to/tk/lib, not C:\path\to\tk\lib - set tk_library [file join $tk_library] - - # Clear Tk's access for that interp (path). - allowTk $slave $argv - - # there seems to be an obscure case where the tk_library - # variable value is changed to point to a sym link destination - # dir instead of the sym link itself, and thus where the $tk_library - # would then not be anymore one of the auto_path dir, so we use - # the addToAccessPath which adds if it's not already in instead - # of the more conventional findInAccessPath. - # Might be usefull for masters without Tk really loaded too. - ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]] - return $slave - } - - -# tkInterpLoadTk : -# Do additional configuration as needed (calling tkInterpInit) -# and actually load Tk into the slave. -# -# Either contained in the specified windowId (-use) or -# creating a decorated toplevel for it. - -# empty definition for auto_mkIndex -proc ::safe::loadTk {} {} - -::tcl::OptProc loadTk { - {slave -interp "name of the slave interpreter"} - {-use -windowId {} "window Id to use (new toplevel otherwise)"} - {-display -displayName {} "display name to use (current one otherwise)"} -} { - set displayGiven [::tcl::OptProcArgGiven "-display"] - if {!$displayGiven} { - - # Try to get the current display from "." - # (which might not exist if the master is tk-less) - - if {[catch {set display [winfo screen .]}]} { - if {[info exists ::env(DISPLAY)]} { - set display $::env(DISPLAY) - } else { - Log $slave "no winfo screen . nor env(DISPLAY)" WARNING - set display ":0.0" - } - } - } - if {![::tcl::OptProcArgGiven "-use"]} { - - # create a decorated toplevel - - ::tcl::Lassign [tkTopLevel $slave $display] w use - - # set our delete hook (slave arg is added by interpDelete) - # to clean up both window related code and tkInit(slave) - Set [DeleteHookName $slave] [list tkDelete {} $w] - - } else { - - # set our delete hook (slave arg is added by interpDelete) - # to clean up tkInit(slave) - - Set [DeleteHookName $slave] [list disallowTk] - - # Let's be nice and also accept tk window names instead of ids - - if {[string match ".*" $use]} { - set windowName $use - set use [winfo id $windowName] - set nDisplay [winfo screen $windowName] - } else { - - # Check for a better -display value - # (works only for multi screens on single host, but not - # cross hosts, for that a tk window name would be better - # but embeding is also usefull for non tk names) - - if {![catch {winfo pathname $use} name]} { - set nDisplay [winfo screen $name] - } else { - - # Can't have a better one - - set nDisplay $display - } - } - if {[string compare $nDisplay $display]} { - if {$displayGiven} { - error "conflicting -display $display and -use\ - $use -> $nDisplay" - } else { - set display $nDisplay - } - } - } - - # Prepares the slave for tk with those parameters - - tkInterpInit $slave [list "-use" $use "-display" $display] - - load {} Tk $slave - - return $slave -} - -proc ::safe::TkInit {interpPath} { - variable tkInit - if {[info exists tkInit($interpPath)]} { - set value $tkInit($interpPath) - Log $interpPath "TkInit called, returning \"$value\"" NOTICE - return $value - } else { - Log $interpPath "TkInit called for interp with clearance:\ - preventing Tk init" ERROR - error "not allowed" - } -} - -# safe::allowTk -- -# -# Set tkInit(interpPath) to allow Tk to be initialized in -# safe::TkInit. -# -# Arguments: -# interpPath slave interpreter handle -# argv arguments passed to safe::TkInterpInit -# -# Results: -# none. - -proc ::safe::allowTk {interpPath argv} { - variable tkInit - set tkInit($interpPath) $argv - return -} - - -# safe::disallowTk -- -# -# Unset tkInit(interpPath) to disallow Tk from getting initialized -# in safe::TkInit. -# -# Arguments: -# interpPath slave interpreter handle -# -# Results: -# none. - -proc ::safe::disallowTk {interpPath} { - variable tkInit - # This can already be deleted by the DeleteHook of the interp - if {[info exists tkInit($interpPath)]} { - unset tkInit($interpPath) - } - return -} - - -# safe::tkDelete -- -# -# Clean up the window associated with the interp being deleted. -# -# Arguments: -# interpPath slave interpreter handle -# -# Results: -# none. - -proc ::safe::tkDelete {W window slave} { - - # we are going to be called for each widget... skip untill it's - # top level - - Log $slave "Called tkDelete $W $window" NOTICE - if {[::interp exists $slave]} { - if {[catch {::safe::interpDelete $slave} msg]} { - Log $slave "Deletion error : $msg" - } - } - if {[winfo exists $window]} { - Log $slave "Destroy toplevel $window" NOTICE - destroy $window - } - - # clean up tkInit(slave) - disallowTk $slave - return -} - -proc ::safe::tkTopLevel {slave display} { - variable tkSafeId - incr tkSafeId - set w ".safe$tkSafeId" - if {[catch {toplevel $w -screen $display -class SafeTk} msg]} { - return -code error "Unable to create toplevel for\ - safe slave \"$slave\" ($msg)" - } - Log $slave "New toplevel $w" NOTICE - - set msg "Untrusted Tcl applet ($slave)" - wm title $w $msg - - # Control frame - set wc $w.fc - frame $wc -bg red -borderwidth 3 -relief ridge - - # We will destroy the interp when the window is destroyed - bindtags $wc [concat Safe$wc [bindtags $wc]] - bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave] - - label $wc.l -text $msg -padx 2 -pady 0 -anchor w - - # We want the button to be the last visible item - # (so be packed first) and at the right and not resizing horizontally - - # frame the button so it does not expand horizontally - # but still have the default background instead of red one from the parent - frame $wc.fb -bd 0 - button $wc.fb.b -text "Delete" \ - -bd 1 -padx 2 -pady 0 -highlightthickness 0 \ - -command [list ::safe::tkDelete $w $w $slave] - pack $wc.fb.b -side right -fill both - pack $wc.fb -side right -fill both -expand 1 - pack $wc.l -side left -fill both -expand 1 - pack $wc -side bottom -fill x - - # Container frame - frame $w.c -container 1 - pack $w.c -fill both -expand 1 - - # return both the toplevel window name and the id to use for embedding - list $w [winfo id $w.c] -} - -} diff --git a/tcl/library/scale.tcl b/tcl/library/scale.tcl deleted file mode 100644 index e9ab3e88a03..00000000000 --- a/tcl/library/scale.tcl +++ /dev/null @@ -1,274 +0,0 @@ -# scale.tcl -- -# -# This file defines the default bindings for Tk scale widgets and provides -# procedures that help in implementing the bindings. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -#------------------------------------------------------------------------- -# The code below creates the default class bindings for entries. -#------------------------------------------------------------------------- - -# Standard Motif bindings: - -bind Scale <Enter> { - if {$tk_strictMotif} { - set tk::Priv(activeBg) [%W cget -activebackground] - %W config -activebackground [%W cget -background] - } - tk::ScaleActivate %W %x %y -} -bind Scale <Motion> { - tk::ScaleActivate %W %x %y -} -bind Scale <Leave> { - if {$tk_strictMotif} { - %W config -activebackground $tk::Priv(activeBg) - } - if {[string equal [%W cget -state] "active"]} { - %W configure -state normal - } -} -bind Scale <1> { - tk::ScaleButtonDown %W %x %y -} -bind Scale <B1-Motion> { - tk::ScaleDrag %W %x %y -} -bind Scale <B1-Leave> { } -bind Scale <B1-Enter> { } -bind Scale <ButtonRelease-1> { - tk::CancelRepeat - tk::ScaleEndDrag %W - tk::ScaleActivate %W %x %y -} -bind Scale <2> { - tk::ScaleButton2Down %W %x %y -} -bind Scale <B2-Motion> { - tk::ScaleDrag %W %x %y -} -bind Scale <B2-Leave> { } -bind Scale <B2-Enter> { } -bind Scale <ButtonRelease-2> { - tk::CancelRepeat - tk::ScaleEndDrag %W - tk::ScaleActivate %W %x %y -} -if {[string equal $tcl_platform(platform) "windows"]} { - # On Windows do the same with button 3, as that is the right mouse button - bind Scale <3> [bind Scale <2>] - bind Scale <B3-Motion> [bind Scale <B2-Motion>] - bind Scale <B3-Leave> [bind Scale <B2-Leave>] - bind Scale <B3-Enter> [bind Scale <B2-Enter>] - bind Scale <ButtonRelease-3> [bind Scale <ButtonRelease-2>] -} -bind Scale <Control-1> { - tk::ScaleControlPress %W %x %y -} -bind Scale <Up> { - tk::ScaleIncrement %W up little noRepeat -} -bind Scale <Down> { - tk::ScaleIncrement %W down little noRepeat -} -bind Scale <Left> { - tk::ScaleIncrement %W up little noRepeat -} -bind Scale <Right> { - tk::ScaleIncrement %W down little noRepeat -} -bind Scale <Control-Up> { - tk::ScaleIncrement %W up big noRepeat -} -bind Scale <Control-Down> { - tk::ScaleIncrement %W down big noRepeat -} -bind Scale <Control-Left> { - tk::ScaleIncrement %W up big noRepeat -} -bind Scale <Control-Right> { - tk::ScaleIncrement %W down big noRepeat -} -bind Scale <Home> { - %W set [%W cget -from] -} -bind Scale <End> { - %W set [%W cget -to] -} - -# ::tk::ScaleActivate -- -# This procedure is invoked to check a given x-y position in the -# scale and activate the slider if the x-y position falls within -# the slider. -# -# Arguments: -# w - The scale widget. -# x, y - Mouse coordinates. - -proc ::tk::ScaleActivate {w x y} { - if {[string equal [$w cget -state] "disabled"]} { - return - } - if {[string equal [$w identify $x $y] "slider"]} { - set state active - } else { - set state normal - } - if {[string compare [$w cget -state] $state]} { - $w configure -state $state - } -} - -# ::tk::ScaleButtonDown -- -# This procedure is invoked when a button is pressed in a scale. It -# takes different actions depending on where the button was pressed. -# -# Arguments: -# w - The scale widget. -# x, y - Mouse coordinates of button press. - -proc ::tk::ScaleButtonDown {w x y} { - variable ::tk::Priv - set Priv(dragging) 0 - set el [$w identify $x $y] - if {[string equal $el "trough1"]} { - ScaleIncrement $w up little initial - } elseif {[string equal $el "trough2"]} { - ScaleIncrement $w down little initial - } elseif {[string equal $el "slider"]} { - set Priv(dragging) 1 - set Priv(initValue) [$w get] - set coords [$w coords] - set Priv(deltaX) [expr {$x - [lindex $coords 0]}] - set Priv(deltaY) [expr {$y - [lindex $coords 1]}] - $w configure -sliderrelief sunken - } -} - -# ::tk::ScaleDrag -- -# This procedure is called when the mouse is dragged with -# mouse button 1 down. If the drag started inside the slider -# (i.e. the scale is active) then the scale's value is adjusted -# to reflect the mouse's position. -# -# Arguments: -# w - The scale widget. -# x, y - Mouse coordinates. - -proc ::tk::ScaleDrag {w x y} { - variable ::tk::Priv - if {!$Priv(dragging)} { - return - } - $w set [$w get [expr {$x-$Priv(deltaX)}] [expr {$y-$Priv(deltaY)}]] -} - -# ::tk::ScaleEndDrag -- -# This procedure is called to end an interactive drag of the -# slider. It just marks the drag as over. -# -# Arguments: -# w - The scale widget. - -proc ::tk::ScaleEndDrag {w} { - variable ::tk::Priv - set Priv(dragging) 0 - $w configure -sliderrelief raised -} - -# ::tk::ScaleIncrement -- -# This procedure is invoked to increment the value of a scale and -# to set up auto-repeating of the action if that is desired. The -# way the value is incremented depends on the "dir" and "big" -# arguments. -# -# Arguments: -# w - The scale widget. -# dir - "up" means move value towards -from, "down" means -# move towards -to. -# big - Size of increments: "big" or "little". -# repeat - Whether and how to auto-repeat the action: "noRepeat" -# means don't auto-repeat, "initial" means this is the -# first action in an auto-repeat sequence, and "again" -# means this is the second repetition or later. - -proc ::tk::ScaleIncrement {w dir big repeat} { - variable ::tk::Priv - if {![winfo exists $w]} return - if {[string equal $big "big"]} { - set inc [$w cget -bigincrement] - if {$inc == 0} { - set inc [expr {abs([$w cget -to] - [$w cget -from])/10.0}] - } - if {$inc < [$w cget -resolution]} { - set inc [$w cget -resolution] - } - } else { - set inc [$w cget -resolution] - } - if {([$w cget -from] > [$w cget -to]) ^ [string equal $dir "up"]} { - set inc [expr {-$inc}] - } - $w set [expr {[$w get] + $inc}] - - if {[string equal $repeat "again"]} { - set Priv(afterId) [after [$w cget -repeatinterval] \ - [list tk::ScaleIncrement $w $dir $big again]] - } elseif {[string equal $repeat "initial"]} { - set delay [$w cget -repeatdelay] - if {$delay > 0} { - set Priv(afterId) [after $delay \ - [list tk::ScaleIncrement $w $dir $big again]] - } - } -} - -# ::tk::ScaleControlPress -- -# This procedure handles button presses that are made with the Control -# key down. Depending on the mouse position, it adjusts the scale -# value to one end of the range or the other. -# -# Arguments: -# w - The scale widget. -# x, y - Mouse coordinates where the button was pressed. - -proc ::tk::ScaleControlPress {w x y} { - set el [$w identify $x $y] - if {[string equal $el "trough1"]} { - $w set [$w cget -from] - } elseif {[string equal $el "trough2"]} { - $w set [$w cget -to] - } -} - -# ::tk::ScaleButton2Down -# This procedure is invoked when button 2 is pressed over a scale. -# It sets the value to correspond to the mouse position and starts -# a slider drag. -# -# Arguments: -# w - The scrollbar widget. -# x, y - Mouse coordinates within the widget. - -proc ::tk::ScaleButton2Down {w x y} { - variable ::tk::Priv - - if {[string equal [$w cget -state] "disabled"]} { - return - } - $w configure -state active - $w set [$w get $x $y] - set Priv(dragging) 1 - set Priv(initValue) [$w get] - set coords "$x $y" - set Priv(deltaX) 0 - set Priv(deltaY) 0 -} diff --git a/tcl/library/scrlbar.tcl b/tcl/library/scrlbar.tcl deleted file mode 100644 index 8f241954dd4..00000000000 --- a/tcl/library/scrlbar.tcl +++ /dev/null @@ -1,415 +0,0 @@ -# scrlbar.tcl -- -# -# This file defines the default bindings for Tk scrollbar widgets. -# It also provides procedures that help in implementing the bindings. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -#------------------------------------------------------------------------- -# The code below creates the default class bindings for scrollbars. -#------------------------------------------------------------------------- - -# Standard Motif bindings: -if {[string equal [tk windowingsystem] "x11"]} { - -bind Scrollbar <Enter> { - if {$tk_strictMotif} { - set tk::Priv(activeBg) [%W cget -activebackground] - %W config -activebackground [%W cget -background] - } - %W activate [%W identify %x %y] -} -bind Scrollbar <Motion> { - %W activate [%W identify %x %y] -} - -# The "info exists" command in the following binding handles the -# situation where a Leave event occurs for a scrollbar without the Enter -# event. This seems to happen on some systems (such as Solaris 2.4) for -# unknown reasons. - -bind Scrollbar <Leave> { - if {$tk_strictMotif && [info exists tk::Priv(activeBg)]} { - %W config -activebackground $tk::Priv(activeBg) - } - %W activate {} -} -bind Scrollbar <1> { - tk::ScrollButtonDown %W %x %y -} -bind Scrollbar <B1-Motion> { - tk::ScrollDrag %W %x %y -} -bind Scrollbar <B1-B2-Motion> { - tk::ScrollDrag %W %x %y -} -bind Scrollbar <ButtonRelease-1> { - tk::ScrollButtonUp %W %x %y -} -bind Scrollbar <B1-Leave> { - # Prevents <Leave> binding from being invoked. -} -bind Scrollbar <B1-Enter> { - # Prevents <Enter> binding from being invoked. -} -bind Scrollbar <2> { - tk::ScrollButton2Down %W %x %y -} -bind Scrollbar <B1-2> { - # Do nothing, since button 1 is already down. -} -bind Scrollbar <B2-1> { - # Do nothing, since button 2 is already down. -} -bind Scrollbar <B2-Motion> { - tk::ScrollDrag %W %x %y -} -bind Scrollbar <ButtonRelease-2> { - tk::ScrollButtonUp %W %x %y -} -bind Scrollbar <B1-ButtonRelease-2> { - # Do nothing: B1 release will handle it. -} -bind Scrollbar <B2-ButtonRelease-1> { - # Do nothing: B2 release will handle it. -} -bind Scrollbar <B2-Leave> { - # Prevents <Leave> binding from being invoked. -} -bind Scrollbar <B2-Enter> { - # Prevents <Enter> binding from being invoked. -} -bind Scrollbar <Control-1> { - tk::ScrollTopBottom %W %x %y -} -bind Scrollbar <Control-2> { - tk::ScrollTopBottom %W %x %y -} - -bind Scrollbar <Up> { - tk::ScrollByUnits %W v -1 -} -bind Scrollbar <Down> { - tk::ScrollByUnits %W v 1 -} -bind Scrollbar <Control-Up> { - tk::ScrollByPages %W v -1 -} -bind Scrollbar <Control-Down> { - tk::ScrollByPages %W v 1 -} -bind Scrollbar <Left> { - tk::ScrollByUnits %W h -1 -} -bind Scrollbar <Right> { - tk::ScrollByUnits %W h 1 -} -bind Scrollbar <Control-Left> { - tk::ScrollByPages %W h -1 -} -bind Scrollbar <Control-Right> { - tk::ScrollByPages %W h 1 -} -bind Scrollbar <Prior> { - tk::ScrollByPages %W hv -1 -} -bind Scrollbar <Next> { - tk::ScrollByPages %W hv 1 -} -bind Scrollbar <Home> { - tk::ScrollToPos %W 0 -} -bind Scrollbar <End> { - tk::ScrollToPos %W 1 -} -} -# tk::ScrollButtonDown -- -# This procedure is invoked when a button is pressed in a scrollbar. -# It changes the way the scrollbar is displayed and takes actions -# depending on where the mouse is. -# -# Arguments: -# w - The scrollbar widget. -# x, y - Mouse coordinates. - -proc tk::ScrollButtonDown {w x y} { - variable ::tk::Priv - set Priv(relief) [$w cget -activerelief] - $w configure -activerelief sunken - set element [$w identify $x $y] - if {[string equal $element "slider"]} { - ScrollStartDrag $w $x $y - } else { - ScrollSelect $w $element initial - } -} - -# ::tk::ScrollButtonUp -- -# This procedure is invoked when a button is released in a scrollbar. -# It cancels scans and auto-repeats that were in progress, and restores -# the way the active element is displayed. -# -# Arguments: -# w - The scrollbar widget. -# x, y - Mouse coordinates. - -proc ::tk::ScrollButtonUp {w x y} { - variable ::tk::Priv - tk::CancelRepeat - if {[info exists Priv(relief)]} { - # Avoid error due to spurious release events - $w configure -activerelief $Priv(relief) - ScrollEndDrag $w $x $y - $w activate [$w identify $x $y] - } -} - -# ::tk::ScrollSelect -- -# This procedure is invoked when a button is pressed over the scrollbar. -# It invokes one of several scrolling actions depending on where in -# the scrollbar the button was pressed. -# -# Arguments: -# w - The scrollbar widget. -# element - The element of the scrollbar that was selected, such -# as "arrow1" or "trough2". Shouldn't be "slider". -# repeat - Whether and how to auto-repeat the action: "noRepeat" -# means don't auto-repeat, "initial" means this is the -# first action in an auto-repeat sequence, and "again" -# means this is the second repetition or later. - -proc ::tk::ScrollSelect {w element repeat} { - variable ::tk::Priv - if {![winfo exists $w]} return - switch -- $element { - "arrow1" {ScrollByUnits $w hv -1} - "trough1" {ScrollByPages $w hv -1} - "trough2" {ScrollByPages $w hv 1} - "arrow2" {ScrollByUnits $w hv 1} - default {return} - } - if {[string equal $repeat "again"]} { - set Priv(afterId) [after [$w cget -repeatinterval] \ - [list tk::ScrollSelect $w $element again]] - } elseif {[string equal $repeat "initial"]} { - set delay [$w cget -repeatdelay] - if {$delay > 0} { - set Priv(afterId) [after $delay \ - [list tk::ScrollSelect $w $element again]] - } - } -} - -# ::tk::ScrollStartDrag -- -# This procedure is called to initiate a drag of the slider. It just -# remembers the starting position of the mouse and slider. -# -# Arguments: -# w - The scrollbar widget. -# x, y - The mouse position at the start of the drag operation. - -proc ::tk::ScrollStartDrag {w x y} { - variable ::tk::Priv - - if {[string equal [$w cget -command] ""]} { - return - } - set Priv(pressX) $x - set Priv(pressY) $y - set Priv(initValues) [$w get] - set iv0 [lindex $Priv(initValues) 0] - if {[llength $Priv(initValues)] == 2} { - set Priv(initPos) $iv0 - } elseif {$iv0 == 0} { - set Priv(initPos) 0.0 - } else { - set Priv(initPos) [expr {(double([lindex $Priv(initValues) 2])) \ - / [lindex $Priv(initValues) 0]}] - } -} - -# ::tk::ScrollDrag -- -# This procedure is called for each mouse motion even when the slider -# is being dragged. It notifies the associated widget if we're not -# jump scrolling, and it just updates the scrollbar if we are jump -# scrolling. -# -# Arguments: -# w - The scrollbar widget. -# x, y - The current mouse position. - -proc ::tk::ScrollDrag {w x y} { - variable ::tk::Priv - - if {[string equal $Priv(initPos) ""]} { - return - } - set delta [$w delta [expr {$x - $Priv(pressX)}] [expr {$y - $Priv(pressY)}]] - if {[$w cget -jump]} { - if {[llength $Priv(initValues)] == 2} { - $w set [expr {[lindex $Priv(initValues) 0] + $delta}] \ - [expr {[lindex $Priv(initValues) 1] + $delta}] - } else { - set delta [expr {round($delta * [lindex $Priv(initValues) 0])}] - eval [list $w] set [lreplace $Priv(initValues) 2 3 \ - [expr {[lindex $Priv(initValues) 2] + $delta}] \ - [expr {[lindex $Priv(initValues) 3] + $delta}]] - } - } else { - ScrollToPos $w [expr {$Priv(initPos) + $delta}] - } -} - -# ::tk::ScrollEndDrag -- -# This procedure is called to end an interactive drag of the slider. -# It scrolls the window if we're in jump mode, otherwise it does nothing. -# -# Arguments: -# w - The scrollbar widget. -# x, y - The mouse position at the end of the drag operation. - -proc ::tk::ScrollEndDrag {w x y} { - variable ::tk::Priv - - if {[string equal $Priv(initPos) ""]} { - return - } - if {[$w cget -jump]} { - set delta [$w delta [expr {$x - $Priv(pressX)}] \ - [expr {$y - $Priv(pressY)}]] - ScrollToPos $w [expr {$Priv(initPos) + $delta}] - } - set Priv(initPos) "" -} - -# ::tk::ScrollByUnits -- -# This procedure tells the scrollbar's associated widget to scroll up -# or down by a given number of units. It notifies the associated widget -# in different ways for old and new command syntaxes. -# -# Arguments: -# w - The scrollbar widget. -# orient - Which kinds of scrollbars this applies to: "h" for -# horizontal, "v" for vertical, "hv" for both. -# amount - How many units to scroll: typically 1 or -1. - -proc ::tk::ScrollByUnits {w orient amount} { - set cmd [$w cget -command] - if {[string equal $cmd ""] || ([string first \ - [string index [$w cget -orient] 0] $orient] < 0)} { - return - } - set info [$w get] - if {[llength $info] == 2} { - uplevel #0 $cmd scroll $amount units - } else { - uplevel #0 $cmd [expr {[lindex $info 2] + $amount}] - } -} - -# ::tk::ScrollByPages -- -# This procedure tells the scrollbar's associated widget to scroll up -# or down by a given number of screenfuls. It notifies the associated -# widget in different ways for old and new command syntaxes. -# -# Arguments: -# w - The scrollbar widget. -# orient - Which kinds of scrollbars this applies to: "h" for -# horizontal, "v" for vertical, "hv" for both. -# amount - How many screens to scroll: typically 1 or -1. - -proc ::tk::ScrollByPages {w orient amount} { - set cmd [$w cget -command] - if {[string equal $cmd ""] || ([string first \ - [string index [$w cget -orient] 0] $orient] < 0)} { - return - } - set info [$w get] - if {[llength $info] == 2} { - uplevel #0 $cmd scroll $amount pages - } else { - uplevel #0 $cmd [expr {[lindex $info 2] + $amount*([lindex $info 1] - 1)}] - } -} - -# ::tk::ScrollToPos -- -# This procedure tells the scrollbar's associated widget to scroll to -# a particular location, given by a fraction between 0 and 1. It notifies -# the associated widget in different ways for old and new command syntaxes. -# -# Arguments: -# w - The scrollbar widget. -# pos - A fraction between 0 and 1 indicating a desired position -# in the document. - -proc ::tk::ScrollToPos {w pos} { - set cmd [$w cget -command] - if {[string equal $cmd ""]} { - return - } - set info [$w get] - if {[llength $info] == 2} { - uplevel #0 $cmd moveto $pos - } else { - uplevel #0 $cmd [expr {round([lindex $info 0]*$pos)}] - } -} - -# ::tk::ScrollTopBottom -# Scroll to the top or bottom of the document, depending on the mouse -# position. -# -# Arguments: -# w - The scrollbar widget. -# x, y - Mouse coordinates within the widget. - -proc ::tk::ScrollTopBottom {w x y} { - variable ::tk::Priv - set element [$w identify $x $y] - if {[string match *1 $element]} { - ScrollToPos $w 0 - } elseif {[string match *2 $element]} { - ScrollToPos $w 1 - } - - # Set Priv(relief), since it's needed by tk::ScrollButtonUp. - - set Priv(relief) [$w cget -activerelief] -} - -# ::tk::ScrollButton2Down -# This procedure is invoked when button 2 is pressed over a scrollbar. -# If the button is over the trough or slider, it sets the scrollbar to -# the mouse position and starts a slider drag. Otherwise it just -# behaves the same as button 1. -# -# Arguments: -# w - The scrollbar widget. -# x, y - Mouse coordinates within the widget. - -proc ::tk::ScrollButton2Down {w x y} { - variable ::tk::Priv - set element [$w identify $x $y] - if {[string match {arrow[12]} $element]} { - ScrollButtonDown $w $x $y - return - } - ScrollToPos $w [$w fraction $x $y] - set Priv(relief) [$w cget -activerelief] - - # Need the "update idletasks" below so that the widget calls us - # back to reset the actual scrollbar position before we start the - # slider drag. - - update idletasks - $w configure -activerelief sunken - $w activate slider - ScrollStartDrag $w $x $y -} diff --git a/tcl/library/spinbox.tcl b/tcl/library/spinbox.tcl deleted file mode 100644 index 449d45d859b..00000000000 --- a/tcl/library/spinbox.tcl +++ /dev/null @@ -1,568 +0,0 @@ -# spinbox.tcl -- -# -# This file defines the default bindings for Tk spinbox widgets and provides -# procedures that help in implementing those bindings. The spinbox builds -# off the entry widget, so it can reuse Entry bindings and procedures. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1999-2000 Jeffrey Hobbs -# Copyright (c) 2000 Ajuba Solutions -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -#------------------------------------------------------------------------- -# Elements of tk::Priv that are used in this file: -# -# afterId - If non-null, it means that auto-scanning is underway -# and it gives the "after" id for the next auto-scan -# command to be executed. -# mouseMoved - Non-zero means the mouse has moved a significant -# amount since the button went down (so, for example, -# start dragging out a selection). -# pressX - X-coordinate at which the mouse button was pressed. -# selectMode - The style of selection currently underway: -# char, word, or line. -# x, y - Last known mouse coordinates for scanning -# and auto-scanning. -# data - Used for Cut and Copy -#------------------------------------------------------------------------- - -# Initialize namespace -namespace eval ::tk::spinbox {} - -#------------------------------------------------------------------------- -# The code below creates the default class bindings for entries. -#------------------------------------------------------------------------- -bind Spinbox <<Cut>> { - if {![catch {::tk::spinbox::GetSelection %W} tk::Priv(data)]} { - clipboard clear -displayof %W - clipboard append -displayof %W $tk::Priv(data) - %W delete sel.first sel.last - unset tk::Priv(data) - } -} -bind Spinbox <<Copy>> { - if {![catch {::tk::spinbox::GetSelection %W} tk::Priv(data)]} { - clipboard clear -displayof %W - clipboard append -displayof %W $tk::Priv(data) - unset tk::Priv(data) - } -} -bind Spinbox <<Paste>> { - global tcl_platform - catch { - if {[tk windowingsystem] ne "x11"} { - catch { - %W delete sel.first sel.last - } - } - %W insert insert [::tk::GetSelection %W CLIPBOARD] - ::tk::EntrySeeInsert %W - } -} -bind Spinbox <<Clear>> { - %W delete sel.first sel.last -} -bind Spinbox <<PasteSelection>> { - if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)] - || !$tk::Priv(mouseMoved)} { - ::tk::spinbox::Paste %W %x - } -} - -# Standard Motif bindings: - -bind Spinbox <1> { - ::tk::spinbox::ButtonDown %W %x %y -} -bind Spinbox <B1-Motion> { - ::tk::spinbox::Motion %W %x %y -} -bind Spinbox <Double-1> { - set tk::Priv(selectMode) word - ::tk::spinbox::MouseSelect %W %x sel.first -} -bind Spinbox <Triple-1> { - set tk::Priv(selectMode) line - ::tk::spinbox::MouseSelect %W %x 0 -} -bind Spinbox <Shift-1> { - set tk::Priv(selectMode) char - %W selection adjust @%x -} -bind Spinbox <Double-Shift-1> { - set tk::Priv(selectMode) word - ::tk::spinbox::MouseSelect %W %x -} -bind Spinbox <Triple-Shift-1> { - set tk::Priv(selectMode) line - ::tk::spinbox::MouseSelect %W %x -} -bind Spinbox <B1-Leave> { - set tk::Priv(x) %x - ::tk::spinbox::AutoScan %W -} -bind Spinbox <B1-Enter> { - tk::CancelRepeat -} -bind Spinbox <ButtonRelease-1> { - ::tk::spinbox::ButtonUp %W %x %y -} -bind Spinbox <Control-1> { - %W icursor @%x -} - -bind Spinbox <Up> { - %W invoke buttonup -} -bind Spinbox <Down> { - %W invoke buttondown -} - -bind Spinbox <Left> { - ::tk::EntrySetCursor %W [expr {[%W index insert] - 1}] -} -bind Spinbox <Right> { - ::tk::EntrySetCursor %W [expr {[%W index insert] + 1}] -} -bind Spinbox <Shift-Left> { - ::tk::EntryKeySelect %W [expr {[%W index insert] - 1}] - ::tk::EntrySeeInsert %W -} -bind Spinbox <Shift-Right> { - ::tk::EntryKeySelect %W [expr {[%W index insert] + 1}] - ::tk::EntrySeeInsert %W -} -bind Spinbox <Control-Left> { - ::tk::EntrySetCursor %W [::tk::EntryPreviousWord %W insert] -} -bind Spinbox <Control-Right> { - ::tk::EntrySetCursor %W [::tk::EntryNextWord %W insert] -} -bind Spinbox <Shift-Control-Left> { - ::tk::EntryKeySelect %W [::tk::EntryPreviousWord %W insert] - ::tk::EntrySeeInsert %W -} -bind Spinbox <Shift-Control-Right> { - ::tk::EntryKeySelect %W [::tk::EntryNextWord %W insert] - ::tk::EntrySeeInsert %W -} -bind Spinbox <Home> { - ::tk::EntrySetCursor %W 0 -} -bind Spinbox <Shift-Home> { - ::tk::EntryKeySelect %W 0 - ::tk::EntrySeeInsert %W -} -bind Spinbox <End> { - ::tk::EntrySetCursor %W end -} -bind Spinbox <Shift-End> { - ::tk::EntryKeySelect %W end - ::tk::EntrySeeInsert %W -} - -bind Spinbox <Delete> { - if {[%W selection present]} { - %W delete sel.first sel.last - } else { - %W delete insert - } -} -bind Spinbox <BackSpace> { - ::tk::EntryBackspace %W -} - -bind Spinbox <Control-space> { - %W selection from insert -} -bind Spinbox <Select> { - %W selection from insert -} -bind Spinbox <Control-Shift-space> { - %W selection adjust insert -} -bind Spinbox <Shift-Select> { - %W selection adjust insert -} -bind Spinbox <Control-slash> { - %W selection range 0 end -} -bind Spinbox <Control-backslash> { - %W selection clear -} -bind Spinbox <KeyPress> { - ::tk::EntryInsert %W %A -} - -# Ignore all Alt, Meta, and Control keypresses unless explicitly bound. -# Otherwise, if a widget binding for one of these is defined, the -# <KeyPress> class binding will also fire and insert the character, -# which is wrong. Ditto for Escape, Return, and Tab. - -bind Spinbox <Alt-KeyPress> {# nothing} -bind Spinbox <Meta-KeyPress> {# nothing} -bind Spinbox <Control-KeyPress> {# nothing} -bind Spinbox <Escape> {# nothing} -bind Spinbox <Return> {# nothing} -bind Spinbox <KP_Enter> {# nothing} -bind Spinbox <Tab> {# nothing} -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - bind Spinbox <Command-KeyPress> {# nothing} -} - -# On Windows, paste is done using Shift-Insert. Shift-Insert already -# generates the <<Paste>> event, so we don't need to do anything here. -if {[string compare $tcl_platform(platform) "windows"]} { - bind Spinbox <Insert> { - catch {::tk::EntryInsert %W [::tk::GetSelection %W PRIMARY]} - } -} - -# Additional emacs-like bindings: - -bind Spinbox <Control-a> { - if {!$tk_strictMotif} { - ::tk::EntrySetCursor %W 0 - } -} -bind Spinbox <Control-b> { - if {!$tk_strictMotif} { - ::tk::EntrySetCursor %W [expr {[%W index insert] - 1}] - } -} -bind Spinbox <Control-d> { - if {!$tk_strictMotif} { - %W delete insert - } -} -bind Spinbox <Control-e> { - if {!$tk_strictMotif} { - ::tk::EntrySetCursor %W end - } -} -bind Spinbox <Control-f> { - if {!$tk_strictMotif} { - ::tk::EntrySetCursor %W [expr {[%W index insert] + 1}] - } -} -bind Spinbox <Control-h> { - if {!$tk_strictMotif} { - ::tk::EntryBackspace %W - } -} -bind Spinbox <Control-k> { - if {!$tk_strictMotif} { - %W delete insert end - } -} -bind Spinbox <Control-t> { - if {!$tk_strictMotif} { - ::tk::EntryTranspose %W - } -} -bind Spinbox <Meta-b> { - if {!$tk_strictMotif} { - ::tk::EntrySetCursor %W [::tk::EntryPreviousWord %W insert] - } -} -bind Spinbox <Meta-d> { - if {!$tk_strictMotif} { - %W delete insert [::tk::EntryNextWord %W insert] - } -} -bind Spinbox <Meta-f> { - if {!$tk_strictMotif} { - ::tk::EntrySetCursor %W [::tk::EntryNextWord %W insert] - } -} -bind Spinbox <Meta-BackSpace> { - if {!$tk_strictMotif} { - %W delete [::tk::EntryPreviousWord %W insert] insert - } -} -bind Spinbox <Meta-Delete> { - if {!$tk_strictMotif} { - %W delete [::tk::EntryPreviousWord %W insert] insert - } -} - -# A few additional bindings of my own. - -bind Spinbox <2> { - if {!$tk_strictMotif} { - ::tk::EntryScanMark %W %x - } -} -bind Spinbox <B2-Motion> { - if {!$tk_strictMotif} { - ::tk::EntryScanDrag %W %x - } -} - -# ::tk::spinbox::Invoke -- -# Invoke an element of the spinbox -# -# Arguments: -# w - The spinbox window. -# elem - Element to invoke - -proc ::tk::spinbox::Invoke {w elem} { - variable ::tk::Priv - - if {![info exists Priv(outsideElement)]} { - $w invoke $elem - incr Priv(repeated) - } - set delay [$w cget -repeatinterval] - if {$delay > 0} { - set Priv(afterId) [after $delay \ - [list ::tk::spinbox::Invoke $w $elem]] - } -} - -# ::tk::spinbox::ClosestGap -- -# 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. -# -# Arguments: -# w - The spinbox window. -# x - X-coordinate within the window. - -proc ::tk::spinbox::ClosestGap {w x} { - set pos [$w index @$x] - set bbox [$w bbox $pos] - if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} { - return $pos - } - incr pos -} - -# ::tk::spinbox::ButtonDown -- -# This procedure is invoked to handle button-1 presses in spinbox -# widgets. It moves the insertion cursor, sets the selection anchor, -# and claims the input focus. -# -# Arguments: -# w - The spinbox window in which the button was pressed. -# x - The x-coordinate of the button press. - -proc ::tk::spinbox::ButtonDown {w x y} { - variable ::tk::Priv - - # Get the element that was clicked in. If we are not directly over - # the spinbox, default to entry. This is necessary for spinbox grabs. - # - set Priv(element) [$w identify $x $y] - if {$Priv(element) eq ""} { - set Priv(element) "entry" - } - - switch -exact $Priv(element) { - "buttonup" - "buttondown" { - if {"disabled" ne [$w cget -state]} { - $w selection element $Priv(element) - set Priv(repeated) 0 - set Priv(relief) [$w cget -$Priv(element)relief] - catch {after cancel $Priv(afterId)} - set delay [$w cget -repeatdelay] - if {$delay > 0} { - set Priv(afterId) [after $delay \ - [list ::tk::spinbox::Invoke $w $Priv(element)]] - } - if {[info exists Priv(outsideElement)]} { - unset Priv(outsideElement) - } - } - } - "entry" { - set Priv(selectMode) char - set Priv(mouseMoved) 0 - set Priv(pressX) $x - $w icursor [::tk::spinbox::ClosestGap $w $x] - $w selection from insert - if {"disabled" ne [$w cget -state]} {focus $w} - $w selection clear - } - default { - return -code error "unknown spinbox element \"$Priv(element)\"" - } - } -} - -# ::tk::spinbox::ButtonUp -- -# This procedure is invoked to handle button-1 releases in spinbox -# widgets. -# -# Arguments: -# w - The spinbox window in which the button was pressed. -# x - The x-coordinate of the button press. - -proc ::tk::spinbox::ButtonUp {w x y} { - variable ::tk::Priv - - ::tk::CancelRepeat - - # Priv(relief) may not exist if the ButtonUp is not paired with - # a preceding ButtonDown - if {[info exists Priv(element)] && [info exists Priv(relief)] && \ - [string match "button*" $Priv(element)]} { - if {[info exists Priv(repeated)] && !$Priv(repeated)} { - $w invoke $Priv(element) - } - $w configure -$Priv(element)relief $Priv(relief) - $w selection element none - } -} - -# ::tk::spinbox::MouseSelect -- -# 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 -# ignores mouse motions initially until the mouse has moved from -# one character to another or until there have been multiple clicks. -# -# Arguments: -# w - The spinbox window in which the button was pressed. -# x - The x-coordinate of the mouse. -# cursor - optional place to set cursor. - -proc ::tk::spinbox::MouseSelect {w x {cursor {}}} { - variable ::tk::Priv - - if {$Priv(element) ne "entry"} { - # The ButtonUp command triggered by ButtonRelease-1 handles - # invoking one of the spinbuttons. - return - } - set cur [::tk::spinbox::ClosestGap $w $x] - set anchor [$w index anchor] - if {($cur ne $anchor) || (abs($Priv(pressX) - $x) >= 3)} { - set Priv(mouseMoved) 1 - } - switch $Priv(selectMode) { - char { - if {$Priv(mouseMoved)} { - if {$cur < $anchor} { - $w selection range $cur $anchor - } elseif {$cur > $anchor} { - $w selection range $anchor $cur - } else { - $w selection clear - } - } - } - word { - if {$cur < [$w index anchor]} { - set before [tcl_wordBreakBefore [$w get] $cur] - set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]] - } else { - set before [tcl_wordBreakBefore [$w get] $anchor] - set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]] - } - if {$before < 0} { - set before 0 - } - if {$after < 0} { - set after end - } - $w selection range $before $after - } - line { - $w selection range 0 end - } - } - if {$cursor ne {} && $cursor ne "ignore"} { - catch {$w icursor $cursor} - } - update idletasks -} - -# ::tk::spinbox::Paste -- -# This procedure sets the insertion cursor to the current mouse position, -# pastes the selection there, and sets the focus to the window. -# -# Arguments: -# w - The spinbox window. -# x - X position of the mouse. - -proc ::tk::spinbox::Paste {w x} { - $w icursor [::tk::spinbox::ClosestGap $w $x] - catch {$w insert insert [::tk::GetSelection $w PRIMARY]} - if {[string equal "disabled" [$w cget -state]]} {focus $w} -} - -# ::tk::spinbox::Motion -- -# This procedure is invoked when the mouse moves in a spinbox window -# with button 1 down. -# -# Arguments: -# w - The spinbox window. - -proc ::tk::spinbox::Motion {w x y} { - variable ::tk::Priv - - if {![info exists Priv(element)]} { - set Priv(element) [$w identify $x $y] - } - - set Priv(x) $x - if {"entry" eq $Priv(element)} { - ::tk::spinbox::MouseSelect $w $x ignore - } elseif {[$w identify $x $y] ne $Priv(element)} { - if {![info exists Priv(outsideElement)]} { - # We've wandered out of the spin button - # setting outside element will cause ::tk::spinbox::Invoke to - # loop without doing anything - set Priv(outsideElement) "" - $w selection element none - } - } elseif {[info exists Priv(outsideElement)]} { - unset Priv(outsideElement) - $w selection element $Priv(element) - } -} - -# ::tk::spinbox::AutoScan -- -# This procedure is invoked when the mouse leaves an spinbox window -# with button 1 down. It scrolls the window left or right, -# depending on where the mouse is, and reschedules itself as an -# "after" command so that the window continues to scroll until the -# mouse moves back into the window or the mouse button is released. -# -# Arguments: -# w - The spinbox window. - -proc ::tk::spinbox::AutoScan {w} { - variable ::tk::Priv - - set x $Priv(x) - if {$x >= [winfo width $w]} { - $w xview scroll 2 units - ::tk::spinbox::MouseSelect $w $x ignore - } elseif {$x < 0} { - $w xview scroll -2 units - ::tk::spinbox::MouseSelect $w $x ignore - } - set Priv(afterId) [after 50 [list ::tk::spinbox::AutoScan $w]] -} - -# ::tk::spinbox::GetSelection -- -# -# Returns the selected text of the spinbox. Differs from entry in that -# a spinbox has no -show option to obscure contents. -# -# Arguments: -# w - The spinbox window from which the text to get - -proc ::tk::spinbox::GetSelection {w} { - return [string range [$w get] [$w index sel.first] \ - [expr {[$w index sel.last] - 1}]] -} diff --git a/tcl/library/tcltest1.0/pkgIndex.tcl b/tcl/library/tcltest1.0/pkgIndex.tcl deleted file mode 100644 index 96b38cc2a24..00000000000 --- a/tcl/library/tcltest1.0/pkgIndex.tcl +++ /dev/null @@ -1,18 +0,0 @@ -# Tcl package index file, version 1.1 -# This file is generated by the "pkg_mkIndex" command -# and sourced either when an application starts up or -# by a "package unknown" script. It invokes the -# "package ifneeded" command to set up package-related -# information so that packages will be loaded automatically -# in response to "package require" commands. When this -# script is sourced, the variable $dir must contain the -# full path name of this file's directory. - -package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \ - {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \ - ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile \ - ::tcltest::normalizeMsg ::tcltest::removeDirectory \ - ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState \ - ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory \ - ::tcltest:grep ::tcltest::getMatchingTestFiles }}}] - diff --git a/tcl/library/tcltest1.0/tcltest.tcl b/tcl/library/tcltest1.0/tcltest.tcl deleted file mode 100644 index a2fc5a7f0ac..00000000000 --- a/tcl/library/tcltest1.0/tcltest.tcl +++ /dev/null @@ -1,1906 +0,0 @@ -# tcltest.tcl -- -# -# This file contains support code for the Tcl test suite. It -# defines the ::tcltest namespace and finds and defines the output -# directory, constraints available, output and error channels, etc. used -# by Tcl tests. See the tcltest man page for more details. -# -# This design was based on the Tcl testing approach designed and -# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. -# -# RCS: @(#) $Id$ - -package provide tcltest 1.0 - -# create the "tcltest" namespace for all testing variables and procedures - -namespace eval tcltest { - - # Export the public tcltest procs - set procList [list test cleanupTests saveState restoreState \ - normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring safeFetch threadReap getMatchingFiles \ - loadTestedCommands normalizePath] - foreach proc $procList { - namespace export $proc - } - - # ::tcltest::verbose defaults to "b" - if {![info exists verbose]} { - variable verbose "b" - } - - # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory - - if {![info exists match]} { - variable match {} - } - if {![info exists skip]} { - variable skip {} - } - if {![info exists matchFiles]} { - variable matchFiles {*.test} - } - if {![info exists skipFiles]} { - variable skipFiles {} - } - - # By default, don't save core files - if {![info exists preserveCore]} { - variable preserveCore 0 - } - - # output goes to stdout by default - if {![info exists outputChannel]} { - variable outputChannel stdout - } - - # errors go to stderr by default - if {![info exists errorChannel]} { - variable errorChannel stderr - } - - # debug output doesn't get printed by default; debug level 1 spits - # up only the tests that were skipped because they didn't match or were - # specifically skipped. A debug level of 2 would spit up the tcltest - # variables and flags provided; a debug level of 3 causes some additional - # output regarding operations of the test harness. The tcltest package - # currently implements only up to debug level 3. - if {![info exists debug]} { - variable debug 0 - } - - # Save any arguments that we might want to pass through to other programs. - # This is used by the -args flag. - if {![info exists parameters]} { - variable parameters {} - } - - # Count the number of files tested (0 if all.tcl wasn't called). - # The all.tcl file will set testSingleFile to false, so stats will - # not be printed until all.tcl calls the cleanupTests proc. - # The currentFailure var stores the boolean value of whether the - # current test file has had any failures. The failFiles list - # stores the names of test files that had failures. - - if {![info exists numTestFiles]} { - variable numTestFiles 0 - } - if {![info exists testSingleFile]} { - variable testSingleFile true - } - if {![info exists currentFailure]} { - variable currentFailure false - } - if {![info exists failFiles]} { - variable failFiles {} - } - - # Tests should remove all files they create. The test suite will - # check the current working dir for files created by the tests. - # ::tcltest::filesMade keeps track of such files created using the - # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. - # ::tcltest::filesExisted stores the names of pre-existing files. - - if {![info exists filesMade]} { - variable filesMade {} - } - if {![info exists filesExisted]} { - variable filesExisted {} - } - - # ::tcltest::numTests will store test files as indices and the list - # of files (that should not have been) left behind by the test files. - - if {![info exists createdNewFiles]} { - variable createdNewFiles - array set ::tcltest::createdNewFiles {} - } - - # initialize ::tcltest::numTests array to keep track fo the number of - # tests that pass, fail, and are skipped. - - if {![info exists numTests]} { - variable numTests - array set ::tcltest::numTests \ - [list Total 0 Passed 0 Skipped 0 Failed 0] - } - - # initialize ::tcltest::skippedBecause array to keep track of - # constraints that kept tests from running; a constraint name of - # "userSpecifiedSkip" means that the test appeared on the list of tests - # that matched the -skip value given to the flag; "userSpecifiedNonMatch" - # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if ::tcltest::debug is set to - # true. - - if {![info exists skippedBecause]} { - variable skippedBecause - array set ::tcltest::skippedBecause {} - } - - # initialize the ::tcltest::testConstraints array to keep track of valid - # predefined constraints (see the explanation for the - # ::tcltest::initConstraints proc for more details). - - if {![info exists testConstraints]} { - variable testConstraints - array set ::tcltest::testConstraints {} - } - - # Don't run only the constrained tests by default - - if {![info exists limitConstraints]} { - variable limitConstraints false - } - - # A test application has to know how to load the tested commands into - # the interpreter. - - if {![info exists loadScript]} { - variable loadScript {} - } - - # tests that use threads need to know which is the main thread - - if {![info exists mainThread]} { - variable mainThread 1 - if {[info commands thread::id] != {}} { - set mainThread [thread::id] - } elseif {[info commands testthread] != {}} { - set mainThread [testthread id] - } - } - - # save the original environment so that it can be restored later - - if {![info exists originalEnv]} { - variable originalEnv - array set ::tcltest::originalEnv [array get ::env] - } - - # Set ::tcltest::workingDirectory to [pwd]. The default output directory - # for Tcl tests is the working directory. - - if {![info exists workingDirectory]} { - variable workingDirectory [pwd] - } - if {![info exists temporaryDirectory]} { - variable temporaryDirectory $workingDirectory - } - - # Tests should not rely on the current working directory. - # Files that are part of the test suite should be accessed relative to - # ::tcltest::testsDirectory. - - if {![info exists testsDirectory]} { - set oldpwd [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] - cd $oldpwd - unset oldpwd - } - - # the variables and procs that existed when ::tcltest::saveState was - # called are stored in a variable of the same name - if {![info exists saveState]} { - variable saveState {} - } - - # Internationalization support - if {![info exists isoLocale]} { - variable isoLocale fr - switch $tcl_platform(platform) { - "unix" { - - # Try some 'known' values for some platforms: - - switch -exact -- $tcl_platform(os) { - "FreeBSD" { - set ::tcltest::isoLocale fr_FR.ISO_8859-1 - } - HP-UX { - set ::tcltest::isoLocale fr_FR.iso88591 - } - Linux - - IRIX { - set ::tcltest::isoLocale fr - } - default { - - # Works on SunOS 4 and Solaris, and maybe others... - # define it to something else on your system - #if you want to test those. - - set ::tcltest::isoLocale iso_8859_1 - } - } - } - "windows" { - set ::tcltest::isoLocale French - } - } - } - - # Set the location of the execuatble - if {![info exists tcltest]} { - variable tcltest [info nameofexecutable] - } - - # save the platform information so it can be restored later - if {![info exists originalTclPlatform]} { - variable originalTclPlatform [array get tcl_platform] - } - - # If a core file exists, save its modification time. - if {![info exists coreModificationTime]} { - if {[file exists [file join $::tcltest::workingDirectory core]]} { - variable coreModificationTime [file mtime [file join \ - $::tcltest::workingDirectory core]] - } - } - - # Tcl version numbers - if {![info exists version]} { - variable version 8.3 - } - if {![info exists patchLevel]} { - variable patchLevel 8.3.0 - } -} - -# ::tcltest::Debug* -- -# -# Internal helper procedures to write out debug information -# dependent on the chosen level. A test shell may overide -# them, f.e. to redirect the output into a different -# channel, or even into a GUI. - -# ::tcltest::DebugPuts -- -# -# Prints the specified string if the current debug level is -# higher than the provided level argument. -# -# Arguments: -# level The lowest debug level triggering the output -# string The string to print out. -# -# Results: -# Prints the string. Nothing else is allowed. -# - -proc ::tcltest::DebugPuts {level string} { - variable debug - if {$debug >= $level} { - puts $string - } -} - -# ::tcltest::DebugPArray -- -# -# Prints the contents of the specified array if the current -# debug level is higher than the provided level argument -# -# Arguments: -# level The lowest debug level triggering the output -# arrayvar The name of the array to print out. -# -# Results: -# Prints the contents of the array. Nothing else is allowed. -# - -proc ::tcltest::DebugPArray {level arrayvar} { - variable debug - - if {$debug >= $level} { - catch {upvar $arrayvar $arrayvar} - parray $arrayvar - } -} - -# ::tcltest::DebugDo -- -# -# Executes the script if the current debug level is greater than -# the provided level argument -# -# Arguments: -# level The lowest debug level triggering the execution. -# script The tcl script executed upon a debug level high enough. -# -# Results: -# Arbitrary side effects, dependent on the executed script. -# - -proc ::tcltest::DebugDo {level script} { - variable debug - - if {$debug >= $level} { - uplevel $script - } -} - -# ::tcltest::AddToSkippedBecause -- -# -# Increments the variable used to track how many tests were skipped -# because of a particular constraint. -# -# Arguments: -# constraint The name of the constraint to be modified -# -# Results: -# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't -# previously exist - otherwise, it just increments it. - -proc ::tcltest::AddToSkippedBecause { constraint } { - # add the constraint to the list of constraints that kept tests - # from running - - if {[info exists ::tcltest::skippedBecause($constraint)]} { - incr ::tcltest::skippedBecause($constraint) - } else { - set ::tcltest::skippedBecause($constraint) 1 - } - return -} - -# ::tcltest::PrintError -- -# -# Prints errors to ::tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per line. -# -# Arguments: -# errorMsg String containing the error to be printed -# - -proc ::tcltest::PrintError {errorMsg} { - set InitialMessage "Error: " - set InitialMsgLen [string length $InitialMessage] - puts -nonewline $::tcltest::errorChannel $InitialMessage - - # Keep track of where the end of the string is. - set endingIndex [string length $errorMsg] - - if {$endingIndex < 80} { - puts $::tcltest::errorChannel $errorMsg - } else { - # Print up to 80 characters on the first line, including the - # InitialMessage. - set beginningIndex [string last " " [string range $errorMsg 0 \ - [expr {80 - $InitialMsgLen}]]] - puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] - - while {$beginningIndex != "end"} { - puts -nonewline $::tcltest::errorChannel \ - [string repeat " " $InitialMsgLen] - if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts $::tcltest::errorChannel [string trim \ - [string range $errorMsg $beginningIndex end]] - set beginningIndex end - } else { - set newEndingIndex [expr [string last " " [string range \ - $errorMsg $beginningIndex \ - [expr {$beginningIndex + 72}]]] + $beginningIndex] - if {($newEndingIndex <= 0) \ - || ($newEndingIndex <= $beginningIndex)} { - set newEndingIndex end - } - puts $::tcltest::errorChannel [string trim \ - [string range $errorMsg \ - $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex - } - } - } - flush $::tcltest::errorChannel - return -} - -if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { - proc ::tcltest::initConstraintsHook {} {} -} - -# ::tcltest::initConstraints -- -# -# Check Constraintsuration information that will determine which tests -# to run. To do this, create an array ::tcltest::testConstraints. Each -# element has a 0 or 1 value. If the element is "true" then tests -# with that constraint will be run, otherwise tests with that constraint -# will be skipped. See the tcltest man page for the list of built-in -# constraints defined in this procedure. -# -# Arguments: -# none -# -# Results: -# The ::tcltest::testConstraints array is reset to have an index for -# each built-in test constraint. - -proc ::tcltest::initConstraints {} { - global tcl_platform tcl_interactive tk_version - - # The following trace procedure makes it so that we can safely refer to - # non-existent members of the ::tcltest::testConstraints array without - # causing an error. Instead, reading a non-existent member will return 0. - # This is necessary because tests are allowed to use constraint "X" without - # ensuring that ::tcltest::testConstraints("X") is defined. - - trace variable ::tcltest::testConstraints r ::tcltest::safeFetch - - proc ::tcltest::safeFetch {n1 n2 op} { - if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} { - set ::tcltest::testConstraints($n2) 0 - } - } - - ::tcltest::initConstraintsHook - - set ::tcltest::testConstraints(unixOnly) \ - [string equal $tcl_platform(platform) "unix"] - set ::tcltest::testConstraints(macOnly) \ - [string equal $tcl_platform(platform) "macintosh"] - set ::tcltest::testConstraints(pcOnly) \ - [string equal $tcl_platform(platform) "windows"] - - set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly) - set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly) - set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly) - - set ::tcltest::testConstraints(unixOrPc) \ - [expr {$::tcltest::testConstraints(unix) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrPc) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrUnix) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(unix)}] - - set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ - "Windows NT"] - set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \ - "Windows 95"] - set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \ - "Windows 98"] - - # The following Constraints switches are used to mark tests that should - # work, but have been temporarily disabled on certain platforms because - # they don't and we haven't gotten around to fixing the underlying - # problem. - - set ::tcltest::testConstraints(tempNotPc) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(tempNotMac) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(tempNotUnix) \ - [expr {!$::tcltest::testConstraints(unix)}] - - # The following Constraints switches are used to mark tests that crash on - # certain platforms, so that they can be reactivated again when the - # underlying problem is fixed. - - set ::tcltest::testConstraints(pcCrash) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macCrash) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(unixCrash) \ - [expr {!$::tcltest::testConstraints(unix)}] - - # Skip empty tests - - set ::tcltest::testConstraints(emptyTest) 0 - - # By default, tests that expose known bugs are skipped. - - set ::tcltest::testConstraints(knownBug) 0 - - # By default, non-portable tests are skipped. - - set ::tcltest::testConstraints(nonPortable) 0 - - # Some tests require user interaction. - - set ::tcltest::testConstraints(userInteraction) 0 - - # Some tests must be skipped if the interpreter is not in interactive mode - - if {[info exists tcl_interactive]} { - set ::tcltest::testConstraints(interactive) $::tcl_interactive - } else { - set ::tcltest::testConstraints(interactive) 0 - } - - # Some tests can only be run if the installation came from a CD image - # instead of a web image - # Some tests must be skipped if you are running as root on Unix. - # Other tests can only be run if you are running as root on Unix. - - set ::tcltest::testConstraints(root) 0 - set ::tcltest::testConstraints(notRoot) 1 - set user {} - if {[string equal $tcl_platform(platform) "unix"]} { - catch {set user [exec whoami]} - if {[string equal $user ""]} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} - } - if {([string equal $user "root"]) || ([string equal $user ""])} { - set ::tcltest::testConstraints(root) 1 - set ::tcltest::testConstraints(notRoot) 0 - } - } - - # Set nonBlockFiles constraint: 1 means this platform supports - # setting files into nonblocking mode. - - if {[catch {set f [open defs r]}]} { - set ::tcltest::testConstraints(nonBlockFiles) 1 - } else { - if {[catch {fconfigure $f -blocking off}] == 0} { - set ::tcltest::testConstraints(nonBlockFiles) 1 - } else { - set ::tcltest::testConstraints(nonBlockFiles) 0 - } - close $f - } - - # Set asyncPipeClose constraint: 1 means this platform supports - # async flush and async close on a pipe. - # - # Test for SCO Unix - cannot run async flushing tests because a - # potential problem with select is apparently interfering. - # (Mark Diekhans). - - if {[string equal $tcl_platform(platform) "unix"]} { - if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - set ::tcltest::testConstraints(asyncPipeClose) 0 - } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 - } - } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 - } - - # Test to see if we have a broken version of sprintf with respect - # to the "e" format of floating-point numbers. - - set ::tcltest::testConstraints(eformat) 1 - if {![string equal "[format %g 5e-5]" "5e-05"]} { - set ::tcltest::testConstraints(eformat) 0 - } - - # Test to see if execed commands such as cat, echo, rm and so forth are - # present on this machine. - - set ::tcltest::testConstraints(unixExecs) 1 - if {[string equal $tcl_platform(platform) "macintosh"]} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([string equal $tcl_platform(platform) "windows"])} { - if {[catch {exec cat defs}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec sh -c echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec wc defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {$::tcltest::testConstraints(unixExecs) == 1} { - exec echo hello > removeMe - if {[catch {exec rm removeMe}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 - } - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec sleep 1}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec fgrep unixExecs defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec ps}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec echo abc > removeMe}] == 0) && \ - ([catch {exec chmod 644 removeMe}] == 1) && \ - ([catch {exec rm removeMe}] == 0)} { - set ::tcltest::testConstraints(unixExecs) 0 - } else { - catch {exec rm -f removeMe} - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec mkdir removeMe}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } else { - catch {exec rm -r removeMe} - } - } - - # Locate tcltest executable - - if {![info exists tk_version]} { - set tcltest [info nameofexecutable] - - if {$tcltest == "{}"} { - set tcltest {} - } - } - - set ::tcltest::testConstraints(stdio) 0 - catch { - catch {file delete -force tmp} - set f [open tmp w] - puts $f { - exit - } - close $f - - set f [open "|[list $tcltest tmp]" r] - close $f - - set ::tcltest::testConstraints(stdio) 1 - } - catch {file delete -force tmp} - - # Deliberately call socket with the wrong number of arguments. The error - # message you get will indicate whether sockets are available on this - # system. - - catch {socket} msg - set ::tcltest::testConstraints(socket) \ - [expr {$msg != "sockets are not available on this system"}] - - # Check for internationalization - - if {[info commands testlocale] == ""} { - # No testlocale command, no tests... - set ::tcltest::testConstraints(hasIsoLocale) 0 - } else { - set ::tcltest::testConstraints(hasIsoLocale) \ - [string length [::tcltest::set_iso8859_1_locale]] - ::tcltest::restore_locale - } -} - -# ::tcltest::PrintUsageInfoHook -# -# Hook used for customization of display of usage information. -# - -if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} { - proc ::tcltest::PrintUsageInfoHook {} {} -} - -# ::tcltest::PrintUsageInfo -# -# Prints out the usage information for package tcltest. This can be -# customized with the redefinition of ::tcltest::PrintUsageInfoHook. -# -# Arguments: -# none -# - -proc ::tcltest::PrintUsageInfo {} { - puts [format "Usage: [file tail [info nameofexecutable]] \ - script ?-help? ?flag value? ... \n\ - Available flags (and valid input values) are: \n\ - -help \t Display this usage information. \n\ - -verbose level \t Takes any combination of the values \n\ - \t 'p', 's' and 'b'. Test suite will \n\ - \t display all passed tests if 'p' is \n\ - \t specified, all skipped tests if 's' \n\ - \t is specified, and the bodies of \n\ - \t failed tests if 'b' is specified. \n\ - \t The default value is 'b'. \n\ - -constraints list\t Do not skip the listed constraints\n\ - -limitconstraints bool\t Only run tests with the constraints\n\ - \t listed in -constraints.\n\ - -match pattern \t Run all tests within the specified \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -skip pattern \t Skip all tests within the set of \n\ - \t specified tests (via -match) and \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -file pattern \t Run tests in all test files that \n\ - \t match the glob pattern given. \n\ - -notfile pattern\t Skip all test files that match the \n\ - \t glob pattern given. \n\ - -preservecore level \t If 2, save any core files produced \n\ - \t during testing in the directory \n\ - \t specified by -tmpdir. If 1, notify the\n\ - \t user if core files are created. The default \n\ - \t is $::tcltest::preserveCore. \n\ - -tmpdir directory\t Save temporary files in the specified\n\ - \t directory. The default value is \n\ - \t $::tcltest::temporaryDirectory. \n\ - -testdir directories\t Search tests in the specified\n\ - \t directories. The default value is \n\ - \t $::tcltest::testsDirectory. \n\ - -outfile file \t Send output from test runs to the \n\ - \t specified file. The default is \n\ - \t stdout. \n\ - -errfile file \t Send errors from test runs to the \n\ - \t specified file. The default is \n\ - \t stderr. \n\ - -loadfile file \t Read the script to load the tested \n\ - \t commands from the specified file. \n\ - -load script \t Specifies the script to load the tested \n\ - \t commands. \n\ - -debug level \t Internal debug flag."] - ::tcltest::PrintUsageInfoHook - return -} - -# ::tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# - -proc ::tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not a directory" - exit 1 - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not writeable" - exit 1 - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not readable" - exit 1 - } -} - -# ::tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd -} - -# ::tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } -} - -# ::tcltest::processCmdLineArgsFlagsHook -- -# -# This hook is used to add to the list of command line arguments that are -# processed by ::tcltest::processCmdLineArgs. -# - -if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} -} - -# ::tcltest::processCmdLineArgsHook -- -# -# This hook is used to actually process the flags added by -# ::tcltest::processCmdLineArgsAddFlagsHook. -# -# Arguments: -# flags The flags that have been pulled out of argv -# - -if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} { - proc ::tcltest::processCmdLineArgsHook {flag} {} -} - -# ::tcltest::processCmdLineArgs -- -# -# Use command line args to set the verbose, skip, and -# match, outputChannel, errorChannel, debug, and temporaryDirectory -# variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. -# -# Arguments: -# none -# -# Results: -# Sets the above-named variables in the tcltest namespace. - -proc ::tcltest::processCmdLineArgs {} { - global argv - - # The "argv" var doesn't exist in some cases, so use {}. - - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - # Allow for 1-char abbreviations, where applicable (e.g., -match == -m). - # Note that -verbose cannot be abbreviated to -v in wish because it - # conflicts with the wish option -visual. - - # Process -help first - if {([lsearch -exact $flagArray {-help}] != -1) || \ - ([lsearch -exact $flagArray {-h}] != -1)} { - ::tcltest::PrintUsageInfo - exit 1 - } - - if {[catch {array set flag $flagArray}]} { - ::tcltest::PrintError "odd number of arguments specified on command line: \ - $argv" - ::tcltest::PrintUsageInfo - exit 1 - } - - # -help is not listed since it has already been processed - lappend defaultFlags -verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -args -testdir \ - -load -loadfile - set defaultFlags [concat $defaultFlags \ - [ ::tcltest::processCmdLineArgsAddFlagsHook ]] - - foreach arg $defaultFlags { - set abbrev [string range $arg 0 1] - if {([info exists flag($abbrev)]) && \ - ([lsearch -exact $flagArray $arg] < [lsearch -exact \ - $flagArray $abbrev])} { - set flag($arg) $flag($abbrev) - } - } - - # Set ::tcltest::parameters to the arg of the -args flag, if given - if {[info exists flag(-args)]} { - set ::tcltest::parameters $flag(-args) - } - - # Set ::tcltest::verbose to the arg of the -verbose flag, if given - - if {[info exists flag(-verbose)]} { - set ::tcltest::verbose $flag(-verbose) - } - - # Set ::tcltest::match to the arg of the -match flag, if given. - - if {[info exists flag(-match)]} { - set ::tcltest::match $flag(-match) - } - - # Set ::tcltest::skip to the arg of the -skip flag, if given - - if {[info exists flag(-skip)]} { - set ::tcltest::skip $flag(-skip) - } - - # Handle the -file and -notfile flags - if {[info exists flag(-file)]} { - set ::tcltest::matchFiles $flag(-file) - } - if {[info exists flag(-notfile)]} { - set ::tcltest::skipFiles $flag(-notfile) - } - - # Use the -constraints flag, if given, to turn on constraints that are - # turned off by default: userInteractive knownBug nonPortable. This - # code fragment must be run after constraints are initialized. - - if {[info exists flag(-constraints)]} { - foreach elt $flag(-constraints) { - set ::tcltest::testConstraints($elt) 1 - } - } - - # Use the -limitconstraints flag, if given, to tell the harness to limit - # tests run to those that were specified using the -constraints flag. If - # the -constraints flag was not specified, print out an error and exit. - if {[info exists flag(-limitconstraints)]} { - if {![info exists flag(-constraints)]} { - puts "You can only use the -limitconstraints flag with \ - -constraints" - exit 1 - } - set ::tcltest::limitConstraints $flag(-limitconstraints) - foreach elt [array names ::tcltest::testConstraints] { - if {[lsearch -exact $flag(-constraints) $elt] == -1} { - set ::tcltest::testConstraints($elt) 0 - } - } - } - - # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if - # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist, create it. - # If you cannot create it, then return an error. - - set tmpDirError "" - if {[info exists flag(-tmpdir)]} { - set ::tcltest::temporaryDirectory $flag(-tmpdir) - - MakeAbsolutePath ::tcltest::temporaryDirectory - set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: " - } - if {[file exists $::tcltest::temporaryDirectory]} { - ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $::tcltest::temporaryDirectory - } - - normalizePath ::tcltest::temporaryDirectory - - # Set the ::tcltest::testsDirectory to the arg of -testdir, if - # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist return an error. - - set testDirError "" - if {[info exists flag(-testdir)]} { - set ::tcltest::testsDirectory $flag(-testdir) - - MakeAbsolutePath ::tcltest::testsDirectory - set testDirError "bad argument \"$flag(-testdir)\" to -testdir: " - } - if {[file exists $::tcltest::testsDirectory]} { - ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError - } else { - ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \ - does not exist" - exit 1 - } - - normalizePath ::tcltest::testsDirectory - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend ::tcltest::filesExisted [file tail $file] - } - - # If an alternate error or output files are specified, change the - # default channels. - - if {[info exists flag(-outfile)]} { - set tmp $flag(-outfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::outputChannel [open $tmp w] - } - - if {[info exists flag(-errfile)]} { - set tmp $flag(-errfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::errorChannel [open $tmp w] - } - - # If a load script was specified, either directly or through - # a file, remember it for later usage. - - if {[info exists flag(-load)] && \ - ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - set ::tcltest::loadScript $flag(-load) - } - - if {[info exists flag(-loadfile)] && \ - ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - set tmp $flag(-loadfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set tmp [open $tmp r] - set ::tcltest::loadScript [read $tmp] - close $tmp - } - - # If the user specifies debug testing, print out extra information during - # the run. - if {[info exists flag(-debug)]} { - set ::tcltest::debug $flag(-debug) - } - - # Handle -preservecore - if {[info exists flag(-preservecore)]} { - set ::tcltest::preserveCore $flag(-preservecore) - } - - # Call the hook - ::tcltest::processCmdLineArgsHook [array get flag] - - # Spit out everything you know if we're at a debug level 2 or greater - - DebugPuts 2 "Flags passed into tcltest:" - DebugPArray 2 flag - DebugPuts 2 "::tcltest::debug = $::tcltest::debug" - DebugPuts 2 "::tcltest::testsDirectory = $::tcltest::testsDirectory" - DebugPuts 2 "::tcltest::workingDirectory = $::tcltest::workingDirectory" - DebugPuts 2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory" - DebugPuts 2 "::tcltest::outputChannel = $::tcltest::outputChannel" - DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel" - DebugPuts 2 "Original environment (::tcltest::originalEnv):" - DebugPArray 2 ::tcltest::originalEnv - DebugPuts 2 "Constraints:" - DebugPArray 2 ::tcltest::testConstraints -} - -# ::tcltest::loadTestedCommands -- -# -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. -# -# Arguments -# none -# -# Results -# none - -proc ::tcltest::loadTestedCommands {} { - if {$::tcltest::loadScript == {}} { - return - } - - uplevel #0 $::tcltest::loadScript -} - -# ::tcltest::cleanupTests -- -# -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. -# -# Print the names of the files created without the makeFile command -# since the tests were invoked. -# -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). - -proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] - - # Call the cleanup hook - ::tcltest::cleanupTestsHook - - # Remove files and directories created by the :tcltest::makeFile and - # ::tcltest::makeDirectory procedures. - # Record the names of files in ::tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. - - if {!$calledFromAllFile} { - foreach file $::tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } - } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] - } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set ::tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set ::tcltest::createdNewFiles($testFileName) $newFiles - } - } - - if {$calledFromAllFile || $::tcltest::testSingleFile} { - - # print stats - - puts -nonewline $::tcltest::outputChannel "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline $::tcltest::outputChannel \ - "\t$index\t$::tcltest::numTests($index)" - } - puts $::tcltest::outputChannel "" - - # print number test files sourced - # print names of files that ran tests which failed - - if {$calledFromAllFile} { - puts $::tcltest::outputChannel \ - "Sourced $::tcltest::numTestFiles Test Files." - set ::tcltest::numTestFiles 0 - if {[llength $::tcltest::failFiles] > 0} { - puts $::tcltest::outputChannel \ - "Files with failing tests: $::tcltest::failFiles" - set ::tcltest::failFiles {} - } - } - - # if any tests were skipped, print the constraints that kept them - # from running. - - set constraintList [array names ::tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts $::tcltest::outputChannel \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts $::tcltest::outputChannel \ - "\t$::tcltest::skippedBecause($constraint)\t$constraint" - unset ::tcltest::skippedBecause($constraint) - } - } - - # report the names of test files in ::tcltest::createdNewFiles, and - # reset the array to be empty. - - set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts $::tcltest::outputChannel "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts $::tcltest::outputChannel \ - "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" - unset ::tcltest::createdNewFiles($testFile) - } - } - - # reset filesMade, filesExisted, and numTests - - set ::tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set ::tcltest::numTests($index) 0 - } - - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit - } - } else { - - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed - - incr ::tcltest::numTestFiles - if {($::tcltest::currentFailure) && \ - ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { - lappend ::tcltest::failFiles $testFileName - } - set ::tcltest::currentFailure false - - # restore the environment to the state it was in before this package - # was loaded - - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists ::tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $::tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $::tcltest::originalEnv($index) - } - } - } - foreach index [array names ::tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $::tcltest::originalEnv($index) - } - } - if {[llength $newEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements changed:\t$changedEnv" - } - if {[llength $removedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements removed:\t$removedEnv" - } - - set changedTclPlatform {} - foreach index [array names ::tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $::tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $::tcltest::originalTclPlatform($index) - } - } - if {[llength $changedTclPlatform] > 0} { - puts $::tcltest::outputChannel \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "produced core file! \ - Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" - flush $::tcltest::outputChannel - catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" - } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists ::tcltest::coreModificationTime]} { - if {$::tcltest::coreModificationTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "A core file was created!" - } - } else { - puts $::tcltest::outputChannel "A core file was created!" - } - } - } - } -} - -# ::tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { - proc ::tcltest::cleanupTestsHook {} {} -} - -# test -- -# -# This procedure runs a test and prints an error message if the test fails. -# If ::tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# ::tcltest::match variable, if it matches an element in -# ::tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "::tcltest::testConstraints". If any of these -# elements is zero, the test is skipped. -# This argument may be omitted. -# script - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. -# expectedAnswer - Expected result from script. - -proc ::tcltest::test {name description script expectedAnswer args} { - - DebugPuts 3 "Running $name ($description)" - - incr ::tcltest::numTests(Total) - - # skip the test if it's name matches an element of skip - - foreach pattern $::tcltest::skip { - if {[string match $pattern $name]} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip} - return - } - } - - # skip the test if it's name doesn't match any element of match - - if {[llength $::tcltest::match] > 0} { - set ok 0 - foreach pattern $::tcltest::match { - if {[string match $pattern $name]} { - set ok 1 - break - } - } - if {!$ok} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch} - return - } - } - - set i [llength $args] - if {$i == 0} { - set constraints {} - # If we're limited to the listed constraints and there aren't any - # listed, then we shouldn't run the test. - if {$::tcltest::limitConstraints} { - ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - incr ::tcltest::numTests(Skipped) - return - } - } elseif {$i == 1} { - - # "constraints" argument exists; shuffle arguments down, then - # make sure that the constraints are satisfied. - - set constraints $script - set script $expectedAnswer - set expectedAnswer [lindex $args 0] - set doTest 0 - if {[string match {*[$\[]*} $constraints] != 0} { - # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { - # something like {a || b} should be turned into - # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$::tcltest::testConstraints(&)} c - catch {set doTest [eval expr $c]} - } else { - # just simple constraints such as {unixOnly fonts}. - set doTest 1 - foreach constraint $constraints { - if {(![info exists ::tcltest::testConstraints($constraint)]) \ - || (!$::tcltest::testConstraints($constraint))} { - set doTest 0 - - # store the constraint that kept the test from running - set constraints $constraint - break - } - } - } - if {$doTest == 0} { - if {[string first s $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints" - } - - incr ::tcltest::numTests(Skipped) - ::tcltest::AddToSkippedBecause $constraints - return - } - } else { - error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" - } - - # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with tcl_platform. - - if {$::tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - array set tcl_platform $::tcltest::originalTclPlatform - if {[file exists [file join $::tcltest::workingDirectory core]]} { - set coreModTime [file mtime [file join \ - $::tcltest::workingDirectory core]] - } - array set tcl_platform $currentTclPlatform - } - - # If there is no "memory" command (because memory debugging isn't - # enabled), then don't attempt to use the command. - - if {[info commands memory] != {}} { - memory tag $name - } - - set code [catch {uplevel $script} actualAnswer] - if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} { - incr ::tcltest::numTests(Passed) - if {[string first p $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name PASSED" - } - } else { - incr ::tcltest::numTests(Failed) - set ::tcltest::currentFailure true - if {[string first b $::tcltest::verbose] == -1} { - set script "" - } - puts $::tcltest::outputChannel "\n==== $name $description FAILED" - if {$script != ""} { - puts $::tcltest::outputChannel "==== Contents of test case:" - puts $::tcltest::outputChannel $script - } - if {$code != 0} { - if {$code == 1} { - puts $::tcltest::outputChannel "==== Test generated error:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 2} { - puts $::tcltest::outputChannel "==== Test generated return exception; result was:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 3} { - puts $::tcltest::outputChannel "==== Test generated break exception" - } elseif {$code == 4} { - puts $::tcltest::outputChannel "==== Test generated continue exception" - } else { - puts $::tcltest::outputChannel "==== Test generated exception $code; message was:" - puts $::tcltest::outputChannel $actualAnswer - } - } else { - puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer" - } - puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" - puts $::tcltest::outputChannel "==== $name FAILED\n" - } - if {$::tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "==== $name produced core file! \ - Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" - } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "==== $name produced core file!" - } - } else { - puts $::tcltest::outputChannel "==== $name produced core file!" - } - } - } - array set tcl_platform $currentTclPlatform - } -} - -# ::tcltest::getMatchingFiles -# -# Looks at the patterns given to match and skip files -# and uses them to put together a list of the tests that will be run. -# -# Arguments: -# none -# -# Results: -# The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. - -proc ::tcltest::getMatchingFiles {args} { - set matchingFiles {} - if {[llength $args]} { - set searchDirectory $args - } else { - set searchDirectory [list $::tcltest::testsDirectory] - } - # Find the matching files in the list of directories and then remove the - # ones that match the skip pattern - foreach directory $searchDirectory { - set matchFileList {} - foreach match $::tcltest::matchFiles { - set matchFileList [concat $matchFileList \ - [glob -nocomplain [file join $directory $match]]] - } - if {[string compare {} $::tcltest::skipFiles]} { - set skipFileList {} - foreach skip $::tcltest::skipFiles { - set skipFileList [concat $skipFileList \ - [glob -nocomplain [file join $directory $skip]]] - } - foreach file $matchFileList { - # Only include files that don't match the skip pattern and - # aren't SCCS lock files. - if {([lsearch -exact $skipFileList $file] == -1) && \ - (![string match l.*.test [file tail $file]])} { - lappend matchingFiles $file - } - } - } else { - set matchingFiles [concat $matchingFiles $matchFileList] - } - } - if {[string equal $matchingFiles {}]} { - ::tcltest::PrintError "No test files remain after applying \ - your match and skip patterns!" - } - return $matchingFiles -} - -# The following two procs are used in the io tests. - -proc ::tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} - } - return $result -} - -proc ::tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} - } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p - } - } - return $leak -} - -# ::tcltest::saveState -- -# -# Save information regarding what procs and variables exist. -# -# Arguments: -# none -# -# Results: -# Modifies the variable ::tcltest::saveState - -proc ::tcltest::saveState {} { - uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState" -} - -# ::tcltest::restoreState -- -# -# Remove procs and variables that didn't exist before the call to -# ::tcltest::saveState. -# -# Arguments: -# none -# -# Results: -# Removes procs and variables from your environment if they don't exist -# in the ::tcltest::saveState variable. - -proc ::tcltest::restoreState {} { - foreach p [info procs] { - if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ - (![string equal ::tcltest::$p [namespace origin $p]])} { - - DebugPuts 3 "::tcltest::restoreState: Removing proc $p" - rename $p {} - } - } - foreach p [uplevel #0 {info vars}] { - if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - DebugPuts 3 "::tcltest::restoreState: Removing variable $p" - uplevel #0 "catch {unset $p}" - } - } -} - -# ::tcltest::normalizeMsg -- -# -# Removes "extra" newlines from a string. -# -# Arguments: -# msg String to be modified -# - -proc ::tcltest::normalizeMsg {msg} { - regsub "\n$" [string tolower $msg] "" msg - regsub -all "\n\n" $msg "\n" msg - regsub -all "\n\}" $msg "\}" msg - return $msg -} - -# makeFile -- -# -# Create a new file with the name <name>, and write <contents> to it. -# -# If this file hasn't been created via makeFile since the last time -# cleanupTests was called, add it to the $filesMade list, so it will -# be removed by the next call to cleanupTests. -# -proc ::tcltest::makeFile {contents name} { - global tcl_platform - - DebugPuts 3 "::tcltest::makeFile: putting $contents into $name" - - set fullName [file join $::tcltest::temporaryDirectory $name] - set fd [open $fullName w] - - fconfigure $fd -translation lf - - if {[string equal [string index $contents end] "\n"]} { - puts -nonewline $fd $contents - } else { - puts $fd $contents - } - close $fd - - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName - } - return $fullName -} - -# ::tcltest::removeFile -- -# -# Removes the named file from the filesystem -# -# Arguments: -# name file to be removed -# - -proc ::tcltest::removeFile {name} { - DebugPuts 3 "::tcltest::removeFile: removing $name" - file delete [file join $::tcltest::temporaryDirectory $name] -} - -# makeDirectory -- -# -# Create a new dir with the name <name>. -# -# If this dir hasn't been created via makeDirectory since the last time -# cleanupTests was called, add it to the $directoriesMade list, so it will -# be removed by the next call to cleanupTests. -# -proc ::tcltest::makeDirectory {name} { - file mkdir $name - - set fullName [file join [pwd] $name] - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName - } -} - -# ::tcltest::removeDirectory -- -# -# Removes a named directory from the file system. -# -# Arguments: -# name Name of the directory to remove -# - -proc ::tcltest::removeDirectory {name} { - file delete -force $name -} - -proc ::tcltest::viewFile {name} { - global tcl_platform - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ($::tcltest::testConstraints(unixExecs) == 0)} { - set f [open [file join $::tcltest::temporaryDirectory $name]] - set data [read -nonewline $f] - close $f - return $data - } else { - exec cat [file join $::tcltest::temporaryDirectory $name] - } -} - -# grep -- -# -# Evaluate a given expression against each element of a list and return all -# elements for which the expression evaluates to true. For the purposes of -# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the -# value of the current element within the expression. This is equivalent to -# the perl grep command where CURRENT_ELEMENT would be the name for the special -# variable $_. -# -# Examples of usage would be: -# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] -# -# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is -# assumed to be the final argument to the expression provided. -# -# Example: -# grep {regexp a} $someList -# -proc ::tcltest::grep { expression searchList } { - foreach element $searchList { - if {[regsub -all CURRENT_ELEMENT $expression $element \ - newExpression] == 0} { - set newExpression "$expression {$element}" - } - if {[eval $newExpression] == 1} { - lappend returnList $element - } - } - if {[info exists returnList]} { - return $returnList - } - return -} - -# -# Construct a string that consists of the requested sequence of bytes, -# as opposed to a string of properly formed UTF-8 characters. -# This allows the tester to -# 1. Create denormalized or improperly formed strings to pass to C procedures -# that are supposed to accept strings with embedded NULL bytes. -# 2. Confirm that a string result has a certain pattern of bytes, for instance -# to confirm that "\xe0\0" in a Tcl script is stored internally in -# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". -# -# Generally, it's a bad idea to examine the bytes in a Tcl string or to -# construct improperly formed strings in this manner, because it involves -# exposing that Tcl uses UTF-8 internally. - -proc ::tcltest::bytestring {string} { - encoding convertfrom identity $string -} - -# -# Internationalization / ISO support procs -- dl -# -proc ::tcltest::set_iso8859_1_locale {} { - if {[info commands testlocale] != ""} { - set ::tcltest::previousLocale [testlocale ctype] - testlocale ctype $::tcltest::isoLocale - } - return -} - -proc ::tcltest::restore_locale {} { - if {[info commands testlocale] != ""} { - testlocale ctype $::tcltest::previousLocale - } - return -} - -# threadReap -- -# -# Kill all threads except for the main thread. -# Do nothing if testthread is not defined. -# -# Arguments: -# none. -# -# Results: -# Returns the number of existing threads. -proc ::tcltest::threadReap {} { - if {[info commands testthread] != {}} { - - # testthread built into tcltest - - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != $::tcltest::mainThread} { - catch {testthread send -async $tid {testthread exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } elseif {[info commands thread::id] != {}} { - - # Thread extension - - thread::errorproc ThreadNullError - while {[llength [thread::names]] > 1} { - foreach tid [thread::names] { - if {$tid != $::tcltest::mainThread} { - catch {thread::send -async $tid {thread::exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - thread::errorproc ThreadError - return [llength [thread::names]] - } else { - return 1 - } -} - -# Initialize the constraints and set up command line arguments -namespace eval tcltest { - # Ensure that we have a minimal auto_path so we don't pick up extra junk. - set ::auto_path [list [info library]] - - ::tcltest::initConstraints - if {[namespace children ::tcltest] == {}} { - ::tcltest::processCmdLineArgs - } -} - diff --git a/tcl/library/tearoff.tcl b/tcl/library/tearoff.tcl deleted file mode 100644 index c714a607a90..00000000000 --- a/tcl/library/tearoff.tcl +++ /dev/null @@ -1,166 +0,0 @@ -# tearoff.tcl -- -# -# This file contains procedures that implement tear-off menus. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# ::tk::TearoffMenu -- -# Given the name of a menu, this procedure creates a torn-off menu -# that is identical to the given menu (including nested submenus). -# The new torn-off menu exists as a toplevel window managed by the -# window manager. The return value is the name of the new menu. -# The window is created at the point specified by x and y -# -# Arguments: -# w - The menu to be torn-off (duplicated). -# x - x coordinate where window is created -# y - y coordinate where window is created - -proc ::tk::TearOffMenu {w {x 0} {y 0}} { - # Find a unique name to use for the torn-off menu. Find the first - # ancestor of w that is a toplevel but not a menu, and use this as - # the parent of the new menu. This guarantees that the torn off - # menu will be on the same screen as the original menu. By making - # it a child of the ancestor, rather than a child of the menu, it - # can continue to live even if the menu is deleted; it will go - # away when the toplevel goes away. - - if {$x == 0} { - set x [winfo rootx $w] - } - if {$y == 0} { - set y [winfo rooty $w] - } - - set parent [winfo parent $w] - while {[string compare [winfo toplevel $parent] $parent] \ - || [string equal [winfo class $parent] "Menu"]} { - set parent [winfo parent $parent] - } - if {[string equal $parent "."]} { - set parent "" - } - for {set i 1} 1 {incr i} { - set menu $parent.tearoff$i - if {![winfo exists $menu]} { - break - } - } - - $w clone $menu tearoff - - # Pick a title for the new menu by looking at the parent of the - # original: if the parent is a menu, then use the text of the active - # entry. If it's a menubutton then use its text. - - set parent [winfo parent $w] - if {[string compare [$menu cget -title] ""]} { - wm title $menu [$menu cget -title] - } else { - switch [winfo class $parent] { - Menubutton { - wm title $menu [$parent cget -text] - } - Menu { - wm title $menu [$parent entrycget active -label] - } - } - } - - $menu post $x $y - - if {[winfo exists $menu] == 0} { - return "" - } - - # Set tk::Priv(focus) on entry: otherwise the focus will get lost - # after keyboard invocation of a sub-menu (it will stay on the - # submenu). - - bind $menu <Enter> { - set tk::Priv(focus) %W - } - - # If there is a -tearoffcommand option for the menu, invoke it - # now. - - set cmd [$w cget -tearoffcommand] - if {[string compare $cmd ""]} { - uplevel #0 $cmd [list $w $menu] - } - return $menu -} - -# ::tk::MenuDup -- -# Given a menu (hierarchy), create a duplicate menu (hierarchy) -# in a given window. -# -# Arguments: -# src - Source window. Must be a menu. It and its -# menu descendants will be duplicated at dst. -# dst - Name to use for topmost menu in duplicate -# hierarchy. - -proc ::tk::MenuDup {src dst type} { - set cmd [list menu $dst -type $type] - foreach option [$src configure] { - if {[llength $option] == 2} { - continue - } - if {[string equal [lindex $option 0] "-type"]} { - continue - } - lappend cmd [lindex $option 0] [lindex $option 4] - } - eval $cmd - set last [$src index last] - if {[string equal $last "none"]} { - return - } - for {set i [$src cget -tearoff]} {$i <= $last} {incr i} { - set cmd [list $dst add [$src type $i]] - foreach option [$src entryconfigure $i] { - lappend cmd [lindex $option 0] [lindex $option 4] - } - eval $cmd - } - - # Duplicate the binding tags and bindings from the source menu. - - set tags [bindtags $src] - set srcLen [string length $src] - - # Copy tags to x, replacing each substring of src with dst. - - while {[set index [string first $src $tags]] != -1} { - append x [string range $tags 0 [expr {$index - 1}]]$dst - set tags [string range $tags [expr {$index + $srcLen}] end] - } - append x $tags - - bindtags $dst $x - - foreach event [bind $src] { - unset x - set script [bind $src $event] - set eventLen [string length $event] - - # Copy script to x, replacing each substring of event with dst. - - while {[set index [string first $event $script]] != -1} { - append x [string range $script 0 [expr {$index - 1}]] - append x $dst - set script [string range $script [expr {$index + $eventLen}] end] - } - append x $script - - bind $dst $event $x - } -} diff --git a/tcl/library/text.tcl b/tcl/library/text.tcl deleted file mode 100644 index 70f6b8c74f0..00000000000 --- a/tcl/library/text.tcl +++ /dev/null @@ -1,1136 +0,0 @@ -# text.tcl -- -# -# This file defines the default bindings for Tk text widgets and provides -# procedures that help in implementing the bindings. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -#------------------------------------------------------------------------- -# Elements of ::tk::Priv that are used in this file: -# -# afterId - If non-null, it means that auto-scanning is underway -# and it gives the "after" id for the next auto-scan -# command to be executed. -# char - Character position on the line; kept in order -# to allow moving up or down past short lines while -# still remembering the desired position. -# mouseMoved - Non-zero means the mouse has moved a significant -# amount since the button went down (so, for example, -# start dragging out a selection). -# prevPos - Used when moving up or down lines via the keyboard. -# Keeps track of the previous insert position, so -# we can distinguish a series of ups and downs, all -# in a row, from a new up or down. -# selectMode - The style of selection currently underway: -# char, word, or line. -# x, y - Last known mouse coordinates for scanning -# and auto-scanning. -#------------------------------------------------------------------------- - -#------------------------------------------------------------------------- -# The code below creates the default class bindings for text widgets. -#------------------------------------------------------------------------- - -# Standard Motif bindings: - -bind Text <1> { - tk::TextButton1 %W %x %y - %W tag remove sel 0.0 end -} -bind Text <B1-Motion> { - set tk::Priv(x) %x - set tk::Priv(y) %y - tk::TextSelectTo %W %x %y -} -bind Text <Double-1> { - set tk::Priv(selectMode) word - tk::TextSelectTo %W %x %y - catch {%W mark set insert sel.last} -} -bind Text <Triple-1> { - set tk::Priv(selectMode) line - tk::TextSelectTo %W %x %y - catch {%W mark set insert sel.last} -} -bind Text <Shift-1> { - tk::TextResetAnchor %W @%x,%y - set tk::Priv(selectMode) char - tk::TextSelectTo %W %x %y -} -bind Text <Double-Shift-1> { - set tk::Priv(selectMode) word - tk::TextSelectTo %W %x %y 1 -} -bind Text <Triple-Shift-1> { - set tk::Priv(selectMode) line - tk::TextSelectTo %W %x %y -} -bind Text <B1-Leave> { - set tk::Priv(x) %x - set tk::Priv(y) %y - tk::TextAutoScan %W -} -bind Text <B1-Enter> { - tk::CancelRepeat -} -bind Text <ButtonRelease-1> { - tk::CancelRepeat -} -bind Text <Control-1> { - %W mark set insert @%x,%y -} -bind Text <Left> { - tk::TextSetCursor %W insert-1c -} -bind Text <Right> { - tk::TextSetCursor %W insert+1c -} -bind Text <Up> { - tk::TextSetCursor %W [tk::TextUpDownLine %W -1] -} -bind Text <Down> { - tk::TextSetCursor %W [tk::TextUpDownLine %W 1] -} -bind Text <Shift-Left> { - tk::TextKeySelect %W [%W index {insert - 1c}] -} -bind Text <Shift-Right> { - tk::TextKeySelect %W [%W index {insert + 1c}] -} -bind Text <Shift-Up> { - tk::TextKeySelect %W [tk::TextUpDownLine %W -1] -} -bind Text <Shift-Down> { - tk::TextKeySelect %W [tk::TextUpDownLine %W 1] -} -bind Text <Control-Left> { - tk::TextSetCursor %W [tk::TextPrevPos %W insert tcl_startOfPreviousWord] -} -bind Text <Control-Right> { - tk::TextSetCursor %W [tk::TextNextWord %W insert] -} -bind Text <Control-Up> { - tk::TextSetCursor %W [tk::TextPrevPara %W insert] -} -bind Text <Control-Down> { - tk::TextSetCursor %W [tk::TextNextPara %W insert] -} -bind Text <Shift-Control-Left> { - tk::TextKeySelect %W [tk::TextPrevPos %W insert tcl_startOfPreviousWord] -} -bind Text <Shift-Control-Right> { - tk::TextKeySelect %W [tk::TextNextWord %W insert] -} -bind Text <Shift-Control-Up> { - tk::TextKeySelect %W [tk::TextPrevPara %W insert] -} -bind Text <Shift-Control-Down> { - tk::TextKeySelect %W [tk::TextNextPara %W insert] -} -bind Text <Prior> { - tk::TextSetCursor %W [tk::TextScrollPages %W -1] -} -bind Text <Shift-Prior> { - tk::TextKeySelect %W [tk::TextScrollPages %W -1] -} -bind Text <Next> { - tk::TextSetCursor %W [tk::TextScrollPages %W 1] -} -bind Text <Shift-Next> { - tk::TextKeySelect %W [tk::TextScrollPages %W 1] -} -bind Text <Control-Prior> { - %W xview scroll -1 page -} -bind Text <Control-Next> { - %W xview scroll 1 page -} - -bind Text <Home> { - tk::TextSetCursor %W {insert linestart} -} -bind Text <Shift-Home> { - tk::TextKeySelect %W {insert linestart} -} -bind Text <End> { - tk::TextSetCursor %W {insert lineend} -} -bind Text <Shift-End> { - tk::TextKeySelect %W {insert lineend} -} -bind Text <Control-Home> { - tk::TextSetCursor %W 1.0 -} -bind Text <Control-Shift-Home> { - tk::TextKeySelect %W 1.0 -} -bind Text <Control-End> { - tk::TextSetCursor %W {end - 1 char} -} -bind Text <Control-Shift-End> { - tk::TextKeySelect %W {end - 1 char} -} - -bind Text <Tab> { - if { [string equal [%W cget -state] "normal"] } { - tk::TextInsert %W \t - focus %W - break - } -} -bind Text <Shift-Tab> { - # Needed only to keep <Tab> binding from triggering; doesn't - # have to actually do anything. - break -} -bind Text <Control-Tab> { - focus [tk_focusNext %W] -} -bind Text <Control-Shift-Tab> { - focus [tk_focusPrev %W] -} -bind Text <Control-i> { - tk::TextInsert %W \t -} -bind Text <Return> { - tk::TextInsert %W \n - if {[%W cget -autoseparators]} {%W edit separator} -} -bind Text <Delete> { - if {[string compare [%W tag nextrange sel 1.0 end] ""]} { - %W delete sel.first sel.last - } else { - %W delete insert - %W see insert - } -} -bind Text <BackSpace> { - if {[string compare [%W tag nextrange sel 1.0 end] ""]} { - %W delete sel.first sel.last - } elseif {[%W compare insert != 1.0]} { - %W delete insert-1c - %W see insert - } -} - -bind Text <Control-space> { - %W mark set anchor insert -} -bind Text <Select> { - %W mark set anchor insert -} -bind Text <Control-Shift-space> { - set tk::Priv(selectMode) char - tk::TextKeyExtend %W insert -} -bind Text <Shift-Select> { - set tk::Priv(selectMode) char - tk::TextKeyExtend %W insert -} -bind Text <Control-slash> { - %W tag add sel 1.0 end -} -bind Text <Control-backslash> { - %W tag remove sel 1.0 end -} -bind Text <<Cut>> { - tk_textCut %W -} -bind Text <<Copy>> { - tk_textCopy %W -} -bind Text <<Paste>> { - tk_textPaste %W -} -bind Text <<Clear>> { - catch {%W delete sel.first sel.last} -} -bind Text <<PasteSelection>> { - if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)] - || !$tk::Priv(mouseMoved)} { - tk::TextPasteSelection %W %x %y - } -} -bind Text <Insert> { - catch {tk::TextInsert %W [::tk::GetSelection %W PRIMARY]} -} -bind Text <KeyPress> { - tk::TextInsert %W %A -} - -# Ignore all Alt, Meta, and Control keypresses unless explicitly bound. -# Otherwise, if a widget binding for one of these is defined, the -# <KeyPress> class binding will also fire and insert the character, -# which is wrong. Ditto for <Escape>. - -bind Text <Alt-KeyPress> {# nothing } -bind Text <Meta-KeyPress> {# nothing} -bind Text <Control-KeyPress> {# nothing} -bind Text <Escape> {# nothing} -bind Text <KP_Enter> {# nothing} -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { - bind Text <Command-KeyPress> {# nothing} -} - -# Additional emacs-like bindings: - -bind Text <Control-a> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W {insert linestart} - } -} -bind Text <Control-b> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W insert-1c - } -} -bind Text <Control-d> { - if {!$tk_strictMotif} { - %W delete insert - } -} -bind Text <Control-e> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W {insert lineend} - } -} -bind Text <Control-f> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W insert+1c - } -} -bind Text <Control-k> { - if {!$tk_strictMotif} { - if {[%W compare insert == {insert lineend}]} { - %W delete insert - } else { - %W delete insert {insert lineend} - } - } -} -bind Text <Control-n> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W [tk::TextUpDownLine %W 1] - } -} -bind Text <Control-o> { - if {!$tk_strictMotif} { - %W insert insert \n - %W mark set insert insert-1c - } -} -bind Text <Control-p> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W [tk::TextUpDownLine %W -1] - } -} -bind Text <Control-t> { - if {!$tk_strictMotif} { - tk::TextTranspose %W - } -} - -bind Text <<Undo>> { - catch { %W edit undo } -} - -bind Text <<Redo>> { - catch { %W edit redo } -} - -if {[string compare $tcl_platform(platform) "windows"]} { -bind Text <Control-v> { - if {!$tk_strictMotif} { - tk::TextScrollPages %W 1 - } -} -} - -bind Text <Meta-b> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W [tk::TextPrevPos %W insert tcl_startOfPreviousWord] - } -} -bind Text <Meta-d> { - if {!$tk_strictMotif} { - %W delete insert [tk::TextNextWord %W insert] - } -} -bind Text <Meta-f> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W [tk::TextNextWord %W insert] - } -} -bind Text <Meta-less> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W 1.0 - } -} -bind Text <Meta-greater> { - if {!$tk_strictMotif} { - tk::TextSetCursor %W end-1c - } -} -bind Text <Meta-BackSpace> { - if {!$tk_strictMotif} { - %W delete [tk::TextPrevPos %W insert tcl_startOfPreviousWord] insert - } -} -bind Text <Meta-Delete> { - if {!$tk_strictMotif} { - %W delete [tk::TextPrevPos %W insert tcl_startOfPreviousWord] insert - } -} - -# Macintosh only bindings: - -# if text black & highlight black -> text white, other text the same -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { -bind Text <FocusIn> { - %W tag configure sel -borderwidth 0 - %W configure -selectbackground systemHighlight -selectforeground systemHighlightText -} -bind Text <FocusOut> { - %W tag configure sel -borderwidth 1 - %W configure -selectbackground white -selectforeground black -} -bind Text <Option-Left> { - tk::TextSetCursor %W [tk::TextPrevPos %W insert tcl_startOfPreviousWord] -} -bind Text <Option-Right> { - tk::TextSetCursor %W [tk::TextNextWord %W insert] -} -bind Text <Option-Up> { - tk::TextSetCursor %W [tk::TextPrevPara %W insert] -} -bind Text <Option-Down> { - tk::TextSetCursor %W [tk::TextNextPara %W insert] -} -bind Text <Shift-Option-Left> { - tk::TextKeySelect %W [tk::TextPrevPos %W insert tcl_startOfPreviousWord] -} -bind Text <Shift-Option-Right> { - tk::TextKeySelect %W [tk::TextNextWord %W insert] -} -bind Text <Shift-Option-Up> { - tk::TextKeySelect %W [tk::TextPrevPara %W insert] -} -bind Text <Shift-Option-Down> { - tk::TextKeySelect %W [tk::TextNextPara %W insert] -} - -# End of Mac only bindings -} - -# A few additional bindings of my own. - -bind Text <Control-h> { - if {!$tk_strictMotif} { - if {[%W compare insert != 1.0]} { - %W delete insert-1c - %W see insert - } - } -} -bind Text <2> { - if {!$tk_strictMotif} { - tk::TextScanMark %W %x %y - } -} -bind Text <B2-Motion> { - if {!$tk_strictMotif} { - tk::TextScanDrag %W %x %y - } -} -set ::tk::Priv(prevPos) {} - -# The MouseWheel will typically only fire on Windows. However, -# someone could use the "event generate" command to produce one -# on other platforms. - -bind Text <MouseWheel> { - %W yview scroll [expr {- (%D / 120) * 4}] units -} - -if {[string equal "x11" [tk windowingsystem]]} { - # Support for mousewheels on Linux/Unix commonly comes through mapping - # the wheel to the extended buttons. If you have a mousewheel, find - # Linux configuration info at: - # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ - bind Text <4> { - if {!$tk_strictMotif} { - %W yview scroll -5 units - } - } - bind Text <5> { - if {!$tk_strictMotif} { - %W yview scroll 5 units - } - } -} - -# ::tk::TextClosestGap -- -# 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. -# -# Arguments: -# w - The text window. -# x - X-coordinate within the window. -# y - Y-coordinate within the window. - -proc ::tk::TextClosestGap {w x y} { - set pos [$w index @$x,$y] - set bbox [$w bbox $pos] - if {[string equal $bbox ""]} { - return $pos - } - if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} { - return $pos - } - $w index "$pos + 1 char" -} - -# ::tk::TextButton1 -- -# This procedure is invoked to handle button-1 presses in text -# widgets. It moves the insertion cursor, sets the selection anchor, -# and claims the input focus. -# -# Arguments: -# w - The text window in which the button was pressed. -# x - The x-coordinate of the button press. -# y - The x-coordinate of the button press. - -proc ::tk::TextButton1 {w x y} { - variable ::tk::Priv - - set Priv(selectMode) char - set Priv(mouseMoved) 0 - set Priv(pressX) $x - $w mark set insert [TextClosestGap $w $x $y] - $w mark set anchor insert - # Allow focus in any case on Windows, because that will let the - # selection be displayed even for state disabled text widgets. - if {[string equal $::tcl_platform(platform) "windows"] \ - || [string equal [$w cget -state] "normal"]} {focus $w} - if {[$w cget -autoseparators]} {$w edit separator} -} - -# ::tk::TextSelectTo -- -# This procedure is invoked to extend the selection, typically when -# dragging it with the mouse. Depending on the selection mode (character, -# word, line) it selects in different-sized units. This procedure -# ignores mouse motions initially until the mouse has moved from -# one character to another or until there have been multiple clicks. -# -# Arguments: -# w - The text window in which the button was pressed. -# x - Mouse x position. -# y - Mouse y position. - -proc ::tk::TextSelectTo {w x y {extend 0}} { - global tcl_platform - variable ::tk::Priv - - set cur [TextClosestGap $w $x $y] - if {[catch {$w index anchor}]} { - $w mark set anchor $cur - } - set anchor [$w index anchor] - if {[$w compare $cur != $anchor] || (abs($Priv(pressX) - $x) >= 3)} { - set Priv(mouseMoved) 1 - } - switch $Priv(selectMode) { - char { - if {[$w compare $cur < anchor]} { - set first $cur - set last anchor - } else { - set first anchor - set last $cur - } - } - word { - if {[$w compare $cur < anchor]} { - set first [TextPrevPos $w "$cur + 1c" tcl_wordBreakBefore] - if { !$extend } { - set last [TextNextPos $w "anchor" tcl_wordBreakAfter] - } else { - set last anchor - } - } else { - set last [TextNextPos $w "$cur - 1c" tcl_wordBreakAfter] - if { !$extend } { - set first [TextPrevPos $w anchor tcl_wordBreakBefore] - } else { - set first anchor - } - } - } - line { - if {[$w compare $cur < anchor]} { - set first [$w index "$cur linestart"] - set last [$w index "anchor - 1c lineend + 1c"] - } else { - set first [$w index "anchor linestart"] - set last [$w index "$cur lineend + 1c"] - } - } - } - if {$Priv(mouseMoved) || [string compare $Priv(selectMode) "char"]} { - $w tag remove sel 0.0 end - $w mark set insert $cur - $w tag add sel $first $last - $w tag remove sel $last end - update idletasks - } -} - -# ::tk::TextKeyExtend -- -# This procedure handles extending the selection from the keyboard, -# where the point to extend to is really the boundary between two -# characters rather than a particular character. -# -# Arguments: -# w - The text window. -# index - The point to which the selection is to be extended. - -proc ::tk::TextKeyExtend {w index} { - - set cur [$w index $index] - if {[catch {$w index anchor}]} { - $w mark set anchor $cur - } - set anchor [$w index anchor] - if {[$w compare $cur < anchor]} { - set first $cur - set last anchor - } else { - set first anchor - set last $cur - } - $w tag remove sel 0.0 $first - $w tag add sel $first $last - $w tag remove sel $last end -} - -# ::tk::TextPasteSelection -- -# This procedure sets the insertion cursor to the mouse position, -# inserts the selection, and sets the focus to the window. -# -# Arguments: -# w - The text window. -# x, y - Position of the mouse. - -proc ::tk::TextPasteSelection {w x y} { - $w mark set insert [TextClosestGap $w $x $y] - if {![catch {::tk::GetSelection $w PRIMARY} sel]} { - set oldSeparator [$w cget -autoseparators] - if {$oldSeparator} { - $w configure -autoseparators 0 - $w edit separator - } - $w insert insert $sel - if {$oldSeparator} { - $w edit separator - $w configure -autoseparators 1 - } - } - if {[string equal [$w cget -state] "normal"]} {focus $w} -} - -# ::tk::TextAutoScan -- -# This procedure is invoked when the mouse leaves a text window -# with button 1 down. It scrolls the window up, down, left, or right, -# depending on where the mouse is (this information was saved in -# ::tk::Priv(x) and ::tk::Priv(y)), and reschedules itself as an "after" -# command so that the window continues to scroll until the mouse -# moves back into the window or the mouse button is released. -# -# Arguments: -# w - The text window. - -proc ::tk::TextAutoScan {w} { - variable ::tk::Priv - if {![winfo exists $w]} return - if {$Priv(y) >= [winfo height $w]} { - $w yview scroll 2 units - } elseif {$Priv(y) < 0} { - $w yview scroll -2 units - } elseif {$Priv(x) >= [winfo width $w]} { - $w xview scroll 2 units - } elseif {$Priv(x) < 0} { - $w xview scroll -2 units - } else { - return - } - TextSelectTo $w $Priv(x) $Priv(y) - set Priv(afterId) [after 50 [list tk::TextAutoScan $w]] -} - -# ::tk::TextSetCursor -# Move the insertion cursor to a given position in a text. Also -# clears the selection, if there is one in the text, and makes sure -# that the insertion cursor is visible. Also, don't let the insertion -# cursor appear on the dummy last line of the text. -# -# Arguments: -# w - The text window. -# pos - The desired new position for the cursor in the window. - -proc ::tk::TextSetCursor {w pos} { - - if {[$w compare $pos == end]} { - set pos {end - 1 chars} - } - $w mark set insert $pos - $w tag remove sel 1.0 end - $w see insert - if {[$w cget -autoseparators]} {$w edit separator} -} - -# ::tk::TextKeySelect -# This procedure is invoked when stroking out selections using the -# keyboard. It moves the cursor to a new position, then extends -# the selection to that position. -# -# Arguments: -# w - The text window. -# new - A new position for the insertion cursor (the cursor hasn't -# actually been moved to this position yet). - -proc ::tk::TextKeySelect {w new} { - - if {[string equal [$w tag nextrange sel 1.0 end] ""]} { - if {[$w compare $new < insert]} { - $w tag add sel $new insert - } else { - $w tag add sel insert $new - } - $w mark set anchor insert - } else { - if {[$w compare $new < anchor]} { - set first $new - set last anchor - } else { - set first anchor - set last $new - } - $w tag remove sel 1.0 $first - $w tag add sel $first $last - $w tag remove sel $last end - } - $w mark set insert $new - $w see insert - update idletasks -} - -# ::tk::TextResetAnchor -- -# Set the selection anchor to whichever end is farthest from the -# index argument. One special trick: if the selection has two or -# fewer characters, just leave the anchor where it is. In this -# case it doesn't matter which point gets chosen for the anchor, -# and for the things like Shift-Left and Shift-Right this produces -# better behavior when the cursor moves back and forth across the -# anchor. -# -# Arguments: -# w - The text widget. -# index - Position at which mouse button was pressed, which determines -# which end of selection should be used as anchor point. - -proc ::tk::TextResetAnchor {w index} { - - if {[string equal [$w tag ranges sel] ""]} { - # Don't move the anchor if there is no selection now; this makes - # the widget behave "correctly" when the user clicks once, then - # shift-clicks somewhere -- ie, the area between the two clicks will be - # selected. [Bug: 5929]. - return - } - set a [$w index $index] - set b [$w index sel.first] - set c [$w index sel.last] - if {[$w compare $a < $b]} { - $w mark set anchor sel.last - return - } - if {[$w compare $a > $c]} { - $w mark set anchor sel.first - return - } - scan $a "%d.%d" lineA chA - scan $b "%d.%d" lineB chB - scan $c "%d.%d" lineC chC - if {$lineB < $lineC+2} { - set total [string length [$w get $b $c]] - if {$total <= 2} { - return - } - if {[string length [$w get $b $a]] < ($total/2)} { - $w mark set anchor sel.last - } else { - $w mark set anchor sel.first - } - return - } - if {($lineA-$lineB) < ($lineC-$lineA)} { - $w mark set anchor sel.last - } else { - $w mark set anchor sel.first - } -} - -# ::tk::TextInsert -- -# Insert a string into a text at the point of the insertion cursor. -# If there is a selection in the text, and it covers the point of the -# insertion cursor, then delete the selection before inserting. -# -# Arguments: -# w - The text window in which to insert the string -# s - The string to insert (usually just a single character) - -proc ::tk::TextInsert {w s} { - if {[string equal $s ""] || [string equal [$w cget -state] "disabled"]} { - return - } - set compound 0 - catch { - if {[$w compare sel.first <= insert] \ - && [$w compare sel.last >= insert]} { - set oldSeparator [$w cget -autoseparators] - if { $oldSeparator } { - $w configure -autoseparators 0 - $w edit separator - set compound 1 - } - $w delete sel.first sel.last - } - } - $w insert insert $s - $w see insert - if { $compound && $oldSeparator } { - $w edit separator - $w configure -autoseparators 1 - } -} - -# ::tk::TextUpDownLine -- -# Returns the index of the character one line above or below the -# insertion cursor. There are two tricky things here. First, -# we want to maintain the original column across repeated operations, -# even though some lines that will get passed through don't have -# enough characters to cover the original column. Second, don't -# try to scroll past the beginning or end of the text. -# -# Arguments: -# w - The text window in which the cursor is to move. -# n - The number of lines to move: -1 for up one line, -# +1 for down one line. - -proc ::tk::TextUpDownLine {w n} { - variable ::tk::Priv - - set i [$w index insert] - scan $i "%d.%d" line char - if {[string compare $Priv(prevPos) $i]} { - set Priv(char) $char - } - set new [$w index [expr {$line + $n}].$Priv(char)] - if {[$w compare $new == end] || [$w compare $new == "insert linestart"]} { - set new $i - } - set Priv(prevPos) $new - return $new -} - -# ::tk::TextPrevPara -- -# Returns the index of the beginning of the paragraph just before a given -# position in the text (the beginning of a paragraph is the first non-blank -# character after a blank line). -# -# Arguments: -# w - The text window in which the cursor is to move. -# pos - Position at which to start search. - -proc ::tk::TextPrevPara {w pos} { - set pos [$w index "$pos linestart"] - while {1} { - if {([string equal [$w get "$pos - 1 line"] "\n"] \ - && [string compare [$w get $pos] "\n"]) \ - || [string equal $pos "1.0"]} { - if {[regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ - dummy index]} { - set pos [$w index "$pos + [lindex $index 0] chars"] - } - if {[$w compare $pos != insert] || [string equal $pos 1.0]} { - return $pos - } - } - set pos [$w index "$pos - 1 line"] - } -} - -# ::tk::TextNextPara -- -# Returns the index of the beginning of the paragraph just after a given -# position in the text (the beginning of a paragraph is the first non-blank -# character after a blank line). -# -# Arguments: -# w - The text window in which the cursor is to move. -# start - Position at which to start search. - -proc ::tk::TextNextPara {w start} { - set pos [$w index "$start linestart + 1 line"] - while {[string compare [$w get $pos] "\n"]} { - if {[$w compare $pos == end]} { - return [$w index "end - 1c"] - } - set pos [$w index "$pos + 1 line"] - } - while {[string equal [$w get $pos] "\n"]} { - set pos [$w index "$pos + 1 line"] - if {[$w compare $pos == end]} { - return [$w index "end - 1c"] - } - } - if {[regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ - dummy index]} { - return [$w index "$pos + [lindex $index 0] chars"] - } - return $pos -} - -# ::tk::TextScrollPages -- -# This is a utility procedure used in bindings for moving up and down -# pages and possibly extending the selection along the way. It scrolls -# the view in the widget by the number of pages, and it returns the -# index of the character that is at the same position in the new view -# as the insertion cursor used to be in the old view. -# -# Arguments: -# w - The text window in which the cursor is to move. -# count - Number of pages forward to scroll; may be negative -# to scroll backwards. - -proc ::tk::TextScrollPages {w count} { - set bbox [$w bbox insert] - $w yview scroll $count pages - if {[string equal $bbox ""]} { - return [$w index @[expr {[winfo height $w]/2}],0] - } - return [$w index @[lindex $bbox 0],[lindex $bbox 1]] -} - -# ::tk::TextTranspose -- -# This procedure implements the "transpose" function for text widgets. -# It tranposes the characters on either side of the insertion cursor, -# unless the cursor is at the end of the line. In this case it -# transposes the two characters to the left of the cursor. In either -# case, the cursor ends up to the right of the transposed characters. -# -# Arguments: -# w - Text window in which to transpose. - -proc ::tk::TextTranspose w { - set pos insert - if {[$w compare $pos != "$pos lineend"]} { - set pos [$w index "$pos + 1 char"] - } - set new [$w get "$pos - 1 char"][$w get "$pos - 2 char"] - if {[$w compare "$pos - 1 char" == 1.0]} { - return - } - $w delete "$pos - 2 char" $pos - $w insert insert $new - $w see insert -} - -# ::tk_textCopy -- -# This procedure copies the selection from a text widget into the -# clipboard. -# -# Arguments: -# w - Name of a text widget. - -proc ::tk_textCopy w { - if {![catch {set data [$w get sel.first sel.last]}]} { - clipboard clear -displayof $w - clipboard append -displayof $w $data - } -} - -# ::tk_textCut -- -# This procedure copies the selection from a text widget into the -# clipboard, then deletes the selection (if it exists in the given -# widget). -# -# Arguments: -# w - Name of a text widget. - -proc ::tk_textCut w { - if {![catch {set data [$w get sel.first sel.last]}]} { - clipboard clear -displayof $w - clipboard append -displayof $w $data - $w delete sel.first sel.last - } -} - -# ::tk_textPaste -- -# This procedure pastes the contents of the clipboard to the insertion -# point in a text widget. -# -# Arguments: -# w - Name of a text widget. - -proc ::tk_textPaste w { - global tcl_platform - if {![catch {::tk::GetSelection $w CLIPBOARD} sel]} { - set oldSeparator [$w cget -autoseparators] - if { $oldSeparator } { - $w configure -autoseparators 0 - $w edit separator - } - if {[string compare [tk windowingsystem] "x11"]} { - catch { $w delete sel.first sel.last } - } - $w insert insert $sel - if { $oldSeparator } { - $w edit separator - $w configure -autoseparators 1 - } - } -} - -# ::tk::TextNextWord -- -# Returns the index of the next word position after a given position in the -# text. 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 -# end-of-word position. -# -# Arguments: -# w - The text window in which the cursor is to move. -# start - Position at which to start search. - -if {[string equal $tcl_platform(platform) "windows"]} { - proc ::tk::TextNextWord {w start} { - TextNextPos $w [TextNextPos $w $start tcl_endOfWord] \ - tcl_startOfNextWord - } -} else { - proc ::tk::TextNextWord {w start} { - TextNextPos $w $start tcl_endOfWord - } -} - -# ::tk::TextNextPos -- -# Returns the index of the next position after the given starting -# position in the text as computed by a specified function. -# -# Arguments: -# w - The text window in which the cursor is to move. -# start - Position at which to start search. -# op - Function to use to find next position. - -proc ::tk::TextNextPos {w start op} { - set text "" - set cur $start - while {[$w compare $cur < end]} { - set text $text[$w get $cur "$cur lineend + 1c"] - set pos [$op $text 0] - if {$pos >= 0} { - ## Adjust for embedded windows and images - ## dump gives us 3 items per window/image - set dump [$w dump -image -window $start "$start + $pos c"] - if {[llength $dump]} { - set pos [expr {$pos + ([llength $dump]/3)}] - } - return [$w index "$start + $pos c"] - } - set cur [$w index "$cur lineend +1c"] - } - return end -} - -# ::tk::TextPrevPos -- -# Returns the index of the previous position before the given starting -# position in the text as computed by a specified function. -# -# Arguments: -# w - The text window in which the cursor is to move. -# start - Position at which to start search. -# op - Function to use to find next position. - -proc ::tk::TextPrevPos {w start op} { - set text "" - set cur $start - while {[$w compare $cur > 0.0]} { - set text [$w get "$cur linestart - 1c" $cur]$text - set pos [$op $text end] - if {$pos >= 0} { - ## Adjust for embedded windows and images - ## dump gives us 3 items per window/image - set dump [$w dump -image -window "$cur linestart" "$start - 1c"] - if {[llength $dump]} { - ## This is a hokey extra hack for control-arrow movement - ## that should be in a while loop to be correct (hobbs) - if {[$w compare [lindex $dump 2] > \ - "$cur linestart - 1c + $pos c"]} { - incr pos -1 - } - set pos [expr {$pos + ([llength $dump]/3)}] - } - return [$w index "$cur linestart - 1c + $pos c"] - } - set cur [$w index "$cur linestart - 1c"] - } - return 0.0 -} - -# ::tk::TextScanMark -- -# -# Marks the start of a possible scan drag operation -# -# Arguments: -# w - The text window from which the text to get -# x - x location on screen -# y - y location on screen - -proc ::tk::TextScanMark {w x y} { - $w scan mark $x $y - set ::tk::Priv(x) $x - set ::tk::Priv(y) $y - set ::tk::Priv(mouseMoved) 0 -} - -# ::tk::TextScanDrag -- -# -# Marks the start of a possible scan drag operation -# -# Arguments: -# w - The text window from which the text to get -# x - x location on screen -# y - y location on screen - -proc ::tk::TextScanDrag {w x y} { - # Make sure these exist, as some weird situations can trigger the - # motion binding without the initial press. [Bug #220269] - if {![info exists ::tk::Priv(x)]} { set ::tk::Priv(x) $x } - if {![info exists ::tk::Priv(y)]} { set ::tk::Priv(y) $y } - if {($x != $::tk::Priv(x)) || ($y != $::tk::Priv(y))} { - set ::tk::Priv(mouseMoved) 1 - } - if {[info exists ::tk::Priv(mouseMoved)] && $::tk::Priv(mouseMoved)} { - $w scan dragto $x $y - } -} diff --git a/tcl/library/tk.tcl b/tcl/library/tk.tcl deleted file mode 100644 index add0cd50878..00000000000 --- a/tcl/library/tk.tcl +++ /dev/null @@ -1,580 +0,0 @@ -# tk.tcl -- -# -# Initialization script normally executed in the interpreter for each -# Tk-based application. Arranges class bindings for widgets. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -# Insist on running with compatible versions of Tcl and Tk. -package require -exact Tk 8.4 -package require -exact Tcl 8.4 - -# Create a ::tk namespace -namespace eval ::tk { - # Set up the msgcat commands - namespace eval msgcat { - namespace export mc mcmax - if {[interp issafe] || [catch {package require msgcat}]} { - # The msgcat package is not available. Supply our own - # minimal replacement. - proc mc {src args} { - return [eval [list format $src] $args] - } - proc mcmax {args} { - set max 0 - foreach string $args { - set len [string length $string] - if {$len>$max} { - set max $len - } - } - return $max - } - } else { - # Get the commands from the msgcat package that Tk uses. - namespace import ::msgcat::mc - namespace import ::msgcat::mcmax - ::msgcat::mcload [file join $::tk_library msgs] - } - } - namespace import ::tk::msgcat::* -} - -# Add Tk's directory to the end of the auto-load search path, if it -# isn't already on the path: - -if {[info exists ::auto_path] && [string compare {} $::tk_library] && \ - [lsearch -exact $::auto_path $::tk_library] < 0} { - lappend ::auto_path $::tk_library -} - -# Turn off strict Motif look and feel as a default. - -set ::tk_strictMotif 0 - -# Turn on useinputmethods (X Input Methods) by default. -# We catch this because safe interpreters may not allow the call. - -catch {tk useinputmethods 1} - -# ::tk::PlaceWindow -- -# place a toplevel at a particular position -# Arguments: -# toplevel name of toplevel window -# ?placement? pointer ?center? ; places $w centered on the pointer -# widget widgetPath ; centers $w over widget_name -# defaults to placing toplevel in the middle of the screen -# ?anchor? center or widgetPath -# Results: -# Returns nothing -# -proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { - wm withdraw $w - update idletasks - set checkBounds 1 - if {[string equal -len [string length $place] $place "pointer"]} { - ## place at POINTER (centered if $anchor == center) - if {[string equal -len [string length $anchor] $anchor "center"]} { - set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}] - set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}] - } else { - set x [winfo pointerx $w] - set y [winfo pointery $w] - } - } elseif {[string equal -len [string length $place] $place "widget"] && \ - [winfo exists $anchor] && [winfo ismapped $anchor]} { - ## center about WIDGET $anchor, widget must be mapped - set x [expr {[winfo rootx $anchor] + \ - ([winfo width $anchor]-[winfo reqwidth $w])/2}] - set y [expr {[winfo rooty $anchor] + \ - ([winfo height $anchor]-[winfo reqheight $w])/2}] - } else { - set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] - set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] - set checkBounds 0 - } - if {$checkBounds} { - if {$x < 0} { - set x 0 - } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} { - set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}] - } - if {$y < 0} { - set y 0 - } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} { - set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}] - } - if {[tk windowingsystem] eq "macintosh" \ - || [tk windowingsystem] eq "aqua"} { - # Avoid the native menu bar which sits on top of everything. - if {$y < 20} { set y 20 } - } - } - wm geometry $w +$x+$y - wm deiconify $w -} - -# ::tk::SetFocusGrab -- -# swap out current focus and grab temporarily (for dialogs) -# Arguments: -# grab new window to grab -# focus window to give focus to -# Results: -# Returns nothing -# -proc ::tk::SetFocusGrab {grab {focus {}}} { - set index "$grab,$focus" - upvar ::tk::FocusGrab($index) data - - lappend data [focus] - set oldGrab [grab current $grab] - lappend data $oldGrab - if {[winfo exists $oldGrab]} { - lappend data [grab status $oldGrab] - } - # The "grab" command will fail if another application - # already holds the grab. So catch it. - catch {grab $grab} - if {[winfo exists $focus]} { - focus $focus - } -} - -# ::tk::RestoreFocusGrab -- -# restore old focus and grab (for dialogs) -# Arguments: -# grab window that had taken grab -# focus window that had taken focus -# destroy destroy|withdraw - how to handle the old grabbed window -# Results: -# Returns nothing -# -proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} { - set index "$grab,$focus" - if {[info exists ::tk::FocusGrab($index)]} { - foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break } - unset ::tk::FocusGrab($index) - } else { - set oldGrab "" - } - - catch {focus $oldFocus} - grab release $grab - if {[string equal $destroy "withdraw"]} { - wm withdraw $grab - } else { - destroy $grab - } - if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} { - if {[string equal $oldStatus "global"]} { - grab -global $oldGrab - } else { - grab $oldGrab - } - } -} - -# ::tk::GetSelection -- -# This tries to obtain the default selection. On Unix, we first try -# and get a UTF8_STRING, a type supported by modern Unix apps for -# passing Unicode data safely. We fall back on the default STRING -# type otherwise. On Windows, only the STRING type is necessary. -# Arguments: -# w The widget for which the selection will be retrieved. -# Important for the -displayof property. -# sel The source of the selection (PRIMARY or CLIPBOARD) -# Results: -# Returns the selection, or an error if none could be found -# -if {[string equal $tcl_platform(platform) "unix"]} { - proc ::tk::GetSelection {w {sel PRIMARY}} { - if {[catch {selection get -displayof $w -selection $sel \ - -type UTF8_STRING} txt] \ - && [catch {selection get -displayof $w -selection $sel} txt]} { - return -code error "could not find default selection" - } else { - return $txt - } - } -} else { - proc ::tk::GetSelection {w {sel PRIMARY}} { - if {[catch {selection get -displayof $w -selection $sel} txt]} { - return -code error "could not find default selection" - } else { - return $txt - } - } -} - -# ::tk::ScreenChanged -- -# This procedure is invoked by the binding mechanism whenever the -# "current" screen is changing. The procedure does two things. -# First, it uses "upvar" to make variable "::tk::Priv" point at an -# array variable that holds state for the current display. Second, -# it initializes the array if it didn't already exist. -# -# Arguments: -# screen - The name of the new screen. - -proc ::tk::ScreenChanged screen { - set x [string last . $screen] - if {$x > 0} { - set disp [string range $screen 0 [expr {$x - 1}]] - } else { - set disp $screen - } - - uplevel #0 upvar #0 ::tk::Priv.$disp ::tk::Priv - variable ::tk::Priv - global tcl_platform - - if {[info exists Priv]} { - set Priv(screen) $screen - return - } - array set Priv { - activeMenu {} - activeItem {} - afterId {} - buttons 0 - buttonWindow {} - dragging 0 - focus {} - grab {} - initPos {} - inMenubutton {} - listboxPrev {} - menuBar {} - mouseMoved 0 - oldGrab {} - popup {} - postedMb {} - pressX 0 - pressY 0 - prevPos 0 - selectMode char - } - set Priv(screen) $screen - set Priv(tearoff) [string equal [tk windowingsystem] "x11"] - set Priv(window) {} -} - -# Do initial setup for Priv, so that it is always bound to something -# (otherwise, if someone references it, it may get set to a non-upvar-ed -# value, which will cause trouble later). - -tk::ScreenChanged [winfo screen .] - -# ::tk::EventMotifBindings -- -# This procedure is invoked as a trace whenever ::tk_strictMotif is -# changed. It is used to turn on or turn off the motif virtual -# bindings. -# -# Arguments: -# n1 - the name of the variable being changed ("::tk_strictMotif"). - -proc ::tk::EventMotifBindings {n1 dummy dummy} { - upvar $n1 name - - if {$name} { - set op delete - } else { - set op add - } - - event $op <<Cut>> <Control-Key-w> - event $op <<Copy>> <Meta-Key-w> - event $op <<Paste>> <Control-Key-y> - event $op <<Undo>> <Control-underscore> -} - -#---------------------------------------------------------------------- -# Define common dialogs on platforms where they are not implemented -# using compiled code. -#---------------------------------------------------------------------- - -if {[string equal [info commands tk_chooseColor] ""]} { - proc ::tk_chooseColor {args} { - return [eval tk::dialog::color:: $args] - } -} -if {[string equal [info commands tk_getOpenFile] ""]} { - proc ::tk_getOpenFile {args} { - if {$::tk_strictMotif} { - return [eval tk::MotifFDialog open $args] - } else { - return [eval ::tk::dialog::file:: open $args] - } - } -} -if {[string equal [info commands tk_getSaveFile] ""]} { - proc ::tk_getSaveFile {args} { - if {$::tk_strictMotif} { - return [eval tk::MotifFDialog save $args] - } else { - return [eval ::tk::dialog::file:: save $args] - } - } -} -if {[string equal [info commands tk_messageBox] ""]} { - proc ::tk_messageBox {args} { - return [eval tk::MessageBox $args] - } -} -if {[string equal [info command tk_chooseDirectory] ""]} { - proc ::tk_chooseDirectory {args} { - return [eval ::tk::dialog::file::chooseDir:: $args] - } -} - -#---------------------------------------------------------------------- -# Define the set of common virtual events. -#---------------------------------------------------------------------- - -switch [tk windowingsystem] { - "x11" { - event add <<Cut>> <Control-Key-x> <Key-F20> - event add <<Copy>> <Control-Key-c> <Key-F16> - event add <<Paste>> <Control-Key-v> <Key-F18> - event add <<PasteSelection>> <ButtonRelease-2> - event add <<Undo>> <Control-Key-z> - event add <<Redo>> <Control-Key-Z> - # Some OS's define a goofy (as in, not <Shift-Tab>) keysym - # that is returned when the user presses <Shift-Tab>. In order for - # tab traversal to work, we have to add these keysyms to the - # PrevWindow event. - # The info exists is necessary, because tcl_platform(os) doesn't - # exist in safe interpreters. - if {[info exists tcl_platform(os)]} { - switch $tcl_platform(os) { - "IRIX" - - "Linux" { event add <<PrevWindow>> <ISO_Left_Tab> } - "HP-UX" { - # This seems to be correct on *some* HP systems. - catch { event add <<PrevWindow>> <hpBackTab> } - } - } - } - trace variable ::tk_strictMotif w ::tk::EventMotifBindings - set ::tk_strictMotif $::tk_strictMotif - } - "win32" { - event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> - event add <<Copy>> <Control-Key-c> <Control-Key-Insert> - event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> - event add <<PasteSelection>> <ButtonRelease-2> - event add <<Undo>> <Control-Key-z> - event add <<Redo>> <Control-Key-y> - } - "aqua" { - event add <<Cut>> <Command-Key-x> <Key-F2> - event add <<Copy>> <Command-Key-c> <Key-F3> - event add <<Paste>> <Command-Key-v> <Key-F4> - event add <<PasteSelection>> <ButtonRelease-2> - event add <<Clear>> <Clear> - event add <<Undo>> <Command-Key-z> - event add <<Redo>> <Command-Key-y> - } - "classic" { - event add <<Cut>> <Control-Key-x> <Key-F2> - event add <<Copy>> <Control-Key-c> <Key-F3> - event add <<Paste>> <Control-Key-v> <Key-F4> - event add <<PasteSelection>> <ButtonRelease-2> - event add <<Clear>> <Clear> - event add <<Undo>> <Control-Key-z> <Key-F1> - event add <<Redo>> <Control-Key-Z> - } -} -# ---------------------------------------------------------------------- -# Read in files that define all of the class bindings. -# ---------------------------------------------------------------------- - -if {$::tk_library ne ""} { - if {[string equal $tcl_platform(platform) "macintosh"]} { - proc ::tk::SourceLibFile {file} { - if {[catch { - namespace eval :: \ - [list source [file join $::tk_library $file.tcl]] - }]} { - namespace eval :: [list source -rsrc $file] - } - } - } else { - proc ::tk::SourceLibFile {file} { - namespace eval :: [list source [file join $::tk_library $file.tcl]] - } - } - namespace eval ::tk { - SourceLibFile button - SourceLibFile entry - SourceLibFile listbox - SourceLibFile menu - SourceLibFile panedwindow - SourceLibFile scale - SourceLibFile scrlbar - SourceLibFile spinbox - SourceLibFile text - } -} -# ---------------------------------------------------------------------- -# Default bindings for keyboard traversal. -# ---------------------------------------------------------------------- - -event add <<PrevWindow>> <Shift-Tab> -bind all <Tab> {tk::TabToWindow [tk_focusNext %W]} -bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]} - -# ::tk::CancelRepeat -- -# This procedure is invoked to cancel an auto-repeat action described -# by ::tk::Priv(afterId). It's used by several widgets to auto-scroll -# the widget when the mouse is dragged out of the widget with a -# button pressed. -# -# Arguments: -# None. - -proc ::tk::CancelRepeat {} { - variable ::tk::Priv - after cancel $Priv(afterId) - set Priv(afterId) {} -} - -# ::tk::TabToWindow -- -# This procedure moves the focus to the given widget. If the widget -# is an entry, it selects the entire contents of the widget. -# -# Arguments: -# w - Window to which focus should be set. - -proc ::tk::TabToWindow {w} { - if {[string equal [winfo class $w] Entry]} { - $w selection range 0 end - $w icursor end - } - focus $w -} - -# ::tk::UnderlineAmpersand -- -# This procedure takes some text with ampersand and returns -# text w/o ampersand and position of the ampersand. -# Double ampersands are converted to single ones. -# Position returned is -1 when there is no ampersand. -# -proc ::tk::UnderlineAmpersand {text} { - set idx [string first "&" $text] - if {$idx >= 0} { - set underline $idx - # ignore "&&" - while {[string match "&" [string index $text [expr {$idx + 1}]]]} { - set base [expr {$idx + 2}] - set idx [string first "&" [string range $text $base end]] - if {$idx < 0} { - break - } else { - set underline [expr {$underline + $idx + 1}] - incr idx $base - } - } - } - if {$idx >= 0} { - regsub -all -- {&([^&])} $text {\1} text - } - return [list $text $idx] -} - -# ::tk::SetAmpText -- -# Given widget path and text with "magic ampersands", -# sets -text and -underline options for the widget -# -proc ::tk::SetAmpText {widget text} { - foreach {newtext under} [::tk::UnderlineAmpersand $text] { - $widget configure -text $newtext -underline $under - } -} - -# ::tk::AmpWidget -- -# Creates new widget, turning -text option into -text and -# -underline options, returned by ::tk::UnderlineAmpersand. -# -proc ::tk::AmpWidget {class path args} { - set wcmd [list $class $path] - foreach {opt val} $args { - if {[string equal $opt {-text}]} { - foreach {newtext under} [::tk::UnderlineAmpersand $val] { - lappend wcmd -text $newtext -underline $under - } - } else { - lappend wcmd $opt $val - } - } - eval $wcmd - if {$class=="button"} { - bind $path <<AltUnderlined>> [list $path invoke] - } - return $path -} - -# ::tk::FindAltKeyTarget -- -# search recursively through the hierarchy of visible widgets -# to find button or label which has $char as underlined character -# -proc ::tk::FindAltKeyTarget {path char} { - switch [winfo class $path] { - Button - - Label { - if {[string equal -nocase $char \ - [string index [$path cget -text] \ - [$path cget -underline]]]} {return $path} else {return {}} - } - default { - foreach child \ - [concat [grid slaves $path] \ - [pack slaves $path] \ - [place slaves $path] ] { - if {""!=[set target [::tk::FindAltKeyTarget $child $char]]} { - return $target - } - } - } - } - return {} -} - -# ::tk::AltKeyInDialog -- -# <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>> -# to button or label which has appropriate underlined character -# -proc ::tk::AltKeyInDialog {path key} { - set target [::tk::FindAltKeyTarget $path $key] - if { $target == ""} return - event generate $target <<AltUnderlined>> -} - -# ::tk::mcmaxamp -- -# Replacement for mcmax, used for texts with "magic ampersand" in it. -# - -proc ::tk::mcmaxamp {args} { - set maxlen 0 - foreach arg $args { - set length [string length [lindex [::tk::UnderlineAmpersand [mc $arg]] 0]] - if {$length>$maxlen} { - set maxlen $length - } - } - return $maxlen -} -# For now, turn off the custom mdef proc for the mac: - -if {[string equal [tk windowingsystem] "aqua"]} { - namespace eval ::tk::mac { - set useCustomMDEF 0 - } -} diff --git a/tcl/library/tkfbox.tcl b/tcl/library/tkfbox.tcl deleted file mode 100644 index 256447abfb2..00000000000 --- a/tcl/library/tkfbox.tcl +++ /dev/null @@ -1,1803 +0,0 @@ -# tkfbox.tcl -- -# -# Implements the "TK" standard file selection dialog box. This -# dialog box is used on the Unix platforms whenever the tk_strictMotif -# flag is not set. -# -# The "TK" standard file selection dialog box is similar to the -# file selection dialog box on Win95(TM). The user can navigate -# the directories by clicking on the folder icons or by -# selecting the "Directory" option menu. The user can select -# files by clicking on the file icons or by entering a filename -# in the "Filename:" entry. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1994-1998 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -#---------------------------------------------------------------------- -# -# I C O N L I S T -# -# This is a pseudo-widget that implements the icon list inside the -# ::tk::dialog::file:: dialog box. -# -#---------------------------------------------------------------------- - -# ::tk::IconList -- -# -# Creates an IconList widget. -# -proc ::tk::IconList {w args} { - IconList_Config $w $args - IconList_Create $w -} - -proc ::tk::IconList_Index {w i} { - upvar #0 ::tk::$w data - upvar #0 ::tk::$w:itemList itemList - if {![info exists data(list)]} {set data(list) {}} - switch -regexp -- $i { - "^-?[0-9]+$" { - if { $i < 0 } { - set i 0 - } - if { $i >= [llength $data(list)] } { - set i [expr {[llength $data(list)] - 1}] - } - return $i - } - "^active$" { - return $data(index,active) - } - "^anchor$" { - return $data(index,anchor) - } - "^end$" { - return [llength $data(list)] - } - "@-?[0-9]+,-?[0-9]+" { - foreach {x y} [scan $i "@%d,%d"] { - break - } - set item [$data(canvas) find closest $x $y] - return [lindex [$data(canvas) itemcget $item -tags] 1] - } - } -} - -proc ::tk::IconList_Selection {w op args} { - upvar ::tk::$w data - switch -exact -- $op { - "anchor" { - if { [llength $args] == 1 } { - set data(index,anchor) [tk::IconList_Index $w [lindex $args 0]] - } else { - return $data(index,anchor) - } - } - "clear" { - if { [llength $args] == 2 } { - foreach {first last} $args { - break - } - } elseif { [llength $args] == 1 } { - set first [set last [lindex $args 0]] - } else { - error "wrong # args: should be [lindex [info level 0] 0] path\ - clear first ?last?" - } - set first [IconList_Index $w $first] - set last [IconList_Index $w $last] - if { $first > $last } { - set tmp $first - set first $last - set last $tmp - } - set ind 0 - foreach item $data(selection) { - if { $item >= $first } { - set first $ind - break - } - } - set ind [expr {[llength $data(selection)] - 1}] - for {} {$ind >= 0} {incr ind -1} { - set item [lindex $data(selection) $ind] - if { $item <= $last } { - set last $ind - break - } - } - - if { $first > $last } { - return - } - set data(selection) [lreplace $data(selection) $first $last] - event generate $w <<ListboxSelect>> - IconList_DrawSelection $w - } - "includes" { - set index [lsearch -exact $data(selection) [lindex $args 0]] - return [expr {$index != -1}] - } - "set" { - if { [llength $args] == 2 } { - foreach {first last} $args { - break - } - } elseif { [llength $args] == 1 } { - set last [set first [lindex $args 0]] - } else { - error "wrong # args: should be [lindex [info level 0] 0] path\ - set first ?last?" - } - - set first [IconList_Index $w $first] - set last [IconList_Index $w $last] - if { $first > $last } { - set tmp $first - set first $last - set last $tmp - } - for {set i $first} {$i <= $last} {incr i} { - lappend data(selection) $i - } - set data(selection) [lsort -integer -unique $data(selection)] - event generate $w <<ListboxSelect>> - IconList_DrawSelection $w - } - } -} - -proc ::tk::IconList_Curselection {w} { - upvar ::tk::$w data - return $data(selection) -} - -proc ::tk::IconList_DrawSelection {w} { - upvar ::tk::$w data - upvar ::tk::$w:itemList itemList - - $data(canvas) delete selection - foreach item $data(selection) { - set rTag [lindex [lindex $data(list) $item] 2] - foreach {iTag tTag text serial} $itemList($rTag) { - break - } - - set bbox [$data(canvas) bbox $tTag] - $data(canvas) create rect $bbox -fill \#a0a0ff -outline \#a0a0ff \ - -tags selection - } - $data(canvas) lower selection - return -} - -proc ::tk::IconList_Get {w item} { - upvar ::tk::$w data - upvar ::tk::$w:itemList itemList - set rTag [lindex [lindex $data(list) $item] 2] - foreach {iTag tTag text serial} $itemList($rTag) { - break - } - return $text -} - -# ::tk::IconList_Config -- -# -# Configure the widget variables of IconList, according to the command -# line arguments. -# -proc ::tk::IconList_Config {w argList} { - - # 1: the configuration specs - # - set specs { - {-command "" "" ""} - {-multiple "" "" "0"} - } - - # 2: parse the arguments - # - tclParseConfigSpec ::tk::$w $specs "" $argList -} - -# ::tk::IconList_Create -- -# -# Creates an IconList widget by assembling a canvas widget and a -# scrollbar widget. Sets all the bindings necessary for the IconList's -# operations. -# -proc ::tk::IconList_Create {w} { - upvar ::tk::$w data - - frame $w - set data(sbar) [scrollbar $w.sbar -orient horizontal \ - -highlightthickness 0 -takefocus 0] - set data(canvas) [canvas $w.canvas -bd 2 -relief sunken \ - -width 400 -height 120 -takefocus 1] - pack $data(sbar) -side bottom -fill x -padx 2 - pack $data(canvas) -expand yes -fill both - - $data(sbar) config -command [list $data(canvas) xview] - $data(canvas) config -xscrollcommand [list $data(sbar) set] - - # Initializes the max icon/text width and height and other variables - # - set data(maxIW) 1 - set data(maxIH) 1 - set data(maxTW) 1 - set data(maxTH) 1 - set data(numItems) 0 - set data(curItem) {} - set data(noScroll) 1 - set data(selection) {} - set data(index,anchor) "" - - # Creates the event bindings. - # - bind $data(canvas) <Configure> [list tk::IconList_Arrange $w] - - bind $data(canvas) <1> [list tk::IconList_Btn1 $w %x %y] - bind $data(canvas) <B1-Motion> [list tk::IconList_Motion1 $w %x %y] - bind $data(canvas) <B1-Leave> [list tk::IconList_Leave1 $w %x %y] - bind $data(canvas) <Control-1> [list tk::IconList_CtrlBtn1 $w %x %y] - bind $data(canvas) <Shift-1> [list tk::IconList_ShiftBtn1 $w %x %y] - bind $data(canvas) <B1-Enter> [list tk::CancelRepeat] - bind $data(canvas) <ButtonRelease-1> [list tk::CancelRepeat] - bind $data(canvas) <Double-ButtonRelease-1> \ - [list tk::IconList_Double1 $w %x %y] - - bind $data(canvas) <Up> [list tk::IconList_UpDown $w -1] - bind $data(canvas) <Down> [list tk::IconList_UpDown $w 1] - bind $data(canvas) <Left> [list tk::IconList_LeftRight $w -1] - bind $data(canvas) <Right> [list tk::IconList_LeftRight $w 1] - bind $data(canvas) <Return> [list tk::IconList_ReturnKey $w] - bind $data(canvas) <KeyPress> [list tk::IconList_KeyPress $w %A] - bind $data(canvas) <Control-KeyPress> ";" - bind $data(canvas) <Alt-KeyPress> ";" - - bind $data(canvas) <FocusIn> [list tk::IconList_FocusIn $w] - bind $data(canvas) <FocusOut> [list tk::IconList_FocusOut $w] - - return $w -} - -# ::tk::IconList_AutoScan -- -# -# This procedure is invoked when the mouse leaves an entry window -# with button 1 down. It scrolls the window up, down, left, or -# right, depending on where the mouse left the window, and reschedules -# itself as an "after" command so that the window continues to scroll until -# the mouse moves back into the window or the mouse button is released. -# -# Arguments: -# w - The IconList window. -# -proc ::tk::IconList_AutoScan {w} { - upvar ::tk::$w data - variable ::tk::Priv - - if {![winfo exists $w]} return - set x $Priv(x) - set y $Priv(y) - - if {$data(noScroll)} { - return - } - if {$x >= [winfo width $data(canvas)]} { - $data(canvas) xview scroll 1 units - } elseif {$x < 0} { - $data(canvas) xview scroll -1 units - } elseif {$y >= [winfo height $data(canvas)]} { - # do nothing - } elseif {$y < 0} { - # do nothing - } else { - return - } - - IconList_Motion1 $w $x $y - set Priv(afterId) [after 50 [list tk::IconList_AutoScan $w]] -} - -# Deletes all the items inside the canvas subwidget and reset the IconList's -# state. -# -proc ::tk::IconList_DeleteAll {w} { - upvar ::tk::$w data - upvar ::tk::$w:itemList itemList - - $data(canvas) delete all - catch {unset data(selected)} - catch {unset data(rect)} - catch {unset data(list)} - catch {unset itemList} - set data(maxIW) 1 - set data(maxIH) 1 - set data(maxTW) 1 - set data(maxTH) 1 - set data(numItems) 0 - set data(curItem) {} - set data(noScroll) 1 - set data(selection) {} - set data(index,anchor) "" - $data(sbar) set 0.0 1.0 - $data(canvas) xview moveto 0 -} - -# Adds an icon into the IconList with the designated image and text -# -proc ::tk::IconList_Add {w image items} { - upvar ::tk::$w data - upvar ::tk::$w:itemList itemList - upvar ::tk::$w:textList textList - - foreach text $items { - set iTag [$data(canvas) create image 0 0 -image $image -anchor nw \ - -tags [list icon $data(numItems) item$data(numItems)]] - set tTag [$data(canvas) create text 0 0 -text $text -anchor nw \ - -font $data(font) \ - -tags [list text $data(numItems) item$data(numItems)]] - set rTag [$data(canvas) create rect 0 0 0 0 -fill "" -outline "" \ - -tags [list rect $data(numItems) item$data(numItems)]] - - foreach {x1 y1 x2 y2} [$data(canvas) bbox $iTag] { - break - } - set iW [expr {$x2 - $x1}] - set iH [expr {$y2 - $y1}] - if {$data(maxIW) < $iW} { - set data(maxIW) $iW - } - if {$data(maxIH) < $iH} { - set data(maxIH) $iH - } - - foreach {x1 y1 x2 y2} [$data(canvas) bbox $tTag] { - break - } - set tW [expr {$x2 - $x1}] - set tH [expr {$y2 - $y1}] - if {$data(maxTW) < $tW} { - set data(maxTW) $tW - } - if {$data(maxTH) < $tH} { - set data(maxTH) $tH - } - - lappend data(list) [list $iTag $tTag $rTag $iW $iH $tW \ - $tH $data(numItems)] - set itemList($rTag) [list $iTag $tTag $text $data(numItems)] - set textList($data(numItems)) [string tolower $text] - incr data(numItems) - } -} - -# Places the icons in a column-major arrangement. -# -proc ::tk::IconList_Arrange {w} { - upvar ::tk::$w data - - if {![info exists data(list)]} { - if {[info exists data(canvas)] && [winfo exists $data(canvas)]} { - set data(noScroll) 1 - $data(sbar) config -command "" - } - return - } - - set W [winfo width $data(canvas)] - set H [winfo height $data(canvas)] - set pad [expr {[$data(canvas) cget -highlightthickness] + \ - [$data(canvas) cget -bd]}] - if {$pad < 2} { - set pad 2 - } - - incr W -[expr {$pad*2}] - incr H -[expr {$pad*2}] - - set dx [expr {$data(maxIW) + $data(maxTW) + 8}] - if {$data(maxTH) > $data(maxIH)} { - set dy $data(maxTH) - } else { - set dy $data(maxIH) - } - incr dy 2 - set shift [expr {$data(maxIW) + 4}] - - set x [expr {$pad * 2}] - set y [expr {$pad * 1}] ; # Why * 1 ? - set usedColumn 0 - foreach sublist $data(list) { - set usedColumn 1 - foreach {iTag tTag rTag iW iH tW tH} $sublist { - break - } - - set i_dy [expr {($dy - $iH)/2}] - set t_dy [expr {($dy - $tH)/2}] - - $data(canvas) coords $iTag $x [expr {$y + $i_dy}] - $data(canvas) coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}] - $data(canvas) coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}] - - incr y $dy - if {($y + $dy) > $H} { - set y [expr {$pad * 1}] ; # *1 ? - incr x $dx - set usedColumn 0 - } - } - - if {$usedColumn} { - set sW [expr {$x + $dx}] - } else { - set sW $x - } - - if {$sW < $W} { - $data(canvas) config -scrollregion [list $pad $pad $sW $H] - $data(sbar) config -command "" - $data(canvas) xview moveto 0 - set data(noScroll) 1 - } else { - $data(canvas) config -scrollregion [list $pad $pad $sW $H] - $data(sbar) config -command [list $data(canvas) xview] - set data(noScroll) 0 - } - - set data(itemsPerColumn) [expr {($H-$pad)/$dy}] - if {$data(itemsPerColumn) < 1} { - set data(itemsPerColumn) 1 - } - - if {$data(curItem) != ""} { - IconList_Select $w [lindex [lindex $data(list) $data(curItem)] 2] 0 - } -} - -# Gets called when the user invokes the IconList (usually by double-clicking -# or pressing the Return key). -# -proc ::tk::IconList_Invoke {w} { - upvar ::tk::$w data - - if {$data(-command) != "" && [llength $data(selection)]} { - uplevel #0 $data(-command) - } -} - -# ::tk::IconList_See -- -# -# If the item is not (completely) visible, scroll the canvas so that -# it becomes visible. -proc ::tk::IconList_See {w rTag} { - upvar ::tk::$w data - upvar ::tk::$w:itemList itemList - - if {$data(noScroll)} { - return - } - set sRegion [$data(canvas) cget -scrollregion] - if {[string equal $sRegion {}]} { - return - } - - if { $rTag < 0 || $rTag >= [llength $data(list)] } { - return - } - - set bbox [$data(canvas) bbox item$rTag] - set pad [expr {[$data(canvas) cget -highlightthickness] + \ - [$data(canvas) cget -bd]}] - - set x1 [lindex $bbox 0] - set x2 [lindex $bbox 2] - incr x1 -[expr {$pad * 2}] - incr x2 -[expr {$pad * 1}] ; # *1 ? - - set cW [expr {[winfo width $data(canvas)] - $pad*2}] - - set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}] - set dispX [expr {int([lindex [$data(canvas) xview] 0]*$scrollW)}] - set oldDispX $dispX - - # check if out of the right edge - # - if {($x2 - $dispX) >= $cW} { - set dispX [expr {$x2 - $cW}] - } - # check if out of the left edge - # - if {($x1 - $dispX) < 0} { - set dispX $x1 - } - - if {$oldDispX != $dispX} { - set fraction [expr {double($dispX)/double($scrollW)}] - $data(canvas) xview moveto $fraction - } -} - -proc ::tk::IconList_Btn1 {w x y} { - upvar ::tk::$w data - - focus $data(canvas) - set x [expr {int([$data(canvas) canvasx $x])}] - set y [expr {int([$data(canvas) canvasy $y])}] - set i [IconList_Index $w @${x},${y}] - if {$i==""} return - IconList_Selection $w clear 0 end - IconList_Selection $w set $i - IconList_Selection $w anchor $i -} - -proc ::tk::IconList_CtrlBtn1 {w x y} { - upvar ::tk::$w data - - if { $data(-multiple) } { - focus $data(canvas) - set x [expr {int([$data(canvas) canvasx $x])}] - set y [expr {int([$data(canvas) canvasy $y])}] - set i [IconList_Index $w @${x},${y}] - if {$i==""} return - if { [IconList_Selection $w includes $i] } { - IconList_Selection $w clear $i - } else { - IconList_Selection $w set $i - IconList_Selection $w anchor $i - } - } -} - -proc ::tk::IconList_ShiftBtn1 {w x y} { - upvar ::tk::$w data - - if { $data(-multiple) } { - focus $data(canvas) - set x [expr {int([$data(canvas) canvasx $x])}] - set y [expr {int([$data(canvas) canvasy $y])}] - set i [IconList_Index $w @${x},${y}] - if {$i==""} return - set a [IconList_Index $w anchor] - if { [string equal $a ""] } { - set a $i - } - IconList_Selection $w clear 0 end - IconList_Selection $w set $a $i - } -} - -# Gets called on button-1 motions -# -proc ::tk::IconList_Motion1 {w x y} { - upvar ::tk::$w data - variable ::tk::Priv - set Priv(x) $x - set Priv(y) $y - set x [expr {int([$data(canvas) canvasx $x])}] - set y [expr {int([$data(canvas) canvasy $y])}] - set i [IconList_Index $w @${x},${y}] - if {$i==""} return - IconList_Selection $w clear 0 end - IconList_Selection $w set $i -} - -proc ::tk::IconList_Double1 {w x y} { - upvar ::tk::$w data - - if {[llength $data(selection)]} { - IconList_Invoke $w - } -} - -proc ::tk::IconList_ReturnKey {w} { - IconList_Invoke $w -} - -proc ::tk::IconList_Leave1 {w x y} { - variable ::tk::Priv - - set Priv(x) $x - set Priv(y) $y - IconList_AutoScan $w -} - -proc ::tk::IconList_FocusIn {w} { - upvar ::tk::$w data - - if {![info exists data(list)]} { - return - } - - if {[llength $data(selection)]} { - IconList_DrawSelection $w - } -} - -proc ::tk::IconList_FocusOut {w} { - IconList_Selection $w clear 0 end -} - -# ::tk::IconList_UpDown -- -# -# Moves the active element up or down by one element -# -# Arguments: -# w - The IconList widget. -# amount - +1 to move down one item, -1 to move back one item. -# -proc ::tk::IconList_UpDown {w amount} { - upvar ::tk::$w data - - if {![info exists data(list)]} { - return - } - - set curr [tk::IconList_Curselection $w] - if { [llength $curr] == 0 } { - set i 0 - } else { - set i [tk::IconList_Index $w anchor] - if {$i==""} return - incr i $amount - } - IconList_Selection $w clear 0 end - IconList_Selection $w set $i - IconList_Selection $w anchor $i - IconList_See $w $i -} - -# ::tk::IconList_LeftRight -- -# -# Moves the active element left or right by one column -# -# Arguments: -# w - The IconList widget. -# amount - +1 to move right one column, -1 to move left one column. -# -proc ::tk::IconList_LeftRight {w amount} { - upvar ::tk::$w data - - if {![info exists data(list)]} { - return - } - - set curr [IconList_Curselection $w] - if { [llength $curr] == 0 } { - set i 0 - } else { - set i [IconList_Index $w anchor] - if {$i==""} return - incr i [expr {$amount*$data(itemsPerColumn)}] - } - IconList_Selection $w clear 0 end - IconList_Selection $w set $i - IconList_Selection $w anchor $i - IconList_See $w $i -} - -#---------------------------------------------------------------------- -# Accelerator key bindings -#---------------------------------------------------------------------- - -# ::tk::IconList_KeyPress -- -# -# Gets called when user enters an arbitrary key in the listbox. -# -proc ::tk::IconList_KeyPress {w key} { - variable ::tk::Priv - - append Priv(ILAccel,$w) $key - IconList_Goto $w $Priv(ILAccel,$w) - catch { - after cancel $Priv(ILAccel,$w,afterId) - } - set Priv(ILAccel,$w,afterId) [after 500 [list tk::IconList_Reset $w]] -} - -proc ::tk::IconList_Goto {w text} { - upvar ::tk::$w data - upvar ::tk::$w:textList textList - - if {![info exists data(list)]} { - return - } - - if {[string equal {} $text]} { - return - } - - if {$data(curItem) == "" || $data(curItem) == 0} { - set start 0 - } else { - set start $data(curItem) - } - - set text [string tolower $text] - set theIndex -1 - set less 0 - set len [string length $text] - set len0 [expr {$len-1}] - set i $start - - # Search forward until we find a filename whose prefix is an exact match - # with $text - while {1} { - set sub [string range $textList($i) 0 $len0] - if {[string equal $text $sub]} { - set theIndex $i - break - } - incr i - if {$i == $data(numItems)} { - set i 0 - } - if {$i == $start} { - break - } - } - - if {$theIndex > -1} { - IconList_Selection $w clear 0 end - IconList_Selection $w set $theIndex - IconList_Selection $w anchor $theIndex - IconList_See $w $theIndex - } -} - -proc ::tk::IconList_Reset {w} { - variable ::tk::Priv - - catch {unset Priv(ILAccel,$w)} -} - -#---------------------------------------------------------------------- -# -# F I L E D I A L O G -# -#---------------------------------------------------------------------- - -namespace eval ::tk::dialog {} -namespace eval ::tk::dialog::file { - namespace import ::tk::msgcat::* -} - -# ::tk::dialog::file:: -- -# -# Implements the TK file selection dialog. This dialog is used when -# the tk_strictMotif flag is set to false. This procedure shouldn't -# be called directly. Call tk_getOpenFile or tk_getSaveFile instead. -# -# Arguments: -# type "open" or "save" -# args Options parsed by the procedure. -# - -proc ::tk::dialog::file:: {type args} { - variable ::tk::Priv - set dataName __tk_filedialog - upvar ::tk::dialog::file::$dataName data - - ::tk::dialog::file::Config $dataName $type $args - - if {[string equal $data(-parent) .]} { - set w .$dataName - } else { - set w $data(-parent).$dataName - } - - # (re)create the dialog box if necessary - # - if {![winfo exists $w]} { - ::tk::dialog::file::Create $w TkFDialog - } elseif {[string compare [winfo class $w] TkFDialog]} { - destroy $w - ::tk::dialog::file::Create $w TkFDialog - } else { - set data(dirMenuBtn) $w.f1.menu - set data(dirMenu) $w.f1.menu.menu - set data(upBtn) $w.f1.up - set data(icons) $w.icons - set data(ent) $w.f2.ent - set data(typeMenuLab) $w.f3.lab - set data(typeMenuBtn) $w.f3.menu - set data(typeMenu) $data(typeMenuBtn).m - set data(okBtn) $w.f2.ok - set data(cancelBtn) $w.f3.cancel - ::tk::dialog::file::SetSelectMode $w $data(-multiple) - } - - # Dialog boxes should be transient with respect to their parent, - # so that they will always stay on top of their parent window. However, - # some window managers will create the window as withdrawn if the parent - # window is withdrawn or iconified. Combined with the grab we put on the - # window, this can hang the entire application. Therefore we only make - # the dialog transient if the parent is viewable. - - if {[winfo viewable [winfo toplevel $data(-parent)]] } { - wm transient $w $data(-parent) - } - - # Add traces on the selectPath variable - # - - trace variable data(selectPath) w "::tk::dialog::file::SetPath $w" - $data(dirMenuBtn) configure \ - -textvariable ::tk::dialog::file::${dataName}(selectPath) - - # Initialize the file types menu - # - if {[llength $data(-filetypes)]} { - $data(typeMenu) delete 0 end - foreach type $data(-filetypes) { - set title [lindex $type 0] - set filter [lindex $type 1] - $data(typeMenu) add command -label $title \ - -command [list ::tk::dialog::file::SetFilter $w $type] - } - ::tk::dialog::file::SetFilter $w [lindex $data(-filetypes) 0] - $data(typeMenuBtn) config -state normal - $data(typeMenuLab) config -state normal - } else { - set data(filter) "*" - $data(typeMenuBtn) config -state disabled -takefocus 0 - $data(typeMenuLab) config -state disabled - } - ::tk::dialog::file::UpdateWhenIdle $w - - # Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. - - ::tk::PlaceWindow $w widget $data(-parent) - wm title $w $data(-title) - - # Set a grab and claim the focus too. - - ::tk::SetFocusGrab $w $data(ent) - $data(ent) delete 0 end - $data(ent) insert 0 $data(selectFile) - $data(ent) selection range 0 end - $data(ent) icursor end - - # Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - - vwait ::tk::Priv(selectFilePath) - - ::tk::RestoreFocusGrab $w $data(ent) withdraw - - # Cleanup traces on selectPath variable - # - - foreach trace [trace vinfo data(selectPath)] { - trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1] - } - $data(dirMenuBtn) configure -textvariable {} - - return $Priv(selectFilePath) -} - -# ::tk::dialog::file::Config -- -# -# Configures the TK filedialog according to the argument list -# -proc ::tk::dialog::file::Config {dataName type argList} { - upvar ::tk::dialog::file::$dataName data - - set data(type) $type - - # 0: Delete all variable that were set on data(selectPath) the - # last time the file dialog is used. The traces may cause troubles - # if the dialog is now used with a different -parent option. - - foreach trace [trace vinfo data(selectPath)] { - trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1] - } - - # 1: the configuration specs - # - set specs { - {-defaultextension "" "" ""} - {-filetypes "" "" ""} - {-initialdir "" "" ""} - {-initialfile "" "" ""} - {-parent "" "" "."} - {-title "" "" ""} - } - - # The "-multiple" option is only available for the "open" file dialog. - # - if { [string equal $type "open"] } { - lappend specs {-multiple "" "" "0"} - } - - # 2: default values depending on the type of the dialog - # - if {![info exists data(selectPath)]} { - # first time the dialog has been popped up - set data(selectPath) [pwd] - set data(selectFile) "" - } - - # 3: parse the arguments - # - tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList - - if {$data(-title) == ""} { - if {[string equal $type "open"]} { - set data(-title) "[mc "Open"]" - } else { - set data(-title) "[mc "Save As"]" - } - } - - # 4: set the default directory and selection according to the -initial - # settings - # - if {$data(-initialdir) != ""} { - # Ensure that initialdir is an absolute path name. - if {[file isdirectory $data(-initialdir)]} { - set old [pwd] - cd $data(-initialdir) - set data(selectPath) [pwd] - cd $old - } else { - set data(selectPath) [pwd] - } - } - set data(selectFile) $data(-initialfile) - - # 5. Parse the -filetypes option - # - set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)] - - if {![winfo exists $data(-parent)]} { - error "bad window path name \"$data(-parent)\"" - } - - # Set -multiple to a one or zero value (not other boolean types - # like "yes") so we can use it in tests more easily. - if {![string compare $type save]} { - set data(-multiple) 0 - } elseif {$data(-multiple)} { - set data(-multiple) 1 - } else { - set data(-multiple) 0 - } -} - -proc ::tk::dialog::file::Create {w class} { - set dataName [lindex [split $w .] end] - upvar ::tk::dialog::file::$dataName data - variable ::tk::Priv - global tk_library - - toplevel $w -class $class - - # f1: the frame with the directory option menu - # - set f1 [frame $w.f1] - bind [::tk::AmpWidget label $f1.lab -text "[mc "&Directory:"]" ] \ - <<AltUnderlined>> [list focus $f1.menu] - - set data(dirMenuBtn) $f1.menu - set data(dirMenu) [tk_optionMenu $f1.menu [format %s(selectPath) ::tk::dialog::file::$dataName] ""] - set data(upBtn) [button $f1.up] - if {![info exists Priv(updirImage)]} { - set Priv(updirImage) [image create bitmap -data { -#define updir_width 28 -#define updir_height 16 -static char updir_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00, - 0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01, - 0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01, - 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, - 0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01, - 0xf0, 0xff, 0xff, 0x01};}] - } - $data(upBtn) config -image $Priv(updirImage) - - $f1.menu config -takefocus 1 -highlightthickness 2 - - pack $data(upBtn) -side right -padx 4 -fill both - pack $f1.lab -side left -padx 4 -fill both - pack $f1.menu -expand yes -fill both -padx 4 - - # data(icons): the IconList that list the files and directories. - # - if { [string equal $class TkFDialog] } { - if { $data(-multiple) } { - set fNameCaption "[mc {File &names:}]" - } else { - set fNameCaption "[mc {File &name:}]" - } - set fTypeCaption [mc "Files of &type:"] - set fCaptionWidth [::tk::mcmaxamp $fNameCaption $fTypeCaption] - set fCaptionWidth [expr {$fCaptionWidth<14?14:$fCaptionWidth}] - set iconListCommand [list ::tk::dialog::file::OkCmd $w] - } else { - set fNameCaption [mc "&Selection:"] - set fCaptionWidth [string length $fNameCaption] - set iconListCommand [list ::tk::dialog::file::chooseDir::DblClick $w] - } - set data(icons) [::tk::IconList $w.icons \ - -command $iconListCommand \ - -multiple $data(-multiple)] - bind $data(icons) <<ListboxSelect>> \ - [list ::tk::dialog::file::ListBrowse $w] - - # f2: the frame with the OK button and the "file name" field - # - set f2 [frame $w.f2 -bd 0] - bind [::tk::AmpWidget label $f2.lab -text $fNameCaption -anchor e -width $fCaptionWidth \ - -pady 0] <<AltUnderlined>> [list focus $f2.ent] - set data(ent) [entry $f2.ent] - - # The font to use for the icons. The default Canvas font on Unix - # is just deviant. - set ::tk::$w.icons(font) [$data(ent) cget -font] - - # f3: the frame with the cancel button and the file types field - # - set f3 [frame $w.f3 -bd 0] - - # Make the file types bits only if this is a File Dialog - if { [string equal $class TkFDialog] } { - # The "File of types:" label needs to be grayed-out when - # -filetypes are not specified. The label widget does not support - # grayed-out text on monochrome displays. Therefore, we have to - # use a button widget to emulate a label widget (by setting its - # bindtags) - - set data(typeMenuLab) [::tk::AmpWidget button $f3.lab -text $fTypeCaption \ - -anchor e -width $fCaptionWidth \ - -bd [$f2.lab cget -bd] \ - -highlightthickness [$f2.lab cget -highlightthickness] \ - -relief [$f2.lab cget -relief] \ - -padx [$f2.lab cget -padx] \ - -pady [$f2.lab cget -pady]] - bindtags $data(typeMenuLab) [list $data(typeMenuLab) Label \ - [winfo toplevel $data(typeMenuLab)] all] - set data(typeMenuBtn) [menubutton $f3.menu -indicatoron 1 \ - -menu $f3.menu.m] - set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0] - $data(typeMenuBtn) config -takefocus 1 -highlightthickness 2 \ - -relief raised -bd 2 -anchor w - bind $data(typeMenuLab) <<AltUnderlined>> [list focus \ - $data(typeMenuBtn)] - } - - # the okBtn is created after the typeMenu so that the keyboard traversal - # is in the right order - set maxWidth [::tk::mcmaxamp &OK &Cancel] - set maxWidth [expr {$maxWidth<6?6:$maxWidth}] - set data(okBtn) [::tk::AmpWidget button $f2.ok -text "[mc "&OK"]" \ - -width $maxWidth -default active -pady 3] - set data(cancelBtn) [::tk::AmpWidget button $f3.cancel -text "[mc "&Cancel"]" \ - -width $maxWidth -default normal -pady 3] - - # pack the widgets in f2 and f3 - # - pack $data(okBtn) -side right -padx 4 -anchor e - pack $f2.lab -side left -padx 4 - pack $f2.ent -expand yes -fill x -padx 2 -pady 0 - - pack $data(cancelBtn) -side right -padx 4 -anchor w - if { [string equal $class TkFDialog] } { - pack $data(typeMenuLab) -side left -padx 4 - pack $data(typeMenuBtn) -expand yes -fill x -side right - } - - # Pack all the frames together. We are done with widget construction. - # - pack $f1 -side top -fill x -pady 4 - pack $f3 -side bottom -fill x - pack $f2 -side bottom -fill x - pack $data(icons) -expand yes -fill both -padx 4 -pady 1 - - # Set up the event handlers that are common to Directory and File Dialogs - # - - wm protocol $w WM_DELETE_WINDOW [list ::tk::dialog::file::CancelCmd $w] - $data(upBtn) config -command [list ::tk::dialog::file::UpDirCmd $w] - $data(cancelBtn) config -command [list ::tk::dialog::file::CancelCmd $w] - bind $w <KeyPress-Escape> [list tk::ButtonInvoke $data(cancelBtn)] - bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A] - # Set up event handlers specific to File or Directory Dialogs - # - - if { [string equal $class TkFDialog] } { - bind $data(ent) <Return> [list ::tk::dialog::file::ActivateEnt $w] - $data(okBtn) config -command [list ::tk::dialog::file::OkCmd $w] - bind $w <Alt-t> [format { - if {[string equal [%s cget -state] "normal"]} { - focus %s - } - } $data(typeMenuBtn) $data(typeMenuBtn)] - } else { - set okCmd [list ::tk::dialog::file::chooseDir::OkCmd $w] - bind $data(ent) <Return> $okCmd - $data(okBtn) config -command $okCmd - bind $w <Alt-s> [list focus $data(ent)] - bind $w <Alt-o> [list tk::ButtonInvoke $data(okBtn)] - } - - # Build the focus group for all the entries - # - ::tk::FocusGroup_Create $w - ::tk::FocusGroup_BindIn $w $data(ent) [list ::tk::dialog::file::EntFocusIn $w] - ::tk::FocusGroup_BindOut $w $data(ent) [list ::tk::dialog::file::EntFocusOut $w] -} - -# ::tk::dialog::file::SetSelectMode -- -# -# Set the select mode of the dialog to single select or multi-select. -# -# Arguments: -# w The dialog path. -# multi 1 if the dialog is multi-select; 0 otherwise. -# -# Results: -# None. - -proc ::tk::dialog::file::SetSelectMode {w multi} { - set dataName __tk_filedialog - upvar ::tk::dialog::file::$dataName data - if { $multi } { - set fNameCaption "[mc {File &names:}]" - } else { - set fNameCaption "[mc {File &name:}]" - } - set iconListCommand [list ::tk::dialog::file::OkCmd $w] - ::tk::SetAmpText $w.f2.lab $fNameCaption - ::tk::IconList_Config $data(icons) \ - [list -multiple $multi -command $iconListCommand] - return -} - -# ::tk::dialog::file::UpdateWhenIdle -- -# -# Creates an idle event handler which updates the dialog in idle -# time. This is important because loading the directory may take a long -# time and we don't want to load the same directory for multiple times -# due to multiple concurrent events. -# -proc ::tk::dialog::file::UpdateWhenIdle {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - if {[info exists data(updateId)]} { - return - } else { - set data(updateId) [after idle [list ::tk::dialog::file::Update $w]] - } -} - -# ::tk::dialog::file::Update -- -# -# Loads the files and directories into the IconList widget. Also -# sets up the directory option menu for quick access to parent -# directories. -# -proc ::tk::dialog::file::Update {w} { - - # This proc may be called within an idle handler. Make sure that the - # window has not been destroyed before this proc is called - if {![winfo exists $w]} { - return - } - set class [winfo class $w] - if { [string compare $class TkFDialog] && \ - [string compare $class TkChooseDir] } { - return - } - - set dataName [winfo name $w] - upvar ::tk::dialog::file::$dataName data - variable ::tk::Priv - global tk_library - catch {unset data(updateId)} - - if {![info exists Priv(folderImage)]} { - set Priv(folderImage) [image create photo -data { -R0lGODlhEAAMAKEAAAD//wAAAPD/gAAAACH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB -QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}] - set Priv(fileImage) [image create photo -data { -R0lGODlhDAAMAKEAALLA3AAAAP//8wAAACH5BAEAAAAALAAAAAAMAAwAAAIgRI4Ha+IfWHsO -rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}] - } - set folder $Priv(folderImage) - set file $Priv(fileImage) - - set appPWD [pwd] - if {[catch { - cd $data(selectPath) - }]} { - # We cannot change directory to $data(selectPath). $data(selectPath) - # should have been checked before ::tk::dialog::file::Update is called, so - # we normally won't come to here. Anyways, give an error and abort - # action. - tk_messageBox -type ok -parent $w -message \ - "[mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $data(selectPath)]"\ - -icon warning - cd $appPWD - return - } - - # Turn on the busy cursor. BUG?? We haven't disabled X events, though, - # so the user may still click and cause havoc ... - # - set entCursor [$data(ent) cget -cursor] - set dlgCursor [$w cget -cursor] - $data(ent) config -cursor watch - $w config -cursor watch - update idletasks - - ::tk::IconList_DeleteAll $data(icons) - - # Make the dir list - # - set completeFileList [lsort -dictionary -unique [glob -nocomplain .* *]] - set dirList {} - foreach f $completeFileList { - if {[string equal $f .]} { - continue - } - if {[string equal $f ..]} { - continue - } - if {[file isdir ./$f]} { - lappend dirList $f - } - } - ::tk::IconList_Add $data(icons) $folder $dirList - if { [string equal $class TkFDialog] } { - # Make the file list if this is a File Dialog - # - if {[string equal $data(filter) *]} { - set files $completeFileList - } else { - set files {} - foreach f $completeFileList { - foreach pat $data(filter) { - if { [string match $pat $f] } { - lappend files $f - break - } - } - } - } - set fileList {} - foreach f $files { - if {![file isdir ./$f]} { - lappend fileList $f - } - } - ::tk::IconList_Add $data(icons) $file $fileList - } - - ::tk::IconList_Arrange $data(icons) - - # Update the Directory: option menu - # - set list "" - set dir "" - foreach subdir [file split $data(selectPath)] { - set dir [file join $dir $subdir] - lappend list $dir - } - - $data(dirMenu) delete 0 end - set var [format %s(selectPath) ::tk::dialog::file::$dataName] - foreach path $list { - $data(dirMenu) add command -label $path -command [list set $var $path] - } - - # Restore the PWD to the application's PWD - # - cd $appPWD - - if { [string equal $class TkFDialog] } { - # Restore the Open/Save Button if this is a File Dialog - # - if {[string equal $data(type) open]} { - ::tk::SetAmpText $data(okBtn) [mc "&Open"] - set maxWidth [::tk::mcmaxamp [mc "&Open"]] - if {$maxWidth>[$data(okBtn) cget -width]} { - $data(okBtn) config -width $maxWidth - $data(cancelBtn) config -width $maxWidth - } - } else { - ::tk::SetAmpText $data(okBtn) [mc "&Save"] - set maxWidth [::tk::mcmaxamp [mc "&Save"]] - if {$maxWidth>[$data(okBtn) cget -width]} { - $data(okBtn) config -width $maxWidth - $data(cancelBtn) config -width $maxWidth - } - } - } - - # turn off the busy cursor. - # - $data(ent) config -cursor $entCursor - $w config -cursor $dlgCursor -} - -# ::tk::dialog::file::SetPathSilently -- -# -# Sets data(selectPath) without invoking the trace procedure -# -proc ::tk::dialog::file::SetPathSilently {w path} { - upvar ::tk::dialog::file::[winfo name $w] data - - trace vdelete data(selectPath) w [list ::tk::dialog::file::SetPath $w] - set data(selectPath) $path - trace variable data(selectPath) w [list ::tk::dialog::file::SetPath $w] -} - - -# This proc gets called whenever data(selectPath) is set -# -proc ::tk::dialog::file::SetPath {w name1 name2 op} { - if {[winfo exists $w]} { - upvar ::tk::dialog::file::[winfo name $w] data - ::tk::dialog::file::UpdateWhenIdle $w - # On directory dialogs, we keep the entry in sync with the currentdir. - if { [string equal [winfo class $w] TkChooseDir] } { - $data(ent) delete 0 end - $data(ent) insert end $data(selectPath) - } - } -} - -# This proc gets called whenever data(filter) is set -# -proc ::tk::dialog::file::SetFilter {w type} { - upvar ::tk::dialog::file::[winfo name $w] data - upvar ::tk::$data(icons) icons - - set data(filter) [lindex $type 1] - $data(typeMenuBtn) config -text [lindex $type 0] -indicatoron 1 - - # If we aren't using a default extension, use the one suppled - # by the filter. - if {![info exists data(extUsed)]} { - if {[string length $data(-defaultextension)]} { - set data(extUsed) 1 - } else { - set data(extUsed) 0 - } - } - - if {!$data(extUsed)} { - # Get the first extension in the list that matches {^\*\.\w+$} - # and remove all * from the filter. - set index [lsearch -regexp $data(filter) {^\*\.\w+$}] - if {$index >= 0} { - set data(-defaultextension) \ - [string trimleft [lindex $data(filter) $index] "*"] - } else { - # Couldn't find anything! Reset to a safe default... - set data(-defaultextension) "" - } - } - - $icons(sbar) set 0.0 0.0 - - ::tk::dialog::file::UpdateWhenIdle $w -} - -# tk::dialog::file::ResolveFile -- -# -# Interpret the user's text input in a file selection dialog. -# Performs: -# -# (1) ~ substitution -# (2) resolve all instances of . and .. -# (3) check for non-existent files/directories -# (4) check for chdir permissions -# -# Arguments: -# context: the current directory you are in -# text: the text entered by the user -# defaultext: the default extension to add to files with no extension -# -# Return vaue: -# [list $flag $directory $file] -# -# flag = OK : valid input -# = PATTERN : valid directory/pattern -# = PATH : the directory does not exist -# = FILE : the directory exists by the file doesn't -# exist -# = CHDIR : Cannot change to the directory -# = ERROR : Invalid entry -# -# directory : valid only if flag = OK or PATTERN or FILE -# file : valid only if flag = OK or PATTERN -# -# directory may not be the same as context, because text may contain -# a subdirectory name -# -proc ::tk::dialog::file::ResolveFile {context text defaultext} { - - set appPWD [pwd] - - set path [::tk::dialog::file::JoinFile $context $text] - - # If the file has no extension, append the default. Be careful not - # to do this for directories, otherwise typing a dirname in the box - # will give back "dirname.extension" instead of trying to change dir. - if {![file isdirectory $path] && [string equal [file ext $path] ""]} { - set path "$path$defaultext" - } - - - if {[catch {file exists $path}]} { - # This "if" block can be safely removed if the following code - # stop generating errors. - # - # file exists ~nonsuchuser - # - return [list ERROR $path ""] - } - - if {[file exists $path]} { - if {[file isdirectory $path]} { - if {[catch {cd $path}]} { - return [list CHDIR $path ""] - } - set directory [pwd] - set file "" - set flag OK - cd $appPWD - } else { - if {[catch {cd [file dirname $path]}]} { - return [list CHDIR [file dirname $path] ""] - } - set directory [pwd] - set file [file tail $path] - set flag OK - cd $appPWD - } - } else { - set dirname [file dirname $path] - if {[file exists $dirname]} { - if {[catch {cd $dirname}]} { - return [list CHDIR $dirname ""] - } - set directory [pwd] - set file [file tail $path] - if {[regexp {[*]|[?]} $file]} { - set flag PATTERN - } else { - set flag FILE - } - cd $appPWD - } else { - set directory $dirname - set file [file tail $path] - set flag PATH - } - } - - return [list $flag $directory $file] -} - - -# Gets called when the entry box gets keyboard focus. We clear the selection -# from the icon list . This way the user can be certain that the input in the -# entry box is the selection. -# -proc ::tk::dialog::file::EntFocusIn {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - if {[string compare [$data(ent) get] ""]} { - $data(ent) selection range 0 end - $data(ent) icursor end - } else { - $data(ent) selection clear - } - - if { [string equal [winfo class $w] TkFDialog] } { - # If this is a File Dialog, make sure the buttons are labeled right. - if {[string equal $data(type) open]} { - ::tk::SetAmpText $data(okBtn) [mc "&Open"] - } else { - ::tk::SetAmpText $data(okBtn) [mc "&Save"] - } - } -} - -proc ::tk::dialog::file::EntFocusOut {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - $data(ent) selection clear -} - - -# Gets called when user presses Return in the "File name" entry. -# -proc ::tk::dialog::file::ActivateEnt {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - set text [$data(ent) get] - if {$data(-multiple)} { - # For the multiple case we have to be careful to get the file - # names as a true list, watching out for a single file with a - # space in the name. Thus we query the IconList directly. - - set data(selectFile) "" - foreach item [::tk::IconList_Curselection $data(icons)] { - ::tk::dialog::file::VerifyFileName $w \ - [::tk::IconList_Get $data(icons) $item] - } - } else { - ::tk::dialog::file::VerifyFileName $w $text - } -} - -# Verification procedure -# -proc ::tk::dialog::file::VerifyFileName {w filename} { - upvar ::tk::dialog::file::[winfo name $w] data - - set list [::tk::dialog::file::ResolveFile $data(selectPath) $filename \ - $data(-defaultextension)] - foreach {flag path file} $list { - break - } - - switch -- $flag { - OK { - if {[string equal $file ""]} { - # user has entered an existing (sub)directory - set data(selectPath) $path - $data(ent) delete 0 end - } else { - ::tk::dialog::file::SetPathSilently $w $path - if {$data(-multiple)} { - lappend data(selectFile) $file - } else { - set data(selectFile) $file - } - ::tk::dialog::file::Done $w - } - } - PATTERN { - set data(selectPath) $path - set data(filter) $file - } - FILE { - if {[string equal $data(type) open]} { - tk_messageBox -icon warning -type ok -parent $w \ - -message "[mc "File \"%1\$s\" does not exist." [file join $path $file]]" - $data(ent) selection range 0 end - $data(ent) icursor end - } else { - ::tk::dialog::file::SetPathSilently $w $path - if {$data(-multiple)} { - lappend data(selectFile) $file - } else { - set data(selectFile) $file - } - ::tk::dialog::file::Done $w - } - } - PATH { - tk_messageBox -icon warning -type ok -parent $w \ - -message "[mc "Directory \"%1\$s\" does not exist." $path]" - $data(ent) selection range 0 end - $data(ent) icursor end - } - CHDIR { - tk_messageBox -type ok -parent $w -message \ - "[mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $path]"\ - -icon warning - $data(ent) selection range 0 end - $data(ent) icursor end - } - ERROR { - tk_messageBox -type ok -parent $w -message \ - "[mc "Invalid file name \"%1\$s\"." $path]"\ - -icon warning - $data(ent) selection range 0 end - $data(ent) icursor end - } - } -} - -# Gets called when user presses the Alt-s or Alt-o keys. -# -proc ::tk::dialog::file::InvokeBtn {w key} { - upvar ::tk::dialog::file::[winfo name $w] data - - if {[string equal [$data(okBtn) cget -text] $key]} { - ::tk::ButtonInvoke $data(okBtn) - } -} - -# Gets called when user presses the "parent directory" button -# -proc ::tk::dialog::file::UpDirCmd {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - if {[string compare $data(selectPath) "/"]} { - set data(selectPath) [file dirname $data(selectPath)] - } -} - -# Join a file name to a path name. The "file join" command will break -# if the filename begins with ~ -# -proc ::tk::dialog::file::JoinFile {path file} { - if {[string match {~*} $file] && [file exists $path/$file]} { - return [file join $path ./$file] - } else { - return [file join $path $file] - } -} - -# Gets called when user presses the "OK" button -# -proc ::tk::dialog::file::OkCmd {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - set filenames {} - foreach item [::tk::IconList_Curselection $data(icons)] { - lappend filenames [::tk::IconList_Get $data(icons) $item] - } - - if {([llength $filenames] && !$data(-multiple)) || \ - ($data(-multiple) && ([llength $filenames] == 1))} { - set filename [lindex $filenames 0] - set file [::tk::dialog::file::JoinFile $data(selectPath) $filename] - if {[file isdirectory $file]} { - ::tk::dialog::file::ListInvoke $w [list $filename] - return - } - } - - ::tk::dialog::file::ActivateEnt $w -} - -# Gets called when user presses the "Cancel" button -# -proc ::tk::dialog::file::CancelCmd {w} { - upvar ::tk::dialog::file::[winfo name $w] data - variable ::tk::Priv - - set Priv(selectFilePath) "" -} - -# Gets called when user browses the IconList widget (dragging mouse, arrow -# keys, etc) -# -proc ::tk::dialog::file::ListBrowse {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - set text {} - foreach item [::tk::IconList_Curselection $data(icons)] { - lappend text [::tk::IconList_Get $data(icons) $item] - } - if {[llength $text] == 0} { - return - } - if { [llength $text] > 1 } { - set newtext {} - foreach file $text { - set fullfile [::tk::dialog::file::JoinFile $data(selectPath) $file] - if { ![file isdirectory $fullfile] } { - lappend newtext $file - } - } - set text $newtext - set isDir 0 - } else { - set text [lindex $text 0] - set file [::tk::dialog::file::JoinFile $data(selectPath) $text] - set isDir [file isdirectory $file] - } - if {!$isDir} { - $data(ent) delete 0 end - $data(ent) insert 0 $text - - if { [string equal [winfo class $w] TkFDialog] } { - if {[string equal $data(type) open]} { - ::tk::SetAmpText $data(okBtn) [mc "&Open"] - } else { - ::tk::SetAmpText $data(okBtn) [mc "&Save"] - } - } - } else { - if { [string equal [winfo class $w] TkFDialog] } { - ::tk::SetAmpText $data(okBtn) [mc "&Open"] - } - } -} - -# Gets called when user invokes the IconList widget (double-click, -# Return key, etc) -# -proc ::tk::dialog::file::ListInvoke {w filenames} { - upvar ::tk::dialog::file::[winfo name $w] data - - if {[llength $filenames] == 0} { - return - } - - set file [::tk::dialog::file::JoinFile $data(selectPath) \ - [lindex $filenames 0]] - - set class [winfo class $w] - if {[string equal $class TkChooseDir] || [file isdirectory $file]} { - set appPWD [pwd] - if {[catch {cd $file}]} { - tk_messageBox -type ok -parent $w -message \ - "[mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $file]"\ - -icon warning - } else { - cd $appPWD - set data(selectPath) $file - } - } else { - if {$data(-multiple)} { - set data(selectFile) $filenames - } else { - set data(selectFile) $file - } - ::tk::dialog::file::Done $w - } -} - -# ::tk::dialog::file::Done -- -# -# Gets called when user has input a valid filename. Pops up a -# dialog box to confirm selection when necessary. Sets the -# tk::Priv(selectFilePath) variable, which will break the "vwait" -# loop in ::tk::dialog::file:: and return the selected filename to the -# script that calls tk_getOpenFile or tk_getSaveFile -# -proc ::tk::dialog::file::Done {w {selectFilePath ""}} { - upvar ::tk::dialog::file::[winfo name $w] data - variable ::tk::Priv - - if {[string equal $selectFilePath ""]} { - if {$data(-multiple)} { - set selectFilePath {} - foreach f $data(selectFile) { - lappend selectFilePath [::tk::dialog::file::JoinFile \ - $data(selectPath) $f] - } - } else { - set selectFilePath [::tk::dialog::file::JoinFile \ - $data(selectPath) $data(selectFile)] - } - - set Priv(selectFile) $data(selectFile) - set Priv(selectPath) $data(selectPath) - - if {[string equal $data(type) save]} { - if {[file exists $selectFilePath]} { - set reply [tk_messageBox -icon warning -type yesno\ - -parent $w -message \ - "[mc "File \"%1\$s\" already exists.\nDo you want to overwrite it?" $selectFilePath]"] - if {[string equal $reply "no"]} { - return - } - } - } - } - set Priv(selectFilePath) $selectFilePath -} diff --git a/tcl/library/unsupported.tcl b/tcl/library/unsupported.tcl deleted file mode 100644 index 0db34bc8e07..00000000000 --- a/tcl/library/unsupported.tcl +++ /dev/null @@ -1,297 +0,0 @@ -# unsupported.tcl -- -# -# Commands provided by Tk without official support. Use them at your -# own risk. They may change or go away without notice. -# -# RCS: @(#) $Id$ -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -# ---------------------------------------------------------------------- -# Unsupported compatibility interface for folks accessing Tk's private -# commands and variable against recommended usage. -# ---------------------------------------------------------------------- - -namespace eval ::tk::unsupported { - - # Map from the old global names of Tk private commands to their - # new namespace-encapsulated names. - - variable PrivateCommands - array set PrivateCommands { - tkButtonAutoInvoke ::tk::ButtonAutoInvoke - tkButtonDown ::tk::ButtonDown - tkButtonEnter ::tk::ButtonEnter - tkButtonInvoke ::tk::ButtonInvoke - tkButtonLeave ::tk::ButtonLeave - tkButtonUp ::tk::ButtonUp - tkCancelRepeat ::tk::CancelRepeat - tkCheckRadioDown ::tk::CheckRadioDown - tkCheckRadioEnter ::tk::CheckRadioEnter - tkCheckRadioInvoke ::tk::CheckRadioInvoke - tkColorDialog ::tk::dialog::color:: - tkColorDialog_BuildDialog ::tk::dialog::color::BuildDialog - tkColorDialog_CancelCmd ::tk::dialog::color::CancelCmd - tkColorDialog_Config ::tk::dialog::color::Config - tkColorDialog_CreateSelector ::tk::dialog::color::CreateSelector - tkColorDialog_DrawColorScale ::tk::dialog::color::DrawColorScale - tkColorDialog_EnterColorBar ::tk::dialog::color::EnterColorBar - tkColorDialog_InitValues ::tk::dialog::color::InitValues - tkColorDialog_HandleRGBEntry ::tk::dialog::color::HandleRGBEntry - tkColorDialog_HandleSelEntry ::tk::dialog::color::HandleSelEntry - tkColorDialog_LeaveColorBar ::tk::dialog::color::LeaveColorBar - tkColorDialog_MoveSelector ::tk::dialog::color::MoveSelector - tkColorDialog_OkCmd ::tk::dialog::color::OkCmd - tkColorDialog_RedrawColorBars ::tk::dialog::color::RedrawColorBars - tkColorDialog_RedrawFinalColor ::tk::dialog::color::RedrawFinalColor - tkColorDialog_ReleaseMouse ::tk::dialog::color::ReleaseMouse - tkColorDialog_ResizeColorBars ::tk::dialog::color::ResizeColorBars - tkColorDialog_RgbToX ::tk::dialog::color::RgbToX - tkColorDialog_SetRGBValue ::tk::dialog::color::SetRGBValue - tkColorDialog_StartMove ::tk::dialog::color::StartMove - tkColorDialog_XToRgb ::tk::dialog::color::XToRGB - tkConsoleAbout ::tk::ConsoleAbout - tkConsoleBind ::tk::ConsoleBind - tkConsoleExit ::tk::ConsoleExit - tkConsoleHistory ::tk::ConsoleHistory - tkConsoleInit ::tk::ConsoleInit - tkConsoleInsert ::tk::ConsoleInsert - tkConsoleInvoke ::tk::ConsoleInvoke - tkConsoleOutput ::tk::ConsoleOutput - tkConsolePrompt ::tk::ConsolePrompt - tkConsoleSource ::tk::ConsoleSource - tkDarken ::tk::Darken - tkEntryAutoScan ::tk::EntryAutoScan - tkEntryBackspace ::tk::EntryBackspace - tkEntryButton1 ::tk::EntryButton1 - tkEntryClosestGap ::tk::EntryClosestGap - tkEntryGetSelection ::tk::EntryGetSelection - tkEntryInsert ::tk::EntryInsert - tkEntryKeySelect ::tk::EntryKeySelect - tkEntryMouseSelect ::tk::EntryMouseSelect - tkEntryNextWord ::tk::EntryNextWord - tkEntryPaste ::tk::EntryPaste - tkEntryPreviousWord ::tk::EntryPreviousWord - tkEntrySeeInsert ::tk::EntrySeeInsert - tkEntrySetCursor ::tk::EntrySetCursor - tkEntryTranspose ::tk::EntryTranspose - tkEventMotifBindings ::tk::EventMotifBindings - tkFDGetFileTypes ::tk::FDGetFileTypes - tkFirstMenu ::tk::FirstMenu - tkFocusGroup_BindIn ::tk::FocusGroup_BindIn - tkFocusGroup_BindOut ::tk::FocusGroup_BindOut - tkFocusGroup_Create ::tk::FocusGroup_Create - tkFocusGroup_Destroy ::tk::FocusGroup_Destroy - tkFocusGroup_In ::tk::FocusGroup_In - tkFocusGroup_Out ::tk::FocusGroup_Out - tkFocusOK ::tk::FocusOK - tkGenerateMenuSelect ::tk::GenerateMenuSelect - tkIconList ::tk::IconList - tkIconList_Add ::tk::IconList_Add - tkIconList_Arrange ::tk::IconList_Arrange - tkIconList_AutoScan ::tk::IconList_AutoScan - tkIconList_Btn1 ::tk::IconList_Btn1 - tkIconList_Config ::tk::IconList_Config - tkIconList_Create ::tk::IconList_Create - tkIconList_CtrlBtn1 ::tk::IconList_CtrlBtn1 - tkIconList_Curselection ::tk::IconList_Curselection - tkIconList_DeleteAll ::tk::IconList_DeleteAll - tkIconList_Double1 ::tk::IconList_Double1 - tkIconList_DrawSelection ::tk::IconList_DrawSelection - tkIconList_FocusIn ::tk::IconList_FocusIn - tkIconList_FocusOut ::tk::IconList_FocusOut - tkIconList_Get ::tk::IconList_Get - tkIconList_Goto ::tk::IconList_Goto - tkIconList_Index ::tk::IconList_Index - tkIconList_Invoke ::tk::IconList_Invoke - tkIconList_KeyPress ::tk::IconList_KeyPress - tkIconList_Leave1 ::tk::IconList_Leave1 - tkIconList_LeftRight ::tk::IconList_LeftRight - tkIconList_Motion1 ::tk::IconList_Motion1 - tkIconList_Reset ::tk::IconList_Reset - tkIconList_ReturnKey ::tk::IconList_ReturnKey - tkIconList_See ::tk::IconList_See - tkIconList_Select ::tk::IconList_Select - tkIconList_Selection ::tk::IconList_Selection - tkIconList_ShiftBtn1 ::tk::IconList_ShiftBtn1 - tkIconList_UpDown ::tk::IconList_UpDown - tkListbox ::tk::Listbox - tkListboxAutoScan ::tk::ListboxAutoScan - tkListboxBeginExtend ::tk::ListboxBeginExtend - tkListboxBeginSelect ::tk::ListboxBeginSelect - tkListboxBeginToggle ::tk::ListboxBeginToggle - tkListboxCancel ::tk::ListboxCancel - tkListboxDataExtend ::tk::ListboxDataExtend - tkListboxExtendUpDown ::tk::ListboxExtendUpDown - tkListboxKeyAccel_Goto ::tk::ListboxKeyAccel_Goto - tkListboxKeyAccel_Key ::tk::ListboxKeyAccel_Key - tkListboxKeyAccel_Reset ::tk::ListboxKeyAccel_Reset - tkListboxKeyAccel_Set ::tk::ListboxKeyAccel_Set - tkListboxKeyAccel_Unset ::tk::ListboxKeyAccel_Unxet - tkListboxMotion ::tk::ListboxMotion - tkListboxSelectAll ::tk::ListboxSelectAll - tkListboxUpDown ::tk::ListboxUpDown - tkListboxBeginToggle ::tk::ListboxBeginToggle - tkMbButtonUp ::tk::MbButtonUp - tkMbEnter ::tk::MbEnter - tkMbLeave ::tk::MbLeave - tkMbMotion ::tk::MbMotion - tkMbPost ::tk::MbPost - tkMenuButtonDown ::tk::MenuButtonDown - tkMenuDownArrow ::tk::MenuDownArrow - tkMenuDup ::tk::MenuDup - tkMenuEscape ::tk::MenuEscape - tkMenuFind ::tk::MenuFind - tkMenuFindName ::tk::MenuFindName - tkMenuFirstEntry ::tk::MenuFirstEntry - tkMenuInvoke ::tk::MenuInvoke - tkMenuLeave ::tk::MenuLeave - tkMenuLeftArrow ::tk::MenuLeftArrow - tkMenuMotion ::tk::MenuMotion - tkMenuNextEntry ::tk::MenuNextEntry - tkMenuNextMenu ::tk::MenuNextMenu - tkMenuRightArrow ::tk::MenuRightArrow - tkMenuUnpost ::tk::MenuUnpost - tkMenuUpArrow ::tk::MenuUpArrow - tkMessageBox ::tk::MessageBox - tkMotifFDialog ::tk::MotifFDialog - tkMotifFDialog_ActivateDList ::tk::MotifFDialog_ActivateDList - tkMotifFDialog_ActivateFList ::tk::MotifFDialog_ActivateFList - tkMotifFDialog_ActivateFEnt ::tk::MotifFDialog_ActivateFEnt - tkMotifFDialog_ActivateSEnt ::tk::MotifFDialog_ActivateSEnt - tkMotifFDialog ::tk::MotifFDialog - tkMotifFDialog_BrowseDList ::tk::MotifFDialog_BrowseDList - tkMotifFDialog_BrowseFList ::tk::MotifFDialog_BrowseFList - tkMotifFDialog_BuildUI ::tk::MotifFDialog_BuildUI - tkMotifFDialog_CancelCmd ::tk::MotifFDialog_CancelCmd - tkMotifFDialog_Config ::tk::MotifFDialog_Config - tkMotifFDialog_Create ::tk::MotifFDialog_Create - tkMotifFDialog_FileTypes ::tk::MotifFDialog_FileTypes - tkMotifFDialog_FilterCmd ::tk::MotifFDialog_FilterCmd - tkMotifFDialog_InterpFilter ::tk::MotifFDialog_InterpFilter - tkMotifFDialog_LoadFiles ::tk::MotifFDialog_LoadFiles - tkMotifFDialog_MakeSList ::tk::MotifFDialog_MakeSList - tkMotifFDialog_OkCmd ::tk::MotifFDialog_OkCmd - tkMotifFDialog_SetFilter ::tk::MotifFDialog_SetFilter - tkMotifFDialog_SetListMode ::tk::MotifFDialog_SetListMode - tkMotifFDialog_Update ::tk::MotifFDialog_Update - tkPostOverPoint ::tk::PostOverPoint - tkRecolorTree ::tk::RecolorTree - tkRestoreOldGrab ::tk::RestoreOldGrab - tkSaveGrabInfo ::tk::SaveGrabInfo - tkScaleActivate ::tk::ScaleActivate - tkScaleButtonDown ::tk::ScaleButtonDown - tkScaleButton2Down ::tk::ScaleButton2Down - tkScaleControlPress ::tk::ScaleControlPress - tkScaleDrag ::tk::ScaleDrag - tkScaleEndDrag ::tk::ScaleEndDrag - tkScaleIncrement ::tk::ScaleIncrement - tkScreenChanged ::tk::ScreenChanged - tkScrollButtonDown ::tk::ScrollButtonDown - tkScrollButton2Down ::tk::ScrollButton2Down - tkScrollButtonDrag ::tk::ScrollButtonDrag - tkScrollButtonUp ::tk::ScrollButtonUp - tkScrollByPages ::tk::ScrollByPages - tkScrollByUnits ::tk::ScrollByUnits - tkScrollEndDrag ::tk::ScrollEndDrag - tkScrollSelect ::tk::ScrollSelect - tkScrollStartDrag ::tk::ScrollStartDrag - tkScrollTopBottom ::tk::ScrollTopBottom - tkScrollToPos ::tk::ScrollToPos - tkTabToWindow ::tk::TabToWindow - tkTearOffMenu ::tk::TearOffMenu - tkTextAutoScan ::tk::TextAutoScan - tkTextButton1 ::tk::TextButton1 - tkTextClosestGap ::tk::TextClosestGap - tkTextInsert ::tk::TextInsert - tkTextKeyExtend ::tk::TextKeyExtend - tkTextKeySelect ::tk::TextKeySelect - tkTextNextPara ::tk::TextNextPara - tkTextNextPos ::tk::TextNextPos - tkTextNextWord ::tk::TextNextWord - tkTextPaste ::tk::TextPaste - tkTextPrevPara ::tk::TextPrevPara - tkTextPrevPos ::tk::TextPrevPos - tkTextPrevWord ::tk::TextPrevWord - tkTextResetAnchor ::tk::TextResetAnchor - tkTextScrollPages ::tk::TextScrollPages - tkTextSelectTo ::tk::TextSelectTo - tkTextSetCursor ::tk::TextSetCursor - tkTextTranspose ::tk::TextTranspose - tkTextUpDownLine ::tk::TextUpDownLine - tkTraverseToMenu ::tk::TraverseToMenu - tkTraverseWithinMenu ::tk::TraverseWithinMenu - unsupported1 ::tk::unsupported::MacWindowStyle - } - - # Map from the old global names of Tk private variable to their - # new namespace-encapsulated names. - - variable PrivateVariables - array set PrivateVariables { - droped_to_start ::tk::mac::Droped_to_start - histNum ::tk::HistNum - stub_location ::tk::mac::Stub_location - tkFocusIn ::tk::FocusIn - tkFocusOut ::tk::FocusOut - tkPalette ::tk::Palette - tkPriv ::tk::Priv - tkPrivMsgBox ::tk::PrivMsgBox - } -} - -# ::tk::unsupported::ExposePrivateCommand -- -# -# Expose one of Tk's private commands to be visible under its -# old global name -# -# Arguments: -# cmd Global name by which the command was once known, -# or a glob-style pattern. -# -# Results: -# None. -# -# Side effects: -# The old command name in the global namespace is aliased to the -# new private name. - -proc ::tk::unsupported::ExposePrivateCommand {cmd} { - variable PrivateCommands - set cmds [array get PrivateCommands $cmd] - if {[llength $cmds] == 0} { - return -code error "No compatibility support for \[$cmd]" - } - foreach {old new} $cmds { - namespace eval :: [list interp alias {} $old {}] $new - } -} - -# ::tk::unsupported::ExposePrivateVariable -- -# -# Expose one of Tk's private variables to be visible under its -# old global name -# -# Arguments: -# var Global name by which the variable was once known, -# or a glob-style pattern. -# -# Results: -# None. -# -# Side effects: -# The old variable name in the global namespace is aliased to the -# new private name. - -proc ::tk::unsupported::ExposePrivateVariable {var} { - variable PrivateVariables - set vars [array get PrivateVariables $var] - if {[llength $vars] == 0} { - return -code error "No compatibility support for \$$var" - } - namespace eval ::tk::mac {} - foreach {old new} $vars { - namespace eval :: [list upvar "#0" $new $old] - } -} diff --git a/tcl/library/xmfbox.tcl b/tcl/library/xmfbox.tcl deleted file mode 100644 index 31b02efe557..00000000000 --- a/tcl/library/xmfbox.tcl +++ /dev/null @@ -1,961 +0,0 @@ -# xmfbox.tcl -- -# -# Implements the "Motif" style file selection dialog for the -# Unix platform. This implementation is used only if the -# "::tk_strictMotif" flag is set. -# -# RCS: @(#) $Id$ -# -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Scriptics Corporation -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -namespace eval ::tk::dialog {} -namespace eval ::tk::dialog::file {} - - -# ::tk::MotifFDialog -- -# -# Implements a file dialog similar to the standard Motif file -# selection box. -# -# Arguments: -# type "open" or "save" -# args Options parsed by the procedure. -# -# Results: -# When -multiple is set to 0, this returns the absolute pathname -# of the selected file. (NOTE: This is not the same as a single -# element list.) -# -# When -multiple is set to > 0, this returns a Tcl list of absolute -# pathnames. The argument for -multiple is ignored, but for consistency -# with Windows it defines the maximum amount of memory to allocate for -# the returned filenames. - -proc ::tk::MotifFDialog {type args} { - variable ::tk::Priv - set dataName __tk_filedialog - upvar ::tk::dialog::file::$dataName data - - set w [MotifFDialog_Create $dataName $type $args] - - # Set a grab and claim the focus too. - - ::tk::SetFocusGrab $w $data(sEnt) - $data(sEnt) selection range 0 end - - # Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - - vwait ::tk::Priv(selectFilePath) - ::tk::RestoreFocusGrab $w $data(sEnt) withdraw - - return $Priv(selectFilePath) -} - -# ::tk::MotifFDialog_Create -- -# -# Creates the Motif file dialog (if it doesn't exist yet) and -# initialize the internal data structure associated with the -# dialog. -# -# This procedure is used by ::tk::MotifFDialog to create the -# dialog. It's also used by the test suite to test the Motif -# file dialog implementation. User code shouldn't call this -# procedure directly. -# -# Arguments: -# dataName Name of the global "data" array for the file dialog. -# type "Save" or "Open" -# argList Options parsed by the procedure. -# -# Results: -# Pathname of the file dialog. - -proc ::tk::MotifFDialog_Create {dataName type argList} { - upvar ::tk::dialog::file::$dataName data - - MotifFDialog_Config $dataName $type $argList - - if {[string equal $data(-parent) .]} { - set w .$dataName - } else { - set w $data(-parent).$dataName - } - - # (re)create the dialog box if necessary - # - if {![winfo exists $w]} { - MotifFDialog_BuildUI $w - } elseif {[string compare [winfo class $w] TkMotifFDialog]} { - destroy $w - MotifFDialog_BuildUI $w - } else { - set data(fEnt) $w.top.f1.ent - set data(dList) $w.top.f2.a.l - set data(fList) $w.top.f2.b.l - set data(sEnt) $w.top.f3.ent - set data(okBtn) $w.bot.ok - set data(filterBtn) $w.bot.filter - set data(cancelBtn) $w.bot.cancel - } - MotifFDialog_SetListMode $w - - # Dialog boxes should be transient with respect to their parent, - # so that they will always stay on top of their parent window. However, - # some window managers will create the window as withdrawn if the parent - # window is withdrawn or iconified. Combined with the grab we put on the - # window, this can hang the entire application. Therefore we only make - # the dialog transient if the parent is viewable. - - if {[winfo viewable [winfo toplevel $data(-parent)]] } { - wm transient $w $data(-parent) - } - - MotifFDialog_FileTypes $w - MotifFDialog_Update $w - - # Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display (Motif style) and de-iconify it. - - ::tk::PlaceWindow $w - wm title $w $data(-title) - - return $w -} - -# ::tk::MotifFDialog_FileTypes -- -# -# Checks the -filetypes option. If present this adds a list of radio- -# buttons to pick the file types from. -# -# Arguments: -# w Pathname of the tk_get*File dialogue. -# -# Results: -# none - -proc ::tk::MotifFDialog_FileTypes {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - set f $w.top.f3.types - catch {destroy $f} - - # No file types: use "*" as the filter and display no radio-buttons - if {$data(-filetypes) == ""} { - set data(filter) * - return - } - - # The filetypes radiobuttons - # set data(fileType) $data(-defaulttype) - set data(fileType) 0 - - MotifFDialog_SetFilter $w [lindex $data(-filetypes) $data(fileType)] - - #don't produce radiobuttons for only one filetype - if {[llength $data(-filetypes)] == 1} { - return - } - - frame $f - set cnt 0 - if {$data(-filetypes) != {}} { - foreach type $data(-filetypes) { - set title [lindex [lindex $type 0] 0] - set filter [lindex $type 1] - radiobutton $f.b$cnt \ - -text $title \ - -variable ::tk::dialog::file::[winfo name $w](fileType) \ - -value $cnt \ - -command "[list tk::MotifFDialog_SetFilter $w $type]" - pack $f.b$cnt -side left - incr cnt - } - } - $f.b$data(fileType) invoke - - pack $f -side bottom -fill both - - return -} - -# This proc gets called whenever data(filter) is set -# -proc ::tk::MotifFDialog_SetFilter {w type} { - upvar ::tk::dialog::file::[winfo name $w] data - variable ::tk::Priv - - set data(filter) [lindex $type 1] - set Priv(selectFileType) [lindex [lindex $type 0] 0] - - MotifFDialog_Update $w -} - -# ::tk::MotifFDialog_Config -- -# -# Iterates over the optional arguments to determine the option -# values for the Motif file dialog; gives default values to -# unspecified options. -# -# Arguments: -# dataName The name of the global variable in which -# data for the file dialog is stored. -# type "Save" or "Open" -# argList Options parsed by the procedure. - -proc ::tk::MotifFDialog_Config {dataName type argList} { - upvar ::tk::dialog::file::$dataName data - - set data(type) $type - - # 1: the configuration specs - # - set specs { - {-defaultextension "" "" ""} - {-filetypes "" "" ""} - {-initialdir "" "" ""} - {-initialfile "" "" ""} - {-parent "" "" "."} - {-title "" "" ""} - } - if { [string equal $type "open"] } { - lappend specs {-multiple "" "" "0"} - } - - set data(-multiple) 0 - # 2: default values depending on the type of the dialog - # - if {![info exists data(selectPath)]} { - # first time the dialog has been popped up - set data(selectPath) [pwd] - set data(selectFile) "" - } - - # 3: parse the arguments - # - tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList - - if {[string equal $data(-title) ""]} { - if {[string equal $type "open"]} { - if {$data(-multiple) != 0} { - set data(-title) "[mc {Open Multiple Files}]" - } else { - set data(-title) [mc "Open"] - } - } else { - set data(-title) [mc "Save As"] - } - } - - # 4: set the default directory and selection according to the -initial - # settings - # - if {[string compare $data(-initialdir) ""]} { - if {[file isdirectory $data(-initialdir)]} { - set data(selectPath) [lindex [glob $data(-initialdir)] 0] - } else { - set data(selectPath) [pwd] - } - - # Convert the initialdir to an absolute path name. - - set old [pwd] - cd $data(selectPath) - set data(selectPath) [pwd] - cd $old - } - set data(selectFile) $data(-initialfile) - - # 5. Parse the -filetypes option. It is not used by the motif - # file dialog, but we check for validity of the value to make sure - # the application code also runs fine with the TK file dialog. - # - set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)] - - if {![info exists data(filter)]} { - set data(filter) * - } - if {![winfo exists $data(-parent)]} { - error "bad window path name \"$data(-parent)\"" - } -} - -# ::tk::MotifFDialog_BuildUI -- -# -# Builds the UI components of the Motif file dialog. -# -# Arguments: -# w Pathname of the dialog to build. -# -# Results: -# None. - -proc ::tk::MotifFDialog_BuildUI {w} { - set dataName [lindex [split $w .] end] - upvar ::tk::dialog::file::$dataName data - - # Create the dialog toplevel and internal frames. - # - toplevel $w -class TkMotifFDialog - set top [frame $w.top -relief raised -bd 1] - set bot [frame $w.bot -relief raised -bd 1] - - pack $w.bot -side bottom -fill x - pack $w.top -side top -expand yes -fill both - - set f1 [frame $top.f1] - set f2 [frame $top.f2] - set f3 [frame $top.f3] - - pack $f1 -side top -fill x - pack $f3 -side bottom -fill x - pack $f2 -expand yes -fill both - - set f2a [frame $f2.a] - set f2b [frame $f2.b] - - grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \ - -sticky news - grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \ - -sticky news - grid rowconfig $f2 0 -minsize 0 -weight 1 - grid columnconfig $f2 0 -minsize 0 -weight 1 - grid columnconfig $f2 1 -minsize 150 -weight 2 - - # The Filter box - # - bind [::tk::AmpWidget label $f1.lab -text [mc "Fil&ter:"] -anchor w] \ - <<AltUnderlined>> [list focus $f1.ent] - entry $f1.ent - pack $f1.lab -side top -fill x -padx 6 -pady 4 - pack $f1.ent -side top -fill x -padx 4 -pady 0 - set data(fEnt) $f1.ent - - # The file and directory lists - # - set data(dList) [MotifFDialog_MakeSList $w $f2a \ - [mc "&Directory:"] DList] - set data(fList) [MotifFDialog_MakeSList $w $f2b \ - [mc "Fi&les:"] FList] - - # The Selection box - # - bind [::tk::AmpWidget label $f3.lab -text [mc "&Selection:"] -anchor w] \ - <<AltUnderlined>> [list focus $f3.ent] - entry $f3.ent - pack $f3.lab -side top -fill x -padx 6 -pady 0 - pack $f3.ent -side top -fill x -padx 4 -pady 4 - set data(sEnt) $f3.ent - - # The buttons - # - set maxWidth [::tk::mcmaxamp &OK &Filter &Cancel] - set maxWidth [expr {$maxWidth<6?6:$maxWidth}] - set data(okBtn) [::tk::AmpWidget button $bot.ok -text [mc "&OK"] \ - -width $maxWidth \ - -command [list tk::MotifFDialog_OkCmd $w]] - set data(filterBtn) [::tk::AmpWidget button $bot.filter -text [mc "&Filter"] \ - -width $maxWidth \ - -command [list tk::MotifFDialog_FilterCmd $w]] - set data(cancelBtn) [::tk::AmpWidget button $bot.cancel -text [mc "&Cancel"] \ - -width $maxWidth \ - -command [list tk::MotifFDialog_CancelCmd $w]] - - pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \ - -side left - - # Create the bindings: - # - bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A] - - bind $data(fEnt) <Return> [list tk::MotifFDialog_ActivateFEnt $w] - bind $data(sEnt) <Return> [list tk::MotifFDialog_ActivateSEnt $w] - - wm protocol $w WM_DELETE_WINDOW [list tk::MotifFDialog_CancelCmd $w] -} - -proc ::tk::MotifFDialog_SetListMode {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - if {$data(-multiple) != 0} { - set selectmode extended - } else { - set selectmode browse - } - set f $w.top.f2.b - $f.l configure -selectmode $selectmode -} - -# ::tk::MotifFDialog_MakeSList -- -# -# Create a scrolled-listbox and set the keyboard accelerator -# bindings so that the list selection follows what the user -# types. -# -# Arguments: -# w Pathname of the dialog box. -# f Frame widget inside which to create the scrolled -# listbox. This frame widget already exists. -# label The string to display on top of the listbox. -# under Sets the -under option of the label. -# cmdPrefix Specifies procedures to call when the listbox is -# browsed or activated. - -proc ::tk::MotifFDialog_MakeSList {w f label cmdPrefix} { - bind [::tk::AmpWidget label $f.lab -text $label -anchor w] \ - <<AltUnderlined>> [list focus $f.l] - listbox $f.l -width 12 -height 5 -exportselection 0\ - -xscrollcommand [list $f.h set] -yscrollcommand [list $f.v set] - scrollbar $f.v -orient vertical -takefocus 0 -command [list $f.l yview] - scrollbar $f.h -orient horizontal -takefocus 0 -command [list $f.l xview] - grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \ - -padx 2 -pady 2 - grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news - grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news - grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news - - grid rowconfig $f 0 -weight 0 -minsize 0 - grid rowconfig $f 1 -weight 1 -minsize 0 - grid columnconfig $f 0 -weight 1 -minsize 0 - - # bindings for the listboxes - # - set list $f.l - bind $list <<ListboxSelect>> [list tk::MotifFDialog_Browse$cmdPrefix $w] - bind $list <Double-ButtonRelease-1> \ - [list tk::MotifFDialog_Activate$cmdPrefix $w] - bind $list <Return> "tk::MotifFDialog_Browse$cmdPrefix [list $w]; \ - tk::MotifFDialog_Activate$cmdPrefix [list $w]" - - bindtags $list [list Listbox $list [winfo toplevel $list] all] - ListBoxKeyAccel_Set $list - - return $f.l -} - -# ::tk::MotifFDialog_InterpFilter -- -# -# Interpret the string in the filter entry into two components: -# the directory and the pattern. If the string is a relative -# pathname, give a warning to the user and restore the pattern -# to original. -# -# Arguments: -# w pathname of the dialog box. -# -# Results: -# A list of two elements. The first element is the directory -# specified # by the filter. The second element is the filter -# pattern itself. - -proc ::tk::MotifFDialog_InterpFilter {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - set text [string trim [$data(fEnt) get]] - - # Perform tilde substitution - # - set badTilde 0 - if {[string equal [string index $text 0] ~]} { - set list [file split $text] - set tilde [lindex $list 0] - if {[catch {set tilde [glob $tilde]}]} { - set badTilde 1 - } else { - set text [eval file join [concat $tilde [lrange $list 1 end]]] - } - } - - # If the string is a relative pathname, combine it - # with the current selectPath. - - set relative 0 - if {[string equal [file pathtype $text] "relative"]} { - set relative 1 - } elseif {$badTilde} { - set relative 1 - } - - if {$relative} { - tk_messageBox -icon warning -type ok \ - -message "\"$text\" must be an absolute pathname" - - $data(fEnt) delete 0 end - $data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ - $data(filter)] - - return [list $data(selectPath) $data(filter)] - } - - set resolved [::tk::dialog::file::JoinFile [file dirname $text] [file tail $text]] - - if {[file isdirectory $resolved]} { - set dir $resolved - set fil $data(filter) - } else { - set dir [file dirname $resolved] - set fil [file tail $resolved] - } - - return [list $dir $fil] -} - -# ::tk::MotifFDialog_Update -# -# Load the files and synchronize the "filter" and "selection" fields -# boxes. -# -# Arguments: -# w pathname of the dialog box. -# -# Results: -# None. - -proc ::tk::MotifFDialog_Update {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - $data(fEnt) delete 0 end - $data(fEnt) insert 0 \ - [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)] - $data(sEnt) delete 0 end - $data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ - $data(selectFile)] - - MotifFDialog_LoadFiles $w -} - -# ::tk::MotifFDialog_LoadFiles -- -# -# Loads the files and directories into the two listboxes according -# to the filter setting. -# -# Arguments: -# w pathname of the dialog box. -# -# Results: -# None. - -proc ::tk::MotifFDialog_LoadFiles {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - $data(dList) delete 0 end - $data(fList) delete 0 end - - set appPWD [pwd] - if {[catch {cd $data(selectPath)}]} { - cd $appPWD - - $data(dList) insert end ".." - return - } - - # Make the dir and file lists - # - # For speed we only have one glob, which reduces the file system - # calls (good for slow NFS networks). - # - # We also do two smaller sorts (files + dirs) instead of one large sort, - # which gives a small speed increase. - # - set top 0 - set dlist "" - set flist "" - foreach f [glob -nocomplain .* *] { - if {[file isdir ./$f]} { - lappend dlist $f - } else { - foreach pat $data(filter) { - if {[string match $pat $f]} { - if {[string match .* $f]} { - incr top - } - lappend flist $f - break - } - } - } - } - eval [list $data(dList) insert end] [lsort -dictionary $dlist] - eval [list $data(fList) insert end] [lsort -dictionary $flist] - - # The user probably doesn't want to see the . files. We adjust the view - # so that the listbox displays all the non-dot files - $data(fList) yview $top - - cd $appPWD -} - -# ::tk::MotifFDialog_BrowseDList -- -# -# This procedure is called when the directory list is browsed -# (clicked-over) by the user. -# -# Arguments: -# w The pathname of the dialog box. -# -# Results: -# None. - -proc ::tk::MotifFDialog_BrowseDList {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - focus $data(dList) - if {[string equal [$data(dList) curselection] ""]} { - return - } - set subdir [$data(dList) get [$data(dList) curselection]] - if {[string equal $subdir ""]} { - return - } - - $data(fList) selection clear 0 end - - set list [MotifFDialog_InterpFilter $w] - set data(filter) [lindex $list 1] - - switch -- $subdir { - . { - set newSpec [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)] - } - .. { - set newSpec [::tk::dialog::file::JoinFile [file dirname $data(selectPath)] \ - $data(filter)] - } - default { - set newSpec [::tk::dialog::file::JoinFile [::tk::dialog::file::JoinFile \ - $data(selectPath) $subdir] $data(filter)] - } - } - - $data(fEnt) delete 0 end - $data(fEnt) insert 0 $newSpec -} - -# ::tk::MotifFDialog_ActivateDList -- -# -# This procedure is called when the directory list is activated -# (double-clicked) by the user. -# -# Arguments: -# w The pathname of the dialog box. -# -# Results: -# None. - -proc ::tk::MotifFDialog_ActivateDList {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - if {[string equal [$data(dList) curselection] ""]} { - return - } - set subdir [$data(dList) get [$data(dList) curselection]] - if {[string equal $subdir ""]} { - return - } - - $data(fList) selection clear 0 end - - switch -- $subdir { - . { - set newDir $data(selectPath) - } - .. { - set newDir [file dirname $data(selectPath)] - } - default { - set newDir [::tk::dialog::file::JoinFile $data(selectPath) $subdir] - } - } - - set data(selectPath) $newDir - MotifFDialog_Update $w - - if {[string compare $subdir ..]} { - $data(dList) selection set 0 - $data(dList) activate 0 - } else { - $data(dList) selection set 1 - $data(dList) activate 1 - } -} - -# ::tk::MotifFDialog_BrowseFList -- -# -# This procedure is called when the file list is browsed -# (clicked-over) by the user. -# -# Arguments: -# w The pathname of the dialog box. -# -# Results: -# None. - -proc ::tk::MotifFDialog_BrowseFList {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - focus $data(fList) - set data(selectFile) "" - foreach item [$data(fList) curselection] { - lappend data(selectFile) [$data(fList) get $item] - } - if {[llength $data(selectFile)] == 0} { - return - } - - $data(dList) selection clear 0 end - - $data(fEnt) delete 0 end - $data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ - $data(filter)] - $data(fEnt) xview end - - # if it's a multiple selection box, just put in the filenames - # otherwise put in the full path as usual - $data(sEnt) delete 0 end - if {$data(-multiple) != 0} { - $data(sEnt) insert 0 $data(selectFile) - } else { - $data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ - [lindex $data(selectFile) 0]] - } - $data(sEnt) xview end -} - -# ::tk::MotifFDialog_ActivateFList -- -# -# This procedure is called when the file list is activated -# (double-clicked) by the user. -# -# Arguments: -# w The pathname of the dialog box. -# -# Results: -# None. - -proc ::tk::MotifFDialog_ActivateFList {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - if {[string equal [$data(fList) curselection] ""]} { - return - } - set data(selectFile) [$data(fList) get [$data(fList) curselection]] - if {[string equal $data(selectFile) ""]} { - return - } else { - MotifFDialog_ActivateSEnt $w - } -} - -# ::tk::MotifFDialog_ActivateFEnt -- -# -# This procedure is called when the user presses Return inside -# the "filter" entry. It updates the dialog according to the -# text inside the filter entry. -# -# Arguments: -# w The pathname of the dialog box. -# -# Results: -# None. - -proc ::tk::MotifFDialog_ActivateFEnt {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - set list [MotifFDialog_InterpFilter $w] - set data(selectPath) [lindex $list 0] - set data(filter) [lindex $list 1] - - MotifFDialog_Update $w -} - -# ::tk::MotifFDialog_ActivateSEnt -- -# -# This procedure is called when the user presses Return inside -# the "selection" entry. It sets the ::tk::Priv(selectFilePath) -# variable so that the vwait loop in tk::MotifFDialog will be -# terminated. -# -# Arguments: -# w The pathname of the dialog box. -# -# Results: -# None. - -proc ::tk::MotifFDialog_ActivateSEnt {w} { - variable ::tk::Priv - upvar ::tk::dialog::file::[winfo name $w] data - - set selectFilePath [string trim [$data(sEnt) get]] - - if {[string equal $selectFilePath ""]} { - MotifFDialog_FilterCmd $w - return - } - - if {$data(-multiple) == 0} { - set selectFilePath [list $selectFilePath] - } - - if {[file isdirectory [lindex $selectFilePath 0]]} { - set data(selectPath) [lindex [glob $selectFilePath] 0] - set data(selectFile) "" - MotifFDialog_Update $w - return - } - - set newFileList "" - foreach item $selectFilePath { - if {[string compare [file pathtype $item] "absolute"]} { - set item [file join $data(selectPath) $item] - } elseif {![file exists [file dirname $item]]} { - tk_messageBox -icon warning -type ok \ - -message [mc {Directory "%1$s" does not exist.} \ - [file dirname $item]] - return - } - - if {![file exists $item]} { - if {[string equal $data(type) open]} { - tk_messageBox -icon warning -type ok \ - -message [mc {File "%1$s" does not exist.} $item] - return - } - } else { - if {[string equal $data(type) save]} { - set message [format %s%s \ - [mc {File "%1$s" already exists.\n\n} \ - $selectFilePath] \ - [mc {Replace existing file?}]] - set answer [tk_messageBox -icon warning -type yesno \ - -message $message] - if {[string equal $answer "no"]} { - return - } - } - } - - lappend newFileList $item - } - - if {$data(-multiple) != 0} { - set Priv(selectFilePath) $newFileList - } else { - set Priv(selectFilePath) [lindex $newFileList 0] - } - - # Set selectFile and selectPath to first item in list - set Priv(selectFile) [file tail [lindex $newFileList 0]] - set Priv(selectPath) [file dirname [lindex $newFileList 0]] -} - - -proc ::tk::MotifFDialog_OkCmd {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - MotifFDialog_ActivateSEnt $w -} - -proc ::tk::MotifFDialog_FilterCmd {w} { - upvar ::tk::dialog::file::[winfo name $w] data - - MotifFDialog_ActivateFEnt $w -} - -proc ::tk::MotifFDialog_CancelCmd {w} { - variable ::tk::Priv - - set Priv(selectFilePath) "" - set Priv(selectFile) "" - set Priv(selectPath) "" -} - -proc ::tk::ListBoxKeyAccel_Set {w} { - bind Listbox <Any-KeyPress> "" - bind $w <Destroy> [list tk::ListBoxKeyAccel_Unset $w] - bind $w <Any-KeyPress> [list tk::ListBoxKeyAccel_Key $w %A] -} - -proc ::tk::ListBoxKeyAccel_Unset {w} { - variable ::tk::Priv - - catch {after cancel $Priv(lbAccel,$w,afterId)} - catch {unset Priv(lbAccel,$w)} - catch {unset Priv(lbAccel,$w,afterId)} -} - -# ::tk::ListBoxKeyAccel_Key-- -# -# This procedure maintains a list of recently entered keystrokes -# over a listbox widget. It arranges an idle event to move the -# selection of the listbox to the entry that begins with the -# keystrokes. -# -# Arguments: -# w The pathname of the listbox. -# key The key which the user just pressed. -# -# Results: -# None. - -proc ::tk::ListBoxKeyAccel_Key {w key} { - variable ::tk::Priv - - if { $key == "" } { - return - } - append Priv(lbAccel,$w) $key - ListBoxKeyAccel_Goto $w $Priv(lbAccel,$w) - catch { - after cancel $Priv(lbAccel,$w,afterId) - } - set Priv(lbAccel,$w,afterId) [after 500 \ - [list tk::ListBoxKeyAccel_Reset $w]] -} - -proc ::tk::ListBoxKeyAccel_Goto {w string} { - variable ::tk::Priv - - set string [string tolower $string] - set end [$w index end] - set theIndex -1 - - for {set i 0} {$i < $end} {incr i} { - set item [string tolower [$w get $i]] - if {[string compare $string $item] >= 0} { - set theIndex $i - } - if {[string compare $string $item] <= 0} { - set theIndex $i - break - } - } - - if {$theIndex >= 0} { - $w selection clear 0 end - $w selection set $theIndex $theIndex - $w activate $theIndex - $w see $theIndex - event generate $w <<ListboxSelect>> - } -} - -proc ::tk::ListBoxKeyAccel_Reset {w} { - variable ::tk::Priv - - catch {unset Priv(lbAccel,$w)} -} - -proc ::tk_getFileType {} { - variable ::tk::Priv - - return $Priv(selectFileType) -} - |
