1package Tk::DragDrop; 2require Tk::DragDrop::Common; 3require Tk::Toplevel; 4require Tk::Label; 5 6use vars qw($VERSION); 7$VERSION = '4.015'; # sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; 8 9use base qw(Tk::DragDrop::Common Tk::Toplevel); 10 11# This is a little tricky, ISA says 'Toplevel' but we 12# define a Tk_cmd to actually build a 'Label', then 13# use wmRelease in Populate to make it a toplevel. 14 15my $useWmRelease = Tk::Wm->can('release'); # ($^O ne 'MSWin32'); 16 17sub Tk_cmd { ($useWmRelease) ? \&Tk::label : \&Tk::toplevel } 18 19Construct Tk::Widget 'DragDrop'; 20 21use strict; 22use vars qw(%type @types); 23use Carp; 24 25 26# There is a snag with having a token window and moving to 27# exactly where cursor is - the cursor is "inside" the token 28# window - hence it is not "inside" the dropsite window 29# so we offset X,Y by OFFSET pixels. 30sub OFFSET () {3} 31 32sub ClassInit 33{ 34 my ($class,$mw) = @_; 35 $mw->bind($class,'<Map>','Mapped'); 36 $mw->bind($class,'<Any-KeyPress>','Done'); 37 $mw->bind($class,'<Any-ButtonRelease>','Drop'); 38 $mw->bind($class,'<Any-Motion>','Drag'); 39 return $class; 40} 41 42sub Populate 43{ 44 my ($token,$args) = @_; 45 my $parent = $token->parent; 46 if ($useWmRelease) 47 { 48 $token->wmRelease; 49 $token->ConfigSpecs(-text => ['SELF','text','Text',$parent->class]); 50 } 51 else 52 { 53 my $lab = $token->Label->pack(-expand => 1, -fill => 'both'); 54 bless $lab,ref($token); 55 $lab->bindtags([ref($token), $lab, $token, 'all']); 56 $token->ConfigSpecs(-text => [$lab,'text','Text',$parent->class], 57 DEFAULT => [$lab]); 58 } 59 $token->withdraw; 60 $token->overrideredirect(1); 61 $token->ConfigSpecs(-sitetypes => ['METHOD','siteTypes','SiteTypes',undef], 62 -startcommand => ['CALLBACK',undef,undef,undef], 63 -endcommand => ['CALLBACK',undef,undef,undef], 64 -predropcommand => ['CALLBACK',undef,undef,undef], 65 -postdropcommand => ['CALLBACK',undef,undef,undef], 66 -delta => ['PASSIVE','delta','Delta',10], 67 -cursor => ['SELF','cursor','Cursor','hand2'], 68 -handlers => ['SETMETHOD','handlers','Handlers',[[[$token,'SendText']]]], 69 -selection => ['SETMETHOD','selection','Selection','XdndSelection'], 70 -event => ['SETMETHOD','event','Event','<B1-Motion>'] 71 ); 72 $token->{InstallHandlers} = 0; 73 $args->{-borderwidth} = 3; 74 $args->{-relief} = 'flat'; 75 $args->{-takefocus} = 1; 76} 77 78sub sitetypes 79{ 80 my ($w,$val) = @_; 81 confess "Not a widget $w" unless (ref $w); 82 my $var = \$w->{Configure}{'-sitetypes'}; 83 if (@_ > 1) 84 { 85 if (defined $val) 86 { 87 $val = [$val] unless (ref $val); 88 my $type; 89 foreach $type (@$val) 90 { 91 Tk::DragDrop->import($type); 92 } 93 } 94 $$var = $val; 95 } 96 return (defined $$var) ? $$var : \@types; 97} 98 99sub SendText 100{ 101 my ($w,$offset,$max) = @_; 102 my $s = substr($w->cget('-text'),$offset); 103 $s = substr($s,0,$max) if (length($s) > $max); 104 return $s; 105} 106 107sub handlers 108{ 109 my ($token,$opt,$value) = @_; 110 $token->{InstallHandlers} = (defined($value) && @$value); 111 $token->{'handlers'} = $value; 112} 113 114sub selection 115{ 116 my ($token,$opt,$value) = @_; 117 my $handlers = $token->{'handlers'}; 118 $token->{InstallHandlers} = (defined($handlers) && @$handlers); 119} 120 121sub event 122{ 123 my ($w,$opt,$value) = @_; 124 # delete old bindings 125 $w->parent->Tk::bind($value,[$w,'StartDrag']); 126} 127 128# 129 130sub FindSite 131{ 132 my ($token,$X,$Y,$e) = @_; 133 my $site; 134 my $types = $token->sitetypes; 135 if (defined $types && @$types) 136 { 137 foreach my $type (@$types) 138 { 139 my $class = $type{$type}; 140 last if (defined($class) && ($site = $class->FindSite($token,$X,$Y))); 141 } 142 } 143 else 144 { 145 warn 'No sitetypes'; 146 } 147 my $new = $site || 'undef'; 148 my $over = $token->{'Over'}; 149 if ($over) 150 { 151 if (!$over->Match($site)) 152 { 153 $over->Leave($token,$e); 154 delete $token->{'Over'}; 155 } 156 } 157 if ($site) 158 { 159 unless ($token->{'Over'}) 160 { 161 $site->Enter($token,$e); 162 $token->{'Over'} = $site; 163 } 164 $site->Motion($token,$e) if (defined $site) 165 } 166 return $site; 167} 168 169sub Mapped 170{ 171 my ($token) = @_; 172 my $e = $token->parent->XEvent; 173 $token = $token->toplevel; 174 $token->grabGlobal; 175 $token->focus; 176 if (defined $e) 177 { 178 my $X = $e->X; 179 my $Y = $e->Y; 180 $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET); 181 $token->NewDrag; 182 $token->FindSite($X,$Y,$e); 183 } 184} 185 186sub NewDrag 187{ 188 my ($token) = @_; 189 my $types = $token->sitetypes; 190 if (defined $types && @$types) 191 { 192 my $type; 193 foreach $type (@$types) 194 { 195 my $class = $type{$type}; 196 if (defined $class) 197 { 198 $class->NewDrag($token); 199 } 200 } 201 } 202} 203 204sub Drag 205{ 206 my $token = shift; 207 my $e = $token->XEvent; 208 my $X = $e->X; 209 my $Y = $e->Y; 210 $token = $token->toplevel; 211 $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET); 212 $token->FindSite($X,$Y,$e); 213} 214 215sub Done 216{ 217 my $token = shift; 218 my $e = $token->XEvent; 219 $token = $token->toplevel; 220 my $over = delete $token->{'Over'}; 221 $over->Leave($token,$e) if (defined $over); 222 my $w = $token->parent; 223 eval {local $SIG{__DIE__}; $token->grabRelease }; 224 $token->withdraw; 225 delete $w->{'Dragging'}; 226 $w->update; 227} 228 229sub AcceptDrop 230{ 231 my ($token) = @_; 232 $token->configure(-relief => 'sunken'); 233 $token->{'Accepted'} = 1; 234} 235 236sub RejectDrop 237{ 238 my ($token) = @_; 239 $token->configure(-relief => 'flat'); 240 $token->{'Accepted'} = 0; 241} 242 243sub HandleLoose 244{ 245 my ($w,$seln) = @_; 246 return ''; 247} 248 249sub InstallHandlers 250{ 251 my ($token,$seln) = @_; 252 my $w = $token->parent; 253 $token->configure('-selection' => $seln) if $seln; 254 $seln = $token->cget('-selection'); 255 if ($token->{InstallHandlers}) 256 { 257 foreach my $h (@{$token->cget('-handlers')}) 258 { 259 $w->SelectionHandle('-selection' => $seln,@$h); 260 } 261 $token->{InstallHandlers} = 0; 262 } 263 if (!$w->IS($w->SelectionOwner('-selection'=>$seln))) 264 { 265 $w->SelectionOwn('-selection' => $seln, -command => [\&HandleLoose,$w,$seln]); 266 } 267} 268 269sub Drop 270{ 271 my $ewin = shift; 272 my $e = $ewin->XEvent; 273 my $token = $ewin->toplevel; 274 my $site = $token->FindSite($e->X,$e->Y,$e); 275 Tk::catch { $token->grabRelease }; 276 if (defined $site) 277 { 278 my $seln = $token->cget('-selection'); 279 unless ($token->Callback(-predropcommand => $seln, $site)) 280 { 281# XXX This is ugly if the user restarts a drag within the 2000 ms: 282# my $id = $token->after(2000,[$token,'Done']); 283 my $w = $token->parent; 284 $token->InstallHandlers; 285 $site->Drop($token,$seln,$e); 286 $token->Callback(-postdropcommand => $seln); 287 $token->Done; 288 } 289 } 290 else 291 { 292 $token->Done; 293 } 294 $token->Callback('-endcommand'); 295} 296 297sub StartDrag 298{ 299 my $token = shift; 300 my $w = $token->parent; 301 unless ($w->{'Dragging'}) 302 { 303 my $e = $w->XEvent; 304 my $X = $e->X; 305 my $Y = $e->Y; 306 my $was = $token->{'XY'}; 307 if ($was) 308 { 309 my $dx = $was->[0] - $X; 310 my $dy = $was->[1] - $Y; 311 if (sqrt($dx*$dx+$dy*$dy) > $token->cget('-delta')) 312 { 313 unless ($token->Callback('-startcommand',$token,$e)) 314 { 315 delete $token->{'XY'}; 316 $w->{'Dragging'} = $token; 317 $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET); 318 $token->raise; 319 $token->deiconify; 320 $token->FindSite($X,$Y,$e); 321 } 322 } 323 } 324 else 325 { 326 $token->{'XY'} = [$X,$Y]; 327 } 328 } 329} 330 331 3321; 333