home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _679f3c4218a060764376bf03acecd78c < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.6 KB  |  160 lines
  1. package Tk::DragDrop::XDNDSite;
  2. use strict;
  3. use vars qw($VERSION);
  4. $VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
  5. use base qw(Tk::DropSite);
  6.  
  7. sub XDND_PROTOCOL_VERSION () { 4 }
  8.  
  9. Tk::DropSite->Type('XDND');
  10.  
  11. sub InitSite
  12. {my ($class,$site) = @_;
  13.  my $w = $site->widget;
  14. }
  15.  
  16. sub XdndEnter
  17. {
  18.  my ($t,$sites) = @_;
  19.  my $event = $t->XEvent;
  20.  my ($src,$flags,@types) = unpack('LLLLL',$event->A);
  21.  my $ver = ($flags >> 24) & 0xFF;
  22.  if ($flags & 1)
  23.   {
  24.    my @prop;
  25.    Tk::catch { @prop = $t->property('get','XdndTypeList',$src) };
  26.    @types = @prop if (!$@ && shift(@prop) eq 'ATOM');
  27.   }
  28.  else
  29.   {
  30.    $t->MakeAtom(@types);
  31.   }
  32.  # print "XdndEnter $src $ver @types\n";
  33.  $t->{"XDND$src"} = { ver => $ver, types => \@types };
  34. }
  35.  
  36. sub XdndLeave
  37. {
  38.  my ($t,$sites) = @_;
  39.  my $event = $t->XEvent;
  40.  my ($src,$flags,@types) = unpack('LLLLL',$event->A);
  41.  # print "XdndLeave $src\n";
  42.  my $info = $t->{"XDND$src"};
  43.  if ($info)
  44.   {
  45.    my $over = $info->{site};
  46.    if ($over)
  47.     {
  48.      my $X = $info->{X};
  49.      my $Y = $info->{Y};
  50.      $over->Apply(-entercommand => $X, $Y, 0)
  51.     }
  52.   }
  53.  delete $t->{"XDND$src"};
  54. }
  55.  
  56. sub XdndPosition
  57. {
  58.  my ($t,$sites) = @_;
  59.  my $event = $t->XEvent;
  60.  my ($src,$flags,$xy,$time,$action) = unpack('LLLLL',$event->A);
  61.  $t->MakeAtom($action);
  62.  my $X = $xy >> 16;
  63.  my $Y = $xy & 0xFFFF;
  64.  my $info = $t->{"XDND$src"};
  65.  $info->{X}      = $X;
  66.  $info->{Y}      = $Y;
  67.  $info->{action} = $action;
  68.  $info->{t}      = $time;
  69.  my ($id)  = $t->wrapper;
  70.  my $sxy   = 0;
  71.  my $swh   = 0;
  72.  my $sflags = 0;
  73.  my $saction = 0;
  74.  my $over = $info->{site};
  75.  foreach my $site (@$sites)
  76.   {
  77.    if ($site->Over($X,$Y))
  78.     {
  79.      $sxy = ($site->X << 16)     | $site->Y;
  80.      $swh = ($site->width << 16) | $site->height;
  81.      $saction = $action;
  82.      $sflags |= 1;
  83.      if ($over)
  84.       {
  85.        if ($over == $site)
  86.         {
  87.          $site->Apply(-motioncommand => $X, $Y);
  88.         }
  89.        else
  90.         {
  91.          $over->Apply(-entercommand => $X, $Y, 0);
  92.          $site->Apply(-entercommand => $X, $Y, 1);
  93.         }
  94.       }
  95.      else
  96.       {
  97.        $site->Apply(-entercommand => $X, $Y, 1);
  98.       }
  99.      $info->{site} = $site;
  100.      last;
  101.     }
  102.   }
  103.  unless ($sflags & 1)
  104.   {
  105.    if ($over)
  106.     {
  107.      $over->Apply(-entercommand => $X, $Y, 0)
  108.     }
  109.    delete $info->{site};
  110.   }
  111.  my $data = pack('LLLLL',$id,$sflags,$sxy,$swh,$action);
  112.  $t->SendClientMessage('XdndStatus',$src,32,$data);
  113. }
  114.  
  115. sub XdndDrop
  116. {
  117.  my ($t,$sites) = @_;
  118.  my $event = $t->XEvent;
  119.  my ($src,$flags,$time,$res1,$res2) = unpack('LLLLL',$event->A);
  120.  my $info   = $t->{"XDND$src"};
  121.  my $sflags = 0;
  122.  my $action = 0;
  123.  if ($info)
  124.   {
  125.    $info->{t} = $time;
  126.    my $site = $info->{'site'};
  127.    if ($site)
  128.     {
  129.      my $X = $info->{'X'};
  130.      my $Y = $info->{'Y'};
  131.      $action = $info->{action};
  132.      $site->Apply(-dropcommand => $X, $Y, 'XdndSelection',$action,$info->{types});
  133.      $site->Apply(-entercommand => $X, $Y, 0);
  134.     }
  135.   }
  136.  my ($id) = $t->wrapper;
  137.  my $data  = pack('LLLLL',$id,$sflags,$action,0,0);
  138.  $t->SendClientMessage('XdndFinished',$src,32,$data);
  139. }
  140.  
  141. sub NoteSites
  142. {my ($class,$t,$sites) = @_;
  143.  my ($wrapper) = $t->wrapper;
  144.  if (@$sites)
  145.   {
  146.    $t->BindClientMessage('XdndLeave',[\&XdndLeave,$sites]);
  147.    $t->BindClientMessage('XdndEnter',[\&XdndEnter,$sites]);
  148.    $t->BindClientMessage('XdndPosition',[\&XdndPosition,$sites]);
  149.    $t->BindClientMessage('XdndDrop',[\&XdndDrop,$sites]);
  150.    $t->property('set','XdndAware','ATOM',32,[XDND_PROTOCOL_VERSION],$wrapper);
  151.   }
  152.  else
  153.   {
  154.    $t->property('delete','XdndAware',$wrapper);
  155.   }
  156. }
  157.  
  158. 1;
  159. __END__
  160.