use strict;
use Tcl::Tk;

my $mw = Tcl::Tk::tkinit;
my $interp = $mw->interp;

$interp->invoke('package', 'require', 'tkdnd');

## Iconify ".". We are going to add windows and call update many times.
## Avoid some interesting visual effects :-)
#wm withdraw .

#------------------------------------------------------------------------------
#	Step 1: A simple Drag Source
#------------------------------------------------------------------------------
# create the source window
my $lab_source = $mw->Label(-text=>"source", qw/-relief groove -bd 2 -width 20/)->pack(-pady=>5);
# tells the DND protocol source can deliver textual data
$interp->call('dnd','bindsource', $lab_source->path, 'text/plain', q{return "testing DND"});
# bind the DND operation on left button
$interp->call('bind', $lab_source->path, '<1>', 'dnd drag %W');

#------------------------------------------------------------------------------
#	Step 1: A simple Drop Target accepting plain text
#------------------------------------------------------------------------------
# defines the target window
my $lab_text_plain = $mw->Label(-text=>"drop plain text", qw/-relief raised -bd 1 -width 20/)->pack(-pady=>5);
# Before registering a drop target, we always have to make sure the
# corresponding widget has been created:
$interp->update('idle');
# tells the DND protocol target can handle textual data
$interp->call('dnd','bindtarget', $lab_text_plain, 'text/plain', '<Drop>', \\'WDTA', sub {
	my (undef,$int,$sub) = (shift,shift,shift);
	my ($W,$D,$T,$A) = (@_); # Ev vars
	my $receiver_widget = $int->widget($W);
	$receiver_widget->configure(-text=>$D);
	status("[target1] type='$T', action='$A'");
	$int->after(2000, sub {$receiver_widget->configure(-text=>"drop plain text")});
    });


#------------------------------------------------------------------------------
#	Step 2: Management of multiple types on the source
#------------------------------------------------------------------------------

# defines an other type on source
$interp->call('dnd','bindsource', $lab_source->path, 'TK_COLOR', q{return "pink"});

# defines a target window
my $lab_t2 = $mw->Label(-text=>"drop color", qw/-relief raised -bd 1 -width 20 -bg lightyellow/)
  ->pack(-pady=>5);

# tells the DND protocol target can handle color data
$interp->call('dnd','bindtarget',  $lab_t2, 'TK_COLOR', '<Drop>', , \\'WDTA', sub {
	my (undef,$int,$sub) = (shift,shift,shift);
	my ($W,$D,$T,$A) = (@_); # Ev vars
	$lab_t2->configure(-bg=>$D);
	status("[target1] type='$T', action='$A'");
	$int->after(2000, sub {$lab_t2->configure(-bg=>'lightyellow')});
    });
 

#==============================================================================
#	END
#==============================================================================


$interp->wm('title','.',"Simple Drag & Drop Demo...");

my $lab_stat = $mw->Label(qw/-relief sunken -bd 1 -width 60 -anchor w/)->pack(qw/-side bottom -fill x/);
$mw->Frame(-height=>10)->pack(qw/-side bottom -fill x/);

sub status {
    my $msg = shift;
    $lab_stat->configure(-text=>$msg);
}


$mw->update;

$interp->MainLoop;