The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Tk::DragDrop::SunSite;
require Tk::DropSite;

use vars qw($VERSION);
$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;

use Tk::DragDrop::SunConst;
use base  qw(Tk::DropSite);
use strict;

Tk::DropSite->Type('Sun');

sub SunDrop
{
 my ($w,$site) = @_;
 my $e = $w->XEvent;
 my ($seln,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$e->A);
 $w->MakeAtom($seln);
 if ($flags & &ACK_FLAG)
  {
   Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_ACK') };
  }
 my @targ = $w->SelectionGet(-selection => $seln,'TARGETS');
 $site->Apply(-dropcommand => $x, $y, $seln, SunDrop => \@targ);
 if ($flags & &TRANSIENT_FLAG)
  {
   Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_DONE') };
  }
 $w->configure('-relief' => $w->{'_DND_RELIEF_'}) if (defined $w->{'_DND_RELIEF_'});
 $site->Apply(-entercommand => $x, $y, 0);
}

sub SunPreview
{
 my ($w,$site) = @_;
 my $event = $w->XEvent;
 my ($kind,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$event->A);
 $x -= $site->X;
 $y -= $site->Y;
 if ($kind == _enter)
  {
   $site->Callback(-entercommand => 1, $x, $y);
  }
 elsif ($kind == _leave)
  {
   $site->Callback(-entercommand => 0, $x, $y);
  }
 elsif ($kind == _motion)
  {
   $site->Callback(-motioncommand => $x, $y);
  }
}

sub InitSite
{
 my ($class,$site) = @_;
 my $w = $site->widget;
 $w->BindClientMessage('_SUN_DRAGDROP_TRIGGER',[\&SunDrop,$site]);
 $w->BindClientMessage('_SUN_DRAGDROP_PREVIEW',[\&SunPreview,$site]);
}

sub NoteSites
{
 my ($class,$t,$sites) = @_;
 my $count = @$sites;
 my @data  = (0,0);
 my ($wrapper,$offset) = $t->wrapper;
 if ($t->viewable)
  {
   my $s;
   my $i = 0;
   my @win;
   my $bx = $t->rootx;
   my $by = $t->rooty - $offset;
   $t->MakeWindowExist;
   foreach $s (@$sites)
    {
     my $w = $s->widget;
     if ($w->viewable)
      {
       $w->MakeWindowExist;
       $data[1]++;
       push(@data,${$w->WindowId});                   # XID
       push(@data,$i++);                              # Our 'tag'
       push(@data,ENTERLEAVE|MOTION);                 # Flags
       push(@data,0);                                 # Kind is 'rect'
       push(@data,1);                                 # Number of rects
       push(@data,$s->X-$bx,$s->Y-$by,$s->width,$s->height);  # The rect
      }
    }
  }
 if ($data[1])
  {
   $t->property('set',
                '_SUN_DRAGDROP_INTEREST',           # name
                '_SUN_DRAGDROP_INTEREST',           # type
                32,                                 # format
                \@data,$wrapper);                   # the data
  }
 else
  {
   $t->property('delete','_SUN_DRAGDROP_INTEREST',$wrapper);
  }
}


1;