require Tk
::DragDrop
::Common
;
$VERSION = '3.029'; # $Id: //depot/Tk8/DragDrop/DragDrop.pm#29 $
use base qw(Tk::DragDrop::Common Tk::Toplevel);
# This is a little tricky, ISA says 'Toplevel' but we
# define a Tk_cmd to actually build a 'Label', then
# use wmRelease in Populate to make it a toplevel.
my $useWmRelease = 1; # ($^O ne 'MSWin32');
sub Tk_cmd
{ ($useWmRelease) ? \
&Tk
::label
: \
&Tk
::toplevel
}
Construct Tk
::Widget
'DragDrop';
use vars
qw(%type @types);
# There is a snag with having a token window and moving to
# exactly where cursor is - the cursor is "inside" the token
# window - hence it is not "inside" the dropsite window
# so we offset X,Y by OFFSET pixels.
$mw->bind($class,'<Map>','Mapped');
$mw->bind($class,'<Any-KeyPress>','Done');
$mw->bind($class,'<Any-ButtonRelease>','Drop');
$mw->bind($class,'<Any-Motion>','Drag');
my $parent = $token->parent;
$token->ConfigSpecs(-text => ['SELF','text','Text',$parent->class]);
my $lab = $token->Label->pack(-expand => 1, -fill => 'both');
$lab->bindtags([ref($token), $lab, $token, 'all']);
$token->ConfigSpecs(-text => [$lab,'text','Text',$parent->class],
$token->overrideredirect(1);
$token->ConfigSpecs(-sitetypes => ['METHOD','siteTypes','SiteTypes',undef],
-startcommand => ['CALLBACK',undef,undef,undef],
-endcommand => ['CALLBACK',undef,undef,undef],
-predropcommand => ['CALLBACK',undef,undef,undef],
-postdropcommand => ['CALLBACK',undef,undef,undef],
-delta => ['PASSIVE','delta','Delta',10],
-cursor => ['SELF','cursor','Cursor','hand2'],
-handlers => ['SETMETHOD','handlers','Handlers',[[[$token,'SendText']]]],
-selection => ['SETMETHOD','selection','Selection','XdndSelection'],
-event => ['SETMETHOD','event','Event','<B1-Motion>']
$token->{InstallHandlers} = 0;
$args->{-borderwidth} = 3;
$args->{-relief} = 'flat';
confess "Not a widget $w" unless (ref $w);
my $var = \$w->{Configure}{'-sitetypes'};
$val = [$val] unless (ref $val);
Tk::DragDrop->import($type);
return (defined $$var) ? $$var : \@types;
my ($w,$offset,$max) = @_;
my $s = substr($w->cget('-text'),$offset);
$s = substr($s,0,$max) if (length($s) > $max);
my ($token,$opt,$value) = @_;
$token->{InstallHandlers} = (defined($value) && @$value);
$token->{'handlers'} = $value;
my ($token,$opt,$value) = @_;
my $handlers = $token->{'handlers'};
$token->{InstallHandlers} = (defined($handlers) && @$handlers);
my ($w,$opt,$value) = @_;
$w->parent->Tk::bind($value,[$w,'StartDrag']);
my ($token,$X,$Y,$e) = @_;
my $types = $token->sitetypes;
if (defined $types && @$types)
foreach my $type (@$types)
my $class = $type{$type};
last if (defined($class) && ($site = $class->FindSite($token,$X,$Y)));
my $new = $site || 'undef';
my $over = $token->{'Over'};
if (!$over->Match($site))
unless ($token->{'Over'})
$token->{'Over'} = $site;
$site->Motion($token,$e) if (defined $site)
my $e = $token->parent->XEvent;
$token = $token->toplevel;
$token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
$token->FindSite($X,$Y,$e);
my $types = $token->sitetypes;
if (defined $types && @$types)
my $class = $type{$type};
$token = $token->toplevel;
$token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
$token->FindSite($X,$Y,$e);
$token = $token->toplevel;
my $over = delete $token->{'Over'};
$over->Leave($token,$e) if (defined $over);
eval {local $SIG{__DIE__}; $token->grabRelease };
$token->configure(-relief => 'sunken');
$token->{'Accepted'} = 1;
$token->configure(-relief => 'flat');
$token->{'Accepted'} = 0;
$token->configure('-selection' => $seln) if $seln;
$seln = $token->cget('-selection');
if ($token->{InstallHandlers})
foreach my $h (@{$token->cget('-handlers')})
$w->SelectionHandle('-selection' => $seln,@$h);
$token->{InstallHandlers} = 0;
if (!$w->IS($w->SelectionOwner('-selection'=>$seln)))
$w->SelectionOwn('-selection' => $seln, -command => [\&HandleLoose,$w,$seln]);
my $token = $ewin->toplevel;
my $site = $token->FindSite($e->X,$e->Y,$e);
Tk::catch { $token->grabRelease };
my $seln = $token->cget('-selection');
unless ($token->Callback(-predropcommand => $seln, $site))
my $id = $token->after(2000,[$token,'Done']);
$site->Drop($token,$seln,$e);
$token->Callback(-postdropcommand => $seln);
$token->Callback('-endcommand');
unless ($w->{'Dragging'})
my $was = $token->{'XY'};
if (sqrt($dx*$dx+$dy*$dy) > $token->cget('-delta'))
unless ($token->Callback('-startcommand',$token,$e))
$w->{'Dragging'} = $token;
$token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
$token->FindSite($X,$Y,$e);
$token->{'XY'} = [$X,$Y];