URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
Compare Revisions
- This comparison shows the changes necessary to convert path
/or1k/trunk/insight/libgui/library
- from Rev 1765 to Rev 578
- ↔ Reverse comparison
Rev 1765 → Rev 578
/Makefile.in
File deleted
Makefile.in
Property changes :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: bgerror.tcl
===================================================================
--- bgerror.tcl (revision 1765)
+++ bgerror.tcl (nonexistent)
@@ -1,64 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: toolbar.tcl
===================================================================
--- toolbar.tcl (revision 1765)
+++ toolbar.tcl (nonexistent)
@@ -1,243 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: font.tcl
===================================================================
--- font.tcl (revision 1765)
+++ font.tcl (nonexistent)
@@ -1,26 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: pkgIndex.tcl
===================================================================
--- pkgIndex.tcl (revision 1765)
+++ pkgIndex.tcl (nonexistent)
@@ -1,11 +0,0 @@
-# Tcl package index file, version 1.1
-# This file is generated by the "pkg_mkIndex" command
-# and sourced either when an application starts up or
-# by a "package unknown" script. It invokes the
-# "package ifneeded" command to set up package-related
-# information so that packages will be loaded automatically
-# in response to "package require" commands. When this
-# script is sourced, the variable $dir must contain the
-# full path name of this file's directory.
-
-package ifneeded combobox 1.05 [list tclPkgSetup $dir combobox 1.05 {{combobox.tcl source ::combobox::combobox}}]
pkgIndex.tcl
Property changes :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: canvas.tcl
===================================================================
--- canvas.tcl (revision 1765)
+++ canvas.tcl (nonexistent)
@@ -1,29 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: center.tcl
===================================================================
--- center.tcl (revision 1765)
+++ center.tcl (nonexistent)
@@ -1,28 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: wframe.tcl
===================================================================
--- wframe.tcl (revision 1765)
+++ wframe.tcl (nonexistent)
@@ -1,87 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: parse_args.tcl
===================================================================
--- parse_args.tcl (revision 1765)
+++ parse_args.tcl (nonexistent)
@@ -1,42 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: debug.tcl
===================================================================
--- debug.tcl (revision 1765)
+++ debug.tcl (nonexistent)
@@ -1,765 +0,0 @@
-# -----------------------------------------------------------------------------
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: tclIndex
===================================================================
--- tclIndex (revision 1765)
+++ tclIndex (nonexistent)
@@ -1,180 +0,0 @@
-# Tcl autoload index file, version 2.0
-# This file is generated by the "auto_mkindex" command
-# and sourced to set up indexing information for one or
-# more commands. Typically each line is a command that
-# sets an element in the auto_index array, where the
-# element name is the name of a command and the value is
-# a script that loads the command.
-
-set auto_index(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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: wingrab.tcl
===================================================================
--- wingrab.tcl (revision 1765)
+++ wingrab.tcl (nonexistent)
@@ -1,59 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: bbox.tcl
===================================================================
--- bbox.tcl (revision 1765)
+++ bbox.tcl (nonexistent)
@@ -1,57 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: ulset.tcl
===================================================================
--- ulset.tcl (revision 1765)
+++ ulset.tcl (nonexistent)
@@ -1,22 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: bindings.tcl
===================================================================
--- bindings.tcl (revision 1765)
+++ bindings.tcl (nonexistent)
@@ -1,88 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: def.tcl
===================================================================
--- def.tcl (revision 1765)
+++ def.tcl (nonexistent)
@@ -1,29 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: topbind.tcl
===================================================================
--- topbind.tcl (revision 1765)
+++ topbind.tcl (nonexistent)
@@ -1,29 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: gensym.tcl
===================================================================
--- gensym.tcl (revision 1765)
+++ gensym.tcl (nonexistent)
@@ -1,13 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: multibox.tcl
===================================================================
--- multibox.tcl (revision 1765)
+++ multibox.tcl (nonexistent)
@@ -1,251 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: menu.tcl
===================================================================
--- menu.tcl (revision 1765)
+++ menu.tcl (nonexistent)
@@ -1,39 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: lframe.tcl
===================================================================
--- lframe.tcl (revision 1765)
+++ lframe.tcl (nonexistent)
@@ -1,19 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: mono.tcl
===================================================================
--- mono.tcl (revision 1765)
+++ mono.tcl (nonexistent)
@@ -1,14 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: combobox.tcl
===================================================================
--- combobox.tcl (revision 1765)
+++ combobox.tcl (nonexistent)
@@ -1,1118 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: list.tcl
===================================================================
--- list.tcl (revision 1765)
+++ list.tcl (nonexistent)
@@ -1,83 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: looknfeel.tcl
===================================================================
--- looknfeel.tcl (revision 1765)
+++ looknfeel.tcl (nonexistent)
@@ -1,48 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: prefs.tcl
===================================================================
--- prefs.tcl (revision 1765)
+++ prefs.tcl (nonexistent)
@@ -1,198 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: panedwindow.tcl
===================================================================
--- panedwindow.tcl (revision 1765)
+++ panedwindow.tcl (nonexistent)
@@ -1,851 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: pane.tcl
===================================================================
--- pane.tcl (revision 1765)
+++ pane.tcl (nonexistent)
@@ -1,136 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: hooks.tcl
===================================================================
--- hooks.tcl (revision 1765)
+++ hooks.tcl (nonexistent)
@@ -1,35 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: gettext.tcl
===================================================================
--- gettext.tcl (revision 1765)
+++ gettext.tcl (nonexistent)
@@ -1,7 +0,0 @@
-# gettext.tcl - some stubs
-# Copyright (C) 1997 Cygnus Solutions.
-# Written by Tom Tromey .
-
-proc gettext {str} {
- return $str
-}
gettext.tcl
Property changes :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: balloon.tcl
===================================================================
--- balloon.tcl (revision 1765)
+++ balloon.tcl (nonexistent)
@@ -1,535 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: ventry.tcl
===================================================================
--- ventry.tcl (revision 1765)
+++ ventry.tcl (nonexistent)
@@ -1,137 +0,0 @@
-# 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
ventry.tcl
Property changes :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: internet.tcl
===================================================================
--- internet.tcl (revision 1765)
+++ internet.tcl (nonexistent)
@@ -1,64 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: Makefile.am
===================================================================
--- Makefile.am (revision 1765)
+++ Makefile.am (nonexistent)
@@ -1,54 +0,0 @@
-## 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: postghost.tcl
===================================================================
--- postghost.tcl (revision 1765)
+++ postghost.tcl (nonexistent)
@@ -1,38 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: advice.tcl
===================================================================
--- advice.tcl (revision 1765)
+++ advice.tcl (nonexistent)
@@ -1,82 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: sendpr.tcl
===================================================================
--- sendpr.tcl (revision 1765)
+++ sendpr.tcl (nonexistent)
@@ -1,348 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: print.tcl
===================================================================
--- print.tcl (revision 1765)
+++ print.tcl (nonexistent)
@@ -1,334 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: path.tcl
===================================================================
--- path.tcl (revision 1765)
+++ path.tcl (nonexistent)
@@ -1,20 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: cframe.tcl
===================================================================
--- cframe.tcl (revision 1765)
+++ cframe.tcl (nonexistent)
@@ -1,146 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property