diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 15:05:13 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 15:05:13 +0000 |
commit | 9fc19ef8e2dcd8bcf6a1d034b95c1de2b88e485c (patch) | |
tree | ee28de37fe0de6137d535fee2e64ecafaffefb91 /Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm | |
parent | 73b942cfb4ccf168f9c2b7f20a289b06f1f54a4b (diff) |
New tlperl part II
git-svn-id: svn://tug.org/texlive/trunk@21424 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm | 145 |
1 files changed, 145 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm new file mode 100644 index 00000000000..879874cea9d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm @@ -0,0 +1,145 @@ +package Tk::DragDrop::XDNDDrop; +use strict; +use vars qw($VERSION); +$VERSION = '4.007'; # sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/; +use base qw(Tk::DragDrop::Rect); + +sub XDND_PROTOCOL_VERSION () { 4 } + +Tk::DragDrop->Type('XDND'); + +sub NewDrag +{ + my ($class,$token) = @_; + $token->{$class} = {}; +} + +sub new +{ + my ($class,$token,$id,@prop) = @_; + my $ver = $token->InternAtom(shift(@prop)); + # warn "XDND version $ver ".join(' ',@prop)."\n"; + $ver = XDND_PROTOCOL_VERSION if $ver > XDND_PROTOCOL_VERSION; + my $site = bless { id => $id, token => $token, ver => $ver, state => 0, accept => \@prop}, $class; + my $w = $token->parent; + $w->BindClientMessage('XdndStatus',[$site => 'XdndStatus']); + $w->BindClientMessage('XdndFinished',[$site => 'XdndFinished']); + return $site; +} + +sub Drop +{ + my ($site,$token,$seln,$e) = @_; + my $w = $token->parent; + my $data = pack('LLLLL',oct($w->id),0,$e->t,0,0); + $w->SendClientMessage('XdndDrop',$site->{id},32,$data); +} + +sub FindSite +{ + my ($class,$token,$X,$Y) = @_; + my $id = $token->PointToWindow($X,$Y); + while ($id) + { + my @prop; + Tk::catch { @prop = $token->property('get','XdndAware', $id) }; + if (!$@ && shift(@prop) eq 'ATOM') + { + my $hash = $token->{$class}; + my $site = $hash->{$id}; + if (!defined $site) + { + $site = $class->new($token,$id,@prop); + $hash->{$id} = $site; + } + return $site; + } + $id = $token->PointToWindow($X,$Y,$id) + } + return undef; +} + +sub Enter +{ + my ($site,$token,$e) = @_; + my $w = $token->parent; + $token->InstallHandlers('XdndSelection'); + my $seln = $token->cget('-selection'); + my @targets = grep(!/^(TARGETS|MULTIPLE|TIMESTAMP)$/,reverse($token->SelectionGet('-selection'=> 'XdndSelection','TARGETS'))); + # print join(' ',@targets),"\n"; + my $flags = ($site->{ver} << 24); + my @atarg = map($token->InternAtom($_),@targets); + my $ntarg = @atarg; + if ($ntarg > 3) + { + $flags |= 1; + $w->property('set','XdndTypeList','ATOM',32,\@atarg); + splice(@atarg,3); + } + else + { + splice(@atarg,$ntarg,(0 x 3 - $ntarg)); + } + unshift(@atarg,oct($w->id),$flags); + # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n"; + my $data = pack('LLLLL',@atarg); + $w->SendClientMessage('XdndEnter',$site->{id},32,$data); +} + +sub Leave +{ + my ($site,$token,$e) = @_; + my $w = $token->parent; + my $data = pack('LLLLL',oct($w->id), 0, 0, 0, 0); + $w->SendClientMessage('XdndLeave',$site->{id},32,$data); +} + +sub Motion +{ + my ($site,$token,$e) = @_; + my $X = $e->X; + my $Y = $e->Y; + my $w = $token->parent; + my $action = $token->InternAtom($site->{'action'} || 'XdndActionCopy'); + my @atarg = (oct($w->id),0,($X << 16) | $Y, $e->t, $action); + # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n"; + my $data = pack('LLLLL',@atarg); + $w->SendClientMessage('XdndPosition',$site->{id},32,$data); +} + +sub XdndFinished +{ + my ($site) = @_; + my $token = $site->{token}; + # printf "XdndFinished $site\n", + $token->Done; +} + +sub XdndStatus +{ + my ($site) = @_; + my $token = $site->{token}; + my $w = $token->parent; + my $event = $w->XEvent; + my ($tid,$flags,$xy,$wh,$action) = unpack('LLLLL',$event->A); + $action = $w->GetAtomName($action) if $action; + $site->{flags} = $flags; + $site->{'X'} = $xy >> 16; + $site->{'Y'} = $xy & 0xFFFF; + $site->{'width'} = $wh >> 16; + $site->{'height'} = $wh & 0xFFFF; + #printf "XdndStatus $site targ=%x flags=%08X x=%d y=%d w=%d h=%d a=%s\n", + # $tid,$flags,$xy >> 16, $xy & 0xFFFF, $wh >> 16, $wh & 0xFFFF,$action; + if ($flags & 1) + { + $token->AcceptDrop; + } + else + { + $token->RejectDrop; + } +} + + +1; +__END__ |