1# 2# tkdnd.tcl -- 3# 4# This file implements some utility procedures that are used by the tkDND 5# package. 6# 7# This software is copyrighted by: 8# George Petasis, National Centre for Scientific Research "Demokritos", 9# Aghia Paraskevi, Athens, Greece. 10# e-mail: petasis@iit.demokritos.gr 11# 12# The following terms apply to all files associated 13# with the software unless explicitly disclaimed in individual files. 14# 15# The authors hereby grant permission to use, copy, modify, distribute, 16# and license this software and its documentation for any purpose, provided 17# that existing copyright notices are retained in all copies and that this 18# notice is included verbatim in any distributions. No written agreement, 19# license, or royalty fee is required for any of the authorized uses. 20# Modifications to this software may be copyrighted by their authors 21# and need not follow the licensing terms described here, provided that 22# the new terms are clearly indicated on the first page of each file where 23# they apply. 24# 25# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY 26# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES 27# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY 28# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE 29# POSSIBILITY OF SUCH DAMAGE. 30# 31# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, 32# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, 33# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE 34# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE 35# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR 36# MODIFICATIONS. 37# 38 39namespace eval ::dnd { 40 variable AskSelectedAction 41 42 # This procedure is used just to ensure that the object given as its 43 # argument can be accessed as a binary object. Many thanks to Paul Duffin 44 # for the idea :-) 45 proc ConvertToBinary {object} { 46 binary scan $object {} 47 return $object 48 } 49 50 # This procedure handles the special case where we want items into a canvas 51 # widget to be drop targets. It emulates this case as follows: 52 # 53 # The tkDND extension is able to deliver events only to real windows 54 # (that means tk widgets). This procedure can be the binding script of all 55 # dnd events we are interested in being received by the canvas items. 56 # When this function is called, it tries to find the item that the mouse 57 # is over (if any). Then it examines its bindings, and if it finds the 58 # dnd related event that is processing it delivers this event to the 59 # particular item. Fianlly, it tries to emulate <DragEnter>/<DragLeave> 60 # on every canvas item... 61 proc CanvasDeliverEvent { 62 event actions action button source_codes curr_code data descriptions 63 mods type source_types win X x Y y 64 } { 65 # This function will find the topmost item that the mouse is over, and 66 # Deliver the event specified by the "event" arg to this item... 67 global CanvasDeliverEventStatus 68 switch $event { 69 <DragEnter> - 70 <<DragEnter>> {set CanvasDeliverEventStatus(item) {}} 71 default {} 72 } 73 74 # Translate mouse coordinates to canvas coordinates... 75 set cx [$win canvasx $x] 76 set cy [$win canvasy $y] 77 set cx_1 [expr {$cx+1}] 78 set cy_1 [expr {$cy+1}] 79 # Find all tags that are under the mouse... 80 set tags [$win find overlapping $cx $cy $cx_1 $cy_1] 81 # ... and select the topmost... 82 set length [llength $tags] 83 84 # If no tags under the mouse, return... 85 if {!$length} { 86 #puts -->$CanvasDeliverEventStatus(item) 87 if {[string length $CanvasDeliverEventStatus(item)]} { 88 # Send <<DragLeave>>... 89 set _id $CanvasDeliverEventStatus(item) 90 set _binding {} 91 foreach _tag [concat $_id [$win gettags $_id]] { 92 set _binding [$win bind $_tag <<DragLeave>>] 93 if {[string length $_binding]} {break} 94 } 95 # puts "Sending <DragLeave> (1) to $_id ($_binding)" 96 set script {} 97 foreach element $_binding { 98 switch $element { 99 %% {lappend script %} 100 %A {lappend script $action} 101 %a {lappend script $actions} 102 %b {lappend script $button} 103 %C {lappend script $source_codes} 104 %c {lappend script $curr_code} 105 %D {lappend script $data} 106 %d {lappend script $descriptions} 107 %m {lappend script $mods} 108 %T {lappend script $type} 109 %t {lappend script $source_types} 110 %W {lappend script $win} 111 %X {lappend script $X} 112 %x {lappend script $x} 113 %Y {lappend script $Y} 114 %y {lappend script $y} 115 %I {lappend script $_id} 116 default {lappend script $element} 117 } 118 } 119 if {[llength $script]} {uplevel 1 $script} 120 } 121 set CanvasDeliverEventStatus(item) {} 122 update 123 if {[string equal $event <<Drag>>]} { 124 return -code break 125 } 126 return $action 127 } 128 if {$length == 1} { 129 set id $tags 130 } else { 131 set id [$win find closest $cx $cy] 132 } 133 134 # Now in "id" we have the tag of the item below the mouse... 135 # Has this item a binding? 136 foreach tag [concat $id [$win gettags $id]] { 137 set binding [$win bind $tag $event] 138 if {[string length $binding]} {break} 139 } 140 141 # Is this tag the same as the last one? If is different, we 142 # have to send a leave event to the previous item and an enter 143 # event to this one... 144 if {$CanvasDeliverEventStatus(item) != $id} { 145 if {[string length $CanvasDeliverEventStatus(item)]} { 146 # Send <<DragLeave>>... 147 set _id $CanvasDeliverEventStatus(item) 148 set _binding {} 149 foreach _tag [concat $_id [$win gettags $_id]] { 150 set _binding [$win bind $_tag <<DragLeave>>] 151 if {[string length $_binding]} {break} 152 } 153 # puts "Sending <DragLeave> (2) to $_id ($_binding)" 154 set script {} 155 foreach element $_binding { 156 switch $element { 157 %% {lappend script %} 158 %A {lappend script $action} 159 %a {lappend script $actions} 160 %b {lappend script $button} 161 %C {lappend script $source_codes} 162 %c {lappend script $curr_code} 163 %D {lappend script $data} 164 %d {lappend script $descriptions} 165 %m {lappend script $mods} 166 %T {lappend script $type} 167 %t {lappend script $source_types} 168 %W {lappend script $win} 169 %X {lappend script $X} 170 %x {lappend script $x} 171 %Y {lappend script $Y} 172 %y {lappend script $y} 173 %I {lappend script $_id} 174 default {lappend script $element} 175 } 176 } 177 if {[llength $script]} {uplevel 1 $script} 178 } 179 # Send <<DndEnter>>... 180 set _id $id 181 set _binding {} 182 foreach _tag [concat $_id [$win gettags $_id]] { 183 set _binding [$win bind $_tag <<DragEnter>>] 184 if {[string length $_binding]} {break} 185 } 186 # puts "Sending <DragEnter> to $tag ($_binding)" 187 set script {} 188 foreach element $_binding { 189 switch $element { 190 %% {lappend script %} 191 %A {lappend script $action} 192 %a {lappend script $actions} 193 %b {lappend script $button} 194 %C {lappend script $source_codes} 195 %c {lappend script $curr_code} 196 %D {lappend script $data} 197 %d {lappend script $descriptions} 198 %m {lappend script $mods} 199 %T {lappend script $type} 200 %t {lappend script $source_types} 201 %W {lappend script $win} 202 %X {lappend script $X} 203 %x {lappend script $x} 204 %Y {lappend script $Y} 205 %y {lappend script $y} 206 %I {lappend script $_id} 207 default {lappend script $element} 208 } 209 } 210 if {[llength $script]} {uplevel 1 $script} 211 set CanvasDeliverEventStatus(item) $id 212 } 213 214 set script {} 215 foreach element $binding { 216 switch $element { 217 %% {lappend script %} 218 %A {lappend script $action} 219 %a {lappend script $actions} 220 %b {lappend script $button} 221 %C {lappend script $source_codes} 222 %c {lappend script $curr_code} 223 %D {lappend script $data} 224 %d {lappend script $descriptions} 225 %m {lappend script $mods} 226 %T {lappend script $type} 227 %t {lappend script $source_types} 228 %W {lappend script $win} 229 %X {lappend script $X} 230 %x {lappend script $x} 231 %Y {lappend script $Y} 232 %y {lappend script $y} 233 %I {lappend script $id} 234 default {lappend script $element} 235 } 236 } 237 if {[llength $script]} { 238 return [uplevel 1 $script] 239 } 240 set CanvasDeliverEventStatus(item) {} 241 update 242 if {[string equal $event <<Drag>>]} { 243 return -code break 244 } 245 return $action 246 } 247 248 # ChooseAskAction -- 249 # This procedure displays a dialog with the help of which the user can 250 # select one of the supported actions... 251 proc ChooseAskAction {window x y actions descriptions args} { 252 variable AskSelectedAction 253 set title {Please Select Action:} 254 foreach action $actions descr $descriptions { 255 if {[string equal $action ask]} { 256 set title $descr 257 break 258 } 259 } 260 261 set menu $window.__tk_dnd[pwd]__action_ask__Drop_window_[pid] 262 catch {destroy $menu} 263 menu $menu -title $title -tearoff 0 -disabledforeground darkgreen 264 $menu add command -font {helvetica 12 bold} \ 265 -label $title -command "destroy $menu" -state disabled 266 $menu add separator 267 268 set items 0 269 foreach action $actions descr $descriptions { 270 if {[string equal $action ask]} continue 271 $menu add command -label $descr -command \ 272 "set ::dnd::AskSelectedAction $action; destroy $menu" 273 incr items 274 } 275 if {!$items} { 276 # The drag source accepts the ask action, but has no defined 277 # action list? Add copy action at least... 278 $menu add command -label Copy -command \ 279 "set ::dnd::AskSelectedAction copy; destroy $menu" 280 } 281 282 $menu add separator 283 $menu add command -label {Cancel Drop} -command \ 284 "set ::dnd::AskSelectedAction none; destroy $menu" 285 286 set AskSelectedAction none 287 tk_popup $menu $x $y 288 update 289 bind $menu <Unmap> {after idle {catch {destroy %W}}} 290 tkwait window $menu 291 292 return $AskSelectedAction 293 } 294};# namespace eval ::dnd 295 296# EOF 297