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')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm159
1 files changed, 0 insertions, 159 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
deleted file mode 100644
index 4ac75d63c40..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
+++ /dev/null
@@ -1,159 +0,0 @@
-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__