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