Perl is able to deal with Drag-n-Drop within Tk and another applications

[Courage]

After some discussion at Tk Drag and Drop Between Applications I tried to find a solution, succeeded, and now I want to bring this experience to a broader audience, so to share experience on how to solve this task.

Saying Tk I mean Tcl/Tk and Perl module Tcl::Tk, but not perlTk.

In order to use this approach Tcl::Tk from CPAN should be installed, Tcl/Tk should also be installed, and Tcl/Tk installation should have tkdnd module http://sourceforge.net/projects/tkdnd/

A self-explaining example is as follows:

use strict;
use Tcl::Tk;

my $status = '';

my $mw = Tcl::Tk::MainWindow("Simple Drag & Drop Demo...");

# label widget that will show status
my $lab_stat = $mw->Label(-textvariable=>\$status, qw/-relief sunken 
    -bd 1 -width 60 -anchor w/)->pack(qw/-side bottom -fill x/);
# three more widgets that will be used for trying DND
my $lab_source = $mw->Label(-text=>"source", qw/-relief groove -bd 2
    -width 20/) ->pack(-pady=>5);
my $lab_text_plain = $mw->Label(-text=>"drop plain text", 
    qw/-relief raised -bd 1 -width 20/)->pack(-pady=>5);
my $lab_t2 = $mw->Label(-text=>"drop color", qw/-relief raised -bd 1
    -width 20 -bg lightyellow/)->pack(-pady=>5);
# and a frame
$mw->Frame(-height=>10)->pack(qw/-side bottom -fill x/);


# following line will do 'package require tkdnd' in Tcl/Tk
$mw->interp->need_tk('tkdnd');

# in order to make DND syntax shorter let's define following methods
sub Tcl::Tk::Widget::dndBindsource {
    my $w = shift;
    $w->interp->call('dnd','bindsource',$w,@_);
}
sub Tcl::Tk::Widget::dndBindtarget {
    my $w = shift;
    $w->interp->call('dnd','bindtarget',$w,@_);
}
# could be done without above two methods that go to Tcl::Tk package:
# $int->call('dnd','bindsource',$widget->path,.....);
# but now we will be allowed to shorter
# $widget->dndBindsource(....);

#---------------------------------------------------------------------
# Before registering a drop target, we always have to make sure the
# corresponding widget has been created:
$mw->update('idle');

# tells the DND protocol source can deliver textual data
$lab_source->dndBindsource('text/plain', q{return "testing DND"});

# bind the DND operation on left button
$lab_source->bind('<1>', 'dnd drag %W');

# tells the DND protocol target can handle textual data
$lab_text_plain->dndBindtarget('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")
        });
    });

# defines an other type on source
$lab_source->dndBindsource('TK_COLOR', q{return "pink"});

# tells the DND protocol target can handle color data
$lab_t2->dndBindtarget('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')});
    });

Tcl::Tk::MainLoop;

And, since we're talking in TIMTOWTDI language, here is alternate approach: same logic but here we wrap Tcl/Tk-only GUI which is still available with perlTk syntax

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;

Both approaches are cross-platform, easy-to-use.
Both allow drag-n-drop interaction with non-Tk applications.