source: trunk/BWidget-1.2.1/dropsite.tcl @ 931

Last change on this file since 931 was 931, checked in by toby, 11 years ago

include rest of files

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