| 1 | package Tk::DragDrop::XDNDDrop; |
| 2 | use strict; |
| 3 | use vars qw($VERSION); |
| 4 | $VERSION = '3.009'; # $Id: //depot/Tk8/DragDrop/DragDrop/XDNDDrop.pm#9 $ |
| 5 | use base qw(Tk::DragDrop::Rect); |
| 6 | |
| 7 | sub XDND_PROTOCOL_VERSION () { 3 } |
| 8 | |
| 9 | Tk::DragDrop->Type('XDND'); |
| 10 | |
| 11 | sub NewDrag |
| 12 | { |
| 13 | my ($class,$token) = @_; |
| 14 | $token->{$class} = {}; |
| 15 | } |
| 16 | |
| 17 | sub new |
| 18 | { |
| 19 | my ($class,$token,$id,@prop) = @_; |
| 20 | my $ver = $token->InternAtom(shift(@prop)); |
| 21 | warn "XDND version $ver ".join(' ',@prop)."\n"; |
| 22 | $ver = XDND_PROTOCOL_VERSION if $ver > XDND_PROTOCOL_VERSION; |
| 23 | my $site = bless { id => $id, token => $token, ver => $ver, state => 0, accept => \@prop}, $class; |
| 24 | my $w = $token->parent; |
| 25 | $w->BindClientMessage('XdndStatus',[$site => 'XdndStatus']); |
| 26 | $w->BindClientMessage('XdndFinished',[$site => 'XdndFinished']); |
| 27 | return $site; |
| 28 | } |
| 29 | |
| 30 | sub Drop |
| 31 | { |
| 32 | my ($site,$token,$seln,$e) = @_; |
| 33 | my $w = $token->parent; |
| 34 | my $data = pack('LLLLL',oct($w->id),0,$e->t,0,0); |
| 35 | $w->SendClientMessage('XdndDrop',$site->{id},32,$data); |
| 36 | } |
| 37 | |
| 38 | sub FindSite |
| 39 | { |
| 40 | my ($class,$token,$X,$Y) = @_; |
| 41 | my $id = $token->PointToWindow($X,$Y); |
| 42 | while ($id) |
| 43 | { |
| 44 | my @prop; |
| 45 | Tk::catch { @prop = $token->property('get','XdndAware', $id) }; |
| 46 | if (!$@ && shift(@prop) eq 'ATOM') |
| 47 | { |
| 48 | my $hash = $token->{$class}; |
| 49 | my $site = $hash->{$id}; |
| 50 | if (!defined $site) |
| 51 | { |
| 52 | $site = $class->new($token,$id,@prop); |
| 53 | $hash->{$id} = $site; |
| 54 | } |
| 55 | return $site; |
| 56 | } |
| 57 | $id = $token->PointToWindow($X,$Y,$id) |
| 58 | } |
| 59 | return undef; |
| 60 | } |
| 61 | |
| 62 | sub Enter |
| 63 | { |
| 64 | my ($site,$token,$e) = @_; |
| 65 | my $w = $token->parent; |
| 66 | $token->InstallHandlers('XdndSelection'); |
| 67 | my $seln = $token->cget('-selection'); |
| 68 | my @targets = grep(!/^(TARGETS|MULTIPLE|TIMESTAMP)$/,reverse($token->SelectionGet('-selection'=> 'XdndSelection','TARGETS'))); |
| 69 | # print join(' ',@targets),"\n"; |
| 70 | my $flags = ($site->{ver} << 24); |
| 71 | my @atarg = map($token->InternAtom($_),@targets); |
| 72 | my $ntarg = @atarg; |
| 73 | if ($ntarg > 3) |
| 74 | { |
| 75 | $flags |= 1; |
| 76 | $w->property('set','XdndTypeList','ATOM',32,\@atarg); |
| 77 | splice(@atarg,3); |
| 78 | } |
| 79 | else |
| 80 | { |
| 81 | splice(@atarg,$ntarg,(0 x 3 - $ntarg)); |
| 82 | } |
| 83 | unshift(@atarg,oct($w->id),$flags); |
| 84 | # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n"; |
| 85 | my $data = pack('LLLLL',@atarg); |
| 86 | $w->SendClientMessage('XdndEnter',$site->{id},32,$data); |
| 87 | } |
| 88 | |
| 89 | sub Leave |
| 90 | { |
| 91 | my ($site,$token,$e) = @_; |
| 92 | my $w = $token->parent; |
| 93 | my $data = pack('LLLLL',oct($w->id), 0, 0, 0, 0); |
| 94 | $w->SendClientMessage('XdndLeave',$site->{id},32,$data); |
| 95 | } |
| 96 | |
| 97 | sub Motion |
| 98 | { |
| 99 | my ($site,$token,$e) = @_; |
| 100 | my $X = $e->X; |
| 101 | my $Y = $e->Y; |
| 102 | my $w = $token->parent; |
| 103 | my $action = $token->InternAtom($site->{'action'} || 'XdndActionCopy'); |
| 104 | my @atarg = (oct($w->id),0,($X << 16) | $Y, $e->t, $action); |
| 105 | # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n"; |
| 106 | my $data = pack('LLLLL',@atarg); |
| 107 | $w->SendClientMessage('XdndPosition',$site->{id},32,$data); |
| 108 | } |
| 109 | |
| 110 | sub XdndFinished |
| 111 | { |
| 112 | my ($site) = @_; |
| 113 | my $token = $site->{token}; |
| 114 | # printf "XdndFinished $site\n", |
| 115 | $token->Done; |
| 116 | } |
| 117 | |
| 118 | sub XdndStatus |
| 119 | { |
| 120 | my ($site) = @_; |
| 121 | my $token = $site->{token}; |
| 122 | my $w = $token->parent; |
| 123 | my $event = $w->XEvent; |
| 124 | my ($tid,$flags,$xy,$wh,$action) = unpack('LLLLL',$event->A); |
| 125 | $action = $w->GetAtomName($action) if $action; |
| 126 | $site->{flags} = $flags; |
| 127 | $site->{'X'} = $xy >> 16; |
| 128 | $site->{'Y'} = $xy & 0xFFFF; |
| 129 | $site->{'width'} = $wh >> 16; |
| 130 | $site->{'height'} = $wh & 0xFFFF; |
| 131 | #printf "XdndStatus $site targ=%x flags=%08X x=%d y=%d w=%d h=%d a=%s\n", |
| 132 | # $tid,$flags,$xy >> 16, $xy & 0xFFFF, $wh >> 16, $wh & 0xFFFF,$action; |
| 133 | if ($flags & 1) |
| 134 | { |
| 135 | $token->AcceptDrop; |
| 136 | } |
| 137 | else |
| 138 | { |
| 139 | $token->RejectDrop; |
| 140 | } |
| 141 | } |
| 142 | |
| 143 | |
| 144 | 1; |
| 145 | __END__ |