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