home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _eacd8b3b6f0c55f05453751f3e07ff87 < prev    next >
Encoding:
Text File  |  2004-06-01  |  4.7 KB  |  201 lines
  1. package Tk::DragDrop::SunDrop;
  2. require  Tk::DragDrop::Rect;
  3.  
  4. use vars qw($VERSION);
  5. $VERSION = sprintf '4.%03d', q$Revision: #5 $ =~ /\D(\d+)\s*$/;
  6.  
  7. use base  qw(Tk::DragDrop::Rect);
  8. use strict;
  9. use Tk::DragDrop::SunConst;
  10.  
  11. Tk::DragDrop->Type('Sun');
  12.  
  13. BEGIN
  14.  {
  15.   # Define the Rect API as members of the array
  16.   my @fields = qw(name win X Y width height flags ancestor widget);
  17.   my $i = 0;
  18.   no strict 'refs';
  19.   for ($i=0; $i < @fields; $i++)
  20.    {
  21.     my $j    = $i;
  22.     *{"$fields[$i]"} = sub { shift->[$j] };
  23.    }
  24.  }
  25.  
  26.  
  27. sub Preview
  28. {
  29.  my ($site,$token,$e,$kind,$flags) = (@_);
  30.  $token->BackTrace('No flags') unless defined $flags;
  31.  my $sflags = $site->flags;
  32.  return if ($kind == _motion && !($sflags & MOTION));
  33.  return if ($kind != _motion && !($sflags & ENTERLEAVE));
  34.  my $data = pack('LLSSLL',$kind,$e->t,$e->X,$e->Y,$site->name,$flags);
  35.  $token->SendClientMessage('_SUN_DRAGDROP_PREVIEW',$site->win,32,$data);
  36. }
  37.  
  38. sub Enter
  39. {
  40.  my ($site,$token,$e) = @_;
  41.  $token->AcceptDrop;
  42.  $site->Preview($token,$e,_enter,0);
  43. }
  44.  
  45. sub Leave
  46. {
  47.  my ($site,$token,$e) = @_;
  48.  $token->RejectDrop;
  49.  $site->Preview($token,$e,_leave,0);
  50. }
  51.  
  52. sub Motion
  53. {
  54.  my ($site,$token,$e) = @_;
  55.  $site->Preview($token,$e,_motion,0);
  56. }
  57.  
  58. sub HandleDone
  59. {
  60.  my ($token,$seln,$offset,$max) = @_;
  61.  $token->Done;
  62.  return '';
  63. }
  64.  
  65. sub HandleAck
  66. {
  67.  my ($w,$seln,$offset,$max) = @_;
  68.  return '';
  69. }
  70.  
  71. sub HandleItem
  72. {
  73.  my ($w,$seln,$offset,$max) = @_;
  74.  return undef;
  75. }
  76.  
  77. sub HandleCount
  78. {
  79.  my ($w,$seln,$offset,$max) = @_;
  80.  return 1;
  81. }
  82.  
  83. sub Drop
  84. {
  85.  my ($site,$token,$seln,$e) = @_;
  86.  my $w  = $token->parent;
  87.  $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_ACK',[\&HandleAck,$token,$seln]);
  88.  $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_DONE',[\&HandleDone,$token,$seln]);
  89.  my $atom  = $w->InternAtom($seln);
  90.  my $flags = ACK_FLAG | TRANSIENT_FLAG;
  91.  my $data  = pack('LLSSLL',$atom,$e->t,$e->X,$e->Y,$site->name,$flags);
  92.  $w->SendClientMessage('_SUN_DRAGDROP_TRIGGER',$site->win,32,$data);
  93. }
  94.  
  95. sub FindSite
  96. {
  97.  my ($class,$token,$X,$Y) = @_;
  98.  $token->{'SunDD'} = [] unless exists $token->{'SunDD'};
  99.  my $site = $class->SUPER::FindSite($token,$X,$Y);
  100.  if (!defined $site)
  101.   {
  102.    my $id = $token->PointToWindow($X,$Y);
  103.    while ($id)
  104.     {
  105.      my @prop;
  106.      Tk::catch { @prop = $token->property('get','_SUN_DRAGDROP_INTEREST', $id) };
  107.      if (!$@ && shift(@prop) eq '_SUN_DRAGDROP_INTEREST' && shift(@prop) == 0)
  108.       {
  109.        # This is a "toplevel" which has some sites associated with it.
  110.        my ($bx,$by) = $token->WindowXY($id);
  111.        $token->{'SunDDSeen'} = {} unless exists $token->{'SunDDSeen'};
  112.        return $site if $token->{'SunDDSeen'}{$id};
  113.        $token->{'SunDDSeen'}{$id} = 1;
  114.        my $sites = $token->{'SunDD'};
  115.        my $count = shift(@prop);
  116.        while (@prop && $count-- > 0)
  117.         {
  118.          my ($xid,$sn,$flags,$kind,$n) = splice(@prop,0,5);
  119.          if ($kind != 0)
  120.           {
  121.            warn "Don't understand site type $kind";
  122.            last;
  123.           }
  124.          while (@prop >= 4 && $n-- > 0)
  125.           {
  126.            my ($x,$y,$w,$h) = splice(@prop,0,4);
  127.            push(@$sites,bless [$sn,$xid,$x+$bx,$y+$by,$w,$h,$flags,$id,$token],$class);
  128.           }
  129.         }
  130.        return $class->SUPER::FindSite($token,$X,$Y);
  131.       }
  132.      $id = $token->PointToWindow($X,$Y,$id)
  133.     }
  134.   }
  135.  return $site;
  136. }
  137.  
  138. my $busy = 0;
  139.  
  140. sub NewDrag
  141. {
  142.  my ($class,$token) = @_;
  143.  delete $token->{'SunDD'} unless $busy;
  144.  delete $token->{'SunDDSeen'};
  145. }
  146.  
  147. sub SiteList
  148. {
  149.  my ($class,$token) = @_;
  150.  return @{$token->{'SunDD'}};
  151. }
  152.  
  153. 1;
  154. __END__
  155.  
  156. # this code is obsolete now that we look at properties ourselves
  157. # which means we don't need dropsite manager running
  158. # On Sun's running OpenLook the window manager or dropsite mananger
  159. # watches for and caches site info in a special selection
  160. # This code got sites from that
  161. #
  162.  
  163. sub SiteList
  164. {
  165.  my ($class,$token) = @_;
  166.  unless (1 || $busy || exists $token->{'SunDD'})
  167.   {
  168.    Carp::confess('Already doing it!') if ($busy++);
  169.    my @data  = ();
  170.    my @sites = ();
  171.    my $mw = $token->MainWindow;
  172.    $token->{'SunDD'} = \@sites;
  173.    Tk::catch {
  174.       @data = $mw->SelectionGet( '-selection'=>'_SUN_DRAGDROP_DSDM',  '_SUN_DRAGDROP_SITE_RECTS');
  175.    };
  176.    if ($@)
  177.     {
  178.      $token->configure('-cursor'=>'hand2');
  179.      $token->grab(-global);
  180.     }
  181.    else
  182.     {
  183.      while (@data)
  184.       {
  185.        my $version = shift(@data);
  186.        if ($version != 0)
  187.         {
  188.          warn "Unexpected site version $version";
  189.          last;
  190.         }
  191.        push(@sites,bless [splice(@data,0,7)],$class);
  192.       }
  193.     }
  194.    $busy--;
  195.   }
  196.  return @{$token->{'SunDD'}};
  197. }
  198.  
  199. 1;
  200.  
  201.