home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _16209311f2afc58966fc8895c90b70b5 < prev    next >
Text File  |  2004-06-01  |  4KB  |  146 lines
  1. package Tk::DragDrop::XDNDDrop;
  2. use strict;
  3. use vars qw($VERSION);
  4. $VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
  5. use base qw(Tk::DragDrop::Rect);
  6.  
  7. sub XDND_PROTOCOL_VERSION () { 4 }
  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__
  146.