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