summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm159
1 files changed, 159 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
new file mode 100755
index 00000000000..4ac75d63c40
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
@@ -0,0 +1,159 @@
+package Tk::DragDrop::XDNDSite;
+use strict;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+use base qw(Tk::DropSite);
+
+sub XDND_PROTOCOL_VERSION () { 4 }
+
+Tk::DropSite->Type('XDND');
+
+sub InitSite
+{my ($class,$site) = @_;
+ my $w = $site->widget;
+}
+
+sub XdndEnter
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,@types) = unpack('LLLLL',$event->A);
+ my $ver = ($flags >> 24) & 0xFF;
+ if ($flags & 1)
+ {
+ my @prop;
+ Tk::catch { @prop = $t->property('get','XdndTypeList',$src) };
+ @types = @prop if (!$@ && shift(@prop) eq 'ATOM');
+ }
+ else
+ {
+ $t->MakeAtom(@types);
+ }
+ # print "XdndEnter $src $ver @types\n";
+ $t->{"XDND$src"} = { ver => $ver, types => \@types };
+}
+
+sub XdndLeave
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,@types) = unpack('LLLLL',$event->A);
+ # print "XdndLeave $src\n";
+ my $info = $t->{"XDND$src"};
+ if ($info)
+ {
+ my $over = $info->{site};
+ if ($over)
+ {
+ my $X = $info->{X};
+ my $Y = $info->{Y};
+ $over->Apply(-entercommand => $X, $Y, 0)
+ }
+ }
+ delete $t->{"XDND$src"};
+}
+
+sub XdndPosition
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,$xy,$time,$action) = unpack('LLLLL',$event->A);
+ $t->MakeAtom($action);
+ my $X = $xy >> 16;
+ my $Y = $xy & 0xFFFF;
+ my $info = $t->{"XDND$src"};
+ $info->{X} = $X;
+ $info->{Y} = $Y;
+ $info->{action} = $action;
+ $info->{t} = $time;
+ my ($id) = $t->wrapper;
+ my $sxy = 0;
+ my $swh = 0;
+ my $sflags = 0;
+ my $saction = 0;
+ my $over = $info->{site};
+ foreach my $site (@$sites)
+ {
+ if ($site->Over($X,$Y))
+ {
+ $sxy = ($site->X << 16) | $site->Y;
+ $swh = ($site->width << 16) | $site->height;
+ $saction = $action;
+ $sflags |= 1;
+ if ($over)
+ {
+ if ($over == $site)
+ {
+ $site->Apply(-motioncommand => $X, $Y);
+ }
+ else
+ {
+ $over->Apply(-entercommand => $X, $Y, 0);
+ $site->Apply(-entercommand => $X, $Y, 1);
+ }
+ }
+ else
+ {
+ $site->Apply(-entercommand => $X, $Y, 1);
+ }
+ $info->{site} = $site;
+ last;
+ }
+ }
+ unless ($sflags & 1)
+ {
+ if ($over)
+ {
+ $over->Apply(-entercommand => $X, $Y, 0)
+ }
+ delete $info->{site};
+ }
+ my $data = pack('LLLLL',$id,$sflags,$sxy,$swh,$action);
+ $t->SendClientMessage('XdndStatus',$src,32,$data);
+}
+
+sub XdndDrop
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,$time,$res1,$res2) = unpack('LLLLL',$event->A);
+ my $info = $t->{"XDND$src"};
+ my $sflags = 0;
+ my $action = 0;
+ if ($info)
+ {
+ $info->{t} = $time;
+ my $site = $info->{'site'};
+ if ($site)
+ {
+ my $X = $info->{'X'};
+ my $Y = $info->{'Y'};
+ $action = $info->{action};
+ $site->Apply(-dropcommand => $X, $Y, 'XdndSelection',$action,$info->{types});
+ $site->Apply(-entercommand => $X, $Y, 0);
+ }
+ }
+ my ($id) = $t->wrapper;
+ my $data = pack('LLLLL',$id,$sflags,$action,0,0);
+ $t->SendClientMessage('XdndFinished',$src,32,$data);
+}
+
+sub NoteSites
+{my ($class,$t,$sites) = @_;
+ my ($wrapper) = $t->wrapper;
+ if (@$sites)
+ {
+ $t->BindClientMessage('XdndLeave',[\&XdndLeave,$sites]);
+ $t->BindClientMessage('XdndEnter',[\&XdndEnter,$sites]);
+ $t->BindClientMessage('XdndPosition',[\&XdndPosition,$sites]);
+ $t->BindClientMessage('XdndDrop',[\&XdndDrop,$sites]);
+ $t->property('set','XdndAware','ATOM',32,[XDND_PROTOCOL_VERSION],$wrapper);
+ }
+ else
+ {
+ $t->property('delete','XdndAware',$wrapper);
+ }
+}
+
+1;
+__END__