← Back to branch summary

~ubuntu-branches/ubuntu/gutsy/amsn/gutsy

« back to all changes in this revision

Viewing changes to utils/BWidget-1.7.0/dropsite.tcl

  • Committer: Bazaar Package Importer
  • Author(s): Theodore Karkoulis
  • Date: 2006-01-04 15:26:02 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20060104152602-ipe1yg00rl3nlklv
Tags: 0.95-1
http://bugs.debian.org/345052
http://bugs.debian.org/278575
New Upstream Release (closes: #345052, #278575).

Show diffs side-by-side

added added

removed removed

Lines of Context:
utils/BWidget-1.7.0/dropsite.tcl
 
1
# ------------------------------------------------------------------------------
 
2
#  dropsite.tcl
 
3
#  This file is part of Unifix BWidget Toolkit
 
4
#  $Id: dropsite.tcl,v 1.1 2004/12/03 00:31:24 tjikkun 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
 
 
21
namespace 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
# ----------------------------------------------------------------------------
 
101
proc 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
# ----------------------------------------------------------------------------
 
116
proc 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
# ----------------------------------------------------------------------------
 
135
proc 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
# ----------------------------------------------------------------------------
 
221
proc DropSite::setcursor { cursor } {
 
222
    catch {.drag configure -cursor $cursor}
 
223
}
 
224
 
 
225
 
 
226
# ----------------------------------------------------------------------------
 
227
#  Command DropSite::setoperation
 
228
# ----------------------------------------------------------------------------
 
229
proc 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
# ----------------------------------------------------------------------------
 
249
proc 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
# ----------------------------------------------------------------------------
 
290
proc 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
# ----------------------------------------------------------------------------
 
305
proc 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
# ----------------------------------------------------------------------------
 
325
proc 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
# ----------------------------------------------------------------------------
 
363
proc 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
# ----------------------------------------------------------------------------
 
434
proc 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
}