home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _2355418b255146bee03d9849ddedf640 < prev    next >
Encoding:
Text File  |  2004-06-01  |  2.7 KB  |  108 lines
  1. package Tk::DragDrop::SunSite;
  2. require Tk::DropSite;
  3.  
  4. use vars qw($VERSION);
  5. $VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
  6.  
  7. use Tk::DragDrop::SunConst;
  8. use base  qw(Tk::DropSite);
  9. use strict;
  10.  
  11. Tk::DropSite->Type('Sun');
  12.  
  13. sub SunDrop
  14. {
  15.  my ($w,$site) = @_;
  16.  my $e = $w->XEvent;
  17.  my ($seln,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$e->A);
  18.  $w->MakeAtom($seln);
  19.  if ($flags & &ACK_FLAG)
  20.   {
  21.    Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_ACK') };
  22.   }
  23.  my @targ = $w->SelectionGet(-selection => $seln,'TARGETS');
  24.  $site->Apply(-dropcommand => $x, $y, $seln, SunDrop => \@targ);
  25.  if ($flags & &TRANSIENT_FLAG)
  26.   {
  27.    Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_DONE') };
  28.   }
  29.  $w->configure('-relief' => $w->{'_DND_RELIEF_'}) if (defined $w->{'_DND_RELIEF_'});
  30.  $site->Apply(-entercommand => $x, $y, 0);
  31. }
  32.  
  33. sub SunPreview
  34. {
  35.  my ($w,$site) = @_;
  36.  my $event = $w->XEvent;
  37.  my ($kind,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$event->A);
  38.  $x -= $site->X;
  39.  $y -= $site->Y;
  40.  if ($kind == _enter)
  41.   {
  42.    $site->Callback(-entercommand => 1, $x, $y);
  43.   }
  44.  elsif ($kind == _leave)
  45.   {
  46.    $site->Callback(-entercommand => 0, $x, $y);
  47.   }
  48.  elsif ($kind == _motion)
  49.   {
  50.    $site->Callback(-motioncommand => $x, $y);
  51.   }
  52. }
  53.  
  54. sub InitSite
  55. {
  56.  my ($class,$site) = @_;
  57.  my $w = $site->widget;
  58.  $w->BindClientMessage('_SUN_DRAGDROP_TRIGGER',[\&SunDrop,$site]);
  59.  $w->BindClientMessage('_SUN_DRAGDROP_PREVIEW',[\&SunPreview,$site]);
  60. }
  61.  
  62. sub NoteSites
  63. {
  64.  my ($class,$t,$sites) = @_;
  65.  my $count = @$sites;
  66.  my @data  = (0,0);
  67.  my ($wrapper,$offset) = $t->wrapper;
  68.  if ($t->viewable)
  69.   {
  70.    my $s;
  71.    my $i = 0;
  72.    my @win;
  73.    my $bx = $t->rootx;
  74.    my $by = $t->rooty - $offset;
  75.    $t->MakeWindowExist;
  76.    foreach $s (@$sites)
  77.     {
  78.      my $w = $s->widget;
  79.      if ($w->viewable)
  80.       {
  81.        $w->MakeWindowExist;
  82.        $data[1]++;
  83.        push(@data,${$w->WindowId});                   # XID
  84.        push(@data,$i++);                              # Our 'tag'
  85.        push(@data,ENTERLEAVE|MOTION);                 # Flags
  86.        push(@data,0);                                 # Kind is 'rect'
  87.        push(@data,1);                                 # Number of rects
  88.        push(@data,$s->X-$bx,$s->Y-$by,$s->width,$s->height);  # The rect
  89.       }
  90.     }
  91.   }
  92.  if ($data[1])
  93.   {
  94.    $t->property('set',
  95.                 '_SUN_DRAGDROP_INTEREST',           # name
  96.                 '_SUN_DRAGDROP_INTEREST',           # type
  97.                 32,                                 # format
  98.                 \@data,$wrapper);                   # the data
  99.   }
  100.  else
  101.   {
  102.    $t->property('delete','_SUN_DRAGDROP_INTEREST',$wrapper);
  103.   }
  104. }
  105.  
  106.  
  107. 1;
  108.