Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::DragDrop::SunDrop; |
2 | require Tk::DragDrop::Rect; | |
3 | ||
4 | use vars qw($VERSION); | |
5 | $VERSION = '3.015'; # $Id: //depot/Tk8/DragDrop/DragDrop/SunDrop.pm#15 $ | |
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 | my @fields = qw(name win X Y width height flags); | |
16 | my $i = 0; | |
17 | no strict 'refs'; | |
18 | for ($i=0; $i < @fields; $i++) | |
19 | { | |
20 | my $j = $i; | |
21 | *{"$fields[$i]"} = sub { shift->[$j] }; | |
22 | } | |
23 | } | |
24 | ||
25 | sub Preview | |
26 | { | |
27 | my ($site,$token,$e,$kind,$flags) = (@_); | |
28 | $token->BackTrace('No flags') unless defined $flags; | |
29 | my $sflags = $site->flags; | |
30 | return if ($kind == _motion && !($sflags & MOTION)); | |
31 | return if ($kind != _motion && !($sflags & ENTERLEAVE)); | |
32 | my $data = pack('LLSSLL',$kind,$e->t,$e->X,$e->Y,$site->name,$flags); | |
33 | $token->SendClientMessage('_SUN_DRAGDROP_PREVIEW',$site->win,32,$data); | |
34 | } | |
35 | ||
36 | sub Enter | |
37 | { | |
38 | my ($site,$token,$e) = @_; | |
39 | $token->AcceptDrop; | |
40 | $site->Preview($token,$e,_enter,0); | |
41 | } | |
42 | ||
43 | sub Leave | |
44 | { | |
45 | my ($site,$token,$e) = @_; | |
46 | $token->RejectDrop; | |
47 | $site->Preview($token,$e,_leave,0); | |
48 | } | |
49 | ||
50 | sub Motion | |
51 | { | |
52 | my ($site,$token,$e) = @_; | |
53 | $site->Preview($token,$e,_motion,0); | |
54 | } | |
55 | ||
56 | sub HandleDone | |
57 | { | |
58 | my ($token,$seln,$offset,$max) = @_; | |
59 | $token->Done; | |
60 | return ''; | |
61 | } | |
62 | ||
63 | sub HandleAck | |
64 | { | |
65 | my ($w,$seln,$offset,$max) = @_; | |
66 | return ''; | |
67 | } | |
68 | ||
69 | sub HandleItem | |
70 | { | |
71 | my ($w,$seln,$offset,$max) = @_; | |
72 | return undef; | |
73 | } | |
74 | ||
75 | sub HandleCount | |
76 | { | |
77 | my ($w,$seln,$offset,$max) = @_; | |
78 | return 1; | |
79 | } | |
80 | ||
81 | sub Drop | |
82 | { | |
83 | my ($site,$token,$seln,$e) = @_; | |
84 | my $w = $token->parent; | |
85 | $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_ACK',[\&HandleAck,$token,$seln]); | |
86 | $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_DONE',[\&HandleDone,$token,$seln]); | |
87 | my $atom = $w->InternAtom($seln); | |
88 | my $flags = ACK_FLAG | TRANSIENT_FLAG; | |
89 | my $data = pack('LLSSLL',$atom,$e->t,$e->X,$e->Y,$site->name,$flags); | |
90 | $w->SendClientMessage('_SUN_DRAGDROP_TRIGGER',$site->win,32,$data); | |
91 | } | |
92 | ||
93 | ||
94 | sub FindSite | |
95 | { | |
96 | my ($class,$token,$X,$Y) = @_; | |
97 | $token->{'SunDD'} = [] unless exists $token->{'SunDD'}; | |
98 | my $site = $class->SUPER::FindSite($token,$X,$Y); | |
99 | if (!defined $site) | |
100 | { | |
101 | my $id = $token->PointToWindow($X,$Y); | |
102 | while ($id) | |
103 | { | |
104 | my @prop; | |
105 | Tk::catch { @prop = $token->property('get','_SUN_DRAGDROP_INTEREST', $id) }; | |
106 | if (!$@ && shift(@prop) eq '_SUN_DRAGDROP_INTEREST' && shift(@prop) == 0) | |
107 | { | |
108 | my ($bx,$by) = $token->WindowXY($id); | |
109 | $token->{'SunDDSeen'} = {} unless exists $token->{'SunDDSeen'}; | |
110 | return $site if $token->{'SunDDSeen'}{$id}; | |
111 | $token->{'SunDDSeen'}{$id} = 1; | |
112 | my $sites = $token->{'SunDD'}; | |
113 | my $count = shift(@prop); | |
114 | while (@prop && $count-- > 0) | |
115 | { | |
116 | my ($xid,$sn,$flags,$kind,$n) = splice(@prop,0,5); | |
117 | if ($kind != 0) | |
118 | { | |
119 | warn "Don't understand site type $kind"; | |
120 | last; | |
121 | } | |
122 | while (@prop >= 4 && $n-- > 0) | |
123 | { | |
124 | my ($x,$y,$w,$h) = splice(@prop,0,4); | |
125 | push(@$sites,bless [$sn,$xid,$x+$bx,$y+$by,$w,$h,$flags],$class); | |
126 | } | |
127 | } | |
128 | return $class->SUPER::FindSite($token,$X,$Y); | |
129 | } | |
130 | $id = $token->PointToWindow($X,$Y,$id) | |
131 | } | |
132 | } | |
133 | return $site; | |
134 | } | |
135 | ||
136 | my $busy = 0; | |
137 | ||
138 | sub NewDrag | |
139 | { | |
140 | my ($class,$token) = @_; | |
141 | delete $token->{'SunDD'} unless $busy; | |
142 | delete $token->{'SunDDSeen'}; | |
143 | } | |
144 | ||
145 | sub SiteList | |
146 | { | |
147 | my ($class,$token) = @_; | |
148 | # this code is obsolete now that we look at properties ourselves | |
149 | # which means we don't need dropsite manager running | |
150 | unless (1 || $busy || exists $token->{'SunDD'}) | |
151 | { | |
152 | Carp::confess('Already doing it!') if ($busy++); | |
153 | my @data = (); | |
154 | my @sites = (); | |
155 | my $mw = $token->MainWindow; | |
156 | $token->{'SunDD'} = \@sites; | |
157 | Tk::catch { | |
158 | @data = $mw->SelectionGet( '-selection'=>'_SUN_DRAGDROP_DSDM', '_SUN_DRAGDROP_SITE_RECTS'); | |
159 | }; | |
160 | if ($@) | |
161 | { | |
162 | $token->configure('-cursor'=>'hand2'); | |
163 | $token->grab(-global); | |
164 | } | |
165 | else | |
166 | { | |
167 | while (@data) | |
168 | { | |
169 | my $version = shift(@data); | |
170 | if ($version != 0) | |
171 | { | |
172 | warn "Unexpected site version $version"; | |
173 | last; | |
174 | } | |
175 | push(@sites,bless [splice(@data,0,7)],$class); | |
176 | } | |
177 | } | |
178 | $busy--; | |
179 | } | |
180 | return @{$token->{'SunDD'}}; | |
181 | } | |
182 | ||
183 | 1; | |
184 | __END__ |