Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::DropSite; |
2 | require Tk::DragDrop::Common; | |
3 | require Tk::DragDrop::Rect; | |
4 | ||
5 | use vars qw($VERSION); | |
6 | $VERSION = '3.021'; # $Id: //depot/Tk8/DragDrop/DropSite.pm#21 $ | |
7 | ||
8 | use base qw(Tk::DragDrop::Common Tk::DragDrop::Rect); | |
9 | ||
10 | Construct Tk::Widget 'DropSite'; | |
11 | ||
12 | use strict; | |
13 | use vars qw(%type @types); | |
14 | ||
15 | Tk::DragDrop->Tk::DragDrop::Common::Type('Local'); | |
16 | ||
17 | my @toplevels; | |
18 | ||
19 | BEGIN | |
20 | { | |
21 | # Are these really methods of Tk::DragDrop::Rect ? | |
22 | no strict 'refs'; | |
23 | foreach my $name (qw(x y X Y width height widget)) | |
24 | { | |
25 | my $key = $name; | |
26 | *{"$key"} = sub { shift->{$key} }; | |
27 | } | |
28 | } | |
29 | ||
30 | # Dropping side API - really only here for Local drops | |
31 | # inheritance is a mess right now. | |
32 | ||
33 | sub NewDrag | |
34 | { | |
35 | my ($class,$token) = @_; | |
36 | # No need to clear cached sites we see live data | |
37 | } | |
38 | ||
39 | sub SiteList | |
40 | { | |
41 | # this should be inheritable - so that receive side of XDND can re-use it. | |
42 | my ($class,$widget) = @_; | |
43 | my $t; | |
44 | my @list; | |
45 | foreach $t (@toplevels) | |
46 | { | |
47 | my $sites = $t->{'DropSites'}; | |
48 | if ($sites) | |
49 | { | |
50 | $sites = $sites->{'Local'}; | |
51 | push(@list,@{$sites}) if ($sites); | |
52 | } | |
53 | } | |
54 | return @list; | |
55 | } | |
56 | ||
57 | sub Apply | |
58 | { | |
59 | my $site = shift; | |
60 | my $name = shift; | |
61 | my $cb = $site->{$name}; | |
62 | if ($cb) | |
63 | { | |
64 | my $X = shift; | |
65 | my $Y = shift; | |
66 | $cb->Call(@_,$X - $site->X, $Y - $site->Y); | |
67 | } | |
68 | } | |
69 | ||
70 | sub Drop | |
71 | { | |
72 | my ($site,$token,$seln,$event) = @_; | |
73 | my $X = $event->X; | |
74 | my $Y = $event->Y; | |
75 | $site->Apply(-dropcommand => $X, $Y, $seln); | |
76 | $site->Apply(-entercommand => $X, $Y, 0); | |
77 | $token->Done; | |
78 | } | |
79 | ||
80 | sub Enter | |
81 | { | |
82 | my ($site,$token,$event) = @_; | |
83 | $token->AcceptDrop; | |
84 | $site->Apply(-entercommand => $event->X, $event->Y, 1); | |
85 | } | |
86 | ||
87 | sub Leave | |
88 | { | |
89 | my ($site,$token,$event) = @_; | |
90 | $token->RejectDrop; | |
91 | $site->Apply(-entercommand => $event->X, $event->Y, 0); | |
92 | } | |
93 | ||
94 | sub Motion | |
95 | { | |
96 | my ($site,$token,$event) = @_; | |
97 | $site->Apply(-motioncommand => $event->X, $event->Y); | |
98 | } | |
99 | ||
100 | # This is receive side API. | |
101 | ||
102 | sub NoteSites | |
103 | { | |
104 | my ($class,$t,$sites) = @_; | |
105 | unless (grep($_ == $t,@toplevels)) | |
106 | { | |
107 | $Tk::DragDrop::types{'Local'} = $class if (@$sites); | |
108 | push(@toplevels,$t); | |
109 | $t->OnDestroy(sub { @toplevels = grep($_ != $t,@toplevels) }); | |
110 | } | |
111 | } | |
112 | ||
113 | sub UpdateDropSites | |
114 | { | |
115 | my ($t) = @_; | |
116 | $t->{'DropUpdate'} = 0; | |
117 | foreach my $type (@types) | |
118 | { | |
119 | my $sites = $t->{'DropSites'}->{$type}; | |
120 | if ($sites && @$sites) | |
121 | { | |
122 | my $class = $type{$type}; | |
123 | $class->NoteSites($t,$sites); | |
124 | } | |
125 | } | |
126 | } | |
127 | ||
128 | sub QueueDropSiteUpdate | |
129 | { | |
130 | my $obj = shift; | |
131 | my $class = ref($obj); | |
132 | my $t = $obj->widget->toplevel; | |
133 | unless ($t->{'DropUpdate'}) | |
134 | { | |
135 | $t->{'DropUpdate'} = 1; | |
136 | $t->afterIdle(sub { UpdateDropSites($t) }); | |
137 | } | |
138 | } | |
139 | ||
140 | sub delete | |
141 | { | |
142 | my ($obj) = @_; | |
143 | my $w = $obj->widget; | |
144 | $w->bindtags([grep($_ ne $obj,$w->bindtags)]); | |
145 | my $t = $w->toplevel; | |
146 | foreach my $type (@{$obj->{'-droptypes'}}) | |
147 | { | |
148 | my $a = $t->{'DropSites'}->{$type}; | |
149 | @$a = grep($_ ne $obj,@$a); | |
150 | } | |
151 | $obj->QueueDropSiteUpdate; | |
152 | } | |
153 | ||
154 | sub DropSiteUpdate | |
155 | { | |
156 | # Note size of widget and arrange to update properties etc. | |
157 | my $obj = shift; | |
158 | my $w = $obj->widget; | |
159 | $obj->{'x'} = $w->X; | |
160 | $obj->{'y'} = $w->Y; | |
161 | $obj->{'X'} = $w->rootx; | |
162 | $obj->{'Y'} = $w->rooty; | |
163 | $obj->{'width'} = $w->Width; | |
164 | $obj->{'height'} = $w->Height; | |
165 | $obj->QueueDropSiteUpdate; | |
166 | } | |
167 | ||
168 | sub TopSiteUpdate | |
169 | { | |
170 | my ($t) = @_; | |
171 | foreach my $type (@types) | |
172 | { | |
173 | my $sites = $t->{'DropSites'}->{$type}; | |
174 | if ($sites && @$sites) | |
175 | { | |
176 | my $site; | |
177 | foreach $site (@$sites) | |
178 | { | |
179 | $site->DropSiteUpdate; | |
180 | } | |
181 | } | |
182 | } | |
183 | } | |
184 | ||
185 | sub Callback | |
186 | { | |
187 | my $obj = shift; | |
188 | my $key = shift; | |
189 | my $cb = $obj->{$key}; | |
190 | $cb->Call(@_) if (defined $cb); | |
191 | } | |
192 | ||
193 | sub InitSite | |
194 | { | |
195 | my ($class,$site) = @_; | |
196 | # Tk::DragDrop->Type('Local'); | |
197 | } | |
198 | ||
199 | sub new | |
200 | { | |
201 | my ($class,$w,%args) = @_; | |
202 | my $t = $w->toplevel; | |
203 | $args{'widget'} = $w; | |
204 | if (exists $args{'-droptypes'}) | |
205 | { | |
206 | # Convert single type to array-of-one | |
207 | $args{'-droptypes'} = [$args{'-droptypes'}] unless (ref $args{'-droptypes'}); | |
208 | } | |
209 | else | |
210 | { | |
211 | # Default to all known types. | |
212 | $args{'-droptypes'} = \@types; | |
213 | } | |
214 | my ($key,$val); | |
215 | while (($key,$val) = each %args) | |
216 | { | |
217 | if ($key =~ /command$/) | |
218 | { | |
219 | $val = Tk::Callback->new($val); | |
220 | $args{$key} = $val; | |
221 | } | |
222 | } | |
223 | my $obj = bless \%args,$class; | |
224 | unless (exists $t->{'DropSites'}) | |
225 | { | |
226 | $t->{'DropSites'} = {}; | |
227 | $t->{'DropUpdate'} = 0; | |
228 | } | |
229 | my $type; | |
230 | foreach $type (@{$args{'-droptypes'}}) | |
231 | { | |
232 | Tk::DropSite->import($type) unless (exists $type{$type}); | |
233 | my $class = $type{$type}; | |
234 | $class->InitSite($obj); | |
235 | # Should this be indexed by type or class ? | |
236 | unless (exists $t->{'DropSites'}->{$type}) | |
237 | { | |
238 | $t->{'DropSites'}->{$type} = []; | |
239 | } | |
240 | push(@{$t->{'DropSites'}->{$type}},$obj); | |
241 | } | |
242 | $w->OnDestroy([$obj,'delete']); | |
243 | $obj->DropSiteUpdate; | |
244 | $w->bindtags([$w->bindtags,$obj]); | |
245 | $w->Tk::bind($obj,'<Map>',[$obj,'DropSiteUpdate']); | |
246 | $w->Tk::bind($obj,'<Unmap>',[$obj,'DropSiteUpdate']); | |
247 | $t->Tk::bind($class,'<Configure>',[\&TopSiteUpdate,$t]); | |
248 | unless (grep($_ eq $class,$t->bindtags)) | |
249 | { | |
250 | $t->bindtags([$t->bindtags,$class]); | |
251 | } | |
252 | return $obj; | |
253 | } | |
254 | ||
255 | 1; |