OpenCores

/Makefile.in

0,0 → 1,336

Makefile.in Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: bgerror.tcl =================================================================== --- bgerror.tcl (nonexistent) +++ bgerror.tcl (revision 1765) @@ -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 . + +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 "destroy $w" + bind $w.text "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 .] + } +}

bgerror.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: toolbar.tcl =================================================================== --- toolbar.tcl (nonexistent) +++ toolbar.tcl (revision 1765) @@ -0,0 +1,243 @@ +# toolbar.tcl - Handle layout for a toolbar. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 [list TOOLBAR_button_enter %W] + bind ToolbarButton [list TOOLBAR_button_leave %W] + bind ToolbarButton <1> [list TOOLBAR_button_down %W] + bind ToolbarButton [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 + } +}

toolbar.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: font.tcl =================================================================== --- font.tcl (nonexistent) +++ font.tcl (revision 1765) @@ -0,0 +1,26 @@ +# font.tcl - Font handling. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + + +# 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] +}

font.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: pkgIndex.tcl =================================================================== --- pkgIndex.tcl (nonexistent) +++ pkgIndex.tcl (revision 1765) @@ -0,0 +1,11 @@ +# 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 1.05 [list tclPkgSetup $dir combobox 1.05 {{combobox.tcl source ::combobox::combobox}}]

pkgIndex.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: canvas.tcl =================================================================== --- canvas.tcl (nonexistent) +++ canvas.tcl (revision 1765) @@ -0,0 +1,29 @@ +# canvas.tcl - Handy canvas-related commands. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 +}

canvas.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: center.tcl =================================================================== --- center.tcl (nonexistent) +++ center.tcl (revision 1765) @@ -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 . + +# 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 +}

center.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: wframe.tcl =================================================================== --- wframe.tcl (nonexistent) +++ wframe.tcl (revision 1765) @@ -0,0 +1,87 @@ +# wframe.tcl - Frame with a widget on its border. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +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 [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\"" + } + } + } +}

wframe.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: parse_args.tcl =================================================================== --- parse_args.tcl (nonexistent) +++ parse_args.tcl (revision 1765) @@ -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... +}

parse_args.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: debug.tcl =================================================================== --- debug.tcl (nonexistent) +++ debug.tcl (revision 1765) @@ -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] + } +}

debug.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: tclIndex =================================================================== --- tclIndex (nonexistent) +++ tclIndex (revision 1765) @@ -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(Checkframe) [list source [file join $dir cframe.tcl]] +set auto_index(center_window) [list source [file join $dir center.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(send_mail) [list source [file join $dir internet.tcl]] +set auto_index(open_url) [list source [file join $dir internet.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(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(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(bind_for_toplevel_only) [list source [file join $dir topbind.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(extract_label_info) [list source [file join $dir ulset.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]] +set auto_index(Validated_entry) [list source [file join $dir ventry.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(::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::_caclPos) [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]]

tclIndex Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: wingrab.tcl =================================================================== --- wingrab.tcl (nonexistent) +++ wingrab.tcl (revision 1765) @@ -0,0 +1,59 @@ +# wingrab.tcl -- grab support for Windows. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Ian Lance Taylor . + +# 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 +}

wingrab.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: bbox.tcl =================================================================== --- bbox.tcl (nonexistent) +++ bbox.tcl (revision 1765) @@ -0,0 +1,57 @@ +# bbox.tcl - Function for handling button box. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 + } +}

bbox.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: ulset.tcl =================================================================== --- ulset.tcl (nonexistent) +++ ulset.tcl (revision 1765) @@ -0,0 +1,22 @@ +# ulset.tcl - Set labels based on info from gettext. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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] +}

ulset.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: bindings.tcl =================================================================== --- bindings.tcl (nonexistent) +++ bindings.tcl (revision 1765) @@ -0,0 +1,88 @@ +# bindings.tcl - Procs to handle bindings. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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}> {;} + } + } + } +}

bindings.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: def.tcl =================================================================== --- def.tcl (nonexistent) +++ def.tcl (revision 1765) @@ -0,0 +1,29 @@ +# def.tcl - Definining commands. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 +}

def.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: topbind.tcl =================================================================== --- topbind.tcl (nonexistent) +++ topbind.tcl (revision 1765) @@ -0,0 +1,29 @@ +# topbind.tcl - Put a binding on a toplevel. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . +# +# 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 {} +}

topbind.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: gensym.tcl =================================================================== --- gensym.tcl (nonexistent) +++ gensym.tcl (revision 1765) @@ -0,0 +1,13 @@ +# gensym.tcl - Generate new symbols. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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] +}

gensym.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: multibox.tcl =================================================================== --- multibox.tcl (nonexistent) +++ multibox.tcl (revision 1765) @@ -0,0 +1,251 @@ +# multibox.tcl - Multi-column listbox. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 [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] + } +}

multibox.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: menu.tcl =================================================================== --- menu.tcl (nonexistent) +++ menu.tcl (revision 1765) @@ -0,0 +1,39 @@ +# menu.tcl - Useful proc for dealing with menus. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 +}

menu.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: lframe.tcl =================================================================== --- lframe.tcl (nonexistent) +++ lframe.tcl (revision 1765) @@ -0,0 +1,19 @@ +# lframe.tcl - Labelled frame widget. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +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 + } +}

lframe.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: mono.tcl =================================================================== --- mono.tcl (nonexistent) +++ mono.tcl (revision 1765) @@ -0,0 +1,14 @@ +# mono.tcl - Dealing with monochrome. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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}] +}

mono.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: combobox.tcl =================================================================== --- combobox.tcl (nonexistent) +++ combobox.tcl (revision 1765) @@ -0,0 +1,1118 @@ +# Copyright (c) 1998, Bryan Oakley +# All Rights Reservered +# +# Bryan Oakley +# oakley@channelpoint.com +# +# combobox v1.05 August 17, 1998 +# a dropdown combobox widget +# +# this code is freely distributable without restriction, but is +# provided as-is with no waranty expressed or implied. +# +# Standard Options: +# +# -background -borderwidth -font -foreground -highlightthickness +# -highlightbackground -relief -state -textvariable +# -selectbackground -selectborderwidth -selectforeground +# -cursor +# +# Custom Options: +# -command a command to run whenever the value is changed. +# This command will be called with two values +# appended to it -- the name of the widget and the +# new value. It is run at the global scope. +# -editable if true, user can type into edit box; false, she can't +# -height specifies height of dropdown list, in lines +# -image image for the button to pop down the list... +# -maxheight specifies maximum height of dropdown list, in lines +# -value duh +# -width treated just like the -width option to entry widgets +# +# +# widget commands: +# +# (see source... there's a bunch; duplicates of most of the entry +# widget commands, plus commands to manipulate the listbox and a couple +# unique to the combobox as a whole) +# +# to create a combobox: +# +# namespace import combobox::combobox +# combobox .foo ?options? +# +# +# thanks to the following people who provided beta test support or +# patches to the code: +# +# Martin M. Hunt (hunt@cygnus.com) + +package require Tk 8.0 +package provide combobox 1.05 + +namespace eval ::combobox { + global tcl_platform + # this is the public interface + namespace export combobox + + if {$tcl_platform(platform) != "windows"} { + set sbtest ". " + radiobutton $sbtest + set disabledfg [$sbtest cget -disabledforeground] + set enabledfg [$sbtest cget -fg] + } else { + set disabledfg SystemDisabledText + set enabledfg SystemWindowText + } + + # the image used for the button... + image create bitmap ::combobox::bimage -data { + #define down_arrow_width 15 + #define down_arrow_height 15 + static char down_arrow_bits[] = { + 0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0, + 0x83,0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80 + }; + } +} + +# this is the command that gets exported, and creates a new +# combobox widget. It works like other widget commands in that +# it takes as its first argument a widget path, and any remaining +# arguments are option/value pairs for the widget +proc ::combobox::combobox {w args} { + + # build it... + eval build $w $args + + # set some bindings... + setBindings $w + + # and we are done! + return $w +} + +# builds the combobox... +proc ::combobox::build {w args } { + global tcl_platform + if {[winfo exists $w]} { + error "window name \"$w\" already exists" + } + + # create the namespace... + namespace eval ::combobox::$w { + + variable widgets + variable options + variable oldValue + variable ignoreTrace + variable this + + array set widgets {} + array set options {} + + set oldValue {} + set ignoreTrace 0 + } + + # import the widgets and options arrays into this proc + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + # ok, everything we create should exist in the namespace + # we create for this widget. This is to hide all the internal + # foo from prying eyes. If they really want to get at the + # internals, they know where they can find it... + + # see... I'm pretending to be a Java programmer here... + set this $w + namespace eval ::combobox::$w "set this $this" + + # the basic, always-visible parts of the combobox. We do these + # here, because we want to query some of them for their default + # values, which we want to juggle to other widgets. I suppose + # I could use the options database, but I choose not to... + set widgets(this) [frame $this -class Combobox -takefocus 0] + set widgets(entry) [entry $this.entry -takefocus {}] + set widgets(button) [label $this.button -takefocus 0] + + # we will later rename the frame's widget proc to be our + # own custom widget proc. We need to keep track of this + # new name, so we'll store it here... + set widgets(frame) .$this + + pack $widgets(button) -side right -fill y -expand n + pack $widgets(entry) -side left -fill both -expand y + + # we need these to be defined, regardless if the user defined + # them for us or not... + array set options [list \ + -height 0 \ + -maxheight 10 \ + -command {} \ + -image {} \ + -textvariable {} \ + -editable 1 \ + -state normal + ] + # now, steal some attributes from the entry widget... + foreach option [list -background -foreground -relief \ + -borderwidth -highlightthickness -highlightbackground \ + -font -width -selectbackground -selectborderwidth \ + -selectforeground] { + set options($option) [$widgets(entry) cget $option] + } + + # I should probably do this in a catch, but for now it's + # good enough... What it does, obviously, is put all of + # the option/values pairs into an array. Make them easier + # to handle later on... + array set options $args + + # now, the dropdown list... the same renaming nonsense + # must go on here as well... + set widgets(popup) [toplevel $this.top] + set widgets(listbox) [listbox $this.top.list] + set widgets(vsb) [scrollbar $this.top.vsb] + + pack $widgets(listbox) -side left -fill both -expand y + + # fine tune the widgets based on the options (and a few + # arbitrary values...) + + # NB: we are going to use the frame to handle the relief + # of the widget as a whole, so the entry widget will be + # flat. + $widgets(vsb) configure \ + -command "$widgets(listbox) yview" \ + -highlightthickness 0 + + set width [expr [winfo reqwidth $widgets(vsb)] - 2] + $widgets(button) configure \ + -highlightthickness 0 \ + -borderwidth 1 \ + -relief raised \ + -width $width + + $widgets(entry) configure \ + -borderwidth 0 \ + -relief flat \ + -highlightthickness 0 + + $widgets(popup) configure \ + -borderwidth 1 \ + -relief sunken + $widgets(listbox) configure \ + -selectmode browse \ + -background [$widgets(entry) cget -bg] \ + -yscrollcommand "$widgets(vsb) set" \ + -borderwidth 0 + + #Windows look'n'feel: black boarder around listbox + if {$tcl_platform(platform)=="windows"} { + $widgets(listbox) configure -highlightbackground black + } + + + # do some window management foo. + wm overrideredirect $widgets(popup) 1 + wm transient $widgets(popup) [winfo toplevel $this] + wm group $widgets(popup) [winfo parent $this] + wm resizable $widgets(popup) 0 0 + wm withdraw $widgets(popup) + + # this moves the original frame widget proc into our + # namespace and gives it a handy name + rename ::$this $widgets(frame) + + # now, create our widget proc. Obviously (?) it goes in + # the global namespace + + proc ::$this {command args} \ + "eval ::combobox::widgetProc $this \$command \$args" +# namespace export $this +# uplevel \#0 namespace import ::combobox::${this}::$this + + # ok, the thing exists... let's do a bit more configuration: + foreach opt [array names options] { + ::combobox::configure $widgets(this) set $opt $options($opt) + } +} + +# here's where we do most of the binding foo. I think there's probably +# a few bindings I ought to add that I just haven't thought about... +proc ::combobox::setBindings {w} { + namespace eval ::combobox::$w { + variable widgets + variable options + + # make sure we clean up after ourselves... + bind $widgets(this) [list ::combobox::destroyHandler $this] + + # this closes the listbox if we get hidden + bind $widgets(this) "$widgets(this) close" + + # this helps (but doesn't fully solve) focus issues. + bind $widgets(this) [list focus $widgets(entry)] + + # this makes our "button" (which is actually a label) + # do the right thing + bind $widgets(button) [list $widgets(this) toggle] + + # this lets the autoscan of the listbox work, even if they + # move the cursor over the entry widget. + bind $widgets(entry) "break" + bind $widgets(entry) \ + [list ::combobox::entryFocus $widgets(this) ""] + bind $widgets(entry) \ + [list ::combobox::entryFocus $widgets(this) ""] + + # this will (hopefully) close (and lose the grab on) the + # listbox if the user clicks anywhere outside of it. Note + # that on Windows, you can click on some other app and + # the listbox will still be there, because tcl won't see + # that button click + bind $widgets(this) [list $widgets(this) close] + bind $widgets(this) [list $widgets(this) close] + + bind $widgets(listbox) \ + "::combobox::select $widgets(this) \[$widgets(listbox) nearest %y\]; break" + + bind $widgets(listbox) { + %W selection clear 0 end + %W activate @%x,%y + %W selection anchor @%x,%y + %W selection set @%x,%y @%x,%y + # need to do a yview if the cursor goes off the top + # or bottom of the window... (or do we?) + } + + # these events need to be passed from the entry + # widget to the listbox, or need some sort of special + # handling.... + foreach event [list \ +

<1> \ + ] { + bind $widgets(entry) $event \ + "::combobox::handleEvent $widgets(this) $event" + } + + } +} + +# this proc handles events from the entry widget that we want handled +# specially (typically, to allow navigation of the list even though +# the focus is in the entry widget) +proc ::combobox::handleEvent {w event} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + upvar ::combobox::${w}::oldValue oldValue + + # for all of these events, if we have a special action we'll + # do that and do a "return -code break" to keep additional + # bindings from firing. Otherwise we'll let the event fall + # on through. + switch $event { + "" { + set editable [::combobox::getBoolean $options(-editable)] + # if the widget is editable, clear the selection. + # this makes it more obvious what will happen if the + # user presses (and helps our code know what + # to do if the user presses return) + if {$editable} { + $widgets(listbox) see 0 + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor 0 + $widgets(listbox) activate 0 + } + } + + "" { + set oldValue [$widgets(entry) get] + } + + "" { + $widgets(entry) delete 0 end + $widgets(entry) insert 0 $oldValue + } + + "<1>" { + set editable [::combobox::getBoolean $options(-editable)] + if {!$editable} { + if {[winfo ismapped $widgets(popup)]} { + $widgets(this) close + return -code break; + + } else { + if {$options(-state) != "disabled"} { + $widgets(this) open + return -code break; + } + } + } + } + + "" { + if {$options(-state) != "disabled"} { + $widgets(this) toggle + return -code break; + } + } + "" { + if {[winfo ismapped $widgets(popup)]} { + ::combobox::find $widgets(this) + return -code break; + } + } + "" { + $widgets(entry) delete 0 end + $widgets(entry) insert 0 $oldValue + if {[winfo ismapped $widgets(popup)]} { + $widgets(this) close + return -code break; + } + } + + "" { + set editable [::combobox::getBoolean $options(-editable)] + if {$editable} { + # if there is something in the list that is selected, + # we'll pick it. Otherwise, use whats in the + # entry widget... + set index [$widgets(listbox) curselection] + if {[winfo ismapped $widgets(popup)] && \ + [llength $index] > 0} { + + ::combobox::select $widgets(this) \ + [$widgets(listbox) curselection] + return -code break; + + } else { + ::combobox::setValue $widgets(this) [$widgets(this) get] + $widgets(this) close + return -code break; + } + } + + if {[winfo ismapped $widgets(popup)]} { + ::combobox::select $widgets(this) \ + [$widgets(listbox) curselection] + return -code break; + } + + } + + "" { + $widgets(listbox) yview scroll 1 pages + set index [$widgets(listbox) index @0,0] + $widgets(listbox) see $index + $widgets(listbox) activate $index + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor $index + $widgets(listbox) selection set $index + + } + + "" { + $widgets(listbox) yview scroll -1 pages + set index [$widgets(listbox) index @0,0] + $widgets(listbox) activate $index + $widgets(listbox) see $index + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor $index + $widgets(listbox) selection set $index + } + + "" { + if {![winfo ismapped $widgets(popup)]} { + if {$options(-state) != "disabled"} { + $widgets(this) open + return -code break; + } + } else { + tkListboxUpDown $widgets(listbox) 1 + return -code break; + } + } + "" { + if {![winfo ismapped $widgets(popup)]} { + if {$options(-state) != "disabled"} { + $widgets(this) open + return -code break; + } + } else { + tkListboxUpDown $widgets(listbox) -1 + return -code break; + } + } + } +} + +# this cleans up the mess that is left behind when the widget goes away +proc ::combobox::destroyHandler {w} { + + # kill any trace or after we may have started... + namespace eval ::combobox::$w { + variable options + variable widgets + + if {[string length $options(-textvariable)]} { + trace vdelete $options(-textvariable) w \ + [list ::combobox::vTrace $widgets(this)] + } + + # CYGNUS LOCAL - kill any after command that may be registered. + if {[info exists widgets(after)]} { + after cancel $widgets(after) + unset widgets(after) + } + } + +# catch {rename ::combobox::${w}::$w {}} + # kill the namespace + catch {namespace delete ::combobox::$w} +} + +# finds something in the listbox that matches the pattern in the +# entry widget +# +# I'm not convinced this is working the way it ought to. It works, +# but is the behavior what is expected? I've also got a gut feeling +# that there's a better way to do this, but I'm too lazy to figure +# it out... +proc ::combobox::find {w {exact 0}} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + ## *sigh* this logic is rather gross and convoluted. Surely + ## there is a more simple, straight-forward way to implement + ## all this. As the saying goes, I lack the time to make it + ## shorter... + + # use what is already in the entry widget as a pattern + set pattern [$widgets(entry) get] + + if {[string length $pattern] == 0} { + # clear the current selection + $widgets(listbox) see 0 + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor 0 + $widgets(listbox) activate 0 + return + } + + # we're going to be searching this list... + set list [$widgets(listbox) get 0 end] + + # if we are doing an exact match, try to find, + # well, an exact match + if {$exact} { + set exactMatch [lsearch -exact $list $pattern] + } + + # search for it. We'll try to be clever and not only + # search for a match for what they typed, but a match for + # something close to what they typed. We'll keep removing one + # character at a time from the pattern until we find a match + # of some sort. + set index -1 + while {$index == -1 && [string length $pattern]} { + set index [lsearch -glob $list "$pattern*"] + if {$index == -1} { + regsub {.$} $pattern {} pattern + } + } + + # this is the item that most closely matches... + set thisItem [lindex $list $index] + + # did we find a match? If so, do some additional munging... + if {$index != -1} { + + # we need to find the part of the first item that is + # unique wrt the second... I know there's probably a + # simpler way to do this... + + set nextIndex [expr $index + 1] + set nextItem [lindex $list $nextIndex] + + # we don't really need to do much if the next + # item doesn't match our pattern... + if {[string match $pattern* $nextItem]} { + # ok, the next item matches our pattern, too + # now the trick is to find the first character + # where they *don't* match... + set marker [string length $pattern] + while {$marker <= [string length $pattern]} { + set a [string index $thisItem $marker] + set b [string index $nextItem $marker] + if {[string compare $a $b] == 0} { + append pattern $a + incr marker + } else { + break + } + } + } else { + set marker [string length $pattern] + } + + } else { + set marker end + set index 0 + } + + # ok, we know the pattern and what part is unique; + # update the entry widget and listbox appropriately + if {$exact && $exactMatch == -1} { + $widgets(listbox) selection clear 0 end + $widgets(listbox) see $index + } else { + $widgets(entry) delete 0 end + $widgets(entry) insert end $thisItem + $widgets(entry) selection clear + $widgets(entry) selection range $marker end + $widgets(listbox) activate $index + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor $index + $widgets(listbox) selection set $index + $widgets(listbox) see $index + } +} + +# selects an item from the list and sets the value of the combobox +# to that value +proc ::combobox::select {w index} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + catch { + set data [$widgets(listbox) get [lindex $index 0]] + ::combobox::setValue $widgets(this) $data + } + + $widgets(this) close +} + +# computes the geometry of the popup list based on the size of the +# combobox. Compute size of popup by requested size of listbox +# plus twice the bordersize of the popup. +proc ::combobox::computeGeometry {w} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + if {$options(-height) == 0 && $options(-maxheight) != "0"} { + # if this is the case, count the items and see if + # it exceeds our maxheight. If so, set the listbox + # size to maxheight... + set nitems [$widgets(listbox) size] + if {$nitems > $options(-maxheight)} { + # tweak the height of the listbox + $widgets(listbox) configure -height $options(-maxheight) + } else { + # un-tweak the height of the listbox + $widgets(listbox) configure -height 0 + } + update idletasks + } + set bd [$widgets(popup) cget -borderwidth] + set height [expr [winfo reqheight $widgets(listbox)] + $bd + $bd] + #set height [winfo reqheight $widgets(popup)] + + set width [winfo reqwidth $widgets(this)] + + # Compute size of listbox, allowing larger entries to expand + # the listbox, clipped by the screen + set x [winfo rootx $widgets(this)] + set sw [winfo screenwidth $widgets(this)] + if {$width > $sw - $x} { + # The listbox will run off the side of the screen, so clip it + # (and keep a 10 pixel margin). + set width [expr {$sw - $x - 10}] + } + set size [format "%dx%d" $width $height] + set y [expr {[winfo rooty $widgets(this)]+[winfo reqheight $widgets(this)] + 1}] + if {[expr $y + $height] >= [winfo screenheight .]} { + set y [expr [winfo rooty $widgets(this)] - $height] + } + set location "+[winfo rootx $widgets(this)]+$y" + set geometry "=${size}${location}" + return $geometry +} + +# perform an internal widget command, then mung any error results +# to look like it came from our megawidget. A lot of work just to +# give the illusion that our megawidget is an atomic widget +proc ::combobox::doInternalWidgetCommand {w subwidget command args} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + set subcommand $command + set command [concat $widgets($subwidget) $command $args] + + if {[catch $command result]} { + # replace the subwidget name with the megawidget name + regsub $widgets($subwidget) $result $widgets($w) result + + # replace specific instances of the subwidget command + # with out megawidget command + switch $subwidget,$subcommand { + listbox,index {regsub "index" $result "list index" result} + listbox,insert {regsub "insert" $result "list insert" result} + listbox,delete {regsub "delete" $result "list delete" result} + listbox,get {regsub "get" $result "list get" result} + listbox,size {regsub "size" $result "list size" result} + listbox,curselection {regsub "curselection" $result "list curselection" result} + } + error $result + + } else { + return $result + } +} + + +# this is the widget proc that gets called when you do something like +# ".checkbox configure ..." +proc ::combobox::widgetProc {w command args} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + # this is just shorthand notation... + set doWidgetCommand \ + [list ::combobox::doInternalWidgetCommand $widgets(this)] + + if {$command == "list"} { + # ok, the next argument is a list command; we'll + # rip it from args and append it to command to + # create a unique internal command + # + # NB: because of the sloppy way we are doing this, + # we'll also let the user enter our secret command + # directly (eg: listinsert, listdelete), but we + # won't document that fact + set command "list[lindex $args 0]" + set args [lrange $args 1 end] + } + + # many of these commands are just synonyms for specific + # commands in one of the subwidgets. We'll get them out + # of the way first, then do the custom commands. + switch $command { + bbox {eval $doWidgetCommand entry bbox $args} + delete {eval $doWidgetCommand entry delete $args} + get {eval $doWidgetCommand entry get $args} + icursor {eval $doWidgetCommand entry icursor $args} + index {eval $doWidgetCommand entry index $args} + insert {eval $doWidgetCommand entry insert $args} + listinsert { + eval $doWidgetCommand listbox insert $args + # pack the scrollbar if the number of items exceeds + # the maximum + if {$options(-height) == 0 && $options(-maxheight) != 0 + && ([$widgets(listbox) size] > $options(-maxheight))} { + pack $widgets(vsb) -before $widgets(listbox) -side right \ + -fill y -expand n + } + } + listdelete { + eval $doWidgetCommand listbox delete $args + # unpack the scrollbar if the number of items + # decreases under the maximum + if {$options(-height) == 0 && $options(-maxheight) != 0 + && ([$widgets(listbox) size] <= $options(-maxheight))} { + pack forget $widgets(vsb) + } + } + listget {eval $doWidgetCommand listbox get $args} + listindex {eval $doWidgetCommand listbox index $args} + listsize {eval $doWidgetCommand listbox size $args} + listcurselection {eval $doWidgetCommand listbox curselection $args} + + scan {eval $doWidgetCommand entry scan $args} + selection {eval $doWidgetCommand entry selection $args} + xview {eval $doWidgetCommand entry xview $args} + + entryset { + # update the entry field without invoking the command + ::combobox::setValue $widgets(this) [lindex $args 0] 0 + } + + toggle { + # ignore this command if the widget is disabled... + if {$options(-state) == "disabled"} return + + # pops down the list if it is not, hides it + # if it is... + if {[winfo ismapped $widgets(popup)]} { + $widgets(this) close + } else { + $widgets(this) open + } + } + + open { + # if we are disabled, we won't allow this to happen + if {$options(-state) == "disabled"} { + return 0 + } + + # compute the geometry of the window to pop up, and set + # it, and force the window manager to take notice + # (even if it is not presently visible). + # + # this isn't strictly necessary if the window is already + # mapped, but we'll go ahead and set the geometry here + # since its harmless and *may* actually reset the geometry + # to something better in some weird case. + set geometry [::combobox::computeGeometry $widgets(this)] + wm geometry $widgets(popup) $geometry + update idletasks + + # if we are already open, there's nothing else to do + if {[winfo ismapped $widgets(popup)]} { + return 0 + } + + # ok, tweak the visual appearance of things and + # make the list pop up + $widgets(button) configure -relief sunken + wm deiconify $widgets(popup) + raise $widgets(popup) [winfo parent $widgets(this)] + focus -force $widgets(entry) + + # select something by default, but only if its an + # exact match... + ::combobox::find $widgets(this) 1 + + # *gasp* do a global grab!!! Mom always told not to + # do things like this... :-) + grab -global $widgets(this) + + # fake the listbox into thinking it has focus + event generate $widgets(listbox) + + return 1 + } + + close { + # if we are already closed, don't do anything... + if {![winfo ismapped $widgets(popup)]} { + return 0 + } + # hides the listbox + grab release $widgets(this) + $widgets(button) configure -relief raised + wm withdraw $widgets(popup) + + # select the data in the entry widget. Not sure + # why, other than observation seems to suggest that's + # what windows widgets do. + set editable [::combobox::getBoolean $options(-editable)] + if {$editable} { + $widgets(entry) selection range 0 end + $widgets(button) configure -relief raised + } + + # magic tcl stuff (see tk.tcl in the distribution + # lib directory) + tkCancelRepeat + + return 1 + } + + cget { + # tries to mimic the standard "cget" command + if {[llength $args] != 1} { + error "wrong # args: should be \"$widgets(this) cget option\"" + } + set option [lindex $args 0] + return [::combobox::configure $widgets(this) cget $option] + } + + configure { + # trys to mimic the standard "configure" command + if {[llength $args] == 0} { + # this isn't the same format as "real" widgets, + # but for now its good enough + foreach item [lsort [array names options]] { + lappend result [list $item $options($item)] + } + return $result + + } elseif {[llength $args] == 1} { + # they are requesting configure information... + set option [lindex $args 0] + return [::combobox::configure $widgets(this) get $option] + } else { + array set tmpopt $args + foreach opt [array names tmpopt] { + ::combobox::configure $widgets(this) set $opt $tmpopt($opt) + } + } + } + default { + error "bad option \"$command\"" + } + } +} + +# handles all of the configure and cget foo +proc ::combobox::configure {w action {option ""} {newValue ""}} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + set namespace "::combobox::${w}" + + if {$action == "get"} { + # this really ought to do more than just get the value, + # but for the time being I don't fully support the configure + # command in all its glory... + if {$option == "-value"} { + return [list "-value" [$widgets(entry) get]] + } else { + return [list $option $options($option)] + } + + } elseif {$action == "cget"} { + if {$option == "-value"} { + return [$widgets(entry) get] + } else { + return $options($option) + } + + } else { + + if {[info exists options($option)]} { + set oldValue $options($option) + set options($option) $newValue + } else { + set oldValue "" + set options($option) $newValue + } + + # some (actually, most) options require us to + # do something, like change the attributes of + # a widget or two. Here's where we do that... + switch -- $option { + -background { + $widgets(frame) configure -background $newValue + $widgets(entry) configure -background $newValue + $widgets(listbox) configure -background $newValue + $widgets(vsb) configure -background $newValue + $widgets(vsb) configure -troughcolor $newValue + } + + -borderwidth { + $widgets(frame) configure -borderwidth $newValue + } + + -command { + # nothing else to do... + } + + -cursor { + $widgets(frame) configure -cursor $newValue + $widgets(entry) configure -cursor $newValue + $widgets(listbox) configure -cursor $newValue + } + + -editable { + if {$newValue} { + # it's editable... + $widgets(entry) configure -state normal + $widgets(entry) configure -bg white + } else { + global tcl_platform + + $widgets(entry) configure -state disabled + $widgets(entry) configure -bg white + } + } + + -font { + $widgets(entry) configure -font $newValue + $widgets(listbox) configure -font $newValue + } + + -foreground { + $widgets(entry) configure -foreground $newValue + $widgets(button) configure -foreground $newValue + $widgets(listbox) configure -foreground $newValue + } + + -height { + $widgets(listbox) configure -height $newValue + } + + -highlightbackground { + $widgets(frame) configure -highlightbackground $newValue + } + + -highlightthickness { + $widgets(frame) configure -highlightthickness $newValue + } + + -image { + if {[string length $newValue] > 0} { + $widgets(button) configure -image $newValue + } else { + $widgets(button) configure -image ::combobox::bimage + } + } + + -maxheight { + # computeGeometry may dork with the actual height + # of the listbox, so let's undork it + $widgets(listbox) configure -height $options(-height) + } + + -relief { + $widgets(frame) configure -relief $newValue + } + + -selectbackground { + $widgets(entry) configure -selectbackground $newValue + $widgets(listbox) configure -selectbackground $newValue + } + + -selectborderwidth { + $widgets(entry) configure -selectborderwidth $newValue + $widgets(listbox) configure -selectborderwidth $newValue + } + + -selectforeground { + $widgets(entry) configure -selectforeground $newValue + $widgets(listbox) configure -selectforeground $newValue + } + + -state { + if {$newValue == "normal"} { + # it's enabled + set editable [::combobox::getBoolean \ + $options(-editable)] + if {$editable} { + $widgets(entry) configure -state normal -takefocus 1 + } + $widgets(entry) configure -fg $::combobox::enabledfg + } else { + # it's disabled + $widgets(entry) configure -state disabled -takefocus 0\ + -fg $::combobox::disabledfg + } + } + + -textvariable { + # destroy our trace on the old value, if any + if {[string length $oldValue] > 0} { + trace vdelete $oldValue w \ + [list ::combobox::vTrace $widgets(this)] + } + # set up a trace on the new value, if any. Also, set + # the value of the widget to the current value of + # the variable + + set variable ::$newValue + if {[string length $newValue] > 0} { + if {[info exists $variable]} { + ::combobox::setValue $widgets(this) [set $variable] + } + trace variable $variable w \ + [list ::combobox::vTrace $widgets(this)] + } + } + + -value { + ::combobox::setValue $widgets(this) $newValue + } + + -width { + $widgets(entry) configure -width $newValue + $widgets(listbox) configure -width $newValue + } + + default { + error "unknown option \"$option\"" + } + } + } +} + +# this proc is called whenever the user changes the value of +# the -textvariable associated with a widget +proc ::combobox::vTrace {w args} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + upvar ::combobox::${w}::ignoreTrace ignoreTrace + + if {[info exists ignoreTrace]} return + ::combobox::setValue $widgets(this) [set ::$options(-textvariable)] +} + +# sets the value of the combobox and calls the -command, if defined +proc ::combobox::setValue {w newValue {call 1}} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + upvar ::combobox::${w}::ignoreTrace ignoreTrace + upvar ::combobox::${w}::oldValue oldValue + + set editable [::combobox::getBoolean $options(-editable)] + + # update the widget, no matter what. This might cause a few + # false triggers on a trace of the associated textvariable, + # but that's a chance we'll have to take. + $widgets(entry) configure -state normal + $widgets(entry) delete 0 end + $widgets(entry) insert 0 $newValue + if {!$editable || $options(-state) != "normal"} { + $widgets(entry) configure -state disabled + } + + # set the associated textvariable + if {[string length $options(-textvariable)] > 0} { + set ignoreTrace 1 ;# so we don't get in a recursive loop + uplevel \#0 [list set $options(-textvariable) $newValue] + unset ignoreTrace + } + + # Call the -command, if it exists. + # We could optionally check to see if oldValue == newValue + # first, but sometimes we want to execute the command even + # if the value didn't change... + # CYGNUS LOCAL + # Call it after idle, so the menu gets unposted BEFORE + # the command gets run... Make sure to clean up the afters + # so you don't try to access a dead widget... + + if {$call && [string length $options(-command)] > 0} { + if {[info exists widgets(after)]} { + after cancel $widgets(after) + } + set widgets(after) [after idle $options(-command) \ + [list $widgets(this) $newValue]\;\ + unset ::combobox::${w}::widgets(after)] + } + set oldValue $newValue +} + +# returns the value of a (presumably) boolean string (ie: it should +# do the right thing if the string is "yes", "no", "true", 1, etc +proc ::combobox::getBoolean {value {errorValue 1}} { + if {[catch {expr {([string trim $value])?1:0}} res]} { + return $errorValue + } else { + return $res + } +} + +# computes the combobox widget name based on the name of one of +# it's children widgets.. Not presently used, but might come in +# handy... +proc ::combobox::widgetName {w} { + while {$w != "."} { + if {[winfo class $w] == "Combobox"} { + return $w + } + set w [winfo parent $w] + } + error "internal error: $w is not a child of a combobox" +}

combobox.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: list.tcl =================================================================== --- list.tcl (nonexistent) +++ list.tcl (revision 1765) @@ -0,0 +1,83 @@ +# list.tcl - Some handy list procs. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . +# 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 + } +}

list.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: looknfeel.tcl =================================================================== --- looknfeel.tcl (nonexistent) +++ looknfeel.tcl (revision 1765) @@ -0,0 +1,48 @@ +# looknfeel.tcl - Standard look and feel decisions. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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] + define_font global/menu -family windows-menu + } else { + define_font global/default -family courier -size 9 + define_font global/bold -family courier -size 9 -weight bold + define_font global/fixed -family courier -size 9 + define_font global/status -family courier -size 9 + define_font global/italic -family courier -size 9 -slant italic + define_font global/menu -family courier -size 9 + } + + # Make sure this font is actually used by default. + option add *Font global/default + option add *Menu.Font global/menu +}

looknfeel.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: prefs.tcl =================================================================== --- prefs.tcl (nonexistent) +++ prefs.tcl (revision 1765) @@ -0,0 +1,198 @@ +# prefs.tcl - Preference handling. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 +}

prefs.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: panedwindow.tcl =================================================================== --- panedwindow.tcl (nonexistent) +++ panedwindow.tcl (revision 1765) @@ -0,0 +1,851 @@ +# +# 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 +# ------------------------------------------------------------------ +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 fraction {percentage1 percentage2 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} + + method _resizeArray {} + method _setActivePanes {} + method _caclPos {where num} + 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 +# ------------------------------------------------------------------ +body cyg::PanedWindow::constructor {args} { + itk_option add hull.width hull.height + + pack propagate $itk_component(hull) no + + bind pw-config-$this [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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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). +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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 +} + +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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 +# ------------------------------------------------------------------ +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)] + 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)] + if {$_pmax($n)} { + set _max($i) [expr $_max($n) + $_pmax($n)] + } else { + set _max($i) 0 + } + set _min($i) [expr $_min($n) + $_pmin($n)] + #puts "where($i)=$_where($i)" + #puts "ploc($i)=$_ploc($i)" + #puts "max($i)=$_max($i)" + #puts "min($i)=$_min($i)" + } + set _ploc($i) $_dimension + set _where($i) 1.0 +} + +# ------------------------------------------------------------------ +# 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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +body cyg::PanedWindow::_configDrag {where num} { + set _sashloc($num) $where +} + +# ------------------------------------------------------------------ +# PROTECTED METHOD: _handleDrag where num +# +# Motion action for sash. +# ------------------------------------------------------------------ +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 +# ------------------------------------------------------------------ +body cyg::PanedWindow::_moveSash {where num} { + #puts "moveSash $where $num" + set _minsashmoved [expr ($_minsashmoved<$num)?$_minsashmoved:$num] + set _maxsashmoved [expr ($_maxsashmoved>$num)?$_maxsashmoved:$num] + _caclPos $where $num +} + + +# ------------------------------------------------------------------ +# PRIVATE METHOD: _caclPos where num +# +# Determines the new position for the sash. Make sure theposition does +# not go past the minimum for the pane on each side of the sash. +# ------------------------------------------------------------------ +body cyg::PanedWindow::_caclPos {where num} { + #puts "calcPos $num $where" + set dir [expr $where - $_ploc($num)] + 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} { + set done 1 + if {$p == [llength $_activePanes]} { + set _ploc($num) $upper2 + } else { + _moveSash [expr $where + $_pmax($num)] $p + set _ploc($num) [expr $_ploc($p) - $_pmax($num)] + } + } + if {$where < $lower1} { + set done 1 + if {$num == 1} { + set _ploc($num) $lower1 + } else { + _moveSash [expr $where - $_pmin($m)] $m + set _ploc($num) [expr $_ploc($m) + $_pmin($m)] + } + } + } elseif {$dir > 0 && ($_max($num) == 0 || $where < $_max($num))} { + if {$where > $upper1} { + set done 1 + if {$num == 1} { + set _ploc($num) $upper1 + } else { + _moveSash [expr $where - $_pmax($m)] $m + set _ploc($num) [expr $_ploc($m) + $_pmax($m)] + } + } + if {$where > $upper2} { + set done 1 + if {$p == [llength $_activePanes]} { + set _ploc($num) $upper2 + } else { + _moveSash [expr $where + $_pmin($num)] $p + set _ploc($num) [expr $_ploc($p) - $_pmin($num)] + } + } + } + + if {!$done} { + if {!($_max($num) > 0 && $where > $_max($num)) && $where >= $_min($num)} { + #puts "ploc($num)=$where" + set _ploc($num) $where + } + } + set _where($num) [expr $_ploc($num).0 / $_dimension] +} + +# ------------------------------------------------------------------ +# PRIVATE METHOD: _makeSashes +# +# Removes any previous sashes and creates new ones. +# ------------------------------------------------------------------ +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 [code $this _startDrag $id] + + switch $itk_option(-orient) { + vertical { + bind $com \ + [code $this _handleDrag %x $id] + bind $com \ + [code $this _endDrag %x $id] + bind $com \ + [code $this _configDrag %x $id] + # FIXME Windows should have a different cirsor + $com configure -cursor sb_h_double_arrow + } + + horizontal { + bind $com \ + [code $this _handleDrag %y $id] + bind $com \ + [code $this _endDrag %y $id] + bind $com \ + [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 +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +body cyg::PanedWindow::_placePanes {{start 0} {end end} {forget 0}} { + #puts "placeplanes $start $end" + 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 + } + } +}

panedwindow.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: pane.tcl =================================================================== --- pane.tcl (nonexistent) +++ pane.tcl (revision 1765) @@ -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.1.1.1 2002-01-16 10:24:52 markom 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 +# ------------------------------------------------------------------ +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 +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +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. +# ------------------------------------------------------------------ +body cyg::Pane::childSite {} { + return $itk_component(childsite) +}

pane.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: hooks.tcl =================================================================== --- hooks.tcl (nonexistent) +++ hooks.tcl (revision 1765) @@ -0,0 +1,35 @@ +# hooks.tcl - Hook functions. +# Copyright (C) 1997, 1999 Cygnus Solutions. +# Written by Tom Tromey . + +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 + } +}

hooks.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: gettext.tcl =================================================================== --- gettext.tcl (nonexistent) +++ gettext.tcl (revision 1765) @@ -0,0 +1,7 @@ +# gettext.tcl - some stubs +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +proc gettext {str} { + return $str +}

gettext.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: balloon.tcl =================================================================== --- balloon.tcl (nonexistent) +++ balloon.tcl (revision 1765) @@ -0,0 +1,535 @@ +# balloon.tcl - Balloon help. +# Copyright (C) 1997, 1998, 2000 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 [list $this _enter %W] + bind $_top [list $this _leave] + # Only run this one if we aren't already destroyed. + bind $_top [format { + if {[info commands %s] != ""} then { + %s _subdestroy %%W + } + } $this $this] + bind $_top [list $this _unmap %W] + # Add more here as required. + bind $_top <1> [format { + %s _cancel + %s _unshowballoon + } $this $this] + bind $_top <3> [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 [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 <> [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 +[list $this _enter $window $tag] + $window bind $tag +[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 +[list $this _enter $window $tag] + $window tag bind $tag +[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 { + set _in_notifier 1 + uplevel \#0 $_notifiers($index) + set _in_notifier 0 + # Get value afterwards to give notifier a chance to change it. + set value $_help_text($index) + } else { + set value $_help_text($index) + } + + if {$variable != ""} then { + # itcl 1.5 forces us to do this in a strange way. + ::uplevel \#0 [list set $variable $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 help $_help_text($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 + set help $_help_text($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\"" + } + } + } + + # 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 [lindex $args 0]] + return [lindex [$b configure -variable] 4] + } 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 +}

balloon.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: ventry.tcl =================================================================== --- ventry.tcl (nonexistent) +++ ventry.tcl (revision 1765) @@ -0,0 +1,137 @@ +# ventry.tcl - Entry with validation +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +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 [list $this _map] + bind [namespace tail $this].entry [list $this _unmap] + bind [namespace tail $this].entry [list $this delete] + # We never want the focus on the frame. + bind [namespace tail $this] [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 + } + } +}

ventry.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: internet.tcl =================================================================== --- internet.tcl (nonexistent) +++ internet.tcl (revision 1765) @@ -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 +} + +

internet.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: Makefile.am =================================================================== --- Makefile.am (nonexistent) +++ Makefile.am (revision 1765) @@ -0,0 +1,54 @@ +## Process this file with automake to produce Makefile.in. + +AUTOMAKE_OPTIONS = cygnus + +## Convenience variables. +TCL = advice.tcl balloon.tcl bbox.tcl bgerror.tcl bindings.tcl \ +canvas.tcl cframe.tcl center.tcl debug.tcl def.tcl internet.tcl \ +font.tcl gensym.tcl gettext.tcl hooks.tcl lframe.tcl list.tcl \ +looknfeel.tcl menu.tcl mono.tcl multibox.tcl parse_args.tcl path.tcl \ +postghost.tcl prefs.tcl print.tcl sendpr.tcl topbind.tcl toolbar.tcl \ +ulset.tcl wframe.tcl wingrab.tcl ventry.tcl combobox.tcl \ +pane.tcl panedwindow.tcl + +PACKAGES = combobox.tcl + +## This directory is also referenced in paths.c, which see. +guidir = $(datadir)/cygnus/gui +gui_DATA = tclIndex pkgIndex.tcl $(TCL) $(PACKAGES) + +if TCL_SHARED +SET_LIB_PATH = $(RPATH_ENVVAR)=$$here/../../tcl/unix:$$here/../../itcl/itcl/unix:$$$(RPATH_ENVVAR); export $(RPATH_ENVVAR); +else +SET_LIB_PATH = +endif + +WISH = wish + +if CROSS_COMPILING +ITCL_SH = itclsh3.0 +else +ITCL_SH = @ITCL_SH@ +endif + +if MAINTAINER_MODE +tclIndex: $(TCL) + TCL_LIBRARY=$(srcdir)/../../tcl/library; export TCL_LIBRARY; \ + here=`pwd`; \ + $(SET_LIB_PATH) \ + cd $(srcdir) && \ + echo "auto_mkindex $(LIBGUI_LIBRARY_DIR) $(TCL)" | $(ITCL_SH) + +pkgIndex.tcl: @MAINT@ $(PACKAGES) + here=`pwd`; \ + $(SET_LIB_PATH) \ + cd $(srcdir) && \ + echo "pkg_mkIndex . $(PACKAGES); exit" | $(ITCL_SH) +else +tclIndex: + +pkgIndex.tcl: + +endif + +ETAGS_ARGS = --lang=none --regex='/[ \t]*$proc\|method\|itcl_class$[ \t]+$[^ \t]+$/\1/' $(TCL) --lang=auto

Makefile.am Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: postghost.tcl =================================================================== --- postghost.tcl (nonexistent) +++ postghost.tcl (revision 1765) @@ -0,0 +1,38 @@ +# postghost.tcl - Ghost a menu item at post time. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + + +# 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] +}

postghost.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: advice.tcl =================================================================== --- advice.tcl (nonexistent) +++ advice.tcl (revision 1765) @@ -0,0 +1,82 @@ +# advice.tcl - Generic advice package. +# Copyright (C) 1998 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 + } +}

advice.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: sendpr.tcl =================================================================== --- sendpr.tcl (nonexistent) +++ sendpr.tcl (revision 1765) @@ -0,0 +1,348 @@ +# sendpr.tcl - GUI to send-pr. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +# 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) "Cygnus Solutions" + 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 [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 + } +}

sendpr.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: print.tcl =================================================================== --- print.tcl (nonexistent) +++ print.tcl (revision 1765) @@ -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" +}

print.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: path.tcl =================================================================== --- path.tcl (nonexistent) +++ path.tcl (revision 1765) @@ -0,0 +1,20 @@ +# path.tcl - Path-handling helpers. +# Copyright (C) 1998 Cygnus Solutions. +# Written by Tom Tromey . + +# 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 +}

path.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: cframe.tcl =================================================================== --- cframe.tcl (nonexistent) +++ cframe.tcl (revision 1765) @@ -0,0 +1,146 @@ +# cframe.tcl - Frame controlled by checkbutton. +# Copyright (C) 1997 Cygnus Solutions. +# Written by Tom Tromey . + +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]] + } + } +}

cframe.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property

Browse

Tools

Subversion Repositories or1k

Compare Revisions

Rev 578 → Rev 1765