#!perl
use Tk;
use Tk::Text;
use Tk::DragDrop;
use Tk::DropSite;

$mw=MainWindow->new;
$entry=$mw->Entry()->pack(-expand=>1);
$f=$mw->Frame->pack();
$text=$f->Text()->pack(-anchor=>'e');
$text->bind('<Shift B3>');
$text->bind('<Shift B3-Motion>',sub {print "Moving\n"});
$list=$f->Listbox()->pack(-anchor=>'w');
foreach (qw(one two three four)) {$list->insert('end',$_)}
$text->insert('end',"now is the time for all good perl monks\nto drag and drop.");
$dnd_token2 = $list->DragDrop
  (-event     => '<Shift B3-Motion>',
   -sitetypes => ['Local'],
   -startcommand => sub { $main::dnd_token=$dnd_token2;StartDrag($main::dnd_token,$text) },
  );
    $dnd_token1 = $text->DragDrop
	(-event     => '<Shift B3-Motion>',
	 -sitetypes => ['Local'],
	 -startcommand => sub { $main::dnd_token=$dnd_token1;StartDrag1($main::dnd_token,$text) },
	 );
    # Define the target for drops.
    $entry->DropSite
	(-droptypes     => ['Local'],
	 -dropcommand   => [ \&Drop, $entry, \$main::dnd_token ],
	 );

sub StartDrag1 {

    my($token,$text) = @_;
    my $w = $token->parent; # $w is the source text widget
    my $e = $w->XEvent;
# then the search string is whatever is selected, if anything
    my(@sel,$txt);
    if (@sel=($text->tagRanges('sel'))[0..1]) {
	$txt=$text->get(@sel);
    }
    if (defined $txt) {
        # Configure the dnd token to show the listbox entry
        $token->configure(-text => $txt);
        # Show the token
        my($X, $Y) = ($e->X, $e->Y);
        $token->MoveToplevelWindow($X, $Y);
        $token->raise;
        $token->deiconify;
        $token->FindSite($X, $Y, $e);
    }
}

sub StartDrag{

    my($token,$text) = @_;
    my $w = $token->parent; # $w is the source listbox
    my $e = $w->XEvent;
    my $idx = $w->nearest($e->y); # get the listbox entry under cursor
    if (defined $idx) {
        # Configure the dnd token to show the listbox entry
        $token->configure(-text => $w->get($idx));
        # Show the token
        my($X, $Y) = ($e->X, $e->Y);
        $token->MoveToplevelWindow($X, $Y);
        $token->raise;
        $token->deiconify;
        $token->FindSite($X, $Y, $e);
    }
}

sub Drop {
# Accept a drop and insert a new item in the destination listbox.
    my($lb, $dnd_source) = @_;
    $dnd_source=$$dnd_source;
    $lb->insert("end"," ") if ($lb->get ne '');
    $lb->insert("end", $dnd_source->cget(-text));
}
MainLoop();