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 / XDNDSite.pm

package Tk::DragDrop::XDNDSite;
use strict;
use vars qw($VERSION);
$VERSION = '3.010'; # $Id: //depot/Tk8/DragDrop/DragDrop/XDNDSite.pm#10 $
use base qw(Tk::DropSite);

sub XDND_PROTOCOL_VERSION () { 3 }

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

sub InitSite
{my ($class,$site) = @_;
my $w = $site->widget;
}

sub XdndEnter
{
my ($t,$sites) = @_;
my $event = $t->XEvent;
my ($src,$flags,@types) = unpack('LLLLL',$event->A);
# print "XdndEnter $src\n";
my $ver = ($flags >> 24) & 0xFF;        
if ($flags & 1)
 {
  my @prop;
  Tk::catch { @prop = $t->property('get','XdndTypeList',$src) };
  @types = @prop if (!$@ && shift(@prop) eq 'ATOM');
 }
$t->{"XDND$src"} = { ver => $ver, types => \@types };
}

sub XdndLeave
{
my ($t,$sites) = @_;
my $event = $t->XEvent;
my ($src,$flags,@types) = unpack('LLLLL',$event->A);
# print "XdndLeave $src\n";
my $info = $t->{"XDND$src"};
if ($info)
 {
  my $over = $info->{site};
  if ($over)
   {   
    my $X = $info->{X};
    my $Y = $info->{Y};
    $over->Apply(-entercommand => $X, $Y, 0) 
   }
 }
delete $t->{"XDND$src"};
}

sub XdndPosition
{
my ($t,$sites) = @_;
my $event = $t->XEvent;
my ($src,$flags,$xy,$time,$action) = unpack('LLLLL',$event->A);
my $X = $xy >> 16;
my $Y = $xy & 0xFFFF;
my $info = $t->{"XDND$src"};
$info->{X}      = $X;
$info->{Y}      = $Y;
$info->{action} = $action;
$info->{t}      = $time;
my $id    = oct($t->id);
my $sxy   = 0; 
my $swh   = 0; 
my $sflags = 0;
my $saction = 0;
my $over = $info->{site};
foreach my $site (@$sites)
 {
  if ($site->Over($X,$Y))
   {
    $sxy = ($site->X << 16)     | $site->Y;    
    $swh = ($site->width << 16) | $site->height;
    $saction = $action;                        
    $sflags |= 1;                              
    if ($over)                                 
     {                                         
      if ($over == $site)                      
       {                                       
        $site->Apply(-motioncommand => $X, $Y);
       }                                       
      else                                     
       {                                       
        $over->Apply(-entercommand => $X, $Y, 0);
        $site->Apply(-entercommand => $X, $Y, 1);
       }                                       
     }                                         
    else                                       
     {                                         
      $site->Apply(-entercommand => $X, $Y, 1);
     }     
    $info->{site} = $site;                     
    last;
   }
 }
unless ($sflags & 1)
 {
  if ($over)
   {
    $over->Apply(-entercommand => $X, $Y, 0) 
   }
  delete $info->{site};
 }
my $data = pack('LLLLL',$id,$sflags,$sxy,$swh,$action);
$t->SendClientMessage('XdndStatus',$src,32,$data);
}

sub XdndDrop
{
my ($t,$sites) = @_;
my $event = $t->XEvent;
my ($src,$flags,$time,$res1,$res2) = unpack('LLLLL',$event->A);
my $info   = $t->{"XDND$src"};        
my $sflags = 0;
if ($info)
 {         
  $info->{t} = $time;
  my $site = $info->{'site'};
  if ($site)
   {
    my $X = $info->{'X'};                  
    my $Y = $info->{'Y'};                  
    $site->Apply(-dropcommand => $Y, $Y, 'XdndSelection');
    $site->Apply(-entercommand => $X, $Y, 0);
   }
 }
my $data  = pack('LLLLL',oct($t->id),$sflags,0,0,0);
$t->SendClientMessage('XdndFinished',$src,32,$data);
}

sub NoteSites
{my ($class,$t,$sites) = @_;
if (@$sites)
 {
  $t->BindClientMessage('XdndLeave',[\&XdndLeave,$sites]);
  $t->BindClientMessage('XdndEnter',[\&XdndEnter,$sites]);
  $t->BindClientMessage('XdndPosition',[\&XdndPosition,$sites]);
  $t->BindClientMessage('XdndDrop',[\&XdndDrop,$sites]);
  $t->property('set','XdndAware','ATOM',32,[XDND_PROTOCOL_VERSION]);
 }
else
 {
  $t->property('delete','XdndAware');
 }
}

1;
__END__