use strict;
use Tcl::Tk;

my $mw = Tcl::Tk::tkinit;

$mw->interp->Eval(<<'EOS');
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
label .source -text "source" -relief groove -bd 2 -width 20
pack .source -pady 5
# tells the DND protocol source can deliver textual data
dnd bindsource .source text/plain {return "testing DND"}
# bind the DND operation on left button
bind .source <1> {dnd drag %W}

#------------------------------------------------------------------------------
#	Step 1: A simple Drop Target accepting plain text
#------------------------------------------------------------------------------
# defines the target window
label .text_plain -text "drop plain text" -relief raised -bd 1 -width 20
pack .text_plain -pady 5
# Before registering a drop target, we always have to make sure the
# corresponding widget has been created:
update idle
# tells the DND protocol target can handle textual data
dnd bindtarget .text_plain text/plain <Drop> \
  {%W configure -text %D; status "\[target1\] type='%T', action='%A'"
   after 2000 {%W configure -text "drop plain text"}}


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

# defines an other type on source
dnd bindsource .source TK_COLOR {return "pink"}

# defines a target window
label .target2 -text "drop color" -relief raised -bd 1 -width 20 \
		-bg lightyellow
pack .target2 -pady 5

# tells the DND protocol target can handle color data
dnd bindtarget .target2 TK_COLOR <Drop> {
	status "\[target2\] type='%T', data='%D', action='%A'"
	.target2 configure -bg %D
	after 2000 ".target2 configure -bg lightyellow"
}

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

proc status {msg} {
	.status configure -text $msg
}

proc init {} {
	wm title . "Simple Drag & Drop Demo..."

	label .status -relief sunken -bd 1 -width 60 -anchor w
	pack .status -side bottom -fill x
	pack [frame .sep -height 10] -side bottom -fill x
	pack propagate .status 0
}

init
update
wm deiconify .
EOS

# Tcl inclusion for GUI finished here; you can work with widgets here like:
#   my $lab = $mw->interp->widget('.status');
#   $lab->configure(-text=>'new text here...');

Tcl::Tk::MainLoop;