1package Tk::DragDrop::SunDrop;
2require  Tk::DragDrop::Rect;
3
4use vars qw($VERSION);
5$VERSION = '4.006'; # sprintf '4.%03d', q$Revision: #5 $ =~ /\D(\d+)\s*$/;
6
7use base  qw(Tk::DragDrop::Rect);
8use strict;
9use Tk::DragDrop::SunConst;
10
11Tk::DragDrop->Type('Sun');
12
13BEGIN
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
27sub 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
38sub Enter
39{
40 my ($site,$token,$e) = @_;
41 $token->AcceptDrop;
42 $site->Preview($token,$e,_enter,0);
43}
44
45sub Leave
46{
47 my ($site,$token,$e) = @_;
48 $token->RejectDrop;
49 $site->Preview($token,$e,_leave,0);
50}
51
52sub Motion
53{
54 my ($site,$token,$e) = @_;
55 $site->Preview($token,$e,_motion,0);
56}
57
58sub HandleDone
59{
60 my ($token,$seln,$offset,$max) = @_;
61 $token->Done;
62 return '';
63}
64
65sub HandleAck
66{
67 my ($w,$seln,$offset,$max) = @_;
68 return '';
69}
70
71sub HandleItem
72{
73 my ($w,$seln,$offset,$max) = @_;
74 return undef;
75}
76
77sub HandleCount
78{
79 my ($w,$seln,$offset,$max) = @_;
80 return 1;
81}
82
83sub 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
95sub 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
138my $busy = 0;
139
140sub NewDrag
141{
142 my ($class,$token) = @_;
143 delete $token->{'SunDD'} unless $busy;
144 delete $token->{'SunDDSeen'};
145}
146
147sub SiteList
148{
149 my ($class,$token) = @_;
150 return @{$token->{'SunDD'}};
151}
152
1531;
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
163sub 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
1991;
200
201