1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
# copyright (C) 1997-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu
# $Id: drop.tcl,v 2.15 2005/01/02 00:45:07 jfontain Exp $
class dropSite {
set (list) {} ;# initialize list of objects
proc dropSite {this args} switched {$args} {
lappend (list) $this ;# manage a list of drop sites for drop regions
switched::complete $this
if {[string length $switched::($this,-path)] == 0} {
error {-path option must be defined}
}
}
proc ~dropSite {this} {
set index [lsearch -exact $(list) $this] ;# remove self from list
set (list) [lreplace $(list) $index $index]
if {[string length $switched::($this,-path)] > 0} { ;# if there was an actual drop site
delete $($this,bindings) ;# remove drop bindings
}
}
proc options {this} { ;# accept all data formats by default, force state initialization
return [list\
[list -command {} {}]\
[list -formats {{}} {{}}]\
[list -path {} {}]\
[list -regioncommand {} {}]\
[list -state normal]\
]
}
proc set-command {this value} {} ;# nothing to do as data is stored at the switched level
proc set-formats {this value} {}
proc set-state {this value} {
switch $value {
disabled {set ($this,enabled) 0}
normal {set ($this,enabled) 1}
default {
error "bad state value \"$value\": must be normal or disabled"
}
}
}
# may be used in complement of -path, with a higher priority, must return a left, top, right, bottom region or an empty list:
proc set-regioncommand {this value} {}
proc set-path {this value} { ;# target widget path (must always be specified)
if {$switched::($this,complete)} {
error {option -path cannot be set dynamically}
}
if {![winfo exists $value]} {
error "invalid widget: \"$value\""
}
set ($this,bindings) [new bindings $value end] ;# do not interfere with existing bindings
set ($this,visible) 1 ;# monitor visibility
bindings::set $($this,bindings) <Visibility> "set ::dropSite::($this,visible) \[string compare %s VisibilityFullyObscured\]"
}
proc dropped {this} {
if {[string length $switched::($this,-command)] > 0} {
uplevel #0 $switched::($this,-command) ;# always invoke command at global level as tk buttons do
# the user command can retrieve data in the dragSite format indexed data array, for the available formats (dragSite
# data array names). it is guaranteed that at least 1 drop site format is supported by the drag site
}
}
proc regions {formats} { ;# return a list of drop sites with compatible data formats
# update was invoked here to make sure visibility and coordinates are correct, but it interferences with events in drag code
set regions {}
foreach site $(list) {
if {!$($site,enabled)} continue
set path $switched::($site,-path)
set region {}
if {[string length $switched::($site,-regioncommand)] > 0} {
set region [uplevel #0 $switched::($site,-regioncommand)]
} else {
if {[catch {set viewable [winfo viewable $path]}]} continue ;# check if viewable, path may also be empty
if {!$viewable || !$($site,visible)} continue ;# check that drop site is at least partly visible and not iconified
set x [winfo rootx $path]
set y [winfo rooty $path]
set region [list $x $y [expr {$x + [winfo width $path]}] [expr {$y + [winfo height $path]}]]
}
foreach format $switched::($site,-formats) {
if {[lsearch -exact $formats $format] < 0} continue
if {[llength $region] > 0} {
lappend regions [concat $site $path $region]
break ;# drop site will accept at least one of the data formats from the drag site
}
}
}
return $regions
}
}
|
