[3330] | 1 | # -*- mode: tcl; indent-tabs-mode: nil -*- |
---|
[1] | 2 | # ---------------------------------------------------------------------- |
---|
| 3 | # COMPONENT: editor - pop-up editor for little bits of text |
---|
| 4 | # |
---|
| 5 | # This widget acts as a pop-up editor for small text fields. It |
---|
| 6 | # pops up on top of any text field, accepts edits, and then attempts |
---|
| 7 | # to validate and apply changes back to the underlying widget. |
---|
| 8 | # |
---|
| 9 | # This widget uses a number of callbacks to handle communication |
---|
| 10 | # with the underlying widget: |
---|
| 11 | # |
---|
| 12 | # -activatecommand .... Should return a key/value list with the |
---|
| 13 | # following elements: |
---|
| 14 | # x ...... root x coordinate for editor |
---|
| 15 | # y ...... root y coordinate for editor |
---|
| 16 | # w ...... width of text being edited |
---|
| 17 | # h ...... height of text being edited |
---|
| 18 | # text ... initial text for the editor |
---|
| 19 | # |
---|
| 20 | # -validatecommand .... Invoked with the new value as an argument. |
---|
| 21 | # Should return 1 if the value is okay, and |
---|
| 22 | # 0 otherwise. |
---|
| 23 | # |
---|
| 24 | # -applycommand ....... Invoked with the new value as an argument. |
---|
| 25 | # Should apply the new value to the underlying |
---|
| 26 | # widget. |
---|
| 27 | # |
---|
| 28 | # ====================================================================== |
---|
| 29 | # AUTHOR: Michael McLennan, Purdue University |
---|
[3177] | 30 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
---|
[115] | 31 | # |
---|
| 32 | # See the file "license.terms" for information on usage and |
---|
| 33 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
[1] | 34 | # ====================================================================== |
---|
| 35 | package require Itk |
---|
| 36 | |
---|
| 37 | option add *Editor.background white widgetDefault |
---|
| 38 | option add *Editor.outline black widgetDefault |
---|
| 39 | option add *Editor.borderwidth 1 widgetDefault |
---|
| 40 | option add *Editor.relief flat widgetDefault |
---|
| 41 | option add *Editor.selectBorderWidth 0 widgetDefault |
---|
| 42 | |
---|
| 43 | itcl::class Rappture::Editor { |
---|
| 44 | inherit itk::Toplevel |
---|
| 45 | |
---|
| 46 | itk_option define -outline outline Outline "" |
---|
| 47 | itk_option define -activatecommand activateCommand ActivateCommand "" |
---|
| 48 | itk_option define -validatecommand validateCommand ValidateCommand "" |
---|
| 49 | itk_option define -applycommand applyCommand ApplyCommand "" |
---|
| 50 | |
---|
| 51 | constructor {args} { # defined below } |
---|
| 52 | |
---|
| 53 | public method activate {} |
---|
| 54 | public method deactivate {args} |
---|
| 55 | public method value {newval} |
---|
| 56 | |
---|
| 57 | protected method _click {x y} |
---|
| 58 | protected method _resize {} |
---|
| 59 | protected variable _loc ;# array of editor location parameters |
---|
| 60 | } |
---|
[1850] | 61 | |
---|
[1] | 62 | itk::usual Editor { |
---|
| 63 | keep -cursor -font |
---|
| 64 | } |
---|
| 65 | |
---|
| 66 | # ---------------------------------------------------------------------- |
---|
| 67 | # CONSTRUCTOR |
---|
| 68 | # ---------------------------------------------------------------------- |
---|
| 69 | itcl::body Rappture::Editor::constructor {args} { |
---|
| 70 | wm overrideredirect $itk_component(hull) yes |
---|
| 71 | wm withdraw $itk_component(hull) |
---|
| 72 | |
---|
| 73 | itk_option remove hull.background hull.borderwidth |
---|
| 74 | component hull configure -borderwidth 1 |
---|
| 75 | |
---|
| 76 | itk_component add editor { |
---|
[1850] | 77 | entry $itk_interior.editor -highlightthickness 0 |
---|
[1] | 78 | } { |
---|
[1850] | 79 | usual |
---|
| 80 | keep -relief |
---|
| 81 | ignore -highlightthickness |
---|
| 82 | ignore -highlightcolor |
---|
| 83 | ignore -highlightbackground |
---|
[1] | 84 | } |
---|
| 85 | pack $itk_component(editor) -expand yes -fill both |
---|
| 86 | |
---|
| 87 | bind $itk_component(editor) <KeyPress> \ |
---|
[1850] | 88 | [itcl::code $this _resize] |
---|
[1] | 89 | bind $itk_component(editor) <KeyPress-Return> \ |
---|
[1850] | 90 | [itcl::code $this deactivate] |
---|
[1] | 91 | bind $itk_component(editor) <KeyPress-Escape> \ |
---|
[1850] | 92 | [itcl::code $this deactivate -abort] |
---|
[1] | 93 | bind $itk_component(editor) <ButtonPress> \ |
---|
[1850] | 94 | [itcl::code $this _click %X %Y] |
---|
[1] | 95 | |
---|
[17] | 96 | itk_component add emenu { |
---|
[1850] | 97 | menu $itk_component(editor).menu -tearoff 0 |
---|
[17] | 98 | } { |
---|
[1850] | 99 | usual |
---|
| 100 | ignore -tearoff |
---|
| 101 | ignore -background -foreground |
---|
[17] | 102 | } |
---|
| 103 | $itk_component(emenu) add command -label "Cut" -accelerator "^X" \ |
---|
[1850] | 104 | -command [list event generate $itk_component(editor) <<Cut>>] |
---|
[17] | 105 | $itk_component(emenu) add command -label "Copy" -accelerator "^C" \ |
---|
[1850] | 106 | -command [list event generate $itk_component(editor) <<Copy>>] |
---|
[17] | 107 | $itk_component(emenu) add command -label "Paste" -accelerator "^V" \ |
---|
[1850] | 108 | -command [list event generate $itk_component(editor) <<Paste>>] |
---|
[17] | 109 | bind $itk_component(editor) <<PopupMenu>> { |
---|
[1850] | 110 | tk_popup %W.menu %X %Y |
---|
[17] | 111 | } |
---|
| 112 | |
---|
[1] | 113 | eval itk_initialize $args |
---|
| 114 | } |
---|
| 115 | |
---|
| 116 | # ---------------------------------------------------------------------- |
---|
| 117 | # USAGE: activate |
---|
| 118 | # |
---|
| 119 | # Clients use this to start the editing process on the underlying |
---|
| 120 | # widget. This pops up the editor with the current text from the |
---|
| 121 | # underlying widget and allows the user to edit the text. The editor |
---|
| 122 | # remains up until it is deactivated. |
---|
| 123 | # ---------------------------------------------------------------------- |
---|
| 124 | itcl::body Rappture::Editor::activate {} { |
---|
| 125 | set e $itk_component(editor) |
---|
[17] | 126 | if {[winfo ismapped $e]} { |
---|
[1850] | 127 | return ;# already mapped -- nothing to do |
---|
[17] | 128 | } |
---|
[1] | 129 | |
---|
| 130 | set info "" |
---|
| 131 | if {[string length $itk_option(-activatecommand)] > 0} { |
---|
[1850] | 132 | set status [catch {uplevel #0 $itk_option(-activatecommand)} info] |
---|
| 133 | if {$status != 0} { |
---|
| 134 | bgerror $info |
---|
| 135 | return |
---|
| 136 | } |
---|
[1] | 137 | } |
---|
| 138 | |
---|
| 139 | # |
---|
| 140 | # Pull out the location information from the values passed back |
---|
| 141 | # from the activation command. We must have at least an x,y |
---|
| 142 | # coordinate. If we get width and height too, then use it. |
---|
| 143 | # If not, figure out the width and height based on the size |
---|
| 144 | # of the string. |
---|
| 145 | # |
---|
| 146 | array set vals $info |
---|
| 147 | if {![info exists vals(x)] || ![info exists vals(y)]} { |
---|
[1850] | 148 | return |
---|
[1] | 149 | } |
---|
| 150 | set _loc(x) $vals(x) |
---|
| 151 | set _loc(y) $vals(y) |
---|
| 152 | set _loc(w) [expr {([info exists vals(w)]) ? $vals(w) : 0}] |
---|
| 153 | set _loc(h) [expr {([info exists vals(h)]) ? $vals(h) : 0}] |
---|
| 154 | |
---|
| 155 | $itk_component(editor) delete 0 end |
---|
| 156 | if {[info exists vals(text)]} { |
---|
[1850] | 157 | $itk_component(editor) insert end $vals(text) |
---|
[1] | 158 | } |
---|
| 159 | $itk_component(editor) select from 0 |
---|
| 160 | $itk_component(editor) select to end |
---|
| 161 | |
---|
| 162 | _resize |
---|
| 163 | wm deiconify $itk_component(hull) |
---|
| 164 | raise $itk_component(hull) |
---|
[2159] | 165 | focus -force $itk_component(editor) |
---|
[1] | 166 | |
---|
| 167 | # try to grab the pointer, and keep trying... |
---|
| 168 | update |
---|
| 169 | while {[catch {grab set -global $itk_component(editor)}]} { |
---|
[1850] | 170 | after 100 |
---|
[1] | 171 | } |
---|
| 172 | } |
---|
| 173 | |
---|
| 174 | # ---------------------------------------------------------------------- |
---|
| 175 | # USAGE: deactivate ?-abort? |
---|
| 176 | # |
---|
| 177 | # This is invoked automatically whenever the user presses Enter or |
---|
| 178 | # Escape in the editor. Clients can also use it explicitly to |
---|
| 179 | # deactivate the editor. |
---|
| 180 | # |
---|
| 181 | # If the -abort flag is specified, then the editor is taken down |
---|
| 182 | # without any validation or application of the result. Otherwise, |
---|
| 183 | # we validate the contents of the editor and apply the change back |
---|
| 184 | # to the widget. |
---|
| 185 | # ---------------------------------------------------------------------- |
---|
| 186 | itcl::body Rappture::Editor::deactivate {args} { |
---|
| 187 | # take down any error cue that might be up |
---|
| 188 | ::Rappture::Tooltip::cue hide |
---|
| 189 | |
---|
| 190 | if {$args == "-abort"} { |
---|
[1850] | 191 | grab release $itk_component(editor) |
---|
| 192 | wm withdraw $itk_component(hull) |
---|
| 193 | return |
---|
[1] | 194 | } |
---|
| 195 | |
---|
| 196 | set str [$itk_component(editor) get] |
---|
| 197 | |
---|
| 198 | # |
---|
| 199 | # If there's a -validatecommand option, then invoke the code |
---|
| 200 | # now to check the new value. |
---|
| 201 | # |
---|
| 202 | if {[string length $itk_option(-validatecommand)] > 0} { |
---|
[1850] | 203 | set cmd "uplevel #0 [list $itk_option(-validatecommand) [list $str]]" |
---|
| 204 | if {[catch $cmd result]} { |
---|
| 205 | bgerror $result |
---|
| 206 | set result 1 |
---|
| 207 | } |
---|
| 208 | if {$result == 0} { |
---|
| 209 | bell |
---|
| 210 | $itk_component(editor) select from 0 |
---|
| 211 | $itk_component(editor) select to end |
---|
| 212 | $itk_component(editor) icursor end |
---|
| 213 | focus $itk_component(editor) |
---|
| 214 | return |
---|
| 215 | } |
---|
[1] | 216 | } |
---|
| 217 | |
---|
| 218 | grab release $itk_component(editor) |
---|
| 219 | wm withdraw $itk_component(hull) |
---|
| 220 | |
---|
| 221 | # |
---|
| 222 | # If there's an -applycommand option, then invoke the code |
---|
| 223 | # now to apply the new value. |
---|
| 224 | # |
---|
| 225 | if {[string length $itk_option(-applycommand)] > 0} { |
---|
[1850] | 226 | set cmd "uplevel #0 [list $itk_option(-applycommand) [list $str]]" |
---|
| 227 | if {[catch $cmd result]} { |
---|
| 228 | bgerror $result |
---|
| 229 | return |
---|
| 230 | } |
---|
[1] | 231 | } |
---|
| 232 | } |
---|
| 233 | |
---|
| 234 | # ---------------------------------------------------------------------- |
---|
| 235 | # USAGE: value <newval> |
---|
| 236 | # |
---|
| 237 | # Clients use this to suggest a new value, particular when they've |
---|
| 238 | # caught an error in the editing process. For example, if the user's |
---|
| 239 | # value is below the minimum allowed value, a client would call this |
---|
| 240 | # method to suggest the minimum value. |
---|
| 241 | # ---------------------------------------------------------------------- |
---|
| 242 | itcl::body Rappture::Editor::value {newval} { |
---|
| 243 | $itk_component(editor) delete 0 end |
---|
| 244 | $itk_component(editor) insert end $newval |
---|
| 245 | } |
---|
| 246 | |
---|
| 247 | # ---------------------------------------------------------------------- |
---|
| 248 | # USAGE: _click <X> <Y> |
---|
| 249 | # |
---|
| 250 | # This is invoked automatically whenever the user clicks somewhere |
---|
| 251 | # inside or outside of the editor. If the <X>,<Y> coordinate is |
---|
| 252 | # outside the editor, then we assume the user is done and wants to |
---|
| 253 | # take the editor down. Otherwise, we do nothing, and let the entry |
---|
| 254 | # bindings take over. |
---|
| 255 | # ---------------------------------------------------------------------- |
---|
| 256 | itcl::body Rappture::Editor::_click {x y} { |
---|
| 257 | if {[winfo containing $x $y] != $itk_component(editor)} { |
---|
[1850] | 258 | deactivate |
---|
[17] | 259 | } else { |
---|
[1850] | 260 | # make sure the editor has keyboard focus! |
---|
| 261 | # it loses focus sometimes during cut/copy/paste operations |
---|
| 262 | focus -force $itk_component(editor) |
---|
[1] | 263 | } |
---|
| 264 | } |
---|
| 265 | |
---|
| 266 | # ---------------------------------------------------------------------- |
---|
| 267 | # USAGE: _resize |
---|
| 268 | # |
---|
| 269 | # Invoked automatically as each key is pressed in the editor. |
---|
| 270 | # Resizes the editor so that it is just big enough to show all |
---|
| 271 | # of the text within it. |
---|
| 272 | # ---------------------------------------------------------------------- |
---|
| 273 | itcl::body Rappture::Editor::_resize {} { |
---|
| 274 | set e $itk_component(editor) |
---|
| 275 | set str [$e get] |
---|
| 276 | set fnt [$e cget -font] |
---|
| 277 | |
---|
| 278 | set w [expr {[font measure $fnt $str]+20}] |
---|
| 279 | set w [expr {($w < $_loc(w)) ? $_loc(w) : $w}] |
---|
| 280 | if {$w+$_loc(x) >= [winfo screenwidth $e]} { |
---|
[1850] | 281 | set w [expr {[winfo screenwidth $e]-$_loc(x)}] |
---|
[1] | 282 | } |
---|
| 283 | |
---|
| 284 | set h [expr {[font metrics $fnt -linespace]+4}] |
---|
| 285 | set h [expr {($h < $_loc(h)) ? $_loc(h) : $h}] |
---|
[440] | 286 | if {$h+$_loc(y) >= [winfo screenheight $e]} { |
---|
[1850] | 287 | set h [expr {[winfo screenheight $e]-$_loc(y)}] |
---|
| 288 | } |
---|
[1258] | 289 | # Temporary fix to prevent Opps. Don't deal with negative dimensions. |
---|
| 290 | if { $w <= 0 || $h <= 0 } { |
---|
[1850] | 291 | wm geometry $itk_component(hull) "+$_loc(x)+$_loc(y)" |
---|
[1258] | 292 | } else { |
---|
[1850] | 293 | wm geometry $itk_component(hull) "${w}x${h}+$_loc(x)+$_loc(y)" |
---|
[1] | 294 | } |
---|
| 295 | } |
---|
| 296 | |
---|
| 297 | # ---------------------------------------------------------------------- |
---|
| 298 | # CONFIGURATION OPTION: -outline |
---|
| 299 | # ---------------------------------------------------------------------- |
---|
| 300 | itcl::configbody Rappture::Editor::outline { |
---|
| 301 | component hull configure -background $itk_option(-outline) |
---|
| 302 | } |
---|