source: trunk/builder/scripts/objpath.tcl @ 4503

Last change on this file since 4503 was 3177, checked in by mmc, 8 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.

File size: 11.5 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: objpath - show object path and copy/rename
3#
4#  This widget is used within the header above the object options
5#  panel.  It shows the object name, but includes a button for things
6#  like "rename" to change the object ID, and "copy" to copy the
7#  path and paste into another widget.
8# ======================================================================
9#  AUTHOR:  Michael McLennan, Purdue University
10#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
11#
12#  See the file "license.terms" for information on usage and
13#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14# ======================================================================
15package require Itk
16
17option add *ObjPath.selectBackground cyan widgetDefault
18option add *ObjPath.pathFont {helvetica -12} widgetDefault
19
20itcl::class Rappture::ObjPath {
21    inherit itk::Widget
22
23    itk_option define -label label Label ""
24    itk_option define -pathtext pathText PathText ""
25    itk_option define -selectbackground selectBackground Foreground ""
26    itk_option define -renamecommand renameCommand RenameCommand ""
27
28    constructor {args} { # defined below }
29
30    protected method _redraw {args}
31    protected method _resize {args}
32    protected method _hilite {op}
33    protected method _copy {}
34    protected method _edit {option args}
35
36    private variable _dispatcher ""  ;# dispatcher for !events
37}
38
39itk::usual ObjPath {
40    keep -cursor -font -foreground -background
41}
42
43# ----------------------------------------------------------------------
44# CONSTRUCTOR
45# ----------------------------------------------------------------------
46itcl::body Rappture::ObjPath::constructor {args} {
47    # create a dispatcher for events
48    Rappture::dispatcher _dispatcher
49    $_dispatcher register !redraw
50    $_dispatcher dispatch $this !redraw [itcl::code $this _redraw]
51
52    itk_component add size {
53        frame $itk_interior.size -width 20
54    }
55    pack propagate $itk_component(size) no
56    pack $itk_component(size) -side left -expand yes -fill both
57
58    itk_component add path {
59        text $itk_component(size).path -width 1 -height 1 \
60            -borderwidth 0 -highlightthickness 0
61    } {
62        usual
63        rename -font -pathfont pathFont Font
64        ignore -highlightthickness -highlightbackground -highlightcolor
65    }
66    pack $itk_component(path) -expand yes -fill both
67
68    # bind to <Expose> instead of <Configure> so we get events even after
69    # we've reached the maximum width size, so we can scale down smaller
70    bind $itk_component(path) <Expose> [itcl::code $this _resize]
71    bindtags $itk_component(path) [list $itk_component(path) [winfo toplevel $itk_component(path)] all]
72
73    # binding so when you click on the path, it becomes highlighted
74    $itk_component(path) tag bind path <ButtonPress> [itcl::code $this _hilite toggle]
75
76    # add the button for Rename/Copy
77    itk_component add button {
78        button $itk_interior.btn -width 6 -text "Rename" \
79            -command [itcl::code $this _edit start]
80    } {
81        usual
82        ignore -font -borderwidth -relief
83    }
84    pack $itk_component(button) -side left
85
86    # create a pop-up editor to handle "rename" operations
87    itk_component add editor {
88        Rappture::Editor $itk_interior.editor \
89            -activatecommand [itcl::code $this _edit activate] \
90            -validatecommand [itcl::code $this _edit validate] \
91            -applycommand [itcl::code $this _edit apply]
92    }
93
94    bind $itk_component(editor) <Unmap> [itcl::code $this _edit revert]
95
96    eval itk_initialize $args
97}
98
99# ----------------------------------------------------------------------
100# USAGE: _redraw ?<eventArgs>...?
101#
102# Used internally to redraw all items on the path name display.  This
103# gets invoked after the widget is packed to wrap the path name
104# properly whenever the width changes.
105# ----------------------------------------------------------------------
106itcl::body Rappture::ObjPath::_redraw {args} {
107    set fn $itk_option(-pathfont)
108    $itk_component(path) delete 1.0 end
109
110    set label $itk_option(-label)
111    if {"" != $label && ![string match *: $label]} {
112        append label ":"
113    }
114    $itk_component(path) insert end $label
115    $itk_component(path) insert end "  "
116    $itk_component(path) insert end $itk_option(-pathtext) path
117
118    _resize
119}
120
121# ----------------------------------------------------------------------
122# USAGE: _resize ?<eventArgs>...?
123#
124# Used internally to update the height of the path part of this widget
125# whenever it changes size.  If the path gets squeezed, it wraps onto
126# multiple lines.  This routine figures out how many lines to display.
127# ----------------------------------------------------------------------
128itcl::body Rappture::ObjPath::_resize {args} {
129    set fn $itk_option(-pathfont)
130
131    # figure out how much width is available for the path
132    set whull [winfo width $itk_component(hull)]
133    set wbtn [winfo width $itk_component(button)]
134    set wpath [expr {$whull-$wbtn-10}]
135
136    # if the path were on 1 line, how much width would we need?
137    # if it fits on 1 line, then pack it differently
138    set str [$itk_component(path) get 1.0 end]
139    set w [font measure $fn $str]
140    if {$w < $wpath} {
141        $itk_component(size) configure -width [expr {$w+4}]
142        pack $itk_component(size) -expand no -fill x
143    } else {
144        $itk_component(size) configure -width 1
145        pack $itk_component(size) -expand yes -fill both
146    }
147
148    # figure out how many lines we need for the height
149    set lspace [font metrics $fn -linespace]
150    set bbox [$itk_component(path) bbox end-1char]
151    if {"" != $bbox} {
152        # Find the position of the last char and figure out how tall to be.
153        foreach {x0 y0 w h} $bbox break
154        set ht [expr {round(ceil(($y0+$h-2)/double($lspace)))}]
155        $itk_component(path) configure -height $ht
156    } else {
157        # Dang! bbox won't work because the last char is off screen.
158        # Figure out the char in the bottom-right corner and then
159        # guess how many lines are off screen below that.
160        set w [expr {[winfo width $itk_component(path)]-4}]
161        set h [expr {[winfo height $itk_component(path)]-4}]
162        set index [$itk_component(path) index @$w,$h]
163        set cnum [lindex [split $index .] 1]
164        set end [lindex [split [$itk_component(path) index end-1char] .] 1]
165        set frac [expr {1 + double($end-$cnum)/$end}]
166
167        set ht [expr {$frac*[winfo height $itk_component(path)]}]
168        set ht [expr {round(ceil($ht/$lspace))}]
169        $itk_component(path) configure -height $ht
170    }
171    $itk_component(size) configure -height [expr {$ht*$lspace+4}]
172}
173
174# ----------------------------------------------------------------------
175# USAGE: _hilite set|clear
176#
177# Invoked whenever you click on the path name to highlight the path
178# and change to "copy" mode for the path.
179# ----------------------------------------------------------------------
180itcl::body Rappture::ObjPath::_hilite {op} {
181    switch -- $op {
182        set {
183            $itk_component(path) tag configure path \
184                -background $itk_option(-selectbackground) \
185                -borderwidth 1 -relief raised
186            $itk_component(button) configure -text "Copy" \
187                -command [itcl::code $this _copy]
188        }
189        clear {
190            $itk_component(path) tag configure path \
191                -background "" -borderwidth 0
192            $itk_component(button) configure -text "Rename" \
193                -command [itcl::code $this _edit start]
194        }
195        toggle {
196            if {"" != [$itk_component(path) tag cget path -background]} {
197                _hilite clear
198            } else {
199                _hilite set
200            }
201        }
202        default {
203            error "bad option \"$op\": should be set, clear, toggle"
204        }
205    }
206}
207
208# ----------------------------------------------------------------------
209# USAGE: _copy
210#
211# Handles the operation of the "Copy" button.  Copies the current
212# path text to the clipboard so it can be pasted into other widgets.
213# ----------------------------------------------------------------------
214itcl::body Rappture::ObjPath::_copy {} {
215    clipboard clear
216    clipboard append -type STRING -- $itk_option(-pathtext)
217    _hilite clear
218}
219
220# ----------------------------------------------------------------------
221# USAGE: _edit activate
222# USAGE: _edit validate <value>
223# USAGE: _edit apply <value>
224# USAGE: _edit revert
225#
226# Used internally to handle the pop-up editor that edits part of
227# the title string for a node.  The "start" operation is called when
228# the user clicks on the "rename" button.  This brings up an editor
229# for the id anme, allowing the user to change the name.  The
230# "activate" operation is called by the editor to figure out where
231# it should pop up.  The "validate" operation is called to check the
232# new value and make sure that it is okay.  The "apply" operation
233# applies the new name to the node.  The "revert" operation puts
234# the original value back into the display when the user presses Esc.
235# ----------------------------------------------------------------------
236itcl::body Rappture::ObjPath::_edit {option args} {
237    switch -- $option {
238        start {
239            if {[regexp -indices {[a-zA-Z]+\([a-zA-Z0-9_]+\)$} $itk_option(-pathtext) match]} {
240                foreach {s0 s1} $match break
241                $itk_component(path) delete 1.0 end
242                $itk_component(path) insert 1.0 [string range $itk_option(-pathtext) $s0 end]
243                $itk_component(editor) activate
244            }
245        }
246        activate {
247            if {[regexp -indices {([a-zA-Z]+)\(([a-zA-Z0-9_]+)\)$} $itk_option(-pathtext) match type id]} {
248                foreach {t0 t1} $type break
249                foreach {s0 s1} $id break
250                set str [string range $itk_option(-pathtext) $s0 $s1]
251
252                set s0 [expr {$s0-$t0}]  ;# set relative to start of tail string
253                set s1 [expr {$s1-$t0}]
254
255                # get bbox for first and last char in "(id)" part
256                foreach {x0 y0 w h} [$itk_component(path) bbox 1.$s0] break
257                foreach {x1 y0 w h} [$itk_component(path) bbox 1.$s1] break
258                set x1 [expr {$x1+$w}]
259                set y1 [expr {$y0+$h}]
260
261                # compute overall x0,y0 and width/height for this area
262                set w [expr {$x1-$x0}]
263                set h [expr {$y1-$y0}]
264                set x0 [expr {[winfo rootx $itk_component(path)]+$x0}]
265                set y0 [expr {[winfo rooty $itk_component(path)]+$y0}]
266
267                return [list text $str x $x0 y [expr {$y0-2}] w $w h $h]
268            }
269        }
270        validate {
271            set val [lindex $args 0]
272            if {![regexp {^[a-zA-Z0-9_]+$} $val]} {
273                bell
274                return 0
275            }
276            return 1
277        }
278        apply {
279            set val [lindex $args 0]
280            if {[string length $itk_option(-renamecommand)] > 0} {
281                uplevel #0 $itk_option(-renamecommand) [list $val]
282            }
283        }
284        revert {
285            _redraw
286        }
287        default {
288            error "bad option \"$option\": should be start, activate, validate, apply, revert"
289        }
290    }
291}
292
293# ----------------------------------------------------------------------
294# CONFIGURATION OPTION: -label, -pathtext
295# ----------------------------------------------------------------------
296itcl::configbody Rappture::ObjPath::label {
297    $_dispatcher event -idle !redraw
298}
299itcl::configbody Rappture::ObjPath::pathtext {
300    $_dispatcher event -idle !redraw
301}
Note: See TracBrowser for help on using the repository browser.