home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / DragDrop / SunDrop.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  2.6 KB  |  117 lines
  1. package Tk::DragDrop::SunDrop;
  2. require  Tk::DragDrop::Rect;
  3. @ISA = qw(Tk::DragDrop::Rect);
  4. use strict;
  5. use Tk::DragDrop::SunConst;
  6.  
  7. Tk::DragDrop->Type('Sun');
  8.  
  9. BEGIN 
  10.  {
  11.   my @fields = qw(name win X Y width height flags);
  12.   my $i = 0;
  13.   no strict 'refs';
  14.   for ($i=0; $i < @fields; $i++)
  15.    {
  16.     my $j    = $i;
  17.     *{"$fields[$i]"} = sub { shift->[$j] };
  18.    }
  19.  }
  20.  
  21. sub Preview
  22. {
  23.  my ($site,$token,$e,$kind,$flags) = (@_);
  24.  $token->BackTrace("No flags") unless defined $flags;
  25.  my $sflags = $site->flags;
  26.  return if ($kind == _motion && !($sflags & &MOTION));
  27.  return if ($kind != _motion && !($sflags & &ENTERLEAVE));
  28.  my $data = pack('LLSSLL',$kind,$e->t,$e->X,$e->Y,$site->name,$flags);
  29.  $token->SendClientMessage('_SUN_DRAGDROP_PREVIEW',$site->win,32,$data);
  30. }
  31.  
  32. sub Enter  
  33. {
  34.  my ($site,$token,$e) = @_;
  35.  $site->SUPER::Enter($token,$e);
  36.  $site->Preview($token,$e,_enter,0);
  37. }
  38.  
  39. sub Leave  
  40. {
  41.  my ($site,$token,$e) = @_;
  42.  $site->SUPER::Leave($token,$e);
  43.  $site->Preview($token,$e,_leave,0);
  44. }
  45.  
  46. sub Motion 
  47. {
  48.  my ($site,$token,$e) = @_;
  49.  $site->SUPER::Motion($token,$e);
  50.  $site->Preview($token,$e,_motion,0);
  51. }
  52.  
  53. sub HandleDone
  54. {
  55.  my ($w,$seln,$offset,$max) = @_;
  56.  $w->SelectionClear('-selection',$seln);
  57.  return "";
  58. }
  59.  
  60. sub HandleAck
  61. {
  62.  my ($w,$seln,$offset,$max) = @_;
  63.  return "";
  64. }
  65.  
  66. sub Drop
  67. {
  68.  my ($site,$w,$seln,$e) = @_;
  69.  $site->SUPER::Drop($w,$seln,$e);
  70.  $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_ACK',[\&HandleAck,$w,$seln]);
  71.  $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_DONE',[\&HandleDone,$w,$seln]);
  72.  my $atom  = $w->InternAtom($seln);                                 
  73.  my $flags = &ACK_FLAG | &TRANSIENT_FLAG;                           
  74.  my $data  = pack('LLSSLL',$atom,$e->t,$e->X,$e->Y,$site->name,$flags);
  75.  $w->SendClientMessage('_SUN_DRAGDROP_TRIGGER',$site->win,32,$data);
  76. }
  77.  
  78. sub CheckSites
  79. {
  80.  my ($class,$token) = @_;
  81.  delete $token->{'SunDD'};
  82. }
  83.  
  84. sub SiteList
  85. {
  86.  my ($class,$token) = @_;
  87.  unless (exists $token->{'SunDD'})
  88.   {
  89.    my @data  = ();
  90.    my @sites = ();
  91.    eval {local $SIG{__DIE__}; @data = $token->SelectionGet( '-selection'=>"_SUN_DRAGDROP_DSDM",  "_SUN_DRAGDROP_SITE_RECTS") } ;
  92.    if ($@)
  93.     {
  94.      $token->configure('-cursor'=>'hand2');
  95.      $token->grab(-global);
  96.     }
  97.    else
  98.     {
  99.      while (@data)
  100.       {
  101.        my $version = shift(@data);
  102.        if ($version != 0)          
  103.         {                          
  104.          warn "Unexpected site version $version";
  105.          last;
  106.         }                          
  107.        push(@sites,bless [splice(@data,0,7)],$class);
  108.       }
  109.     }
  110.    $token->{'SunDD'} = \@sites; 
  111.   }
  112.  return @{$token->{'SunDD'}};
  113. }
  114.  
  115. 1;
  116. __END__
  117.