Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / DragDrop / XDNDDrop.pm

package Tk::DragDrop::XDNDDrop;
use strict;
use vars qw($VERSION);
$VERSION = '3.009'; # $Id: //depot/Tk8/DragDrop/DragDrop/XDNDDrop.pm#9 $
use base qw(Tk::DragDrop::Rect);

sub XDND_PROTOCOL_VERSION () { 3 }

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__