1# ------------------------------------------------------------------------------
2#  dropsite.tcl
3#  This file is part of Unifix BWidget Toolkit
4#  $Id: dropsite.tcl 606 2004-04-05 07:06:06Z mcourtoi $
5# ------------------------------------------------------------------------------
6#  Index of commands:
7#     - DropSite::include
8#     - DropSite::setdrop
9#     - DropSite::register
10#     - DropSite::setcursor
11#     - DropSite::setoperation
12#     - DropSite::_update_operation
13#     - DropSite::_compute_operation
14#     - DropSite::_draw_operation
15#     - DropSite::_init_drag
16#     - DropSite::_motion
17#     - DropSite::_release
18# ----------------------------------------------------------------------------
19
20
21namespace eval DropSite {
22    Widget::define DropSite dropsite -classonly
23
24    Widget::declare DropSite [list \
25	    [list -dropovercmd String "" 0] \
26	    [list -dropcmd     String "" 0] \
27	    [list -droptypes   String "" 0] \
28	    ]
29
30    proc use {} {}
31
32    variable _top  ".drag"
33    variable _opw  ".drag.\#op"
34    variable _target  ""
35    variable _status  0
36    variable _tabops
37    variable _defops
38    variable _source
39    variable _type
40    variable _data
41    variable _evt
42    # key       win    unix
43    # shift       1   |   1    ->  1
44    # control     4   |   4    ->  4
45    # alt         8   |  16    -> 24
46    # meta            |  64    -> 88
47
48    array set _tabops {
49        mod,none    0
50        mod,shift   1
51        mod,control 4
52        mod,alt     24
53        ops,copy    1
54        ops,move    1
55        ops,link    1
56    }
57
58    if { $tcl_platform(platform) == "unix" } {
59        set _tabops(mod,alt) 8
60    } else {
61        set _tabops(mod,alt) 16
62    }
63    array set _defops \
64        [list \
65             copy,mod  shift   \
66             move,mod  control \
67             link,mod  alt     \
68             copy,img  @[file join $::BWIDGET::LIBRARY "images" "opcopy.xbm"] \
69             move,img  @[file join $::BWIDGET::LIBRARY "images" "opmove.xbm"] \
70             link,img  @[file join $::BWIDGET::LIBRARY "images" "oplink.xbm"]]
71
72    bind DragTop <KeyPress-Shift_L>     {DropSite::_update_operation [expr %s | 1]}
73    bind DragTop <KeyPress-Shift_R>     {DropSite::_update_operation [expr %s | 1]}
74    bind DragTop <KeyPress-Control_L>   {DropSite::_update_operation [expr %s | 4]}
75    bind DragTop <KeyPress-Control_R>   {DropSite::_update_operation [expr %s | 4]}
76    if { $tcl_platform(platform) == "unix" } {
77        bind DragTop <KeyPress-Alt_L>       {DropSite::_update_operation [expr %s | 8]}
78        bind DragTop <KeyPress-Alt_R>       {DropSite::_update_operation [expr %s | 8]}
79    } else {
80        bind DragTop <KeyPress-Alt_L>       {DropSite::_update_operation [expr %s | 16]}
81        bind DragTop <KeyPress-Alt_R>       {DropSite::_update_operation [expr %s | 16]}
82    }
83
84    bind DragTop <KeyRelease-Shift_L>   {DropSite::_update_operation [expr %s & ~1]}
85    bind DragTop <KeyRelease-Shift_R>   {DropSite::_update_operation [expr %s & ~1]}
86    bind DragTop <KeyRelease-Control_L> {DropSite::_update_operation [expr %s & ~4]}
87    bind DragTop <KeyRelease-Control_R> {DropSite::_update_operation [expr %s & ~4]}
88    if { $tcl_platform(platform) == "unix" } {
89        bind DragTop <KeyRelease-Alt_L>     {DropSite::_update_operation [expr %s & ~8]}
90        bind DragTop <KeyRelease-Alt_R>     {DropSite::_update_operation [expr %s & ~8]}
91    } else {
92        bind DragTop <KeyRelease-Alt_L>     {DropSite::_update_operation [expr %s & ~16]}
93        bind DragTop <KeyRelease-Alt_R>     {DropSite::_update_operation [expr %s & ~16]}
94    }
95}
96
97
98# ----------------------------------------------------------------------------
99#  Command DropSite::include
100# ----------------------------------------------------------------------------
101proc DropSite::include { class types } {
102    set dropoptions [list \
103	    [list	-dropenabled	Boolean	0	0] \
104	    [list	-dropovercmd	String	""	0] \
105	    [list	-dropcmd	String	""	0] \
106	    [list	-droptypes	String	$types	0] \
107	    ]
108    Widget::declare $class $dropoptions
109}
110
111
112# ----------------------------------------------------------------------------
113#  Command DropSite::setdrop
114#  Widget interface to register
115# ----------------------------------------------------------------------------
116proc DropSite::setdrop { path subpath dropover drop {force 0}} {
117    set cen    [Widget::hasChanged $path -dropenabled en]
118    set ctypes [Widget::hasChanged $path -droptypes   types]
119    if { $en } {
120        if { $force || $cen || $ctypes } {
121            register $subpath \
122                -droptypes   $types \
123                -dropcmd     $drop  \
124                -dropovercmd $dropover
125        }
126    } else {
127        register $subpath
128    }
129}
130
131
132# ----------------------------------------------------------------------------
133#  Command DropSite::register
134# ----------------------------------------------------------------------------
135proc DropSite::register { path args } {
136    variable _tabops
137    variable _defops
138    upvar \#0 DropSite::$path drop
139
140    Widget::init DropSite .drop$path $args
141    if { [info exists drop] } {
142        unset drop
143    }
144    set dropcmd [Widget::getMegawidgetOption .drop$path -dropcmd]
145    set types   [Widget::getMegawidgetOption .drop$path -droptypes]
146    set overcmd [Widget::getMegawidgetOption .drop$path -dropovercmd]
147    Widget::destroy .drop$path
148    if { $dropcmd != "" && $types != "" } {
149        set drop(dropcmd) $dropcmd
150        set drop(overcmd) $overcmd
151        foreach {type ops} $types {
152            set drop($type,ops) {}
153            foreach {descop lmod} $ops {
154                if { ![llength $descop] || [llength $descop] > 3 } {
155                    return -code error "invalid operation description \"$descop\""
156                }
157                foreach {subop baseop imgop} $descop {
158                    set subop [string trim $subop]
159                    if { ![string length $subop] } {
160                        return -code error "sub operation is empty"
161                    }
162                    if { ![string length $baseop] } {
163                        set baseop $subop
164                    }
165                    if { [info exists drop($type,ops,$subop)] } {
166                        return -code error "operation \"$subop\" already defined"
167                    }
168                    if { ![info exists _tabops(ops,$baseop)] } {
169                        return -code error "invalid base operation \"$baseop\""
170                    }
171                    if { ![string equal $subop $baseop] &&
172                         [info exists _tabops(ops,$subop)] } {
173                        return -code error "sub operation \"$subop\" is a base operation"
174                    }
175                    if { ![string length $imgop] } {
176                        set imgop $_defops($baseop,img)
177                    }
178                }
179                if { [string equal $lmod "program"] } {
180                    set drop($type,ops,$subop) $baseop
181                    set drop($type,img,$subop) $imgop
182                } else {
183                    if { ![string length $lmod] } {
184                        set lmod $_defops($baseop,mod)
185                    }
186                    set mask 0
187                    foreach mod $lmod {
188                        if { ![info exists _tabops(mod,$mod)] } {
189                            return -code error "invalid modifier \"$mod\""
190                        }
191                        set mask [expr {$mask | $_tabops(mod,$mod)}]
192                    }
193                    if { ($mask == 0) != ([string equal $subop "default"]) } {
194                        return -code error "sub operation default can only be used with modifier \"none\""
195                    }
196                    set drop($type,mod,$mask)  $subop
197                    set drop($type,ops,$subop) $baseop
198                    set drop($type,img,$subop) $imgop
199                    lappend masklist $mask
200                }
201            }
202            if { ![info exists drop($type,mod,0)] } {
203                set drop($type,mod,0)       default
204                set drop($type,ops,default) copy
205                set drop($type,img,default) $_defops(copy,img)
206                lappend masklist 0
207            }
208            set drop($type,ops,force) copy
209            set drop($type,img,force) $_defops(copy,img)
210            foreach mask [lsort -integer -decreasing $masklist] {
211                lappend drop($type,ops) $mask $drop($type,mod,$mask)
212            }
213        }
214    }
215}
216
217
218# ----------------------------------------------------------------------------
219#  Command DropSite::setcursor
220# ----------------------------------------------------------------------------
221proc DropSite::setcursor { cursor } {
222    catch {.drag configure -cursor $cursor}
223}
224
225
226# ----------------------------------------------------------------------------
227#  Command DropSite::setoperation
228# ----------------------------------------------------------------------------
229proc DropSite::setoperation { op } {
230    variable _curop
231    variable _dragops
232    variable _target
233    variable _type
234    upvar \#0 DropSite::$_target drop
235
236    if { [info exist drop($_type,ops,$op)] &&
237         $_dragops($drop($_type,ops,$op)) } {
238        set _curop $op
239    } else {
240        # force to a copy operation
241        set _curop force
242    }
243}
244
245
246# ----------------------------------------------------------------------------
247#  Command DropSite::_init_drag
248# ----------------------------------------------------------------------------
249proc DropSite::_init_drag { top evt source state X Y type ops data } {
250    variable _top
251    variable _source
252    variable _type
253    variable _data
254    variable _target
255    variable _status
256    variable _state
257    variable _dragops
258    variable _opw
259    variable _evt
260
261    if {[info exists _dragops]} {
262        unset _dragops
263    }
264    array set _dragops {copy 1 move 0 link 0}
265    foreach op $ops {
266        set _dragops($op) 1
267    }
268    set _target ""
269    set _status  0
270    set _top     $top
271    set _source  $source
272    set _type    $type
273    set _data    $data
274
275    label $_opw -relief flat -bd 0 -highlightthickness 0 \
276        -foreground black -background white
277
278    bind $top <ButtonRelease-$evt> {DropSite::_release %X %Y}
279    bind $top <B$evt-Motion>       {DropSite::_motion  %X %Y}
280    bind $top <Motion>             {DropSite::_release %X %Y}
281    set _state $state
282    set _evt   $evt
283    _motion $X $Y
284}
285
286
287# ----------------------------------------------------------------------------
288#  Command DropSite::_update_operation
289# ----------------------------------------------------------------------------
290proc DropSite::_update_operation { state } {
291    variable _top
292    variable _status
293    variable _state
294
295    if { $_status & 3 } {
296        set _state $state
297        _motion [winfo pointerx $_top] [winfo pointery $_top]
298    }
299}
300
301
302# ----------------------------------------------------------------------------
303#  Command DropSite::_compute_operation
304# ----------------------------------------------------------------------------
305proc DropSite::_compute_operation { target state type } {
306    variable  _curop
307    variable  _dragops
308    upvar \#0 DropSite::$target drop
309
310    foreach {mask op} $drop($type,ops) {
311        if { ($state & $mask) == $mask } {
312            if { $_dragops($drop($type,ops,$op)) } {
313                set _curop $op
314                return
315            }
316        }
317    }
318    set _curop force
319}
320
321
322# ----------------------------------------------------------------------------
323#  Command DropSite::_draw_operation
324# ----------------------------------------------------------------------------
325proc DropSite::_draw_operation { target type } {
326    variable _opw
327    variable _curop
328    variable _dragops
329    variable _tabops
330    variable _status
331
332    upvar \#0 DropSite::$target drop
333
334    if { !($_status & 1) } {
335        catch {place forget $_opw}
336        return
337    }
338
339    if { 0 } {
340    if { ![info exist drop($type,ops,$_curop)] ||
341         !$_dragops($drop($type,ops,$_curop)) } {
342        # force to a copy operation
343        set _curop copy
344        catch {
345            $_opw configure -bitmap $_tabops(img,copy)
346            place $_opw -relx 1 -rely 1 -anchor se
347        }
348    }
349    } elseif { [string equal $_curop "default"] } {
350        catch {place forget $_opw}
351    } else {
352        catch {
353            $_opw configure -bitmap $drop($type,img,$_curop)
354            place $_opw -relx 1 -rely 1 -anchor se
355        }
356    }
357}
358
359
360# ----------------------------------------------------------------------------
361#  Command DropSite::_motion
362# ----------------------------------------------------------------------------
363proc DropSite::_motion { X Y } {
364    variable _top
365    variable _target
366    variable _status
367    variable _state
368    variable _curop
369    variable _type
370    variable _data
371    variable _source
372    variable _evt
373
374    set script [bind $_top <B$_evt-Motion>]
375    bind $_top <B$_evt-Motion> {}
376    bind $_top <Motion>        {}
377    wm geometry $_top "+[expr {$X+1}]+[expr {$Y+1}]"
378    update
379    if { ![winfo exists $_top] } {
380        return
381    }
382    set path [winfo containing $X $Y]
383    if { ![string equal $path $_target] } {
384        # path != current target
385        if { $_status & 2 } {
386            # current target is valid and has recall status
387            # generate leave event
388            upvar   \#0 DropSite::$_target drop
389            uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
390        }
391        set _target $path
392        upvar \#0 DropSite::$_target drop
393        if { [info exists drop($_type,ops)] } {
394            # path is a valid target
395            _compute_operation $_target $_state $_type
396            if { $drop(overcmd) != "" } {
397                set arg     [list $_target $_source enter $X $Y $_curop $_type $_data]
398                set _status [uplevel \#0 $drop(overcmd) $arg]
399            } else {
400                set _status 1
401                catch {$_top configure -cursor based_arrow_down}
402            }
403            _draw_operation $_target $_type
404            update
405            catch {
406                bind $_top <B$_evt-Motion> {DropSite::_motion  %X %Y}
407                bind $_top <Motion>        {DropSite::_release %X %Y}
408            }
409            return
410        } else {
411            set _status 0
412            catch {$_top configure -cursor dot}
413            _draw_operation "" ""
414        }
415    } elseif { $_status & 2 } {
416        upvar \#0 DropSite::$_target drop
417        _compute_operation $_target $_state $_type
418        set arg     [list $_target $_source motion $X $Y $_curop $_type $_data]
419        set _status [uplevel \#0 $drop(overcmd) $arg]
420        _draw_operation $_target $_type
421    }
422    update
423    catch {
424        bind $_top <B$_evt-Motion> {DropSite::_motion  %X %Y}
425        bind $_top <Motion>        {DropSite::_release %X %Y}
426    }
427}
428
429
430
431# ----------------------------------------------------------------------------
432#  Command DropSite::_release
433# ----------------------------------------------------------------------------
434proc DropSite::_release { X Y } {
435    variable _target
436    variable _status
437    variable _curop
438    variable _source
439    variable _type
440    variable _data
441
442    if { $_status & 1 } {
443        upvar \#0 DropSite::$_target drop
444
445        set res [uplevel \#0 $drop(dropcmd) [list $_target $_source $X $Y $_curop $_type $_data]]
446        DragSite::_end_drag $_source $_target $drop($_type,ops,$_curop) $_type $_data $res
447    } else {
448        if { $_status & 2 } {
449            # notify leave event
450            upvar \#0 DropSite::$_target drop
451            uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
452        }
453        DragSite::_end_drag $_source "" "" $_type $_data 0
454    }
455}
456