neingeist/arduinisten
Archived
1
0
Fork 0
Code Releases Activity

arduino-0018-windows

Browse source
This commit is contained in:
orange 2010-03-30 21:53:44 +02:00
parent 157fd6f1a1
commit f39fc49523
5182 changed files with 950586 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

82
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/advice.tcl Normal file
View file

@ -0,0 +1,82 @@
# advice.tcl - Generic advice package.
# Copyright (C) 1998 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# Please note that I adapted this from some code I wrote elsewhere,
# for non-Cygnus reasons. Don't complain to me if you see something
# like it somewhere else.
# Internal state.
defarray ADVICE_state
# This is a helper proc that does all the actual work.
proc ADVICE_do {command argList} {
global ADVICE_state
# Run before advice.
if {[info exists ADVICE_state(before,$command)]} {
foreach item $ADVICE_state(before,$command) {
# We purposely let errors in advice go uncaught.
uplevel $item $argList
}
}
# Run the command itself.
set code [catch \
[list uplevel \#0 $ADVICE_state(original,$command) $argList] \
result]
# Run the after advice.
if {[info exists ADVICE_state(after,$command)]} {
foreach item $ADVICE_state(after,$command) {
# We purposely let errors in advice go uncaught.
uplevel $item [list $code $result] $argList
}
}
# Return just as the original command would.
return -code $code $result
}
# Put some advice on a proc or command.
# WHEN says when to run the advice - `before' or `after' the
# advisee is run.
# WHAT is the name of the proc or command to advise.
# ADVISOR is the advice. It is passed the arguments to the advisee
# call as its arguments. In addition, `after' advisors are
# passed the return code and return value of the proc as their
# first and second arguments.
proc advise {when what advisor} {
global ADVICE_state
if {! [info exists ADVICE_state(original,$what)]} {
set newName [gensym]
rename $what $newName
set ADVICE_state(original,$what) $newName
# Create a new proc which just runs our internal command with the
# correct arguments.
uplevel \#0 [list proc $what args \
[format {ADVICE_do %s $args} $what]]
}
lappend ADVICE_state($when,$what) $advisor
}
# Remove some previously-set advice. Note that we could undo the
# `rename' when the last advisor is removed. This adds complexity,
# though, and there isn't much reason to.
proc unadvise {when what advisor} {
global ADVICE_state
if {[info exists ADVICE_state($when,$what)]} {
set newList {}
foreach item $ADVICE_state($when,$what) {
if {[string compare $advisor $item]} {
lappend newList $item
}
}
set ADVICE_state($when,$what) $newList
}
}

538
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/balloon.tcl Normal file
View file

@ -0,0 +1,538 @@
# balloon.tcl - Balloon help.
# Copyright (C) 1997, 1998, 2000 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# KNOWN BUGS:
# * On Windows, various delays should be determined from system;
# presently they are hard-coded.
# * Likewise, balloon positioning on Windows is a hack.
itcl_class Balloon {
# Name of associated global variable which should be set whenever
# the help is shown.
public variable {}
# Name of associated toplevel. Private variable.
protected _top {}
# This is non-empty if there is an after script pending. Private
# method.
protected _after_id {}
# This is an array mapping window name to help text.
protected _help_text
# This is an array mapping window name to notification proc.
protected _notifiers
# This is set to the name of the parent widget whenever the mouse is
# in a widget with balloon help.
protected _active {}
# This is true when we're already calling a notification proc.
# Private variable.
protected _in_notifier 0
# This holds the parent of the most recently entered widget. It is
# used to determine when the user is moving through a toolbar.
# Private variable.
protected _recent_parent {}
constructor {top} {
global tcl_platform
set _top $top
set class [$this info class]
# The standard widget-making trick.
set hull [namespace tail $this]
set old_name $this
::rename $this $this-tmp-
::toplevel $hull -class $class -borderwidth 1 -background black
::rename $hull $old_name-win-
::rename $this $old_name
# By default we are invisible. When we are visible, we are
# borderless.
wm withdraw [namespace tail $this]
wm overrideredirect [namespace tail $this] 1
# Put some bindings on the toplevel. We don't use
# bind_for_toplevel_only because *do* want these bindings to be
# run when the event happens on some child.
bind $_top <Enter> [list $this _enter %W]
bind $_top <Leave> [list $this _leave]
# Only run this one if we aren't already destroyed.
bind $_top <Destroy> [format {
if {[info commands %s] != ""} then {
%s _subdestroy %%W
}
} $this $this]
bind $_top <Unmap> [list $this _unmap %W]
# Add more here as required.
bind $_top <1> [format {
%s _cancel
%s _unshowballoon
} $this $this]
if {$tcl_platform(platform) == "windows"} then {
set bg SystemInfoBackground
set fg SystemInfoText
} else {
# This color is called `LemonChiffon' by my X installation.
set bg \#ffffffffcccc
set fg black
}
# Where we display stuff.
label [namespace tail $this].label -background $bg -foreground $fg -font global/status \
-anchor w -justify left
pack [namespace tail $this].label -expand 1 -fill both
# Clean up when the label is destroyed. This has the hidden
# assumption that the balloon widget is a child of the toplevel to
# which it is connected.
bind [namespace tail $this].label <Destroy> [list $this delete]
}
destructor {
catch {_cancel}
catch {after cancel [list $this _unshowballoon]}
catch {destroy $this}
}
method configure {config} {}
# Register a notifier for a window.
method notify {command window {tag {}}} {
if {$tag == ""} then {
set item $window
} else {
set item $window,$tag
}
if {$command == ""} then {
unset _notifiers($item)
} else {
set _notifiers($item) $command
}
}
# Register help for a window.
method register {window text {tag {}}} {
if {$tag == ""} then {
set item $window
} else {
# Switching on the window class is bad. Do something better.
set class [winfo class $window]
# Switching on window class is bad. Do something better.
switch -- $class {
Menu {
# Menus require bindings that other items do not require.
# So here we make sure the menu has the binding. We could
# speed this up by keeping a special entry in the _help_text
# array if we wanted. Note that we pass in the name of the
# window as we know it. That lets us work even when we're
# actually getting events for a clone window. This is less
# than ideal, because it means we have to hijack the
# MenuSelect binding, but we live with it. (The other
# choice is to make a new bindtag per menu -- yuck.)
# This is relatively nasty: we have to encode the window
# name as passed to the _motion method; otherwise the
# cloning munges it. Sigh.
regsub -all -- \\. $window ! munge
bind $window <<MenuSelect>> [list $this _motion %W $munge]
}
Canvas {
# If we need to add a binding for this tag, do so.
if {! [info exists _help_text($window,$tag)]} then {
$window bind $tag <Enter> +[list $this _enter $window $tag]
$window bind $tag <Leave> +[list $this _leave]
$window bind $tag <1> +[format {
%s _cancel
%s _unshowballoon
} $this $this]
}
}
Text {
# If we need to add a binding for this tag, do so.
if {! [info exists _help_text($window,$tag)]} then {
$window tag bind $tag <Enter> +[list $this _enter $window $tag]
$window tag bind $tag <Leave> +[list $this _leave]
$window tag bind $tag <1> +[format {
%s _cancel
%s _unshowballoon
} $this $this]
}
}
}
set item $window,$tag
}
set _help_text($item) $text
if {$_active == $item} then {
_set_variable $item
# If the label is already showing, then we re-show it. Why not
# just set the -text on the label? Because if the label changes
# size it might be offscreen, and we need to handle that.
if {[wm state [namespace tail $this]] == "normal"} then {
showballoon $window $tag
}
}
}
# Cancel any pending after handler. Private method.
method _cancel {} {
if {$_after_id != ""} then {
after cancel $_after_id
set _after_id {}
}
}
# This is run when the toplevel, or any child, is entered. Private
# method.
method _enter {W {tag {}}} {
_cancel
# Don't bother for menus, since we know we use a different
# mechanism for them.
if {[winfo class $W] == "Menu"} then {
return
}
# If we just moved into the parent of the last child, then do
# nothing. We want to keep the parent the same so the right thing
# can happen if we move into a child of this same parent.
set delay 1000
if {$W != $_recent_parent} then {
if {[winfo parent $W] == $_recent_parent} then {
# As soon as possible.
set delay idle
} else {
set _recent_parent ""
}
}
if {$tag == ""} then {
set index $W
} else {
set index $W,$tag
}
set _active $index
if {[info exists _help_text($index)]} then {
# There is some help text. So arrange to display it when the
# time is up. We arbitrarily set this to 1 second.
set _after_id [after $delay [list $this showballoon $W $tag]]
# Set variable here; that way simply entering a window will
# cause the text to appear.
_set_variable $index
}
}
# This is run when the toplevel, or any child, is left. Private
# method.
method _leave {} {
_cancel
_unshowballoon
_set_variable {}
set _active {}
}
# This is run to undisplay the balloon. Note that it does not
# change the text stored in the variable. That is handled
# elsewhere. Private method.
method _unshowballoon {} {
wm withdraw [namespace tail $this]
}
# Set the variable, if it exists. Private method.
method _set_variable {index} {
# Run the notifier.
if {$index == ""} then {
set value ""
} elseif {[info exists _notifiers($index)] && ! $_in_notifier} then {
if {$variable != ""} {
upvar $variable var
set var $_help_text($index)
}
set _in_notifier 1
uplevel \#0 $_notifiers($index)
set _in_notifier 0
# Get value afterwards to give notifier a chance to change it.
if {$variable != ""} {
upvar $variable var
set _help_text($index) $var
}
set value $_help_text($index)
} else {
set value $_help_text($index)
}
if {$variable != ""} then {
upvar $variable var
set var $value
}
}
# This is run to show the balloon. Private method.
method showballoon {W tag {keep 0}} {
global tcl_platform
if {$tag == ""} then {
# An ordinary window. Position below the window, and right of
# center.
set _active $W
set left [expr {[winfo rootx $W] + round ([winfo width $W] * .75)}]
set ypos [expr {[winfo rooty $W] + [winfo height $W]}]
set alt_ypos [winfo rooty $W]
# Balloon shown, so set parent info.
set _recent_parent [winfo parent $W]
} else {
set _active $W,$tag
# Switching on class name is bad. Do something better. Can't
# just use the widget's bbox method, because the results differ
# for Text and Canvas widgets. Bummer.
switch -- [winfo class $W] {
Menu {
# Recognize but do nothing.
}
Text {
lassign [$W bbox $tag.first] x y width height
set left [expr {[winfo rootx $W] + $x + round ($width * .75)}]
set ypos [expr {[winfo rooty $W] + $y + $height}]
set alt_ypos [expr {[winfo rooty $W] - $y}]
}
Canvas {
lassign [$W bbox $tag] x1 y1 x2 y2
# Must subtract out coordinates of top-left corner of canvas
# window; otherwise this will get the wrong position when
# the canvas has been scrolled.
set tlx [$W canvasx 0]
set tly [$W canvasy 0]
# Must round results because canvas coordinates are floats.
set left [expr {round ([winfo rootx $W] + $x1 - $tlx
+ ($x2 - $x1) * .75)}]
set ypos [expr {round ([winfo rooty $W] + $y2 - $tly)}]
set alt_ypos [expr {round ([winfo rooty $W] + $y1 - $tly)}]
}
default {
error "unrecognized window class for window \"$W\""
}
}
}
set help $_help_text($_active)
# On Windows, the popup location is always determined by the
# cursor. Actually, the rule seems to be somewhat more complex.
# Unfortunately it doesn't seem to be written down anywhere.
# Experiments show that the location is determined by the cursor
# if the text is wider than the widget; and otherwise it is
# centered under the widget. FIXME: we don't deal with those
# cases.
if {$tcl_platform(platform) == "windows"} then {
# FIXME: for now this is turned off. It isn't enough to get the
# cursor size; we actually have to find the bottommost "on"
# pixel in the cursor and use that for the height. I don't know
# how to do that.
# lassign [ide_cursor size] dummy height
# lassign [ide_cursor position] left ypos
# incr ypos $height
}
if {[info exists left] && $help != ""} then {
[namespace tail $this].label configure -text $help
set lw [winfo reqwidth [namespace tail $this].label]
set sw [winfo screenwidth [namespace tail $this]]
set bw [$this-win- cget -borderwidth]
if {$left + $lw + 2 * $bw >= $sw} then {
set left [expr {$sw - 2 * $bw - $lw}]
}
set lh [winfo reqheight [namespace tail $this].label]
if {$ypos + $lh >= [winfo screenheight [namespace tail $this]]} then {
set ypos [expr {$alt_ypos - $lh}]
}
wm positionfrom [namespace tail $this] user
wm geometry [namespace tail $this] +${left}+${ypos}
update
wm deiconify [namespace tail $this]
raise [namespace tail $this]
if {!$keep} {
# After 6 seconds, close the window. The timer is reset every
# time the window is shown.
after cancel [list $this _unshowballoon]
after 6000 [list $this _unshowballoon]
}
}
}
# This is run when a window or tag is destroyed. Private method.
method _subdestroy {W {tag {}}} {
if {$tag == ""} then {
# A window. Remove the window and any associated tags. Note
# that this is called for all Destroy events on descendents,
# even for windows which were never registered. Hence the use
# of catch.
catch {unset _help_text($W)}
foreach thing [array names _help_text($W,*)] {
unset _help_text($thing)
}
} else {
# Just a tag. This one can't be called by mistake, so this
# shouldn't need to be caught.
unset _help_text($W,$tag)
}
}
# This is run in response to a MenuSelect event on a menu.
method _motion {window name} {
# Decode window name.
regsub -all -- ! $name . name
if {$variable == ""} then {
# There's no point to doing anything.
return
}
set n [$window index active]
if {$n == "none"} then {
set index ""
set _active {}
} elseif {[info exists _help_text($name,$n)]} then {
# Tag specified by index number.
set index $name,$n
set _active $name,$n
} elseif {! [catch {$window entrycget $n -label} label]
&& [info exists _help_text($name,$label)]} then {
# Tag specified by index name.
set index $name,$label
set _active $name,$label
} else {
# No help for this item.
set index ""
set _active {}
}
_set_variable $index
}
# This is run when some widget unmaps. If the widget is the current
# widget, then unmap the balloon help. Private method.
method _unmap w {
if {$w == $_active} then {
_cancel
_unshowballoon
_set_variable {}
set _active {}
}
}
}
################################################################
# Find (and possibly create) balloon widget associated with window.
proc BALLOON_find_balloon {window} {
# Find our associated toplevel. If it is a menu, then keep going.
set top [winfo toplevel $window]
while {[winfo class $top] == "Menu"} {
set top [winfo toplevel [winfo parent $top]]
}
if {$top == "."} {
set bname .__balloon
} else {
set bname $top.__balloon
}
# If the balloon help for this toplevel doesn't exist, then create
# it. Yes, this relies on a magic name for the balloon help widget.
if {! [winfo exists $bname]} then {
Balloon $bname $top
}
return $bname
}
# This implements "balloon register".
proc BALLOON_command_register {window text {tag {}}} {
set b [BALLOON_find_balloon $window]
$b register $window $text $tag
}
# This implements "balloon notify".
proc BALLOON_command_notify {command window {tag {}}} {
set b [BALLOON_find_balloon $window]
$b notify $command $window $tag
}
# This implements "balloon show".
proc BALLOON_command_show {window {tag {}} {keep 0}} {
set b [BALLOON_find_balloon $window]
$b showballoon $window $tag $keep
}
proc BALLOON_command_withdraw {window} {
set b [BALLOON_find_balloon $window]
$b _unmap $window
}
# This implements "balloon variable".
proc BALLOON_command_variable {window args} {
if {[llength $args] == 0} then {
# Fetch.
set b [BALLOON_find_balloon $window]
return [$b cget -variable]
} else {
# FIXME: no arg checking here.
# Set.
set b [BALLOON_find_balloon $window]
$b configure -variable [lindex $args 0]
}
}
# The primary interface to balloon help.
# Usage:
# balloon notify COMMAND WINDOW ?TAG?
# Run COMMAND just before the help text for WINDOW (and TAG, if
# given) is displayed. If COMMAND is the empty string, then
# notification is disabled for this window.
# balloon register WINDOW TEXT ?TAG?
# Associate TEXT as the balloon help for WINDOW.
# If TAG is given, the use the appropriate tag for association.
# For menu widgets, TAG is a menu index.
# For canvas widgets, TAG is a tagOrId.
# For text widgets, TAG is a text index. If you want to use
# the text tag FOO, use `FOO.last'.
# balloon show WINDOW ?TAG?
# Immediately pop up the balloon for the given window and tag.
# This should be used sparingly. For instance, you might need to
# use it if the tag you're interested in does not track the mouse,
# but instead is added just before show-time.
# balloon variable WINDOW ?NAME?
# If NAME specified, set balloon help variable associated
# with window. This variable is set to the text whenever the
# balloon help is on. If NAME is specified but empty,
# no variable is set. If NAME not specified, then the
# current variable name is returned.
# balloon withdraw WINDOW
# Withdraw the balloon window associated with WINDOW. This should
# be used sparingly.
proc balloon {key args} {
if {[info commands BALLOON_command_$key] == "" } then {
error "unrecognized key \"$key\""
}
eval BALLOON_command_$key $args
}

57
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/bbox.tcl Normal file
View file

@ -0,0 +1,57 @@
# bbox.tcl - Function for handling button box.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# Pass this proc a frame whose children are all buttons. It will put
# the children into the frame so that they look right on the current
# platform. On Windows this means that they are all the same width
# and have a uniform separation. (And currently on Unix it means this
# same thing, though that might change.)
proc standard_button_box {frame {horizontal 1}} {
# This is half the separation we want between the buttons. This
# number comes from the Windows UI "standards" manual.
set half_gap 2
set width 0
foreach button [winfo children $frame] {
set bw [winfo reqwidth $button]
if {$bw > $width} then {
set width $bw
}
}
incr width $half_gap
incr width $half_gap
if {$horizontal} then {
set i 1
} else {
set i 0
}
foreach button [winfo children $frame] {
if {$horizontal} then {
# We set the size via the grid, and not -width on the button.
# Why? Because in Tk -width has different units depending on the
# contents of the button. And worse, the font units don't really
# make sense when dealing with a proportional font.
grid $button -row 0 -column $i -sticky ew \
-padx $half_gap -pady $half_gap
grid columnconfigure $frame $i -weight 0 -minsize $width
} else {
grid $button -column 0 -row $i -sticky new \
-padx $half_gap -pady $half_gap
grid rowconfigure $frame $i -weight 0
}
incr i
}
if {$horizontal} then {
# Make the empty column 0 suck up all the space.
grid columnconfigure $frame 0 -weight 1
} else {
grid columnconfigure $frame 0 -minsize $width
# Make the last row suck up all the space.
incr i -1
grid rowconfigure $frame $i -weight 1
}
}

64
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/bgerror.tcl Normal file
View file

@ -0,0 +1,64 @@
# bgerror.tcl - Send bug report in response to uncaught Tcl error.
# Copyright (C) 1997, 1998, 1999 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
proc bgerror err {
global errorInfo errorCode
set info $errorInfo
set code $errorCode
# log the error to the debug window or file
dbug E $info
dbug E $code
set command [list tk_dialog .bgerrorDialog [gettext "GDB Error"] \
[format [gettext "Error: %s"] $err] \
error 0 [gettext "OK"]]
lappend command [gettext "Stack Trace"]
set value [eval $command]
if {$value == 0} {
return
}
set w .bgerrorTrace
catch {destroy $w}
toplevel $w -class ErrorTrace
wm minsize $w 1 1
wm title $w "Stack Trace for Error"
wm iconname $w "Stack Trace"
button $w.ok -text OK -command "destroy $w" -default active
text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \
-setgrid true -width 60 -height 20
scrollbar $w.scroll -relief sunken -command "$w.text yview"
pack $w.ok -side bottom -padx 3m -pady 2m
pack $w.scroll -side right -fill y
pack $w.text -side left -expand yes -fill both
$w.text insert 0.0 "errorCode is $errorCode"
$w.text insert 0.0 $info
$w.text mark set insert 0.0
bind $w <Return> "destroy $w"
bind $w.text <Return> "destroy $w; break"
# Center the window on the screen.
wm withdraw $w
update idletasks
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
# Be sure to release any grabs that might be present on the
# screen, since they could make it impossible for the user
# to interact with the stack trace.
if {[grab current .] != ""} {
grab release [grab current .]
}
}

88
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/bindings.tcl Normal file
View file

@ -0,0 +1,88 @@
# bindings.tcl - Procs to handle bindings.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# Reorder the bindtags so that the tag appears before the widget.
# Tries to preserve other relative orderings as much as possible. In
# particular, nothing changes if the widget is already after the tag.
proc bind_widget_after_tag {w tag} {
set seen_tag 0
set seen_widget 0
set new_list {}
foreach tag [bindtags $w] {
if {$tag == $tag} then {
lappend new_list $tag
if {$seen_widget} then {
lappend new_list $w
}
set seen_tag 1
} elseif {$tag == $w} then {
if {$seen_tag} then {
lappend new_list $tag
}
set seen_widget 1
} else {
lappend new_list $tag
}
}
if {! $seen_widget} then {
lappend new_list $w
}
bindtags $w $new_list
}
# Reorder the bindtags so that the class appears before the widget.
# Tries to preserve other relative orderings as much as possible. In
# particular, nothing changes if the widget is already after the
# class.
proc bind_widget_after_class {w} {
bind_widget_after_tag $w [winfo class $w]
}
# Make the specified binding for KEY and empty bindings for common
# modifiers for KEY. This can be used to ensure that a binding won't
# also be triggered by (eg) Alt-KEY. This proc also makes the binding
# case-insensitive. KEY is either the name of a key, or a key with a
# single modifier.
proc bind_plain_key {w key binding} {
set l [split $key -]
if {[llength $l] == 1} then {
set mod {}
set part $key
} else {
set mod "[lindex $l 0]-"
set part [lindex $l 1]
}
set modifiers {Meta- Alt- Control-}
set part_list [list $part]
# If we just have a single letter, then we can't look for
# Shift-PART; we must use the uppercase equivalent.
if {[string length $part] == 1} then {
# This is nasty: if we bind Control-L, we won't see the events we
# want. Instead we have to bind Shift-Control-L. Actually, we
# must also bind Control-L so that we'll see the event if the Caps
# Lock key is down.
if {$mod != ""} then {
lappend part_list "Shift-[string toupper $part]"
}
lappend part_list [string toupper $part]
} else {
lappend modifiers Shift-
}
foreach part $part_list {
# Bind the key itself (with modifier if required).
bind $w <${mod}${part}> $binding
# Ignore any modifiers other than the one we like.
foreach onemod $modifiers {
if {$onemod != $mod} then {
bind $w <${onemod}${part}> {;}
}
}
}
}

29
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/canvas.tcl Normal file
View file

@ -0,0 +1,29 @@
# canvas.tcl - Handy canvas-related commands.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# Set scroll region on canvas.
proc set_scroll_region {canvas} {
set bbox [$canvas bbox all]
if {[llength $bbox]} then {
set sr [lreplace $bbox 0 1 0 0]
} else {
set sr {0 0 0 0}
}
# Don't include borders in the scrollregion.
set delta [expr {2 * ([$canvas cget -borderwidth]
+ [$canvas cget -highlightthickness])}]
set ww [winfo width $canvas]
if {[lindex $sr 2] < $ww} then {
set sr [lreplace $sr 2 2 [expr {$ww - $delta}]]
}
set wh [winfo height $canvas]
if {[lindex $sr 3] < $wh} then {
set sr [lreplace $sr 3 3 [expr {$wh - $delta}]]
}
$canvas configure -scrollregion $sr
}

28
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/center.tcl Normal file
View file

@ -0,0 +1,28 @@
# center.tcl - Center a window on the screen or over another window
# Copyright (C) 1997, 1998, 2001 Red Hat, Inc.
# Written by Tom Tromey <tromey@cygnus.com>.
# Call this after the TOPLEVEL has been filled in, but before it has
# been mapped. This proc will center the toplevel on the screen or
# over another window.
proc center_window {top args} {
parse_args {{over ""}}
update idletasks
if {$over != ""} {
set cx [expr {int ([winfo rootx $over] + [winfo width $over] / 2)}]
set cy [expr {int ([winfo rooty $over] + [winfo height $over] / 2)}]
set x [expr {$cx - int ([winfo reqwidth $top] / 2)}]
set y [expr {$cy - int ([winfo reqheight $top] / 2)}]
} else {
set x [expr {int (([winfo screenwidth $top] - [winfo reqwidth $top]) / 2)}]
set y [expr {int (([winfo screenheight $top] - [winfo reqheight $top]) / 2)}]
}
wm geometry $top +${x}+${y}
wm positionfrom $top user
# We run this update here because Tk updates toplevel geometry
# (position) info in an idle handler on Windows, but doesn't force
# the handler to run before mapping the window.
update idletasks
}

146
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/cframe.tcl Normal file
View file

@ -0,0 +1,146 @@
# cframe.tcl - Frame controlled by checkbutton.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
itcl_class Checkframe {
inherit Widgetframe
# The checkbutton text.
public text {} {
_set_option -text $text 0
}
# This holds the last value of -variable. We use it to unset our
# trace when the variable changes (or is deleted). Private
# variable.
protected _saved_variable {}
# The checkbutton variable.
public variable {} {
_var_changed
}
# The checkbutton -onvalue.
public onvalue 1 {
_set_option -onvalue $onvalue
}
# The checkbutton -offvalue.
public offvalue 0 {
_set_option -offvalue $offvalue
}
# The checkbutton -command.
public command {} {
_set_option -command $command 0
}
# This holds balloon help for the checkbutton.
public help {} {
if {[winfo exists [namespace tail $this].check]} then {
balloon register [namespace tail $this].check $help
}
}
# This holds a list of all widgets which should be immune to
# enabling/disabling. Private variable.
protected _avoid {}
constructor {config} {
checkbutton [namespace tail $this].check -text $text -variable $variable -padx 2 \
-command $command -onvalue $onvalue -offvalue $offvalue
balloon register [namespace tail $this].check $help
_add [namespace tail $this].check
}
# Exempt a child from state changes. Argument EXEMPT is true if the
# child should be exempted, false if it should be re-enabled again.
# Public method.
method exempt {child {exempt 1}} {
if {$exempt} then {
if {[lsearch -exact $_avoid $child] == -1} then {
lappend _avoid $child
}
} else {
set _avoid [lremove $_avoid $child]
_set_visibility $child
}
}
# This is run when the state of the frame's children should change.
# Private method.
method _set_visibility {{child {}}} {
if {$variable == ""} then {
# No variable means everything is ok. The behavior here is
# arbitrary; this is a losing case.
set state normal
} else {
upvar \#0 $variable the_var
if {! [string compare $the_var $onvalue]} then {
set state normal
} else {
set state disabled
}
}
if {$child != ""} then {
$child configure -state $state
} else {
# FIXME: we force our logical children to be actual children of
# the frame. Instead we should ask the geometry manager what's
# going on.
set avoid(_) {}
unset avoid(_)
foreach child $_avoid {
set avoid($child) {}
}
foreach child [winfo children [namespace tail $this].iframe.frame] {
if {! [info exists avoid($child)]} then {
catch {$child configure -state $state}
}
}
}
}
# This is run to possibly update some option on the checkbutton.
# Private method.
method _set_option {option value {set_vis 1}} {
if {[winfo exists [namespace tail $this].check]} then {
[namespace tail $this].check configure $option $value
if {$set_vis} then {
_set_visibility
}
}
}
# This is run when our associated variable changes. We use the
# resulting information to set the state of our children. Private
# method.
method _trace {name1 name2 op} {
if {$op == "u"} then {
# The variable got deleted. So we stop looking at it.
uplevel \#0 [list trace vdelete $_saved_variable uw [list $this _trace]]
set _saved_variable {}
set variable {}
} else {
# Got a write.
_set_visibility
}
}
# This is run when the -variable changes. We remove our old trace
# (if there was one) and add a new trace (if we need to). Private
# method.
method _var_changed {} {
if {$_saved_variable != ""} then {
# Remove the old trace.
uplevel \#0 [list trace vdelete $_saved_variable uw [list $this _trace]]
}
set _saved_variable $variable
if {$variable != ""} then {
# Set a new trace.
uplevel \#0 [list trace variable $variable uw [list $this _trace]]
}
}
}

2195
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/combobox.tcl Normal file
View file

File diff suppressed because it is too large Load diff

765
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/debug.tcl Normal file
View file

@ -0,0 +1,765 @@
# -----------------------------------------------------------------------------
# NAME:
# ::debug
#
# DESC:
# This namespace implements general-purpose debugging functions
# to display information as a program runs. In addition, it
# includes profiling (derived from Sage 1.1) and tracing. For
# output it can write to files, stdout, or use a debug output
# window.
#
# NOTES:
# Output of profiler is compatible with sageview.
#
# -----------------------------------------------------------------------------
package provide debug 1.0
namespace eval ::debug {
namespace export debug dbug
variable VERSION 1.1
variable absolute
variable stack ""
variable outfile "trace.out"
variable watch 0
variable watchstart 0
variable debugwin ""
variable tracedVars
variable logfile ""
variable initialized 0
variable stoptrace 0
variable tracing 0
variable profiling 0
variable level 0
# here's where we'll store our collected profile data
namespace eval data {
variable entries
}
proc logfile {file} {
variable logfile
if {$logfile != "" && $logfile != "stdout" && $logfile != "stderr"} {
catch {close $logfile}
}
if {$file == ""} {
set logfile ""
} elseif {$file == "stdout" || $file == "stderr"} {
set logfile $file
} else {
set logfile [open $file w+]
fconfigure $logfile -buffering line -blocking 0
}
}
# ----------------------------------------------------------------------------
# NAME: debug::trace_var
# SYNOPSIS: debug::trace_var {varName mode}
# DESC: Sets up variable trace. When the trace is activated,
# debugging messages will be displayed.
# ARGS: varName - the variable name
# mode - one of more of the following letters
# r - read
# w - write
# u - unset
# -----------------------------------------------------------------------------
proc trace_var {varName mode} {
variable tracedVars
lappend tracedVars [list $varName $mode]
uplevel \#0 trace variable $varName $mode ::debug::touched_by
}
# ----------------------------------------------------------------------------
# NAME: debug::remove_trace
# SYNOPSIS: debug::remove_trace {var mode}
# DESC: Removes a trace set up with "trace_var".
# ----------------------------------------------------------------------------
proc remove_trace {var mode} {
uplevel \#0 trace vdelete $var $mode ::debug::touched_by
}
# ----------------------------------------------------------------------------
# NAME: debug::remove_all_traces
# SYNOPSIS: debug::remove_all_traces
# DESC: Removes all traces set up with "trace_var".
# ----------------------------------------------------------------------------
proc remove_all_traces {} {
variable tracedVars
if {[info exists tracedVars]} {
foreach {elem} $tracedVars {
eval remove_trace $elem
}
unset tracedVars
}
}
# ----------------------------------------------------------------------------
# NAME: debug::touched_by
# SYNOPSIS: debug::touched_by {v a m}
# DESC: Trace function used by trace_var. Currently writes standard
# debugging messages or priority "W".
# ARGS: v - variable
# a - array element or ""
# m - mode
# ----------------------------------------------------------------------------
proc touched_by {v a m} {
if {$a==""} {
upvar $v foo
dbug W "Variable $v touched in mode $m"
} else {
dbug W "Variable ${v}($a) touched in mode $m"
upvar $v($a) foo
}
dbug W "New value: $foo"
show_call_stack 2
}
# ----------------------------------------------------------------------------
# NAME: debug::show_call_stack
# SYNOPSIS: debug::show_call_stack {{start_decr 0}}
# DESC: Function used by trace_var to print stack trace. Currently
# writes standard debugging messages or priority "W".
# ARGS: start_decr - how many levels to go up to start trace
# ----------------------------------------------------------------------------
proc show_call_stack {{start_decr 0}} {
set depth [expr {[info level] - $start_decr}]
if {$depth == 0} {
dbug W "Called at global scope"
} else {
dbug W "Stack Trace follows:"
for {set i $depth} {$i > 0} {incr i -1} {
dbug W "Level $i: [info level $i]"
}
}
}
# ----------------------------------------------------------------------------
# NAME: debug::createData
# SYNOPSIS: createData { name }
# DESC: Basically creates a data structure for storing profiling
# information about a function.
# ARGS: name - unique (full) function name
# -----------------------------------------------------------------------------
proc createData {name} {
lappend data::entries $name
namespace eval data::$name {
variable totaltimes 0
variable activetime 0
variable proccounts 0
variable timers 0
variable timerstart 0
variable nest 0
}
}
proc debugwin {obj} {
variable debugwin
set debugwin $obj
}
# -----------------------------------------------------------------------------
# NAME: debug::debug
#
# SYNOPSIS: debug { {msg ""} }
#
# DESC: Writes a message to the proper output. The priority of the
# message is assumed to be "I" (informational). This function
# is provided for compatibility with the previous debug function.
# For higher priority messages, use dbug.
#
# ARGS: msg - Message to be displayed.
# -----------------------------------------------------------------------------
proc debug {{msg ""}} {
set cls [string trimleft [uplevel namespace current] :]
if {$cls == ""} {
set cls "global"
}
set i [expr {[info level] - 1}]
if {$i > 0} {
set func [lindex [info level $i] 0]
set i [string first "::" $func]
if {$i != -1} {
# itcl proc has class prepended to func
# strip it off because we already have class in $cls
set func [string range $func [expr {$i+2}] end]
}
} else {
set func ""
}
::debug::_putdebug I $cls $func $msg
}
# -----------------------------------------------------------------------------
# NAME: debug::dbug
#
# SYNOPSIS: dbug { level msg }
#
# DESC: Writes a message to the proper output. Unlike debug, this
# function take a priority level.
#
# ARGS: msg - Message to be displayed.
# level - One of the following:
# "I" - Informational only
# "W" - Warning
# "E" - Error
# "X" - Fatal Error
# -----------------------------------------------------------------------------
proc dbug {level msg} {
set cls [string trimleft [uplevel namespace current] :]
if {$cls == ""} {
set cls "global"
}
set i [expr {[info level] - 1}]
if {$i > 0} {
set func [lindex [info level $i] 0]
} else {
set func ""
}
::debug::_putdebug $level $cls $func $msg
}
# -----------------------------------------------------------------------------
# NAME: debug::_putdebug
#
# SYNOPSIS: _putdebug { level cls func msg }
#
# DESC: Writes a message to the proper output. Will write to a debug
# window if one is defined. Otherwise will write to stdout.
#
# ARGS: msg - Message to be displayed.
# cls - name of calling itcl class or "global"
# func - name of calling function
# level - One of the following:
# "I" - Informational only
# "W" - Warning
# "E" - Error
# "X" - Fatal Error
# -----------------------------------------------------------------------------
proc _putdebug {lev cls func msg} {
variable debugwin
variable logfile
if {$debugwin != ""} {
$debugwin puts $lev $cls $func $msg
}
if {$logfile == "stdout"} {
if {$func != ""} { append cls ::$func }
puts $logfile "$lev: ($cls) $msg"
} elseif {$logfile != ""} {
puts $logfile [concat [list $lev] [list $cls] [list $func] [list $msg]]
}
}
proc _puttrace {enter lev func {ar ""}} {
variable debugwin
variable logfile
variable stoptrace
variable tracing
if {!$tracing} { return }
set func [string trimleft $func :]
if {$func == "DebugWin::put_trace" || $func == "DebugWin::_buildwin"} {
if {$enter} {
incr stoptrace
} else {
incr stoptrace -1
}
}
if {$stoptrace == 0} {
incr stoptrace
# strip off leading function name
set ar [lrange $ar 1 end]
if {$debugwin != ""} {
$debugwin put_trace $enter $lev $func $ar
}
if {$logfile != ""} {
puts $logfile [concat {T} [list $enter] [list $lev] [list $func] \
[list $ar]]
}
incr stoptrace -1
}
}
# -----------------------------------------------------------------------------
# NAME: debug::init
# SYNOPSIS: init
# DESC: Installs hooks in all procs and methods to enable profiling
# and tracing.
# NOTES: Installing these hooks slows loading of the program. Running
# with the hooks installed will cause significant slowdown of
# program execution.
# -----------------------------------------------------------------------------
proc init {} {
variable VERSION
variable absolute
variable initialized
# create the arrays for the .global. level
createData .global.
# start the absolute timer
set absolute [clock clicks]
# rename waits, exit, and all the ways of declaring functions
rename ::vwait ::original_vwait
interp alias {} ::vwait {} [namespace current]::sagevwait
createData .wait.
rename ::tkwait ::original_tkwait
interp alias {} ::tkwait {} [namespace current]::sagetkwait
rename ::exit ::original_exit
interp alias {} ::exit {} [namespace current]::sageexit
rename ::proc ::original_proc
interp alias {} ::proc {} [namespace current]::sageproc
rename ::itcl::parser::method ::original_method
interp alias {} ::itcl::parser::method {} [namespace current]::sagemethod
rename ::itcl::parser::proc ::original_itclproc
interp alias {} ::itcl::parser::proc {} [namespace current]::sageitclproc
rename ::body ::original_itclbody
interp alias {} ::body {} [namespace current]::sageitclbody
# redefine core procs
# foreach p [uplevel \#0 info procs] {
# set args ""
# set default ""
# # get the list of args (some could be defaulted)
# foreach arg [info args $p] {
# if { [info default $p $arg default] } {
# lappend args [list $arg $default]
# } else {
# lappend args $arg
# }
# }
# uplevel \#0 proc [list $p] [list $args] [list [info body $p]]
#}
set initialized 1
resetWatch 0
procEntry .global.
startWatch
}
# -----------------------------------------------------------------------------
# NAME: ::debug::trace_start
# SYNOPSIS: ::debug::trace_start
# DESC: Starts logging of function trace information.
# -----------------------------------------------------------------------------
proc trace_start {} {
variable tracing
set tracing 1
}
# -----------------------------------------------------------------------------
# NAME: ::debug::trace_stop
# SYNOPSIS: ::debug::trace_stop
# DESC: Stops logging of function trace information.
# -----------------------------------------------------------------------------
proc trace_stop {} {
variable tracing
set tracing 0
}
# -----------------------------------------------------------------------------
# NAME: debug::sagetkwait
# SYNOPSIS: sagetkwait {args}
# DESC: A wrapper function around tkwait so we know how much time the
# program is spending in the wait state.
# ARGS: args - args to pass to tkwait
# ----------------------------------------------------------------------------
proc sagetkwait {args} {
# simulate going into the .wait. proc
stopWatch
procEntry .wait.
startWatch
uplevel ::original_tkwait $args
# simulate the exiting of this proc
stopWatch
procExit .wait.
startWatch
}
# ----------------------------------------------------------------------------
# NAME: debug::sagevwait
# SYNOPSIS: sagevwait {args}
# DESC: A wrapper function around vwait so we know how much time the
# program is spending in the wait state.
# ARGS: args - args to pass to vwait
# ----------------------------------------------------------------------------
proc sagevwait {args} {
# simulate going into the .wait. proc
stopWatch
procEntry .wait.
startWatch
uplevel ::original_vwait $args
# simulate the exiting of this proc
stopWatch
procExit .wait.
startWatch
}
# -----------------------------------------------------------------------------
# NAME: debug::sageexit
# SYNOPSIS: sageexit {{value 0}}
# DESC: A wrapper function around exit so we can turn off profiling
# and tracing before exiting.
# ARGS: value - value to pass to exit
# -----------------------------------------------------------------------------
proc sageexit {{value 0}} {
variable program_name GDBtk
variable program_args ""
variable absolute
# stop the stopwatch
stopWatch
set totaltime [getWatch]
# stop the absolute timer
set stop [clock clicks]
# unwind the stack and turn off everyone's timers
stackUnwind
# disengage the proc callbacks
::original_proc procEntry {name} {}
::original_proc procExit {name args} {}
::original_proc methodEntry {name} {}
::original_proc methodExit {name args} {}
set absolute [expr {$stop - $absolute}]
# get the sage overhead time
set sagetime [expr {$absolute - $totaltime}]
# save the data
variable outfile
variable VERSION
set f [open $outfile w]
puts $f "set VERSION {$VERSION}"
puts $f "set program_name {$program_name}"
puts $f "set program_args {$program_args}"
puts $f "set absolute $absolute"
puts $f "set sagetime $sagetime"
puts $f "set totaltime $totaltime"
foreach procname $data::entries {
set totaltimes($procname) [set data::${procname}::totaltimes]
set proccounts($procname) [set data::${procname}::proccounts]
set timers($procname) [set data::${procname}::timers]
}
puts $f "array set totaltimes {[array get totaltimes]}"
puts $f "array set proccounts {[array get proccounts]}"
puts $f "array set timers {[array get timers]}"
close $f
original_exit $value
}
proc sageproc {name args body} {
# stop the watch
stopWatch
# update the name to include the namespace if it doesn't have one already
if {[string range $name 0 1] != "::"} {
# get the namespace this proc is being defined in
set ns [uplevel namespace current]
if { $ns == "::" } {
set ns ""
}
set name ${ns}::$name
}
createData $name
# create the callbacks for proc entry and exit
set ns [namespace current]
set extra "${ns}::stopWatch;"
append extra "set __.__ {};trace variable __.__ u {${ns}::stopWatch;${ns}::procExit $name;${ns}::startWatch};"
append extra "[namespace current]::procEntry $name;"
append extra "[namespace current]::startWatch;"
set args [list $args]
set body [list [concat $extra $body]]
startWatch
# define the proc with our extra stuff snuck in
uplevel ::original_proc $name $args $body
}
proc sageitclbody {name args body} {
# stop the watch
stopWatch
if {$name == "iwidgets::Scrolledwidget::_scrollWidget"} {
# Hack. This causes too many problems for the scrolled debug window
# so just don't include it in the profile functions.
uplevel ::original_itclbody $name [list $args] [list $body]
return
}
set fullname $name
# update the name to include the namespace if it doesn't have one already
if {[string range $name 0 1] != "::"} {
# get the namespace this proc is being defined in
set ns [uplevel namespace current]
if { $ns == "::" } {
set ns ""
}
set fullname ${ns}::$name
}
createData $fullname
# create the callbacks for proc entry and exit
set ns [namespace current]
set extra "${ns}::stopWatch;"
append extra "set __.__ {};trace variable __.__ u {${ns}::stopWatch;${ns}::procExit $fullname;${ns}::startWatch};"
append extra "[namespace current]::procEntry $fullname;"
append extra "[namespace current]::startWatch;"
set args [list $args]
set body [list [concat $extra $body]]
startWatch
# define the proc with our extra stuff snuck in
uplevel ::original_itclbody $name $args $body
}
proc sageitclproc {name args} {
# stop the watch
stopWatch
set body [lindex $args 1]
set args [lindex $args 0]
if {$body == ""} {
set args [list $args]
set args [concat $args $body]
} else {
# create the callbacks for proc entry and exit
set ns [namespace current]
set extra "${ns}::stopWatch;"
append extra "set __.__ {};trace variable __.__ u {${ns}::stopWatch;${ns}::methodExit $name;${ns}::startWatch};"
append extra "[namespace current]::methodEntry $name;"
append extra "[namespace current]::startWatch;"
set args [list $args [concat $extra $body]]
}
startWatch
uplevel ::original_itclproc $name $args
}
proc sagemethod {name args} {
# stop the watch
stopWatch
set body [lindex $args 1]
set args [lindex $args 0]
if {[string index $body 0] == "@" || $body == ""} {
set args [list $args]
set args [concat $args $body]
} else {
# create the callbacks for proc entry and exit
set ns [namespace current]
set extra "${ns}::stopWatch;"
append extra "set __.__ {};trace variable __.__ u {${ns}::stopWatch;${ns}::methodExit $name;${ns}::startWatch};"
append extra "[namespace current]::methodEntry $name;"
append extra "[namespace current]::startWatch;"
set args [list $args [concat $extra $body]]
}
startWatch
uplevel ::original_method $name $args
}
proc push {v} {
variable stack
variable level
lappend stack $v
incr level
}
proc pop {} {
variable stack
variable level
set v [lindex $stack end]
set stack [lreplace $stack end end]
incr level -1
return $v
}
proc look {} {
variable stack
return [lindex $stack end]
}
proc stackUnwind {} {
# Now unwind all the stacked procs by calling procExit on each.
# It is OK to use procExit on methods because the full name
# was pushed on the stack
while { [set procname [look]] != "" } {
procExit $procname
}
}
# we need args because this is part of a trace callback
proc startWatch {args} {
variable watchstart
set watchstart [clock clicks]
}
proc resetWatch {value} {
variable watch
set watch $value
}
proc stopWatch {} {
variable watch
variable watchstart
set watch [expr {$watch + ([clock clicks] - $watchstart)}]
return $watch
}
proc getWatch {} {
variable watch
return $watch
}
proc startTimer {v} {
if { $v != "" } {
set data::${v}::timerstart [getWatch]
}
}
proc stopTimer {v} {
if { $v == "" } return
set stop [getWatch]
set data::${v}::timers [expr {[set data::${v}::timers] + ($stop - [set data::${v}::timerstart])}]
}
proc procEntry {procname} {
variable level
_puttrace 1 $level $procname [uplevel info level [uplevel info level]]
set time [getWatch]
# stop the timer of the caller
set caller [look]
stopTimer $caller
incr data::${procname}::proccounts
if { [set data::${procname}::nest] == 0 } {
set data::${procname}::activetime $time
}
incr data::${procname}::nest
# push this proc on the stack
push $procname
# start the timer for this
startTimer $procname
}
proc methodEntry {procname} {
variable level
set time [getWatch]
# stop the timer of the caller
set caller [look]
stopTimer $caller
# get the namespace this method is in
set ns [uplevel namespace current]
if { $ns == "::" } {
set ns ""
}
set name ${ns}::$procname
_puttrace 1 $level $name [uplevel info level [uplevel info level]]
if {![info exists data::${name}::proccounts]} {
createData $name
}
incr data::${name}::proccounts
if { [set data::${name}::nest] == 0 } {
set data::${name}::activetime $time
}
incr data::${name}::nest
# push this proc on the stack
push $name
# start the timer for this
startTimer $name
}
# we need the args because this is called from a vartrace handler
proc procExit {procname args} {
variable level
set time [getWatch]
# stop the timer of the proc
stopTimer [pop]
_puttrace 0 $level $procname
set r [incr data::${procname}::nest -1]
if { $r == 0 } {
set data::${procname}::totaltimes \
[expr {[set data::${procname}::totaltimes] \
+ ($time - [set data::${procname}::activetime])}]
}
# now restart the timer of the caller
startTimer [look]
}
proc methodExit {procname args} {
variable level
set time [getWatch]
# stop the timer of the proc
stopTimer [pop]
# get the namespace this method is in
set ns [uplevel namespace current]
if { $ns == "::" } {
set ns ""
}
set procname ${ns}::$procname
_puttrace 0 $level $procname
set r [incr data::${procname}::nest -1]
if { $r == 0 } {
set data::${procname}::totaltimes \
[expr {[set data::${procname}::totaltimes] \
+ ($time - [set data::${procname}::activetime])}]
}
# now restart the timer of the caller
startTimer [look]
}
}

29
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/def.tcl Normal file
View file

@ -0,0 +1,29 @@
# def.tcl - Definining commands.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# Define a global array.
proc defarray {name {value {}}} {
upvar \#0 $name ary
if {! [info exists ary]} then {
set ary(_) {}
unset ary(_)
array set ary $value
}
}
# Define a global variable.
proc defvar {name {value {}}} {
upvar \#0 $name var
if {! [info exists var]} then {
set var $value
}
}
# Define a "constant". For now this is just a pretty way to declare a
# global variable.
proc defconst {name value} {
upvar \#0 $name var
set var $value
}

26
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/font.tcl Normal file
View file

@ -0,0 +1,26 @@
# font.tcl - Font handling.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# This function is called whenever a font preference changes. We use
# this information to update the appropriate symbolic font.
proc FONT_track_change {symbolic prefname value} {
eval font configure [list $symbolic] $value
}
# Primary interface to font handling.
# define_font SYMBOLIC_NAME ARGS
# Define a new font, named SYMBOLIC_NAME. ARGS is the default font
# specification; it is a list of options such as those passed to `font
# create'.
proc define_font {symbolic args} {
# We do a little trick with the names here, by inserting `font' in
# the appropriate place in the name.
set split [split $symbolic /]
set name [join [linsert $split 1 font] /]
pref define $name $args
eval font create [list $symbolic] [pref get $name]
pref add_hook $name [list FONT_track_change $symbolic]
}

13
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/gensym.tcl Normal file
View file

@ -0,0 +1,13 @@
# gensym.tcl - Generate new symbols.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# Internal counter used to provide new symbol names.
defvar GENSYM_counter 0
# Return a new "symbol". This proc hopes that nobody else decides to
# use its prefix.
proc gensym {} {
global GENSYM_counter
return __gensym_symbol_[incr GENSYM_counter]
}

7
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/gettext.tcl Normal file
View file

@ -0,0 +1,7 @@
# gettext.tcl - some stubs
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
proc gettext {str} {
return $str
}

35
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/hooks.tcl Normal file
View file

@ -0,0 +1,35 @@
# hooks.tcl - Hook functions.
# Copyright (C) 1997, 1999 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
proc add_hook {hook command} {
upvar \#0 $hook var
lappend var $command
}
proc remove_hook {hook command} {
upvar \#0 $hook var
set var [lremove $var $command]
}
proc define_hook {hook} {
upvar \#0 $hook var
if {! [info exists var]} then {
set var {}
}
}
proc run_hooks {hook args} {
upvar \#0 $hook var
set mssg_list {}
foreach thunk $var {
if {[catch {uplevel \#0 $thunk $args} mssg]} {
set errStr "hook=$thunk args=\"$args\" $mssg\n"
lappend mssg_list $errStr
}
}
if {$mssg_list != ""} {
error $mssg_list
}
}

64
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/internet.tcl Normal file
View file

@ -0,0 +1,64 @@
#
# internet.tcl - tcl interface to various internet functions
#
# Copyright (C) 1998 Cygnus Solutions
#
# ------------------------------------------------------------------
# send_mail - send email
# ------------------------------------------------------------------
proc send_mail {to subject body} {
global tcl_platform
switch -- $tcl_platform(platform) {
windows {
ide_mapi simple-send $to $subject $body
}
unix {
exec echo $body | mail -s $subject $to &
}
default {
error "platform \"$tcl_platform(platform)\" not supported"
}
}
}
# ------------------------------------------------------------------
# open_url - open a URL in a browser
# Netscape must be available for Unix.
# ------------------------------------------------------------------
proc open_url {url} {
global tcl_platform
switch -- $tcl_platform(platform) {
windows {
ide_shell_execute open $url
# FIXME. can we detect errors?
}
unix {
if {[catch "exec netscape -remote [list openURL($url,new-window)]" result]} {
if {[string match {*not running on display*} $result]} {
# Netscape is not running. Try to start it.
if {[catch "exec netscape [list $url] &" result]} {
tk_dialog .warn "Netscape Error" "$result" error 0 Ok
return 0
}
} elseif {[string match {couldn't execute *} $result]} {
tk_dialog .warn "Netscape Error" "Cannot locate \"netscape\" on your system.\nIt must be installed and in your path." error 0 Ok
return 0
} else {
tk_dialog .warn "Netscape Error" "$result" error 0 Ok
return 0
}
}
}
default {
error "platform \"$tcl_platform(platform)\" not supported"
return 0
}
}
return 1
}

19
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/lframe.tcl Normal file
View file

@ -0,0 +1,19 @@
# lframe.tcl - Labelled frame widget.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
itcl_class Labelledframe {
inherit Widgetframe
# The label text.
public text {} {
if {[winfo exists [namespace tail $this].label]} then {
[namespace tail $this].label configure -text $text
}
}
constructor {config} {
label [namespace tail $this].label -text $text -padx 2
_add [namespace tail $this].label
}
}

83
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/list.tcl Normal file
View file

@ -0,0 +1,83 @@
# list.tcl - Some handy list procs.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# FIXME: some are from TclX; we should probably just use the C
# implementation that is in S-N.
proc lvarpush {listVar element {index 0}} {
upvar $listVar var
if {![info exists var]} then {
lappend var $element
} else {
set var [linsert $var $index $element]
}
}
proc lvarpop {listVar {index 0}} {
upvar $listVar var
set result [lindex $var $index]
# NOTE lreplace can fail if list is empty.
if {! [catch {lreplace $var $index $index} new]} then {
set var $new
}
return $result
}
proc lassign {list args} {
set len [expr {[llength $args] - 1}]
# Special-case last element: if LIST is longer than ARGS, assign a
# list of leftovers to the last variable.
if {[llength $list] - 1 > $len} then {
upvar [lindex $args $len] local
set local [lrange $list $len end]
incr len -1
}
while {$len >= 0} {
upvar [lindex $args $len] local
set local [lindex $list $len]
incr len -1
}
}
# Remove duplicates and sort list. ARGS are arguments to lsort, eg
# --increasing.
proc lrmdups {list args} {
set slist [eval lsort $args [list $list]]
set last [lvarpop slist]
set result [list $last]
foreach item $slist {
if {$item != $last} then {
set last $item
lappend result $item
}
}
return $result
}
proc lremove {list element} {
set index [lsearch -exact $list $element]
if {$index == -1} then {
return $list
}
return [lreplace $list $index $index]
}
# replace element with new element
proc lrep {list element new} {
set index [lsearch -exact $list $element]
if {$index == -1} {
return $list
}
return [lreplace $list $index $index $new]
}
# FIXME: this isn't precisely like the C lvarcat. It is slower.
proc lvarcat {listVar args} {
upvar $listVar var
if {[join $args] != ""} then {
# Yuck!
eval eval lappend var $args
}
}

53
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/looknfeel.tcl Normal file
View file

@ -0,0 +1,53 @@
# looknfeel.tcl - Standard look and feel decisions.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# Run this once just after Tk is initialized. It will do whatever
# setup is required to make the application conform to our look and
# feel.
proc standard_look_and_feel {} {
global tcl_platform
# FIXME: this is really gross: we know how tk_dialog chooses its
# -wraplength, and we make it bigger. Instead we should make our
# own dialog function.
option add *Dialog.msg.wrapLength 0 startupFile
# We don't ever want tearoffs.
option add *Menu.tearOff 0 startupFile
# The default font should be used by default.
# The bold font is like the default font, but is bold; use it for
# emphasis.
# The fixed font is guaranteed not to be proportional.
# The status font should be used in status bars and tooltips.
if {$tcl_platform(platform) == "windows"} then {
define_font global/default -family windows-message
# FIXME: this isn't actually a bold font...
define_font global/bold -family windows-caption
define_font global/fixed -family fixedsys
define_font global/status -family windows-status
# FIXME: we'd like this font to update automatically as well. But
# for now we can't.
array set actual [font actual windows-message]
set actual(-slant) italic
eval define_font global/italic [array get actual]
# The menu font used to be set via the "windows-menu"
# font family, however this seems to have been deprecated
# for Tcl/Tk version 8.3, so we hard code it instead.
define_font global/menu -family {MS Sans Serif} -size 8
} else {
set size 12
define_font global/default -family courier -size $size
define_font global/bold -family courier -size $size -weight bold
define_font global/fixed -family courier -size $size
define_font global/status -family helvetica -size [expr $size - 1]
define_font global/italic -family courier -size $size -slant italic
define_font global/menu -family helvetica -size $size
}
# Make sure this font is actually used by default.
option add *Font global/default
option add *Menu.Font global/menu
}

39
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/menu.tcl Normal file
View file

@ -0,0 +1,39 @@
# menu.tcl - Useful proc for dealing with menus.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# This proc computes the "desired width" of a menu. It can be used to
# determine the minimum width for a toplevel whose -menu option is
# set.
proc compute_menu_width {menu} {
set width 0
set last [$menu index end]
if {$last != "end"} then {
# Start at borderwidth, but also preserve borderwidth on the
# right.
incr width [expr {2 * [$menu cget -borderwidth]}]
set deffont [$menu cget -font]
set abw [expr {2 * [$menu cget -activeborderwidth]}]
for {set i 0} {$i <= $last} {incr i} {
if {[catch {$menu entrycget $i -font} font]} then {
continue
}
if {$font == ""} then {
set font $deffont
}
incr width [font measure $font [$menu entrycget $i -label]]
incr width $abw
# "10" was chosen by reading tkUnixMenu.c.
incr width 10
# This is arbitrary. Apparently I can't read tkUnixMenu.c well
# enough to understand why the naive calculation above doesn't
# work.
incr width 2
}
# Another hack.
incr width 2
}
return $width
}

14
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/mono.tcl Normal file
View file

@ -0,0 +1,14 @@
# mono.tcl - Dealing with monochrome.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# It is safe to run this any number of times, so it is ok to have it
# here. Defined as true if the user wants monochrome display.
pref define global/monochrome 0
# Return 1 if monochrome, 0 otherwise. This should be used to make
# the application experience more friendly for colorblind users as
# well as those stuck on mono displays.
proc monochrome_p {} {
return [expr {[pref get global/monochrome] || [winfo depth .] == 1}]
}

251
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/multibox.tcl Normal file
View file

@ -0,0 +1,251 @@
# multibox.tcl - Multi-column listbox.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# FIXME:
# * Should support sashes so user can repartition widget sizes.
# * Should support itemcget, itemconfigure.
itcl_class Multibox {
# The selection mode.
public selectmode browse {
_apply_all configure [list -selectmode $selectmode]
}
# The height.
public height 10 {
_apply_all configure [list -height $height]
}
# This is a list of all the listbox widgets we've created. Private
# variable.
protected _listboxen {}
# Tricky: take the class bindings for the Listbox widget and turn
# them into Multibox bindings that directly run our bindings. That
# way any binding on any of our children will automatically work the
# right way.
# FIXME: this loses if any Listbox bindings are added later.
# To really fix we need Uhler's change to support megawidgets.
foreach seq [bind Listbox] {
regsub -all -- %W [bind Listbox $seq] {[winfo parent %W]} sub
bind Multibox $seq $sub
}
constructor {config} {
# The standard widget-making trick.
set class [$this info class]
set hull [namespace tail $this]
set old_name $this
::rename $this $this-tmp-
::frame $hull -class $class -relief flat -borderwidth 0
::rename $hull $old_name-win-
::rename $this $old_name
scrollbar [namespace tail $this].vs -orient vertical
bind [namespace tail $this].vs <Destroy> [list $this delete]
grid rowconfigure [namespace tail $this] 0 -weight 0
grid rowconfigure [namespace tail $this] 1 -weight 1
}
destructor {
destroy $this
}
#
# Our interface.
#
# Add a new column.
method add {args} {
# The first array set sets up the default values, and the second
# overwrites with what the user wants.
array set opts {-width 20 -fix 0 -title Zardoz}
array set opts $args
set num [llength $_listboxen]
listbox [namespace tail $this].box$num -exportselection 0 -height $height \
-selectmode $selectmode -width $opts(-width)
if {$num == 0} then {
[namespace tail $this].box$num configure -yscrollcommand [list [namespace tail $this].vs set]
[namespace tail $this].vs configure -command [list $this yview]
}
label [namespace tail $this].label$num -text $opts(-title) -anchor w
# No more class bindings.
set tag_list [bindtags [namespace tail $this].box$num]
set index [lsearch -exact $tag_list Listbox]
bindtags [namespace tail $this].box$num [lreplace $tag_list $index $index Multibox]
grid [namespace tail $this].label$num -row 0 -column $num -sticky new
grid [namespace tail $this].box$num -row 1 -column $num -sticky news
if {$opts(-fix)} then {
grid columnconfigure [namespace tail $this] $num -weight 0 \
-minsize [winfo reqwidth [namespace tail $this].box$num]
} else {
grid columnconfigure [namespace tail $this] $num -weight 1
}
lappend _listboxen [namespace tail $this].box$num
# Move the scrollbar over.
incr num
grid [namespace tail $this].vs -row 1 -column $num -sticky nsw
grid columnconfigure [namespace tail $this] $num -weight 0
}
method configure {config} {}
# FIXME: should handle automatically.
method cget {option} {
switch -- $option {
-selectmode {
return $selectmode
}
-height {
return $height
}
default {
error "option $option not supported"
}
}
}
# FIXME: this isn't ideal. But we want to support adding bindings
# at least. A "bind" method might be better.
method get_boxes {} {
return $_listboxen
}
#
# Methods that duplicate Listbox interface.
#
method activate index {
_apply_all activate [list $index]
}
method bbox index {
error "bbox method not supported"
}
method curselection {} {
return [_apply_first curselection {}]
}
# FIXME: In itcl 1.5, can't have a method name "delete". Sigh.
method delete_hack {args} {
_apply_all delete $args
}
# Return some contents. We return each item as a list of the
# columns.
method get {first {last {}}} {
if {$last == ""} then {
set r {}
foreach l $_listboxen {
lappend r [$l get $first]
}
return $r
} else {
# We do things this way so that we don't have to specially
# handle the index "end".
foreach box $_listboxen {
set seen(var-$box) [$box get $first $last]
}
# Tricky: we use the array indices as variable names and the
# array values as values. This lets us "easily" construct the
# result lists.
set r {}
eval foreach [array get seen] {{
set elt {}
foreach box $_listboxen {
lappend elt [set var-$box]
}
lappend r $elt
}}
return $r
}
}
method index index {
return [_apply_first index [list $index]]
}
# Insert some items. Each new item is a list of items for all
# columns.
method insert {index args} {
if {[llength $args]} then {
set seen(_) {}
unset seen(_)
foreach value $args {
foreach columnvalue $value lname $_listboxen {
lappend seen($lname) $columnvalue
}
}
foreach box $_listboxen {
eval $box insert $index $seen($box)
}
}
}
method nearest y {
return [_apply_first nearest [list $y]]
}
method scan {option args} {
_apply_all scan $option $args
}
method see index {
_apply_all see [list $index]
}
method selection {option args} {
if {$option == "includes"} then {
return [_apply_first selection [concat $option $args]]
} else {
return [_apply_all selection [concat $option $args]]
}
}
method size {} {
return [_apply_first size {}]
}
method xview args {
error "xview method not supported"
}
method yview args {
if {! [llength $args]} then {
return [_apply_first yview {}]
} else {
return [_apply_all yview $args]
}
}
#
# Private methods.
#
# This applies METHOD to every listbox.
method _apply_all {method argList} {
foreach l $_listboxen {
eval $l $method $argList
}
}
# This applies METHOD to the first listbox, and returns the result.
method _apply_first {method argList} {
set l [lindex $_listboxen 0]
return [eval $l $method $argList]
}
}

136
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/pane.tcl Normal file
View file

@ -0,0 +1,136 @@
#
# Cygnus enhanced version of the iwidget Pane class
# ----------------------------------------------------------------------
# Implements a pane for a paned window widget. The pane is itself a
# frame with a child site for other widgets. The pane class performs
# basic option management.
#
# ----------------------------------------------------------------------
# AUTHOR: Mark L. Ulferts EMAIL: mulferts@austin.dsccc.com
#
# @(#) $Id: pane.tcl,v 1.2 1999/01/28 01:18:26 jingham Exp $
# ----------------------------------------------------------------------
# Copyright (c) 1995 DSC Technologies Corporation
# ======================================================================
# Permission to use, copy, modify, distribute and license this software
# and its documentation for any purpose, and without fee or written
# agreement with DSC, is hereby granted, provided that the above copyright
# notice appears in all copies and that both the copyright notice and
# warranty disclaimer below appear in supporting documentation, and that
# the names of DSC Technologies Corporation or DSC Communications
# Corporation not be used in advertising or publicity pertaining to the
# software without specific, written prior permission.
#
# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL
# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION,
# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
# SOFTWARE.
# ======================================================================
#
# Usual options.
#
itk::usual Pane {
keep -background -cursor
}
# ------------------------------------------------------------------
# PANE
# ------------------------------------------------------------------
itcl::class cyg::Pane {
inherit itk::Widget
constructor {args} {}
itk_option define -maximum maximum Maximum 0
itk_option define -minimum minimum Minimum 10
itk_option define -margin margin Margin 0
itk_option define -resizable resizable Resizable 1
public method childSite {} {}
}
#
# Provide a lowercased access method for the Pane class.
#
proc ::cyg::pane {pathName args} {
uplevel ::cyg::Pane $pathName $args
}
# ------------------------------------------------------------------
# CONSTRUCTOR
# ------------------------------------------------------------------
itcl::body cyg::Pane::constructor {args} {
#
# Create the pane childsite.
#
itk_component add childsite {
frame $itk_interior.childsite
} {
keep -background -cursor
}
pack $itk_component(childsite) -fill both -expand yes
#
# Set the itk_interior variable to be the childsite for derived
# classes.
#
set itk_interior $itk_component(childsite)
eval itk_initialize $args
}
# ------------------------------------------------------------------
# OPTIONS
# ------------------------------------------------------------------
# ------------------------------------------------------------------
# OPTION: -minimum
#
# Specifies the minimum size that the pane may reach.
# ------------------------------------------------------------------
itcl::configbody cyg::Pane::minimum {
set pixels [winfo pixels $itk_component(hull) $itk_option(-minimum)]
set $itk_option(-minimum) $pixels
}
# ------------------------------------------------------------------
# OPTION: -maximum
#
# Specifies the maximum size that the pane may reach.
# ------------------------------------------------------------------
itcl::configbody cyg::Pane::maximum {
set pixels [winfo pixels $itk_component(hull) $itk_option(-maximum)]
set $itk_option(-maximum) $pixels
}
# ------------------------------------------------------------------
# OPTION: -margin
#
# Specifies the border distance between the pane and pane contents.
# This is done by setting the borderwidth of the pane to the margin.
# ------------------------------------------------------------------
itcl::configbody cyg::Pane::margin {
set pixels [winfo pixels $itk_component(hull) $itk_option(-margin)]
set itk_option(-margin) $pixels
$itk_component(childsite) configure -borderwidth $itk_option(-margin)
}
# ------------------------------------------------------------------
# METHODS
# ------------------------------------------------------------------
# ------------------------------------------------------------------
# METHOD: childSite
#
# Return the pane child site path name.
# ------------------------------------------------------------------
itcl::body cyg::Pane::childSite {} {
return $itk_component(childsite)
}

875
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/panedwindow.tcl Normal file
View file

@ -0,0 +1,875 @@
#
# Panedwindow
# ----------------------------------------------------------------------
# Implements a very general panedwindow which allows for mixing resizable
# and non-resizable panes. It also allows limits to be set on individual
# pane sizes, both minimum and maximum.
#
# The look of this widget is much like Window, instead of the Motif-like
# iwidget panedwindow.
# ----------------------------------------------------------------------
# Portions of this code are originally from the iwidget panedwindow which
# is Copyright (c) 1995 DSC Technologies Corporation
itk::usual PanedWindow {
keep -background -cursor
}
# ------------------------------------------------------------------
# PANEDWINDOW
# ------------------------------------------------------------------
itcl::class cyg::PanedWindow {
inherit itk::Widget
constructor {args} {}
itk_option define -orient orient Orient horizontal
itk_option define -sashwidth sashWidth SashWidth 10
itk_option define -sashcolor sashColor SashColor gray
public {
method index {index}
method childsite {args}
method add {tag args}
method insert {index tag args}
method delete {index}
method hide {index}
method replace {pane1 pane2}
method show {index}
method paneconfigure {index args}
method reset {}
}
private {
method _eventHandler {width height}
method _startDrag {num}
method _endDrag {where num}
method _configDrag {where num}
method _handleDrag {where num}
method _moveSash {where num {dir ""}}
method _resizeArray {}
method _setActivePanes {}
method _calcPos {where num {dir ""}}
method _makeSashes {}
method _placeSash {i}
method _placePanes {{start 0} {end end} {forget 0}}
variable _initialized 0 ;# flag set when widget is first configured
variable _sashes {} ;# List of sashes.
# Pane information
variable _panes {} ;# List of panes.
variable _activePanes {} ;# List of active panes.
variable _where ;# Array of relative positions
variable _ploc ;# Array of pixel positions
variable _frac ;# Array of relative pane sizes
variable _pixels ;# Array of sizes in pixels for non-resizable panes
variable _max ;# Array of pane maximum locations
variable _min ;# Array of pane minimum locations
variable _pmin ;# Array of pane minimum size
variable _pmax ;# Array of pane maximum size
variable _dimension 0 ;# width or height of window
variable _dir "height" ;# resizable direction, "height" or "width"
variable _rPixels
variable _sashloc ;# Array of dist of sash from above/left.
variable _minsashmoved ;# Lowest sash moved during dragging.
variable _maxsashmoved ;# Highest sash moved during dragging.
variable _width 0 ;# hull's width.
variable _height 0 ;# hull's height.
variable _unique -1 ;# Unique number for pane names.
}
}
#
# Provide a lowercased access method for the PanedWindow class.
#
proc ::cyg::panedwindow {pathName args} {
uplevel ::cyg::PanedWindow $pathName $args
}
#
# Use option database to override default resources of base classes.
#
option add *PanedWindow.width 10 widgetDefault
option add *PanedWindow.height 10 widgetDefault
# ------------------------------------------------------------------
# CONSTRUCTOR
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::constructor {args} {
itk_option add hull.width hull.height
pack propagate $itk_component(hull) no
bind pw-config-$this <Configure> [code $this _eventHandler %w %h]
bindtags $itk_component(hull) \
[linsert [bindtags $itk_component(hull)] 0 pw-config-$this]
eval itk_initialize $args
}
# ------------------------------------------------------------------
# OPTIONS
# ------------------------------------------------------------------
# ------------------------------------------------------------------
# OPTION: -orient
#
# Specifies the orientation of the sashes. Once the paned window
# has been mapped, set the sash bindings and place the panes.
# ------------------------------------------------------------------
itcl::configbody cyg::PanedWindow::orient {
#puts "orient $_initialized"
if {$_initialized} {
set orient $itk_option(-orient)
if {$orient != "vertical" && $orient != "horizontal"} {
error "bad orientation option \"$itk_option(-orient)\":\
should be horizontal or vertical"
}
if {[string compare $orient "vertical"]} {
set _dimension $_height
set _dir "height"
} else {
set _dimension $_width
set _dir "width"
}
_resizeArray
_makeSashes
_placePanes 0 end 1
}
}
# ------------------------------------------------------------------
# OPTION: -sashwidth
#
# Specifies the width of the sash.
# ------------------------------------------------------------------
itcl::configbody cyg::PanedWindow::sashwidth {
set pixels [winfo pixels $itk_component(hull) $itk_option(-sashwidth)]
set itk_option(-sashwidth) $pixels
if {$_initialized} {
# FIXME
for {set i 1} {$i < [llength $_panes]} {incr i} {
$itk_component(sash$i) configure \
-width $itk_option(-sashwidth) -height $itk_option(-sashwidth) \
-borderwidth 2
}
for {set i 1} {$i < [llength $_panes]} {incr i} {
_placeSash $i
}
}
}
# ------------------------------------------------------------------
# OPTION: -sashcolor
#
# Specifies the color of the sash.
# ------------------------------------------------------------------
itcl::configbody cyg::PanedWindow::sashcolor {
if {$_initialized} {
for {set i 1} {$i < [llength $_panes]} {incr i} {
$itk_component(sash$i) configure -background $itk_option(-sashcolor)
}
}
}
# ------------------------------------------------------------------
# METHODS
# ------------------------------------------------------------------
# ------------------------------------------------------------------
# METHOD: index index
#
# Searches the panes in the paned window for the one with the
# requested tag, numerical index, or keyword "end". Returns the pane's
# numerical index if found, otherwise error.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::index {index} {
if {[llength $_panes] > 0} {
if {[regexp {(^[0-9]+$)} $index]} {
if {$index < [llength $_panes]} {
return $index
} else {
error "PanedWindow index \"$index\" is out of range"
}
} elseif {$index == "end"} {
return [expr [llength $_panes] - 1]
} else {
if {[set idx [lsearch $_panes $index]] != -1} {
return $idx
}
error "bad PanedWindow index \"$index\": must be number, end,\
or pattern"
}
} else {
error "PanedWindow \"$itk_component(hull)\" has no panes"
}
}
# ------------------------------------------------------------------
# METHOD: childsite ?index?
#
# Given an index return the specifc childsite path name. Invoked
# without an index return a list of all the child site panes. The
# list is ordered from the near side (left/top).
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::childsite {args} {
#puts "childsite $args ($_initialized)"
if {[llength $args] == 0} {
set children {}
foreach pane $_panes {
lappend children [$itk_component($pane) childSite]
}
return $children
} else {
set index [index [lindex $args 0]]
return [$itk_component([lindex $_panes $index]) childSite]
}
}
# ------------------------------------------------------------------
# METHOD: add tag ?option value option value ...?
#
# Add a new pane to the paned window to the far (right/bottom) side.
# The method takes additional options which are passed on to the
# pane constructor. These include -margin, and -minimum. The path
# of the pane is returned.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::add {tag args} {
itk_component add $tag {
eval cyg::Pane $itk_interior.pane[incr _unique] $args
} {
keep -background -cursor
}
lappend _panes $tag
lappend _activePanes $tag
reset
return $itk_component($tag)
}
# ------------------------------------------------------------------
# METHOD: insert index tag ?option value option value ...?
#
# Insert the specified pane in the paned window just before the one
# given by index. Any additional options which are passed on to the
# pane constructor. These include -margin, -minimum. The path of
# the pane is returned.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::insert {index tag args} {
itk_component add $tag {
eval cyg::Pane $itk_interior.pane[incr _unique] $args
} {
keep -background -cursor
}
set index [index $index]
set _panes [linsert $_panes $index $tag]
lappend _activePanes $tag
reset
return $itk_component($tag)
}
# ------------------------------------------------------------------
# METHOD: delete index
#
# Delete the specified pane.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::delete {index} {
set index [index $index]
set tag [lindex $_panes $index]
# remove the itk component
destroy $itk_component($tag)
# remove it from panes list
set _panes [lreplace $_panes $index $index]
# remove its _frac value
set ind [lsearch -exact $_activePanes $tag]
if {$ind != -1 && [info exists _frac($ind)]} {
unset _frac($ind)
}
# this will reset _activePane and resize things
reset
}
# ------------------------------------------------------------------
# METHOD: hide index
#
# Remove the specified pane from the paned window.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::hide {index} {
set index [index $index]
set tag [lindex $_panes $index]
if {[set idx [lsearch -exact $_activePanes $tag]] != -1} {
set _activePanes [lreplace $_activePanes $idx $idx]
if {[info exists _frac($idx)]} {unset _frac($idx)}
}
reset
}
itcl::body cyg::PanedWindow::replace {pane1 pane2} {
set ind1 [lsearch -exact $_activePanes $pane1]
if {$ind1 == -1} {
error "$pane1 is not an active pane name."
}
set ind2 [lsearch -exact $_panes $pane2]
if {$ind2 == -1} {
error "Pane $pane2 does not exist."
}
set _activePanes [lreplace $_activePanes $ind1 $ind1 $pane2]
_placePanes 0 $ind1 1
}
# ------------------------------------------------------------------
# METHOD: show index
#
# Display the specified pane in the paned window.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::show {index} {
set index [index $index]
set tag [lindex $_panes $index]
if {[lsearch -exact $_activePanes $tag] == -1} {
lappend _activePanes $tag
}
reset
}
# ------------------------------------------------------------------
# METHOD: paneconfigure index ?option? ?value option value ...?
#
# Configure a specified pane. This method allows configuration of
# panes from the PanedWindow level. The options may have any of the
# values accepted by the add method.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::paneconfigure {index args} {
set index [index $index]
set tag [lindex $_panes $index]
return [uplevel $itk_component($tag) configure $args]
}
# ------------------------------------------------------------------
# METHOD: reset
#
# Redisplay the panes based on the default percentages of the panes.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::reset {} {
if {$_initialized && [llength $_panes]} {
#puts RESET
_setActivePanes
_resizeArray
_makeSashes
_placePanes 0 end 1
}
}
# ------------------------------------------------------------------
# PRIVATE METHOD: _setActivePanes
#
# Resets the active pane list.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_setActivePanes {} {
set _prevActivePanes $_activePanes
set _activePanes {}
foreach pane $_panes {
if {[lsearch -exact $_prevActivePanes $pane] != -1} {
lappend _activePanes $pane
}
}
}
# ------------------------------------------------------------------
# PROTECTED METHOD: _eventHandler
#
# Performs operations necessary following a configure event. This
# includes placing the panes.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_eventHandler {width height} {
#puts "Event $width $height"
set _width $width
set _height $height
if {[string compare $itk_option(-orient) "vertical"]} {
set _dimension $_height
set _dir "height"
} else {
set _dimension $_width
set _dir "width"
}
if {$_initialized} {
_resizeArray
_placePanes
} else {
set _initialized 1
reset
}
}
# ------------------------------------------------------------------
# PRIVATE METHOD: _resizeArray
#
# Recalculates the sizes and positions of all the panes.
# This is only done at startup, when the window size changes, when
# a new pane is added, or the orientation is changed.
#
# _frac($i) contains:
# % of resizable space when pane$i is resizable
# _pixels($i) contains
# pixels when pane$i is not resizable
#
# _where($i) contains the relative position of the top of pane$i
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_resizeArray {} {
set numpanes 0
set _rPixels 0
set totalFrac 0.0
set numfreepanes 0
#puts "sresizeArray dim=$_dimension dir=$_dir"
# first pass. Count the number of resizable panes and
# the pixels reserved for non-resizable panes.
set i 0
foreach p $_activePanes {
set _resizable($i) [$itk_component($p) cget -resizable]
if {$_resizable($i)} {
# remember pane min and max
set _pmin($i) [$itk_component($p) cget -minimum]
set _pmax($i) [$itk_component($p) cget -maximum]
incr numpanes
if {[info exists _frac($i)]} {
# sum up all the percents
set totalFrac [expr $totalFrac + $_frac($i)]
} else {
# number of new windows not yet sized
incr numfreepanes
}
} else {
set _pixels($i) [winfo req$_dir $itk_component($p)]
set _pmin($i) $_pixels($i)
set _pmax($i) $_pixels($i)
incr _rPixels $_pixels($i)
}
incr i
}
set totalpanes $i
#puts "numpanes=$numpanes nfp=$numfreepanes _rPixels=$_rPixels totalFrac=$totalFrac"
if {$numfreepanes} {
# set size for the new window(s) to average size
if {$totalFrac > 0.0} {
set freepanesize [expr $totalFrac / ($numpanes - $numfreepanes)]
} else {
set freepanesize [expr 1.0 / $numpanes.0]
}
for {set i 0} {$i < $totalpanes} {incr i} {
if {$_resizable($i) && ![info exists _frac($i)]} {
set _frac($i) $freepanesize
set totalFrac [expr $totalFrac + $_frac($i)]
}
}
}
set done 0
while {!$done} {
# force to a reasonable value
if {$totalFrac <= 0.0} { set totalFrac 1.0 }
# scale the _frac array
if {$totalFrac > 1.01 || $totalFrac < 0.99} {
set cor [expr 1.0 / $totalFrac]
set totalFrac 0.0
for {set i 0} {$i < $totalpanes} {incr i} {
if {$_resizable($i)} {
set _frac($i) [expr $_frac($i) * $cor]
set totalFrac [expr $totalFrac + $_frac($i)]
}
}
}
# bounds checking; look for panes that are too small or too large
# if one is found, fix its size at the min or max and mark the
# window non-resizable. Adjust percents and try again.
set done 1
for {set i 0} {$i < $totalpanes} {incr i} {
if {$_resizable($i)} {
set _pixels($i) [expr int($_frac($i) * ($_dimension - $_rPixels.0))]
if {$_pixels($i) < $_pmin($i)} {
set _resizable($i) 0
set totalFrac [expr $totalFrac - $_frac($i)]
set _pixels($i) $_pmin($i)
incr _rPixels $_pixels($i)
set done 0
break
} elseif {$_pmax($i) && $_pixels($i) > $_pmax($i)} {
set _resizable($i) 0
set totalFrac [expr $totalFrac - $_frac($i)]
set _pixels($i) $_pmax($i)
incr _rPixels $_pixels($i)
set done 0
break
}
}
}
}
# Done adjusting. Now build pane position arrays. These are designed
# to minimize calculations while resizing.
# Note: position of sash $i = position of top of pane $i
# _where($i): relative (0.0 - 1.0) position of sash $i
# _ploc($i): position in pixels of sash $i
# _max($i): maximum position in pixels of sash $i (0 = no max)
set _where(0) 0.0
set _ploc(0) 0
set _max(0) 0
set _min(0) 0
# calculate the percentage of resizable space
set resizePerc [expr 1.0 - ($_rPixels.0 / $_dimension)]
# now set the pane positions
for {set i 1; set n 0} {$i < $totalpanes} {incr i; incr n} {
if {$_resizable($n)} {
set _where($i) [expr $_where($n) + ($_frac($n) * $resizePerc)]
} else {
set _where($i) [expr $_where($n) + [expr $_pixels($n).0 / $_dimension]]
}
set _ploc($i) [expr $_ploc($n) + $_pixels($n)]
set _max($i) [expr $_max($n) + $_pmax($n)]
if {($_max($n) == 0 || $_pmax($n) == 0) && $n != 0} {
set _max($i) 0
}
set _min($i) [expr $_min($n) + $_pmin($n)]
#puts "where($i)=$_where($i)"
#puts "ploc($i)=$_ploc($i)"
#puts "min($i)=$_min($i)"
#puts "pmin($i)=$_pmin($i)"
#puts "pmax($i)=$_pmax($i)"
#puts "pixels($i)=$_pixels($i)"
}
set _ploc($i) $_dimension
set _where($i) 1.0
# finally, starting at the bottom,
# check the _max and _min arrays
set _max($totalpanes) $_dimension
set _min($totalpanes) $_dimension
#puts "_max($totalpanes) = $_max($totalpanes)"
for {set i [expr $totalpanes - 1]} {$i > 0} {incr i -1} {
set n [expr $i + 1]
set m [expr $_max($n) - $_pmin($i)]
if {$_max($i) > $m || !$_max($i)} { set _max($i) $m }
if {$_pmax($i)} {
set m [expr $_min($n) - $_pmax($i)]
if {$_min($i) < $m} {set _min($i) $m }
}
#puts "$i $_max($i) $_min($i)"
}
}
# ------------------------------------------------------------------
# PROTECTED METHOD: _startDrag num
#
# Starts the sash drag and drop operation. At the start of the drag
# operation all the information is known as for the upper and lower
# limits for sash movement. The calculation is made at this time and
# stored in protected variables for later access during the drag
# handling routines.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_startDrag {num} {
#puts "startDrag $num"
set _minsashmoved $num
set _maxsashmoved $num
grab $itk_component(sash$num)
}
# ------------------------------------------------------------------
# PROTECTED METHOD: _endDrag where num
#
# Ends the sash drag and drop operation.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_endDrag {where num} {
#puts "endDrag $where $num"
grab release $itk_component(sash$num)
# set new _frac values
for {set i [expr $_minsashmoved-1]} {$i <= $_maxsashmoved} {incr i} {
set _frac($i) \
[expr ($_ploc([expr $i+1]).0 - $_ploc($i)) / ($_dimension - $_rPixels)]
}
}
# ------------------------------------------------------------------
# PROTECTED METHOD: _configDrag where num
#
# Configure action for sash.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_configDrag {where num} {
set _sashloc($num) $where
}
# ------------------------------------------------------------------
# PROTECTED METHOD: _handleDrag where num
#
# Motion action for sash.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_handleDrag {where num} {
#puts "handleDrag $where $num"
_moveSash [expr $where + $_sashloc($num)] $num
_placePanes [expr $_minsashmoved - 1] $_maxsashmoved
}
# ------------------------------------------------------------------
# PROTECTED METHOD: _moveSash where num
#
# Move the sash to the absolute pixel location
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_moveSash {where num {dir ""}} {
#puts "moveSash $where $num"
set _minsashmoved [expr ($_minsashmoved<$num)?$_minsashmoved:$num]
set _maxsashmoved [expr ($_maxsashmoved>$num)?$_maxsashmoved:$num]
_calcPos $where $num $dir
}
# ------------------------------------------------------------------
# PRIVATE METHOD: _calcPos where num
#
# Determines the new position for the sash. Make sure the position does
# not go past the minimum for the pane on each side of the sash.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_calcPos {where num {direction ""}} {
set dir [expr $where - $_ploc($num)]
#puts "calcPos $where $num $dir $direction"
if {$dir == 0} { return }
# simplify expressions by computing these now
set m [expr $num-1]
set p [expr $num+1]
# we have squeezed the pane below us to the limit
set lower1 [expr $_ploc($m) + $_pmin($m)]
set lower2 0
if {$_pmax($num)} {
# we have stretched the pane above us to the limit
set lower2 [expr $_ploc($p) - $_pmax($num)]
}
set upper1 9999 ;# just a large number
if {$_pmax($m)} {
# we have stretched the pane above us to the limit
set upper1 [expr $_ploc($m) + $_pmax($m)]
}
# we have squeezed the pane below us to the limit
set upper2 [expr $_ploc($p) - $_pmin($num)]
set done 0
#puts "lower1=$lower1 lower2=$lower2 _min($num)=$_min($num)"
#puts "upper1=$upper1 upper2=$upper2 _max($num)=$_max($num)"
if {$dir < 0 && $where > $_min($num)} {
if {$where < $lower2 && $direction != "down"} {
set done 1
if {$p == [llength $_activePanes]} {
set _ploc($num) $upper2
} else {
_moveSash [expr $where + $_pmax($num)] $p up
set _ploc($num) [expr $_ploc($p) - $_pmax($num)]
}
}
if {$where < $lower1 && $direction != "up"} {
set done 1
if {$num == 1} {
set _ploc($num) $lower1
} else {
_moveSash [expr $where - $_pmin($m)] $m down
set _ploc($num) [expr $_ploc($m) + $_pmin($m)]
}
}
} elseif {$dir > 0 && ($_max($num) == 0 || $where < $_max($num))} {
if {$where > $upper1 && $direction != "up"} {
set done 1
if {$num == 1} {
set _ploc($num) $upper1
} else {
_moveSash [expr $where - $_pmax($m)] $m down
set _ploc($num) [expr $_ploc($m) + $_pmax($m)]
}
}
if {$where > $upper2 && $direction != "down"} {
set done 1
if {$p == [llength $_activePanes]} {
set _ploc($num) $upper2
} else {
_moveSash [expr $where + $_pmin($num)] $p up
set _ploc($num) [expr $_ploc($p) - $_pmin($num)]
}
}
}
if {!$done} {
if {!($_max($num) > 0 && $where > $_max($num)) && $where >= $_min($num)} {
set _ploc($num) $where
}
}
set _where($num) [expr $_ploc($num).0 / $_dimension]
}
# ------------------------------------------------------------------
# PRIVATE METHOD: _makeSashes
#
# Removes any previous sashes and creates new ones.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_makeSashes {} {
#
# Remove any existing sashes.
#
foreach sash $_sashes {
destroy $itk_component($sash)
}
set _sashes {}
set skipped_first 0
#
# Create necessary number of sashes
#
for {set id 0} {$id < [llength $_activePanes]} {incr id} {
set p [lindex $_activePanes $id]
if {[$itk_component($p) cget -resizable]} {
if {$skipped_first == 0} {
# create the first sash when we see the 2nd resizable pane
incr skipped_first
} else {
# create sash
itk_component add sash$id {
frame $itk_interior.sash$id -relief raised \
-height $itk_option(-sashwidth) \
-width $itk_option(-sashwidth) \
-borderwidth 2
} {
keep -background
}
lappend _sashes sash$id
set com $itk_component(sash$id)
$com configure -background $itk_option(-sashcolor)
bind $com <Button-1> [code $this _startDrag $id]
switch $itk_option(-orient) {
vertical {
bind $com <B1-Motion> \
[code $this _handleDrag %x $id]
bind $com <B1-ButtonRelease-1> \
[code $this _endDrag %x $id]
bind $com <Configure> \
[code $this _configDrag %x $id]
# FIXME Windows should have a different cirsor
$com configure -cursor sb_h_double_arrow
}
horizontal {
bind $com <B1-Motion> \
[code $this _handleDrag %y $id]
bind $com <B1-ButtonRelease-1> \
[code $this _endDrag %y $id]
bind $com <Configure> \
[code $this _configDrag %y $id]
# FIXME Windows should have a different cirsor
$com configure -cursor sb_v_double_arrow
}
}
}
}
}
}
# ------------------------------------------------------------------
# PRIVATE METHOD: _placeSash i
#
# Places the position of the sash
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_placeSash {i} {
if {[string compare $itk_option(-orient) "vertical"]} {
place $itk_component(sash$i) -in $itk_component(hull) \
-x 0 -relwidth 1 -rely $_where($i) -anchor w \
-height $itk_option(-sashwidth)
} else {
place $itk_component(sash$i) -in $itk_component(hull) \
-y 0 -relheight 1 -relx $_where($i) -anchor n \
-width $itk_option(-sashwidth)
}
}
# ------------------------------------------------------------------
# PRIVATE METHOD: _placePanes
#
# Resets the panes of the window following movement of the sash.
# ------------------------------------------------------------------
itcl::body cyg::PanedWindow::_placePanes {{start 0} {end end} {forget 0}} {
#puts "placeplanes $start $end"
if {!$_initialized} {
return
}
if {$end=="end"} { set end [expr [llength $_activePanes] - 1] }
set _updatePanes [lrange $_activePanes $start $end]
if {$forget} {
if {$_updatePanes == $_activePanes} {
set _forgetPanes $_panes
} else {
set _forgetPanes $_updatePanes
}
foreach pane $_forgetPanes {
place forget $itk_component($pane)
}
}
if {[string compare $itk_option(-orient) "vertical"]} {
set i $start
foreach pane $_updatePanes {
place $itk_component($pane) -in $itk_component(hull) \
-x 0 -rely $_where($i) -relwidth 1 \
-relheight [expr $_where([expr $i + 1]) - $_where($i)]
incr i
}
} else {
set i $start
foreach pane $_updatePanes {
place $itk_component($pane) -in $itk_component(hull) \
-y 0 -relx $_where($i) -relheight 1 \
-relwidth [expr $_where([expr $i + 1]) - $_where($i)]
incr i
}
}
for {set i [expr $start+1]} {$i <= $end} {incr i} {
if {[lsearch -exact $_sashes sash$i] != -1} {
_placeSash $i
}
}
}

42
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/parse_args.tcl Normal file
View file

@ -0,0 +1,42 @@
# parse_args.tcl -- procedure for pulling in arguments
# parse_args takes in a set of arguments with defaults and examines
# the 'args' in the calling procedure to see what the arguments should
# be set to. Sets variables in the calling frame to the right values.
proc parse_args { argset } {
upvar args args
foreach argument $argset {
if {[llength $argument] == 1} {
# No default specified, so we assume that we should set
# the value to 1 if the arg is present and 0 if it's not.
# It is assumed that no value is given with the argument.
set result [lsearch -exact $args "-$argument"]
if {$result != -1} then {
uplevel 1 [list set $argument 1]
set args [lreplace $args $result $result]
} else {
uplevel 1 [list set $argument 0]
}
} elseif {[llength $argument] == 2} {
# There are two items in the argument. The second is a
# default value to use if the item is not present.
# Otherwise, the variable is set to whatever is provided
# after the item in the args.
set arg [lindex $argument 0]
set result [lsearch -exact $args "-[lindex $arg 0]"]
if {$result != -1} then {
uplevel 1 [list set $arg [lindex $args [expr $result+1]]]
set args [lreplace $args $result [expr $result+1]]
} else {
uplevel 1 [list set $arg [lindex $argument 1]]
}
} else {
error "Badly formatted argument \"$argument\" in argument set"
}
}
# The remaining args should be checked to see that they match the
# number of items expected to be passed into the procedure...
}

20
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/path.tcl Normal file
View file

@ -0,0 +1,20 @@
# path.tcl - Path-handling helpers.
# Copyright (C) 1998 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# This proc takes a possibly relative path and expands it to the
# corresponding fully qualified path. Additionally, on Windows the
# result is guaranteed to be in "long" form.
proc canonical_path {path} {
global tcl_platform
set r [file join [pwd] $path]
if {$tcl_platform(platform) == "windows"} then {
# This will fail if the file does not already exist.
if {! [catch {file attributes $r -longname} long]} then {
set r $long
}
}
return $r
}

12
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/pkgIndex.tcl Normal file
View file

@ -0,0 +1,12 @@
# 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 combobox 2.2.1 [list source [file join $dir combobox.tcl]]
package ifneeded debug 1.0 [list source [file join $dir debug.tcl]]

38
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/postghost.tcl Normal file
View file

@ -0,0 +1,38 @@
# postghost.tcl - Ghost a menu item at post time.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# Helper proc.
proc GHOST_helper {menu index predicate} {
if {[eval $predicate]} then {
set state normal
} else {
set state disabled
}
$menu entryconfigure $index -state $state
}
# Add a -postcommand to a menu. This is careful not to stomp other
# postcommands.
proc add_post_command {menu callback} {
set old [$menu cget -postcommand]
# We use a "\n" and not a ";" to separate so that people can put
# comments into their -postcommands without fear.
$menu configure -postcommand "$old\n$callback"
}
# Run this to make a menu item which ghosts or unghosts depending on a
# predicate that is run at menu-post time. The NO_CACHE option
# prevents the index from being looked up statically; this is useful
# if you want to use an entry name as the index and you have a very
# dynamic menu (ie one where the numeric index of a named item is not
# constant over time). If PREDICATE returns 0 at post time, then the
# item will be ghosted.
proc ghosting_menu_item {menu index predicate {no_cache 0}} {
if {! $no_cache} then {
set index [$menu index $index]
}
add_post_command $menu [list GHOST_helper $menu $index $predicate]
}

198
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/prefs.tcl Normal file
View file

@ -0,0 +1,198 @@
# prefs.tcl - Preference handling.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# KNOWN BUGS:
# * When we move to the next tcl/itcl, rewrite to use namespaces and
# possibly ensembles.
# Global state.
defarray PREFS_state {
inhibit-event 0
initialized 0
}
# This is called when a trace on some option fires. It makes sure the
# relevant handlers get run.
proc PREFS_run_handlers {name1 name2 op} {
upvar $name1 state
set option [lindex $name2 0]
global PREFS_state
# Notify everybody else unless we've inhibited event generation.
if {! $PREFS_state(inhibit-event) && $PREFS_state(ide_running)} then {
ide_property set preference/$option $state([list $option value]) global
}
# Run local handlers.
run_hooks PREFS_state([list $option handler]) $option \
$state([list $option value])
}
# This is run when we see a property event. It updates our internal
# state.
proc PREFS_handle_property_event {exists property value} {
global PREFS_state
# If it isn't a preference property, ignore it.
if {! [string match preference/* $property]} then {
return
}
# [string length preference/] == 11.
set name [string range $property 11 end]
if {$exists} then {
incr PREFS_state(inhibit-event)
set PREFS_state([list $name value]) $value
incr PREFS_state(inhibit-event) -1
} elseif {$PREFS_state(ide_running)} then {
# It doesn't make sense to remove a property that mirrors some
# preference. So disallow by immediately redefining. Use
# initialize and not set because several clients are likely to run
# this at once.
ide_property initialize preference/$name \
$PREFS_state([list $name value]) global
}
}
# pref define NAME DEFAULT
# Define a new option
# NAME is the option name
# DEFAULT is the default value of the option
proc PREFS_cmd_define {name default} {
global PREFS_state
# If the option has already been defined, do nothing.
if {[info exists PREFS_state([list $name value])]} then {
return
}
if {$PREFS_state(ide_running)} then {
# We only store the value in the database.
ide_property initialize preference/$name $default global
set default [ide_property get preference/$name]
}
# We set our internal state no matter what. It is harmless if our
# definition causes a property-set event.
set PREFS_state([list $name value]) $default
set PREFS_state([list $name handler]) {}
# Set up a variable trace so that the handlers can be run.
trace variable PREFS_state([list $name value]) w PREFS_run_handlers
}
# pref get NAME
# Return value of option NAME
proc PREFS_cmd_get {name} {
global PREFS_state
return $PREFS_state([list $name value])
}
# pref getd NAME
# Return value of option NAME
# or define it if necessary and return ""
proc PREFS_cmd_getd {name} {
global PREFS_state
PREFS_cmd_define $name ""
return [pref get $name]
}
# pref varname NAME
# Return name of global variable that represents option NAME
# This is suitable for (eg) a -variable option on a radiobutton
proc PREFS_cmd_varname {name} {
return PREFS_state([list $name value])
}
# pref set NAME VALUE
# Set the option NAME to VALUE
proc PREFS_cmd_set {name value} {
global PREFS_state
# For debugging purposes, make sure the preference has already been
# defined.
if {! [info exists PREFS_state([list $name value])]} then {
error "attempt to set undefined preference $name"
}
set PREFS_state([list $name value]) $value
}
# pref setd NAME VALUE
# Set the option NAME to VALUE
# or define NAME and set the default to VALUE
proc PREFS_cmd_setd {name value} {
global PREFS_state
if {[info exists PREFS_state([list $name value])]} then {
set PREFS_state([list $name value]) $value
} else {
PREFS_cmd_define $name $value
}
}
# pref add_hook NAME HOOK
# Add a command to the hook that is run when the preference name NAME
# changes. The command is run with the name of the changed option and
# the new value as arguments.
proc PREFS_cmd_add_hook {name hook} {
add_hook PREFS_state([list $name handler]) $hook
}
# pref remove_hook NAME HOOK
# Remove a command from the per-preference hook.
proc PREFS_cmd_remove_hook {name hook} {
remove_hook PREFS_state([list $name handler]) $hook
}
# pref init ?IDE_RUNNING?
# Initialize the preference module. IDE_RUNNING is an optional
# boolean argument. If 0, then the preference module will assume that
# it is not connected to the IDE backplane. The default is based on
# the global variable IDE_ENABLED.
proc PREFS_cmd_init {{ide_running "unset"}} {
global PREFS_state IDE_ENABLED
if {! $PREFS_state(initialized)} then {
if {$ide_running == "unset"} then {
if {[info exists IDE_ENABLED]} then {
set ide_running $IDE_ENABLED
} else {
set ide_running 0
}
}
set PREFS_state(initialized) 1
set PREFS_state(ide_running) $ide_running
if {$ide_running} then {
property add_hook "" PREFS_handle_property_event
}
}
}
# pref list
# Return a list of the names of all preferences defined by this
# application.
proc PREFS_cmd_list {} {
global PREFS_state
set list {}
foreach item [array names PREFS_state] {
if {[lindex $item 1] == "value"} then {
lappend list [lindex $item 0]
}
}
return $list
}
# The primary interface to all preference subcommands.
proc pref {dispatch args} {
if {[info commands PREFS_cmd_$dispatch] == ""} then {
error "unrecognized key \"$dispatch\""
}
eval PREFS_cmd_$dispatch $args
}

334
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/print.tcl Normal file
View file

@ -0,0 +1,334 @@
# print.tcl -- some procedures for dealing with printing. To print
# PostScript on Windows, tkmswin.dll will need to be present.
proc send_printer { args } {
global tcl_platform
parse_args {
{printer {}}
{outfile {}}
{parent {}}
ascii
file
}
if {[llength $args] == 0} {
error "No filename or data provided."
}
if {$ascii == 1} {
if {$tcl_platform(platform) == "windows"} then {
PRINT_windows_ascii -file $file -parent $parent [lindex $args 0]
} else {
send_printer_ascii -printer $printer -file $file \
-outfile $outfile [lindex $args 0]
}
return
}
if {$outfile != ""} {
if {$file} {
file copy [lindex 0 $args] $outfile
} else {
set F [open $outfile w]
puts $F [lindex 0 $args]
close $F
}
return
}
if {$tcl_platform(platform) == "windows"} then {
load tkmswin.dll
set cmd {tkmswin print -postscript}
if {$printer != ""} {
lappend cmd -printer $printer
}
if {$file} {
lappend cmd -file
}
lappend cmd [lindex $args 0]
eval $cmd
} else {
# Unix box, assume lpr, but if it fails try lp.
foreach prog {lpr lp} {
set cmd [list exec $prog]
if {$printer != ""} {
if {$prog == "lpr"} {
lappend cmd "-P$printer"
} else {
lappend cmd "-d$printer"
}
}
if {$file} {
lappend cmd "<"
} else {
lappend cmd "<<"
}
# tack on data or filename
lappend cmd [lindex $args 0]
# attempt to run the command, and exit if successful
if ![catch {eval $cmd} ret] {
return
}
}
error "Couldn't run either `lpr' or `lp' to print"
}
}
proc send_printer_ascii { args } {
global tcl_platform
parse_args {
{printer {}}
{outfile {}}
{file 0}
{font Courier}
{fontsize 10}
{pageheight 11}
{pagewidth 8.5}
{margin .5}
}
if {[llength $args] == 0} {
error "No filename or data provided."
}
if {$tcl_platform(platform) == "windows"} then {
PRINT_windows_ascii -file $file [lindex $args 0]
return
}
# convert the filename or data to ascii, and then send to the printer.
set inch 72
set pageheight [expr $pageheight*$inch]
set pagewidth [expr $pagewidth*$inch]
set margin [expr $margin*$inch]
set output "%!PS-Adobe-1.0\n"
append output "%%Creator: libgui ASCII-to-PS converter\n"
append output "%%DocumentFonts: $font\n"
append output "%%Pages: (atend)\n"
append output "/$font findfont $fontsize scalefont setfont\n"
append output "/M{moveto}def\n"
append output "/S{show}def\n"
set pages 1
set y [expr $pageheight-$margin-$fontsize]
if {$file == 1} {
set G [open [lindex $args 0] r]
set strlen [gets $G str]
} else {
# make sure that we end with a newline
set args [lindex $args 0]
append args "\n"
set strlen [string first "\n" $args]
if {$strlen != -1} {
set str [string range $args 0 [expr $strlen-1]]
set args [string range $args [expr $strlen+1] end]
}
}
while {$strlen != -1} {
if {$y < $margin} {
append output "showpage\n"
incr pages
set y [expr $pageheight-$margin-$fontsize]
}
regsub -all {[()\\]} $str {\\&} str
append output "$margin $y M ($str) S\n"
set y [expr $y-($fontsize+1)]
if {$file == 1} {
set strlen [gets $G str]
} else {
set strlen [string first "\n" $args]
if {$strlen != -1} {
set str [string range $args 0 [expr $strlen-1]]
set args [string range $args [expr $strlen+1] end]
}
}
}
append output "showpage\n"
append output "%%Pages: $pages\n"
if {$file == 1} {
close $G
}
send_printer -printer $printer -outfile $outfile $output
}
# Print ASCII text on Windows.
proc PRINT_windows_ascii { args } {
global tcl_platform errorInfo
global PRINT_state
parse_args {
{file 0}
{parent {}}
}
if {[llength $args] == 0} {
error "No filename or data provided."
}
if {$tcl_platform(platform) != "windows"} then {
error "Only works on Windows"
}
# Copied from tk_dialog, except that it returns.
catch {destroy .cancelprint}
toplevel .cancelprint -class Dialog
wm withdraw .cancelprint
wm title .cancelprint [gettext "Printing"]
frame .cancelprint.bot
frame .cancelprint.top
pack .cancelprint.bot -side bottom -fill both
pack .cancelprint.top -side top -fill both -expand 1
set PRINT_state(pageno) [format [gettext "Now printing page %d"] 0]
label .cancelprint.msg -justify left -textvariable PRINT_state(pageno)
pack .cancelprint.msg -in .cancelprint.top -side right -expand 1 \
-fill both -padx 1i -pady 5
button .cancelprint.button -text [gettext "Cancel"] \
-command { ide_winprint abort } -default active
grid .cancelprint.button -in .cancelprint.bot -column 0 -row 0 \
-sticky ew -padx 10
grid columnconfigure .cancelprint.bot 0
update idletasks
set x [expr [winfo screenwidth .cancelprint]/2 \
- [winfo reqwidth .cancelprint]/2 \
- [winfo vrootx [winfo parent .cancelprint]]]
set y [expr [winfo screenheight .cancelprint]/2 \
- [winfo reqheight .cancelprint]/2 \
- [winfo vrooty [winfo parent .cancelprint]]]
wm geom .cancelprint +$x+$y
update
# We're going to change the focus and the grab as soon as we start
# printing, so remember them now.
set oldFocus [focus]
set oldGrab [grab current .cancelprint]
if {$oldGrab != ""} then {
set grabStatus [grab status $oldGrab]
}
focus .cancelprint.button
set PRINT_state(start) 1
set PRINT_state(file) $file
if {$file == 1} then {
set PRINT_state(fp) [open [lindex $args 0] r]
} else {
set PRINT_state(text) [lindex $args 0]
}
set cmd [list ide_winprint print_text PRINT_query PRINT_text \
-pageproc PRINT_page]
if {$parent != {}} then {
lappend cmd -parent $parent
}
set code [catch $cmd errmsg]
set errinfo $errorInfo
catch { focus $oldFocus }
catch { destroy .cancelprint }
if {$oldGrab != ""} then {
if {$grabStatus == "global"} then {
grab -global $oldGrab
} else {
grab $oldGrab
}
}
if {$code == 1} then {
error $errmsg $errinfo
}
}
# The query procedure passed to ide_winprint print_text. This should
# return one of "continue", "done", or "newpage".
proc PRINT_query { } {
global PRINT_state
# Fetch the next line into PRINT_state(str).
if {$PRINT_state(file) == 1} then {
set strlen [gets $PRINT_state(fp) PRINT_state(str)]
} else {
set strlen [string first "\n" $PRINT_state(text)]
if {$strlen != -1} then {
set PRINT_state(str) \
[string range $PRINT_state(text) 0 [expr $strlen-1]]
set PRINT_state(text) \
[string range $PRINT_state(text) [expr $strlen+1] end]
} else {
if {$PRINT_state(text) != ""} then {
set strlen 0
set PRINT_state(str) $PRINT_state(text)
set PRINT_state(text) ""
}
}
}
if {$strlen != -1} then {
# Expand tabs assuming tabstops every 8 spaces and a fixed
# pitch font. Text written to other assumptions will have to
# be handled by the caller.
set str $PRINT_state(str)
while {[set i [string first "\t" $str]] >= 0} {
set c [expr 8 - ($i % 8)]
set spaces ""
while {$c > 0} {
set spaces "$spaces "
incr c -1
}
set str "[string range $str 0 [expr $i - 1]]$spaces[string range $str [expr $i + 1] end]"
}
set PRINT_state(str) $str
return "continue"
} else {
return "done"
}
}
# The text procedure passed to ide_winprint print_text. This should
# return the next line to print.
proc PRINT_text { } {
global PRINT_state
return $PRINT_state(str)
}
# This page procedure passed to ide_winprint print_text. This is
# called at the start of each page.
proc PRINT_page { pageno } {
global PRINT_state
set PRINT_state(pageno) [format [gettext "Now printing page %d"] $pageno]
if {$PRINT_state(start)} then {
wm deiconify .cancelprint
grab .cancelprint
focus .cancelprint.button
set PRINT_state(start) 0
}
update
return "continue"
}

348
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/sendpr.tcl Normal file
View file

@ -0,0 +1,348 @@
# sendpr.tcl - GUI to send-pr.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# FIXME:
# * consider adding ability to set various options from outside,
# eg via the configure method.
# * Have explanatory text at the top
# * if synopsis not set, don't allow PR to be sent
# * at least one text field must have text in it before PR can be sent
# * see other fixme comments in text.
# FIXME: shouldn't have global variable.
defarray SENDPR_state
itcl_class Sendpr {
inherit Ide_window
# This array holds information about this site. It is a private
# common array. Once initialized it is never changed.
common _site
# Initialize the _site array.
global Paths tcl_platform
# On Windows, there is no `send-pr' program. For now, we just
# hard-code things there to work in the most important case.
if {$tcl_platform(platform) == "windows"} then {
set _site(header) ""
set _site(to) bugs@cygnus.com
set _site(field,Submitter-Id) cygnus
set _site(field,Originator) Nobody
set _site(field,Release) "Internal"
set _site(field,Organization) "Red Hat, Inc."
set _site(field,Environment) ""
foreach item {byteOrder machine os osVersion platform} {
append _site(field,Environment) "$item = $tcl_platform($item)\n"
}
set _site(categories) foundry
} else {
set _site(sendpr) [file join $Paths(bindir) send-pr]
# If it doesn't exist, try the user's path. This is a hack for
# developers.
if {! [file exists $_site(sendpr)]} then {
set _site(sendpr) send-pr
}
set _site(header) {}
set outList [split [exec $_site(sendpr) -P] \n]
set lastField {}
foreach line $outList {
if {[string match SEND-PR* $line]} then {
# Nothing.
} elseif {[regexp {^$} $line] || [regexp "^\[ \t\]" $line]} then {
# Empty lines and lines starting with a blank are skipped.
} elseif {$lastField == "" &&
[regexp [format {^[^>]([^:]+):[ %s]+(.+)$} \t] \
$line dummy field value]} then {
# A non-empty mail header line. This can only occur when there
# is no last field.
if {[string tolower $field] == "to"} then {
set _site(to) $value
}
} elseif {[regexp {^>([^:]*):(.*)$} $line dummy field value]} then {
# Found a field. Set it.
set lastField $field
if {$value != "" && ![string match <*> [string trim $value]]} then {
set _site(field,$lastField) $value
}
} elseif {$lastField == ""} then {
# No last field.
} else {
# Stuff into last field.
if {[info exists _site(field,$lastField)]} then {
append _site(field,$lastField) \n
}
append _site(field,$lastField) $line
}
}
# Now find the categories.
regsub -all -- {[()\"]} [exec $_site(sendpr) -CL] \
"" _site(categories)
set _site(categories) [lrmdups [concat foundry $_site(categories)]]
}
# Internationalize some text. We have to do this because of how
# Tk's optionmenu works. Indices here are the names that GNATS
# wants; this is important.
set _site(sw-bug) [gettext "Software bug"]
set _site(doc-bug) [gettext "Documentation bug"]
set _site(change-request) [gettext "Change request"]
set _site(support) [gettext "Support"]
set _site(non-critical) [gettext "Non-critical"]
set _site(serious) [gettext "Serious"]
set _site(critical) [gettext "Critical"]
set _site(low) [gettext "Low"]
set _site(medium) [gettext "Medium"]
set _site(high) [gettext "High"]
# Any text passed to constructor is saved and put into Description
# section of output.
constructor {{text ""}} {
Ide_window::constructor [gettext "Report Bug"]
} {
global SENDPR_state
# The standard widget-making trick.
set class [$this info class]
set hull [namespace tail $this]
set old_name $this
::rename $this $this-tmp-
# For now always make a toplevel. Number 7 comes from Windows
::rename $hull $old_name-win-
::rename $this $old_name
::rename $this $this-win-
::rename $this-tmp- $this
wm withdraw [namespace tail $this]
###FIXME - this constructor callout will cause the parent constructor to be called twice
::set SENDPR_state($this,desc) $text
#
# The Classification frame.
#
Labelledframe [namespace tail $this].cframe -text [gettext "Classification"]
set parent [[namespace tail $this].cframe get_frame]
tixComboBox $parent.category -dropdown 1 -editable 0 \
-label [gettext "Category"] -variable SENDPR_state($this,category)
foreach item $_site(categories) {
$parent.category insert end $item
}
# FIXME: allow user of this class to set default category.
::set SENDPR_state($this,category) foundry
::set SENDPR_state($this,secret) no
checkbutton $parent.secret -text [gettext "Confidential"] \
-variable SENDPR_state($this,secret) -onvalue yes -offvalue no \
-anchor w
# FIXME: put labels on these?
set m1 [_make_omenu $parent.class class 0 \
sw-bug doc-bug change-request support]
set m2 [_make_omenu $parent.severity severity 1 \
non-critical serious critical]
set m3 [_make_omenu $parent.priority priority 1 \
low medium high]
if {$m1 > $m2} then {
set m2 $m1
}
if {$m2 > $m3} then {
set m3 $m2
}
$parent.class configure -width $m3
$parent.severity configure -width $m3
$parent.priority configure -width $m3
grid $parent.category $parent.severity -sticky nw -padx 2
grid $parent.secret $parent.class -sticky nw -padx 2
grid x $parent.priority -sticky nw -padx 2
#
# The text and entry frames.
#
Labelledframe [namespace tail $this].synopsis -text [gettext "Synopsis"]
set parent [[namespace tail $this].synopsis get_frame]
entry $parent.synopsis -textvariable SENDPR_state($this,synopsis)
pack $parent.synopsis -expand 1 -fill both
# Text fields. Each is wrapped in its own label frame.
# We decided to eliminate all the frames but one; the others are
# just confusing.
::set SENDPR_state($this,repeat) [_make_text [namespace tail $this].desc \
[gettext "Description"]]
# Some buttons.
frame [namespace tail $this].buttons -borderwidth 0 -relief flat
button [namespace tail $this].buttons.send -text [gettext "Send"] \
-command [list $this _send]
button [namespace tail $this].buttons.cancel -text [gettext "Cancel"] \
-command [list destroy $this]
button [namespace tail $this].buttons.help -text [gettext "Help"] -state disabled
standard_button_box [namespace tail $this].buttons
# FIXME: we'd really like to have sashes between the text widgets.
# iwidgets or tix will provide that for us.
grid [namespace tail $this].cframe -sticky ew -padx 4 -pady 4
grid [namespace tail $this].synopsis -sticky ew -padx 4 -pady 4
grid [namespace tail $this].desc -sticky news -padx 4 -pady 4
grid [namespace tail $this].buttons -sticky ew -padx 4
grid rowconfigure [namespace tail $this] 0 -weight 0
grid rowconfigure [namespace tail $this] 1 -weight 0
grid rowconfigure [namespace tail $this] 2 -weight 1
grid rowconfigure [namespace tail $this] 3 -weight 1
grid columnconfigure [namespace tail $this] 0 -weight 1
bind [namespace tail $this].buttons <Destroy> [list $this delete]
wm deiconify [namespace tail $this]
}
destructor {
global SENDPR_state
foreach item [array names SENDPR_state $this,*] {
::unset SENDPR_state($item)
}
catch {destroy $this}
}
method configure {config} {}
# Create an optionmenu and fill it. Also, go through all the items
# and find the one that makes the menubutton the widest. Return the
# max width. Private method.
method _make_omenu {name index def_index args} {
global SENDPR_state
set max 0
set values {}
# FIXME: we can't actually examine which one makes the menubutton
# widest. Why not? Because the menubutton's -width option is in
# characters, but we can only look at the width in pixels.
foreach item $args {
lappend values $_site($item)
if {[string length $_site($item)] > $max} then {
set max [string length $_site($item)]
}
}
eval tk_optionMenu $name SENDPR_state($this,$index) $values
::set SENDPR_state($this,$index) $_site([lindex $args $def_index])
return $max
}
# Create a labelled frame and put a text widget in it. Private
# method.
method _make_text {name text} {
Labelledframe $name -text $text
set parent [$name get_frame]
text $parent.text -width 80 -height 15 -wrap word \
-yscrollcommand [list $parent.vb set]
scrollbar $parent.vb -orient vertical -command [list $parent.text yview]
grid $parent.text -sticky news
grid $parent.vb -row 0 -column 1 -sticky ns
grid rowconfigure $parent 0 -weight 1
grid columnconfigure $parent 0 -weight 1
grid columnconfigure $parent 1 -weight 0
return $parent.text
}
# This takes a text string and finds the element of site which has
# the same value. It returns the corresponding key. Private
# method.
method _invert {text values} {
foreach item $values {
if {$_site($item) == $text} then {
return $item
}
}
error "couldn't find \"$text\""
}
# Send the PR. Private method.
method _send {} {
global SENDPR_state
set email {}
if {[info exists _site(field,Submitter-Id)]} then {
set _site(field,Customer-Id) $_site(field,Submitter-Id)
unset _site(field,Submitter-Id)
}
foreach field {Customer-Id Originator Release} {
append email ">$field: $_site(field,$field)\n"
}
foreach field {Organization Environment} {
append email ">$field:\n$_site(field,$field)\n"
}
append email ">Confidential: "
if {$SENDPR_state($this,secret)} then {
append email yes\n
} else {
append email no\n
}
append email ">Synopsis: $SENDPR_state($this,synopsis)\n"
foreach field {Severity Priority Class} \
values {{non-critical serious critical} {low medium high}
{sw-bug doc-bug change-request support}} {
set name [string tolower $field]
set value [_invert $SENDPR_state($this,$name) $values]
append email ">$field: $value\n"
}
append email ">Category: $SENDPR_state($this,category)\n"
# Now big things.
append email ">How-To-Repeat:\n"
append email "[$SENDPR_state($this,repeat) get 1.0 end]\n"
# This isn't displayed to the user, but can be set by the caller.
append email ">Description:\n$SENDPR_state($this,desc)\n"
send_mail $_site(to) $SENDPR_state($this,synopsis) $email
destroy $this
}
# Override from Ide_window.
method idew_save {} {
global SENDPR_state
foreach name {category secret severity priority class synopsis} {
set result($name) $SENDPR_state($this,$name)
}
# Stop just before `end'; otherwise we add a newline each time.
set result(repeat) [$SENDPR_state($this,repeat) get 1.0 {end - 1c}]
set result(desc) $SENDPR_state($this,desc)
return [list Sendpr :: _restore [array get result]]
}
# This is used to restore a bug report window. Private proc.
proc _restore {alist x y width height visibility} {
global SENDPR_state
array set values $alist
set name .[gensym]
Sendpr $name $values(desc)
foreach name {category secret severity priority class synopsis} {
::set $SENDPR_state($this,$name) $values($name)
}
$SENDPR_state($name,repeat) insert end $desc
$name idew_set_geometry $x $y $width $height
$name idew_set_visibility $visibility
}
}

180
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/tclIndex Normal file
View file

@ -0,0 +1,180 @@
# 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(ADVICE_do) [list source [file join $dir advice.tcl]]
set auto_index(advise) [list source [file join $dir advice.tcl]]
set auto_index(unadvise) [list source [file join $dir advice.tcl]]
set auto_index(Balloon) [list source [file join $dir balloon.tcl]]
set auto_index(BALLOON_find_balloon) [list source [file join $dir balloon.tcl]]
set auto_index(BALLOON_command_register) [list source [file join $dir balloon.tcl]]
set auto_index(BALLOON_command_notify) [list source [file join $dir balloon.tcl]]
set auto_index(BALLOON_command_show) [list source [file join $dir balloon.tcl]]
set auto_index(BALLOON_command_withdraw) [list source [file join $dir balloon.tcl]]
set auto_index(BALLOON_command_variable) [list source [file join $dir balloon.tcl]]
set auto_index(balloon) [list source [file join $dir balloon.tcl]]
set auto_index(standard_button_box) [list source [file join $dir bbox.tcl]]
set auto_index(bgerror) [list source [file join $dir bgerror.tcl]]
set auto_index(bind_widget_after_tag) [list source [file join $dir bindings.tcl]]
set auto_index(bind_widget_after_class) [list source [file join $dir bindings.tcl]]
set auto_index(bind_plain_key) [list source [file join $dir bindings.tcl]]
set auto_index(set_scroll_region) [list source [file join $dir canvas.tcl]]
set auto_index(center_window) [list source [file join $dir center.tcl]]
set auto_index(Checkframe) [list source [file join $dir cframe.tcl]]
set auto_index(::combobox::combobox) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::build) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::setBindings) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::handleEvent) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::destroyHandler) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::find) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::select) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::computeGeometry) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::doInternalWidgetCommand) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::widgetProc) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::configure) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::vTrace) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::setValue) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::getBoolean) [list source [file join $dir combobox.tcl]]
set auto_index(::combobox::widgetName) [list source [file join $dir combobox.tcl]]
set auto_index(::debug::logfile) [list source [file join $dir debug.tcl]]
set auto_index(::debug::trace_var) [list source [file join $dir debug.tcl]]
set auto_index(::debug::remove_trace) [list source [file join $dir debug.tcl]]
set auto_index(::debug::remove_all_traces) [list source [file join $dir debug.tcl]]
set auto_index(::debug::touched_by) [list source [file join $dir debug.tcl]]
set auto_index(::debug::show_call_stack) [list source [file join $dir debug.tcl]]
set auto_index(::debug::createData) [list source [file join $dir debug.tcl]]
set auto_index(::debug::debugwin) [list source [file join $dir debug.tcl]]
set auto_index(::debug::debug) [list source [file join $dir debug.tcl]]
set auto_index(::debug::dbug) [list source [file join $dir debug.tcl]]
set auto_index(::debug::_putdebug) [list source [file join $dir debug.tcl]]
set auto_index(::debug::_puttrace) [list source [file join $dir debug.tcl]]
set auto_index(::debug::init) [list source [file join $dir debug.tcl]]
set auto_index(::debug::trace_start) [list source [file join $dir debug.tcl]]
set auto_index(::debug::trace_stop) [list source [file join $dir debug.tcl]]
set auto_index(::debug::sagetkwait) [list source [file join $dir debug.tcl]]
set auto_index(::debug::sagevwait) [list source [file join $dir debug.tcl]]
set auto_index(::debug::sageexit) [list source [file join $dir debug.tcl]]
set auto_index(::debug::sageproc) [list source [file join $dir debug.tcl]]
set auto_index(::debug::sageitclbody) [list source [file join $dir debug.tcl]]
set auto_index(::debug::sageitclproc) [list source [file join $dir debug.tcl]]
set auto_index(::debug::sagemethod) [list source [file join $dir debug.tcl]]
set auto_index(::debug::push) [list source [file join $dir debug.tcl]]
set auto_index(::debug::pop) [list source [file join $dir debug.tcl]]
set auto_index(::debug::look) [list source [file join $dir debug.tcl]]
set auto_index(::debug::stackUnwind) [list source [file join $dir debug.tcl]]
set auto_index(::debug::startWatch) [list source [file join $dir debug.tcl]]
set auto_index(::debug::resetWatch) [list source [file join $dir debug.tcl]]
set auto_index(::debug::stopWatch) [list source [file join $dir debug.tcl]]
set auto_index(::debug::getWatch) [list source [file join $dir debug.tcl]]
set auto_index(::debug::startTimer) [list source [file join $dir debug.tcl]]
set auto_index(::debug::stopTimer) [list source [file join $dir debug.tcl]]
set auto_index(::debug::procEntry) [list source [file join $dir debug.tcl]]
set auto_index(::debug::methodEntry) [list source [file join $dir debug.tcl]]
set auto_index(::debug::procExit) [list source [file join $dir debug.tcl]]
set auto_index(::debug::methodExit) [list source [file join $dir debug.tcl]]
set auto_index(defarray) [list source [file join $dir def.tcl]]
set auto_index(defvar) [list source [file join $dir def.tcl]]
set auto_index(defconst) [list source [file join $dir def.tcl]]
set auto_index(FONT_track_change) [list source [file join $dir font.tcl]]
set auto_index(define_font) [list source [file join $dir font.tcl]]
set auto_index(gensym) [list source [file join $dir gensym.tcl]]
set auto_index(gettext) [list source [file join $dir gettext.tcl]]
set auto_index(add_hook) [list source [file join $dir hooks.tcl]]
set auto_index(remove_hook) [list source [file join $dir hooks.tcl]]
set auto_index(define_hook) [list source [file join $dir hooks.tcl]]
set auto_index(run_hooks) [list source [file join $dir hooks.tcl]]
set auto_index(send_mail) [list source [file join $dir internet.tcl]]
set auto_index(open_url) [list source [file join $dir internet.tcl]]
set auto_index(Labelledframe) [list source [file join $dir lframe.tcl]]
set auto_index(lvarpush) [list source [file join $dir list.tcl]]
set auto_index(lvarpop) [list source [file join $dir list.tcl]]
set auto_index(lassign) [list source [file join $dir list.tcl]]
set auto_index(lrmdups) [list source [file join $dir list.tcl]]
set auto_index(lremove) [list source [file join $dir list.tcl]]
set auto_index(lrep) [list source [file join $dir list.tcl]]
set auto_index(lvarcat) [list source [file join $dir list.tcl]]
set auto_index(standard_look_and_feel) [list source [file join $dir looknfeel.tcl]]
set auto_index(compute_menu_width) [list source [file join $dir menu.tcl]]
set auto_index(monochrome_p) [list source [file join $dir mono.tcl]]
set auto_index(Multibox) [list source [file join $dir multibox.tcl]]
set auto_index(::cyg::Pane) [list source [file join $dir pane.tcl]]
set auto_index(::cyg::pane) [list source [file join $dir pane.tcl]]
set auto_index(::cyg::Pane::constructor) [list source [file join $dir pane.tcl]]
set auto_index(::cyg::Pane::minimum) [list source [file join $dir pane.tcl]]
set auto_index(::cyg::Pane::maximum) [list source [file join $dir pane.tcl]]
set auto_index(::cyg::Pane::margin) [list source [file join $dir pane.tcl]]
set auto_index(::cyg::Pane::childSite) [list source [file join $dir pane.tcl]]
set auto_index(::cyg::PanedWindow) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::panedwindow) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::constructor) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::orient) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::sashwidth) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::sashcolor) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::index) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::childsite) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::add) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::insert) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::delete) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::hide) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::replace) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::show) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::paneconfigure) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::reset) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_setActivePanes) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_eventHandler) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_resizeArray) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_startDrag) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_endDrag) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_configDrag) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_handleDrag) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_moveSash) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_calcPos) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_makeSashes) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_placeSash) [list source [file join $dir panedwindow.tcl]]
set auto_index(::cyg::PanedWindow::_placePanes) [list source [file join $dir panedwindow.tcl]]
set auto_index(parse_args) [list source [file join $dir parse_args.tcl]]
set auto_index(canonical_path) [list source [file join $dir path.tcl]]
set auto_index(GHOST_helper) [list source [file join $dir postghost.tcl]]
set auto_index(add_post_command) [list source [file join $dir postghost.tcl]]
set auto_index(ghosting_menu_item) [list source [file join $dir postghost.tcl]]
set auto_index(PREFS_run_handlers) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_handle_property_event) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_define) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_get) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_getd) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_varname) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_set) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_setd) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_add_hook) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_remove_hook) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_init) [list source [file join $dir prefs.tcl]]
set auto_index(PREFS_cmd_list) [list source [file join $dir prefs.tcl]]
set auto_index(pref) [list source [file join $dir prefs.tcl]]
set auto_index(send_printer) [list source [file join $dir print.tcl]]
set auto_index(send_printer_ascii) [list source [file join $dir print.tcl]]
set auto_index(PRINT_windows_ascii) [list source [file join $dir print.tcl]]
set auto_index(PRINT_query) [list source [file join $dir print.tcl]]
set auto_index(PRINT_text) [list source [file join $dir print.tcl]]
set auto_index(PRINT_page) [list source [file join $dir print.tcl]]
set auto_index(Sendpr) [list source [file join $dir sendpr.tcl]]
set auto_index(::Sendpr::_restore) [list source [file join $dir sendpr.tcl]]
set auto_index(TOOLBAR_button_enter) [list source [file join $dir toolbar.tcl]]
set auto_index(TOOLBAR_button_leave) [list source [file join $dir toolbar.tcl]]
set auto_index(TOOLBAR_button_down) [list source [file join $dir toolbar.tcl]]
set auto_index(TOOLBAR_button_up) [list source [file join $dir toolbar.tcl]]
set auto_index(TOOLBAR_maybe_init) [list source [file join $dir toolbar.tcl]]
set auto_index(TOOLBAR_command) [list source [file join $dir toolbar.tcl]]
set auto_index(standard_toolbar) [list source [file join $dir toolbar.tcl]]
set auto_index(bind_for_toplevel_only) [list source [file join $dir topbind.tcl]]
set auto_index(extract_label_info) [list source [file join $dir ulset.tcl]]
set auto_index(Validated_entry) [list source [file join $dir ventry.tcl]]
set auto_index(Widgetframe) [list source [file join $dir wframe.tcl]]
set auto_index(WINGRAB_disable) [list source [file join $dir wingrab.tcl]]
set auto_index(WINGRAB_disable_except) [list source [file join $dir wingrab.tcl]]
set auto_index(WINGRAB_enable) [list source [file join $dir wingrab.tcl]]
set auto_index(WINGRAB_enable_all) [list source [file join $dir wingrab.tcl]]
set auto_index(ide_grab_support) [list source [file join $dir wingrab.tcl]]

243
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/toolbar.tcl Normal file
View file

@ -0,0 +1,243 @@
# toolbar.tcl - Handle layout for a toolbar.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# This holds global state for this module.
defarray TOOLBAR_state {
initialized 0
button ""
window ""
relief flat
last ""
}
proc TOOLBAR_button_enter {w} {
global TOOLBAR_state
#save older relief (it covers buttons that
#interacte like checkbuttons)
set TOOLBAR_state(relief) [$w cget -relief]
if {[$w cget -state] != "disabled"} then {
if {$TOOLBAR_state(button) == $w} then {
set relief sunken
} else {
set relief raised
}
$w configure \
-state active \
-relief $relief
}
#store last action to synchronize operations
set TOOLBAR_state(last) enter
set TOOLBAR_state(window) $w
}
proc TOOLBAR_button_leave {w} {
global TOOLBAR_state
if {[$w cget -state] != "disabled"} then {
$w configure -state normal
}
#restore original relief
if {
$TOOLBAR_state(window) == $w
&& $TOOLBAR_state(last) == "enter"
} then {
$w configure -relief $TOOLBAR_state(relief)
} else {
$w configure -relief flat
}
set TOOLBAR_state(window) ""
#store last action to synch operations (enter->leave)
set TOOLBAR_state(last) leave
}
proc TOOLBAR_button_down {w} {
global TOOLBAR_state
if {[$w cget -state] != "disabled"} then {
set TOOLBAR_state(button) $w
$w configure -relief sunken
}
}
proc TOOLBAR_button_up {w} {
global TOOLBAR_state
if {$w == $TOOLBAR_state(button)} then {
set TOOLBAR_state(button) ""
#restore original relief
$w configure -relief $TOOLBAR_state(relief)
if {$TOOLBAR_state(window) == $w
&& [$w cget -state] != "disabled"} then {
#SN does the toolbar bindings using "+" so that older
#bindings don't disapear. So no need to invoke the command.
#other applications should do the same so that we can delete
#this hack
global sn_options
if {! [array exists sn_options]} {
#invoke the binding
uplevel \#0 [list $w invoke]
}
if {[winfo exists $w]} then {
if {[$w cget -state] != "disabled"} then {
$w configure -state normal
}
}
# HOWEVER, if the pointer is still over the button, and it
# is enabled, then raise it again.
if {[string compare [winfo containing \
[winfo pointerx $w] \
[winfo pointery $w]] $w] == 0} {
$w configure -relief raised
}
}
}
}
# Set up toolbar bindings.
proc TOOLBAR_maybe_init {} {
global TOOLBAR_state
if {! $TOOLBAR_state(initialized)} then {
set TOOLBAR_state(initialized) 1
# We can't put our bindings onto the widget (and then use "break"
# to avoid the class bindings) because that interacts poorly with
# balloon help.
bind ToolbarButton <Enter> [list TOOLBAR_button_enter %W]
bind ToolbarButton <Leave> [list TOOLBAR_button_leave %W]
bind ToolbarButton <1> [list TOOLBAR_button_down %W]
bind ToolbarButton <ButtonRelease-1> [list TOOLBAR_button_up %W]
}
}
#Allows changing options of a toolbar button from the application
#especially the relief value
proc TOOLBAR_command {w args} {
global TOOLBAR_state
set len [llength $args]
for {set i 0} {$i < $len} {incr i} {
set cmd [lindex $args $i]
switch -- $cmd {
"relief" -
"-relief" {
incr i
set TOOLBAR_state(relief) [lindex $args $i]
$w configure $cmd [lindex $args $i]
}
"window" -
"-window" {
incr i
set TOOLBAR_state(window) [lindex $args $i]
}
default {
#normal widget options
incr i
$w configure $cmd [lindex $args $i]
}
}
}
}
# Pass this proc a frame and some children of the frame. It will put
# the children into the frame so that they look like a toolbar.
# Children are added in the order they are listed. If a child's name
# is "-", then the appropriate type of separator is entered instead.
# If a child's name is "--" then all remaining children will be placed
# on the right side of the window.
#
# For non-flat mode, each button must display an image, and this image
# must have a twin. The primary (raised) image's name must end in
# "u", and the depressed image's name must end in "d". Eg the edit
# images should be called "editu" and "editd". There's no doubt that
# this is a hack.
#
# If you want to add a button that doesn't have an image (or whose
# image doesn't have a twin), you must wrap it in a frame.
#
# FIXME: someday, write a `toolbar button' widget that handles the
# image mess invisibly.
proc standard_toolbar {frame args} {
global tcl_platform
# For now, there are two different layouts, depending on which kind
# of icons we're using. This is just a test feature and will be
# eliminated once we decide on an icon style.
TOOLBAR_maybe_init
# We reserve column 0 for some padding.
set column 1
if {$tcl_platform(platform) == "windows"} then {
# See below to understand this.
set row 1
} else {
set row 0
}
# This is set if we see "--" and thus the filling happens in the
# center.
set center_fill 0
set sticky w
foreach button $args {
grid columnconfigure $frame $column -weight 0
if {$button == "-"} then {
# A separator.
set f [frame $frame.[gensym] -borderwidth 1 -width 2 -relief sunken]
grid $f -row $row -column $column -sticky ns${sticky} -padx 4
} elseif {$button == "--"} then {
# Everything after this is put on the right. We do this by
# adding a column that sucks up all the space.
set center_fill 1
set sticky e
grid columnconfigure $frame $column -weight 1 -minsize 7
} elseif {[winfo class $button] != "Button"} then {
# Something other than a button. Just put it into the frame.
grid $button -row $row -column $column -sticky $sticky -pady 2
} else {
# A button.
# FIXME: does Windows allow focus traversal? For now we're
# just turning it off.
$button configure -takefocus 0 -highlightthickness 0 \
-relief flat -borderwidth 1
grid $button -row $row -column $column -sticky $sticky -pady 2
# Make sure the button acts the way we want, not the default Tk
# way.
set index [lsearch -exact [bindtags $button] Button]
bindtags $button [lreplace [bindtags $button] $index $index \
ToolbarButton]
}
incr column
}
# On Unix, it looks a little more natural to have a raised toolbar.
# On Windows the toolbar is flat, but there is a horizontal
# separator between the toolbar and the menubar. On both platforms
# we provide some space to the left of the leftmost widget.
grid columnconfigure $frame 0 -minsize 7 -weight 0
if {$tcl_platform(platform) == "windows"} then {
$frame configure -borderwidth 0 -relief flat
set name $frame.[gensym]
frame $name -height 2 -borderwidth 1 -relief sunken
grid $name -row 0 -column 0 -columnspan $column -pady 1 -sticky ew
} else {
$frame configure -borderwidth 2 -relief raised
}
if {! $center_fill} then {
# The rightmost column sucks up the extra space.
incr column -1
grid columnconfigure $frame $column -weight 1
}
}

29
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/topbind.tcl Normal file
View file

@ -0,0 +1,29 @@
# topbind.tcl - Put a binding on a toplevel.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
#
# Put a binding on a toplevel. This needs a separate proc because by
# default the toplevel's name is put into the bindtags list for all
# its descendents. Eg Destroy bindings typically don't want to be run
# more than once.
#
# FIXME: should catch destroy operations and remove all bindings for
# our tag.
# Make the binding. Return nothing.
proc bind_for_toplevel_only {toplevel sequence script} {
set tagList [bindtags $toplevel]
set tag _DBind_$toplevel
if {[lsearch -exact $tagList $tag] == -1} then {
# Always put our new binding first in case the other bindings run
# break.
bindtags $toplevel [concat $tag $tagList]
}
# Use "+" binding in case there are multiple calls to this. FIXME
# should just use gensym.
bind $tag $sequence +$script
return {}
}

22
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/ulset.tcl Normal file
View file

@ -0,0 +1,22 @@
# ulset.tcl - Set labels based on info from gettext.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# Extract underline and label info from a descriptor string. Any
# underline in the descriptor is extracted, and the next character's
# index is used as the -underline value. There can only be one _ in
# the label.
proc extract_label_info {option label} {
set uList [split $label _]
if {[llength $uList] > 2} then {
error "too many underscores in label \"$label\""
}
if {[llength $uList] == 1} then {
set ul -1
} else {
set ul [string length [lindex $uList 0]]
}
return [list $option [join $uList {}] -underline $ul]
}

137
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/ventry.tcl Normal file
View file

@ -0,0 +1,137 @@
# ventry.tcl - Entry with validation
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
itcl_class Validated_entry {
# The validation command. It is passed the contents of the entry.
# It should throw an error if there is a problem; the error text
# will be displayed to the user.
public command {}
constructor {config} {
upvar \#0 $this state
# The standard widget-making trick.
set class [$this info class]
set hull [namespace tail $this]
set old_name $this
::rename $this $this-tmp-
::frame $hull -class $class -borderwidth 0
::rename $hull $old_name-win-
::rename $this $old_name
::set ${this}(value) ""
::entry [namespace tail $this].entry -textvariable ${this}(value)
pack [namespace tail $this].entry -expand 1 -fill both
bind [namespace tail $this].entry <Map> [list $this _map]
bind [namespace tail $this].entry <Unmap> [list $this _unmap]
bind [namespace tail $this].entry <Destroy> [list $this delete]
# We never want the focus on the frame.
bind [namespace tail $this] <FocusIn> [list focus [namespace tail $this].entry]
# This window is used when the user enters a bad name for the new
# executable. The color here is "plum3". We use a toplevel here
# both to get a nice black border and because a frame would be
# clipped by its parents.
toplevel [namespace tail $this].badname -borderwidth 1 -background black -relief flat
wm withdraw [namespace tail $this].badname
wm overrideredirect [namespace tail $this].badname 1
::set state(message) ""
# FIXME: -textvariable didn't work; I suspect itcl.
::label [namespace tail $this].badname.text -anchor w -justify left \
-background \#cdd29687cdd2 ;# -textvariable ${this}(message)
pack [namespace tail $this].badname.text -expand 1 -fill both
# Trace the entry contents.
uplevel \#0 [list trace variable ${this}(value) w [list $this _trace]]
}
destructor {
upvar \#0 $this state
catch {destroy $this}
uplevel \#0 [list trace vdelete ${this}(value) w [list $this _trace]]
unset state
}
method configure {config} {}
# Return 1 if we're in the error state, 0 otherwise.
method is_error {} {
upvar \#0 $this state
return [expr {$state(message) != ""}]
}
# Return error text.
method error_text {} {
upvar \#0 $this state
return $state(message)
}
# Some methods to forward messages to the entry. Add more as
# required.
# FIXME: itcl 1.5 won't let us have a `delete' method. Sigh.
method delete_hack {args} {
return [eval [namespace tail $this].entry delete $args]
}
method get {} {
return [[namespace tail $this].entry get]
}
method insert {index string} {
return [[namespace tail $this].entry insert $index $string]
}
# This is run to display the label. Private method.
method _display {} {
# FIXME: place above if it would go offscreen.
set y [expr {[winfo rooty [namespace tail $this].entry] + [winfo height [namespace tail $this].entry] + 1}]
set x [expr {round ([winfo rootx [namespace tail $this].entry]
+ 0.12 * [winfo width [namespace tail $this].entry])}]
wm positionfrom [namespace tail $this].badname user
wm geometry [namespace tail $this].badname +$x+$y
# Workaround for Tk 8.0b2 bug on NT.
update
wm deiconify [namespace tail $this].badname
raise [namespace tail $this].badname
}
# This is run when the entry widget is mapped. If we have an error,
# map our error label. Private method.
method _map {} {
if {[is_error]} then {
_display
}
}
# This is run when the entry widget is unmapped. Private method.
method _unmap {} {
wm withdraw [namespace tail $this].badname
}
# This is called when the entry contents change. Private method.
method _trace {args} {
upvar \#0 $this state
if {$command != ""} then {
set cmd $command
lappend cmd $state(value)
set cmd [list uplevel \#0 $cmd]
}
if {[info exists cmd] && [catch $cmd msg]} then {
# FIXME: for some reason, the -textvariable on the label doesn't
# work. I suspect itcl.
set state(message) $msg
[namespace tail $this].badname.text configure -text $msg
_display
} else {
set state(message) ""
wm withdraw [namespace tail $this].badname
}
}
}

87
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/wframe.tcl Normal file
View file

@ -0,0 +1,87 @@
# wframe.tcl - Frame with a widget on its border.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
itcl_class Widgetframe {
# Where to put the widget. For now, we don't support many anchors.
# Augment as you like.
public anchor nw {
if {$anchor != "nw" && $anchor != "n"} then {
error "anchors nw and n are the only ones supported"
}
_layout
}
# The name of the widget to put on the frame. This is set by some
# subclass calling the _add method. Private variable.
protected _widget {}
constructor {config} {
# The standard widget-making trick.
set class [$this info class]
set hull [namespace tail $this]
set old_name $this
::rename $this $this-tmp-
::frame $hull -class $class -relief flat -borderwidth 0
::rename $hull $old_name-win-
::rename $this $old_name
frame [namespace tail $this].iframe -relief groove -borderwidth 2
grid [namespace tail $this].iframe -row 1 -sticky news
grid rowconfigure [namespace tail $this] 1 -weight 1
grid columnconfigure [namespace tail $this] 0 -weight 1
# Make an internal frame so that user stuff isn't obscured. Note
# that we can't use the placer, because it doesn't set the
# geometry of the parent.
frame [namespace tail $this].iframe.frame -borderwidth 4 -relief flat
grid [namespace tail $this].iframe.frame -row 1 -sticky news
grid rowconfigure [namespace tail $this].iframe 1 -weight 1
grid columnconfigure [namespace tail $this].iframe 0 -weight 1
bind [namespace tail $this].iframe <Destroy> [list $this delete]
}
destructor {
catch {destroy $this}
}
# Return name of internal frame.
method get_frame {} {
return [namespace tail $this].iframe.frame
}
# Name a certain widget to be put on the frame. This should be
# called by some subclass after making the widget. Protected
# method.
method _add {widget} {
set _widget $widget
set height [expr {int ([winfo reqheight $_widget] / 2)}]
grid rowconfigure [namespace tail $this] 0 -minsize $height -weight 0
grid rowconfigure [namespace tail $this].iframe 0 -minsize $height -weight 0
_layout
}
# Re-layout according to the anchor. Private method.
method _layout {} {
if {$_widget == "" || ! [winfo exists $_widget]} then {
return
}
switch -- $anchor {
n {
# Put the label over the border, in the center.
place $_widget -in [namespace tail $this].iframe -relx 0.5 -rely 0 -y -2 \
-anchor center
}
nw {
# Put the label over the border, at the top left.
place $_widget -in [namespace tail $this].iframe -relx 0 -x 6 -rely 0 -y -2 \
-anchor w
}
default {
error "unsupported anchor \"$anchor\""
}
}
}
}

59
arduino-0018-windows/hardware/tools/avr/share/redhat/gui/wingrab.tcl Normal file
View file

@ -0,0 +1,59 @@
# wingrab.tcl -- grab support for Windows.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Ian Lance Taylor <ian@cygnus.com>.
# Disable a list of windows.
proc WINGRAB_disable { args } {
foreach w $args {
ide_grab_support_disable [wm frame $w]
}
}
# Disable all top level windows, other than the argument, which are
# children of `.'. Note that if you do this, and then destroy the
# frame of the only enabled window, your application will lose the
# input focus to some other application. Make sure that you reenable
# the windows before calling wm transient or wm withdraw or destroy on
# the only enabled window.
proc WINGRAB_disable_except { window } {
foreach w [winfo children .] {
if {$w != $window} then {
ide_grab_support_disable [wm frame [winfo toplevel $w]]
}
}
}
# Enable a list of windows.
proc WINGRAB_enable { args } {
foreach w $args {
ide_grab_support_enable [wm frame $w]
}
}
# Enable all top level windows which are children of `.'.
proc WINGRAB_enable_all {} {
foreach w [winfo children .] {
ide_grab_support_enable [wm frame [winfo toplevel $w]]
}
}
# The basic routine. All commands are subcommands of this.
proc ide_grab_support {dispatch args} {
global tcl_platform
if {[info commands WINGRAB_$dispatch] == ""} then {
error "unrecognized key \"$dispatch\""
}
# We only need to do stuff on Windows.
if {$tcl_platform(platform) != "windows"} then {
return
}
eval WINGRAB_$dispatch $args
}