| 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; |