Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::DragDrop; |
2 | require Tk::DragDrop::Common; | |
3 | require Tk::Toplevel; | |
4 | require Tk::Label; | |
5 | ||
6 | use vars qw($VERSION); | |
7 | $VERSION = '3.029'; # $Id: //depot/Tk8/DragDrop/DragDrop.pm#29 $ | |
8 | ||
9 | use base qw(Tk::DragDrop::Common Tk::Toplevel); | |
10 | ||
11 | # This is a little tricky, ISA says 'Toplevel' but we | |
12 | # define a Tk_cmd to actually build a 'Label', then | |
13 | # use wmRelease in Populate to make it a toplevel. | |
14 | ||
15 | my $useWmRelease = 1; # ($^O ne 'MSWin32'); | |
16 | ||
17 | sub Tk_cmd { ($useWmRelease) ? \&Tk::label : \&Tk::toplevel } | |
18 | ||
19 | Construct Tk::Widget 'DragDrop'; | |
20 | ||
21 | use strict; | |
22 | use vars qw(%type @types); | |
23 | use Carp; | |
24 | ||
25 | ||
26 | # There is a snag with having a token window and moving to | |
27 | # exactly where cursor is - the cursor is "inside" the token | |
28 | # window - hence it is not "inside" the dropsite window | |
29 | # so we offset X,Y by OFFSET pixels. | |
30 | sub OFFSET () {3} | |
31 | ||
32 | sub ClassInit | |
33 | { | |
34 | my ($class,$mw) = @_; | |
35 | $mw->bind($class,'<Map>','Mapped'); | |
36 | $mw->bind($class,'<Any-KeyPress>','Done'); | |
37 | $mw->bind($class,'<Any-ButtonRelease>','Drop'); | |
38 | $mw->bind($class,'<Any-Motion>','Drag'); | |
39 | return $class; | |
40 | } | |
41 | ||
42 | sub Populate | |
43 | { | |
44 | my ($token,$args) = @_; | |
45 | my $parent = $token->parent; | |
46 | if ($useWmRelease) | |
47 | { | |
48 | $token->wmRelease; | |
49 | $token->saveunder(1); | |
50 | $token->ConfigSpecs(-text => ['SELF','text','Text',$parent->class]); | |
51 | } | |
52 | else | |
53 | { | |
54 | my $lab = $token->Label->pack(-expand => 1, -fill => 'both'); | |
55 | bless $lab,ref($token); | |
56 | $lab->bindtags([ref($token), $lab, $token, 'all']); | |
57 | $token->ConfigSpecs(-text => [$lab,'text','Text',$parent->class], | |
58 | DEFAULT => [$lab]); | |
59 | } | |
60 | $token->withdraw; | |
61 | $token->overrideredirect(1); | |
62 | $token->ConfigSpecs(-sitetypes => ['METHOD','siteTypes','SiteTypes',undef], | |
63 | -startcommand => ['CALLBACK',undef,undef,undef], | |
64 | -endcommand => ['CALLBACK',undef,undef,undef], | |
65 | -predropcommand => ['CALLBACK',undef,undef,undef], | |
66 | -postdropcommand => ['CALLBACK',undef,undef,undef], | |
67 | -delta => ['PASSIVE','delta','Delta',10], | |
68 | -cursor => ['SELF','cursor','Cursor','hand2'], | |
69 | -handlers => ['SETMETHOD','handlers','Handlers',[[[$token,'SendText']]]], | |
70 | -selection => ['SETMETHOD','selection','Selection','XdndSelection'], | |
71 | -event => ['SETMETHOD','event','Event','<B1-Motion>'] | |
72 | ); | |
73 | $token->{InstallHandlers} = 0; | |
74 | $args->{-borderwidth} = 3; | |
75 | $args->{-relief} = 'flat'; | |
76 | $args->{-takefocus} = 1; | |
77 | } | |
78 | ||
79 | sub sitetypes | |
80 | { | |
81 | my ($w,$val) = @_; | |
82 | confess "Not a widget $w" unless (ref $w); | |
83 | my $var = \$w->{Configure}{'-sitetypes'}; | |
84 | if (@_ > 1) | |
85 | { | |
86 | if (defined $val) | |
87 | { | |
88 | $val = [$val] unless (ref $val); | |
89 | my $type; | |
90 | foreach $type (@$val) | |
91 | { | |
92 | Tk::DragDrop->import($type); | |
93 | } | |
94 | } | |
95 | $$var = $val; | |
96 | } | |
97 | return (defined $$var) ? $$var : \@types; | |
98 | } | |
99 | ||
100 | sub SendText | |
101 | { | |
102 | my ($w,$offset,$max) = @_; | |
103 | my $s = substr($w->cget('-text'),$offset); | |
104 | $s = substr($s,0,$max) if (length($s) > $max); | |
105 | return $s; | |
106 | } | |
107 | ||
108 | sub handlers | |
109 | { | |
110 | my ($token,$opt,$value) = @_; | |
111 | $token->{InstallHandlers} = (defined($value) && @$value); | |
112 | $token->{'handlers'} = $value; | |
113 | } | |
114 | ||
115 | sub selection | |
116 | { | |
117 | my ($token,$opt,$value) = @_; | |
118 | my $handlers = $token->{'handlers'}; | |
119 | $token->{InstallHandlers} = (defined($handlers) && @$handlers); | |
120 | } | |
121 | ||
122 | sub event | |
123 | { | |
124 | my ($w,$opt,$value) = @_; | |
125 | # delete old bindings | |
126 | $w->parent->Tk::bind($value,[$w,'StartDrag']); | |
127 | } | |
128 | ||
129 | # | |
130 | ||
131 | sub FindSite | |
132 | { | |
133 | my ($token,$X,$Y,$e) = @_; | |
134 | my $site; | |
135 | my $types = $token->sitetypes; | |
136 | if (defined $types && @$types) | |
137 | { | |
138 | foreach my $type (@$types) | |
139 | { | |
140 | my $class = $type{$type}; | |
141 | last if (defined($class) && ($site = $class->FindSite($token,$X,$Y))); | |
142 | } | |
143 | } | |
144 | else | |
145 | { | |
146 | warn 'No sitetypes'; | |
147 | } | |
148 | my $new = $site || 'undef'; | |
149 | my $over = $token->{'Over'}; | |
150 | if ($over) | |
151 | { | |
152 | if (!$over->Match($site)) | |
153 | { | |
154 | $over->Leave($token,$e); | |
155 | delete $token->{'Over'}; | |
156 | } | |
157 | } | |
158 | if ($site) | |
159 | { | |
160 | unless ($token->{'Over'}) | |
161 | { | |
162 | $site->Enter($token,$e); | |
163 | $token->{'Over'} = $site; | |
164 | } | |
165 | $site->Motion($token,$e) if (defined $site) | |
166 | } | |
167 | return $site; | |
168 | } | |
169 | ||
170 | sub Mapped | |
171 | { | |
172 | my ($token) = @_; | |
173 | my $e = $token->parent->XEvent; | |
174 | $token = $token->toplevel; | |
175 | $token->grabGlobal; | |
176 | $token->focus; | |
177 | if (defined $e) | |
178 | { | |
179 | my $X = $e->X; | |
180 | my $Y = $e->Y; | |
181 | $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET); | |
182 | $token->NewDrag; | |
183 | $token->FindSite($X,$Y,$e); | |
184 | } | |
185 | } | |
186 | ||
187 | sub NewDrag | |
188 | { | |
189 | my ($token) = @_; | |
190 | my $types = $token->sitetypes; | |
191 | if (defined $types && @$types) | |
192 | { | |
193 | my $type; | |
194 | foreach $type (@$types) | |
195 | { | |
196 | my $class = $type{$type}; | |
197 | if (defined $class) | |
198 | { | |
199 | $class->NewDrag($token); | |
200 | } | |
201 | } | |
202 | } | |
203 | } | |
204 | ||
205 | sub Drag | |
206 | { | |
207 | my $token = shift; | |
208 | my $e = $token->XEvent; | |
209 | my $X = $e->X; | |
210 | my $Y = $e->Y; | |
211 | $token = $token->toplevel; | |
212 | $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET); | |
213 | $token->FindSite($X,$Y,$e); | |
214 | } | |
215 | ||
216 | sub Done | |
217 | { | |
218 | my $token = shift; | |
219 | my $e = $token->XEvent; | |
220 | $token = $token->toplevel; | |
221 | my $over = delete $token->{'Over'}; | |
222 | $over->Leave($token,$e) if (defined $over); | |
223 | my $w = $token->parent; | |
224 | eval {local $SIG{__DIE__}; $token->grabRelease }; | |
225 | $token->withdraw; | |
226 | delete $w->{'Dragging'}; | |
227 | $w->update; | |
228 | } | |
229 | ||
230 | sub AcceptDrop | |
231 | { | |
232 | my ($token) = @_; | |
233 | $token->configure(-relief => 'sunken'); | |
234 | $token->{'Accepted'} = 1; | |
235 | } | |
236 | ||
237 | sub RejectDrop | |
238 | { | |
239 | my ($token) = @_; | |
240 | $token->configure(-relief => 'flat'); | |
241 | $token->{'Accepted'} = 0; | |
242 | } | |
243 | ||
244 | sub HandleLoose | |
245 | { | |
246 | my ($w,$seln) = @_; | |
247 | return ''; | |
248 | } | |
249 | ||
250 | sub InstallHandlers | |
251 | { | |
252 | my ($token,$seln) = @_; | |
253 | my $w = $token->parent; | |
254 | $token->configure('-selection' => $seln) if $seln; | |
255 | $seln = $token->cget('-selection'); | |
256 | if ($token->{InstallHandlers}) | |
257 | { | |
258 | foreach my $h (@{$token->cget('-handlers')}) | |
259 | { | |
260 | $w->SelectionHandle('-selection' => $seln,@$h); | |
261 | } | |
262 | $token->{InstallHandlers} = 0; | |
263 | } | |
264 | if (!$w->IS($w->SelectionOwner('-selection'=>$seln))) | |
265 | { | |
266 | $w->SelectionOwn('-selection' => $seln, -command => [\&HandleLoose,$w,$seln]); | |
267 | } | |
268 | } | |
269 | ||
270 | sub Drop | |
271 | { | |
272 | my $ewin = shift; | |
273 | my $e = $ewin->XEvent; | |
274 | my $token = $ewin->toplevel; | |
275 | my $site = $token->FindSite($e->X,$e->Y,$e); | |
276 | Tk::catch { $token->grabRelease }; | |
277 | if (defined $site) | |
278 | { | |
279 | my $seln = $token->cget('-selection'); | |
280 | unless ($token->Callback(-predropcommand => $seln, $site)) | |
281 | { | |
282 | my $id = $token->after(2000,[$token,'Done']); | |
283 | my $w = $token->parent; | |
284 | $token->InstallHandlers; | |
285 | $site->Drop($token,$seln,$e); | |
286 | $token->Callback(-postdropcommand => $seln); | |
287 | } | |
288 | } | |
289 | else | |
290 | { | |
291 | $token->Done; | |
292 | } | |
293 | $token->Callback('-endcommand'); | |
294 | } | |
295 | ||
296 | sub StartDrag | |
297 | { | |
298 | my $token = shift; | |
299 | my $w = $token->parent; | |
300 | unless ($w->{'Dragging'}) | |
301 | { | |
302 | my $e = $w->XEvent; | |
303 | my $X = $e->X; | |
304 | my $Y = $e->Y; | |
305 | my $was = $token->{'XY'}; | |
306 | if ($was) | |
307 | { | |
308 | my $dx = $was->[0] - $X; | |
309 | my $dy = $was->[1] - $Y; | |
310 | if (sqrt($dx*$dx+$dy*$dy) > $token->cget('-delta')) | |
311 | { | |
312 | unless ($token->Callback('-startcommand',$token,$e)) | |
313 | { | |
314 | delete $token->{'XY'}; | |
315 | $w->{'Dragging'} = $token; | |
316 | $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET); | |
317 | $token->raise; | |
318 | $token->deiconify; | |
319 | $token->FindSite($X,$Y,$e); | |
320 | } | |
321 | } | |
322 | } | |
323 | else | |
324 | { | |
325 | $token->{'XY'} = [$X,$Y]; | |
326 | } | |
327 | } | |
328 | } | |
329 | ||
330 | ||
331 | 1; |