diff options
Diffstat (limited to 'Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDSite.pm')
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDSite.pm | 159 |
1 files changed, 0 insertions, 159 deletions
diff --git a/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDSite.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDSite.pm deleted file mode 100644 index 4ac75d63c40..00000000000 --- a/Master/tlpkg/tlperl.old/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__ |