[1742] | 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-2010 Purdue Research Foundation |
---|
| 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 | # ====================================================================== |
---|
| 15 | package require Itk |
---|
| 16 | |
---|
| 17 | option add *ObjPath.selectBackground cyan widgetDefault |
---|
| 18 | option add *ObjPath.pathFont {helvetica -12} widgetDefault |
---|
| 19 | |
---|
| 20 | itcl::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 | |
---|
| 39 | itk::usual ObjPath { |
---|
| 40 | keep -cursor -font -foreground -background |
---|
| 41 | } |
---|
| 42 | |
---|
| 43 | # ---------------------------------------------------------------------- |
---|
| 44 | # CONSTRUCTOR |
---|
| 45 | # ---------------------------------------------------------------------- |
---|
| 46 | itcl::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 | # ---------------------------------------------------------------------- |
---|
| 106 | itcl::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 | # ---------------------------------------------------------------------- |
---|
| 128 | itcl::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 | # ---------------------------------------------------------------------- |
---|
| 180 | itcl::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 | # ---------------------------------------------------------------------- |
---|
| 214 | itcl::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 | # ---------------------------------------------------------------------- |
---|
| 236 | itcl::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 | # ---------------------------------------------------------------------- |
---|
| 296 | itcl::configbody Rappture::ObjPath::label { |
---|
| 297 | $_dispatcher event -idle !redraw |
---|
| 298 | } |
---|
| 299 | itcl::configbody Rappture::ObjPath::pathtext { |
---|
| 300 | $_dispatcher event -idle !redraw |
---|
| 301 | } |
---|