in reply to Re^7: Drag and Drop in Tkx
in thread Drag and Drop in Tkx

I'm beginning to think that BWidget won't work for drag and drop from an external source (like Windows Explorer). Here's the latest incarnation of the script. I took out the Tkx::package_require('tile'), in case that was causing a problem. Don't fully understand all the lists being passed around. 
use strict;
use warnings;
use Tkx;
use Data::Dumper;

my $text = "Drag to here";

Main(@ARGV);
exit(0);

sub Main
{
    local $Tkx::TRACE = 64;
    Tkx::package_require('BWidget');
    DrawGUI();
    Tkx::MainLoop();
}
 
sub DrawGUI
{
    my $wm = Tkx::widget->new(".");
    $wm->g_wm_title("BWidgets Demo for Drag 'n Drop enabled buttons.")
+;

    foreach (1 .. 4) { CreateButton( $wm, $_ ); }
    CreateEntry( $wm );

    $wm->new_Button(-text => "Exit Demo",
                    -command => [ \&Tkx::destroy, '.' ])->g_pack(qw'-p
+adx 5 -pady 5');
}

sub CreateButton
{
    my ($wm, $i) = @_;

    print "CreateButton: $i\n";
    my $m  = (qw' 0 Drag and Drop Demo ')[$i];
    my $button = $wm->new_Button(-name => ".b$i",    # auto-name is .b
+ .b2 .b3...
                                 -image => Tkx::Bitmap__get( (qw'0 new
+ file copy redo ')[$i] ),
                                 -text  => "$i.) $m",
                                 -command => sub { print "$m\n"; });
    $button->g_pack;

    print "enable DND for $button\n";
    my $t1 = "DragSiteIncludeButton" . $button;
    my $t2 = "FOOBAR" . $button;
    my $t3 = "DropRegButton" . $button;
    Tkx::DragSite__include('button', $t1, '<B1-Motion>');
    Tkx::DropSite__register($button, 
                            -dropcmd => \&DropCmdButton,
                            -droptypes => Tkx::list("FOOBAR", Tkx::lis
+t('copy', '', 'move', '', 'link', '')),);
    Tkx::DragSite__register($button,
                            -dragevent => 1,
                            -draginitcmd => \&DragInitCmdButton,
                            -dragendcmd => \&DragEndCmdButton);
}

sub CreateEntry
{
    my ($wm) = @_;

    print "CreateEntry\n";
    my $entry = $wm->new_entry(-name => "$wm.e",
                               -width => 20,
                               -textvariable => \$text);
    $entry->g_pack(qw '-padx 5 -pady 5');

    print "enable DND for $entry\n";
    my $data = "DropRegEntry" . $entry;
    my $t1 = "DragSiteIncludeEntry" . $entry;
    Tkx::DragSite__include('entry', "FOOBAR", '<B1-Motion>');
    Tkx::DropSite__register($entry,
                            -dropcmd => \&DropCmdEntry,
                            -dropovercmd => \&DropOverCmdEntry,
                            -droptypes => Tkx::list("FOOBAR", Tkx::lis
+t('copy', '', 'move', '', 'link', '')),);
}

#
# This command is called when user release the drag icon over a valid 
+drop target widget.
#
sub DropCmdButton
{
    my @args = (@_);
 
    print "\tDropCmdButton:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drop Target:    $args[3]\n";
    print "Drag Source:    $args[4]\n";
    print "X-Coordinate:   $args[5]\n";
    print "Y-Coordinate:   $args[6]\n";
    print "Operation:      $args[7]\n";
    print "Type of Data:   $args[8]\n";
    print "Dragged Data:   $args[9]\n";

    my $data = "DropCmdButton" . $args[3];

    return Tkx::list("DropCmdButton", "copy", $data);   # passed to -d
+ragendcmd
}

#
# Command called when drag initiates. When the event of option drageve
+nt occurs on path.
#
# If the command returns an empty string, then the drag will be suppre
+ssed.
# Otherwise the command must return a list containing three elements:
#   the type of the data
#   the list of acceptable basic operations (copy, move and link)
#   the data
#
# Note that even if copy does not appear in the list of basic operatio
+n, it is considered
# as an acceptable operation, since copy semantic does not modify the 
+drag source.
#
sub DragInitCmdButton
{
    my @args = (@_);
 
    print "\tDragInitCmdButton:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drag Source:    $args[3]\n";
    print "X-Coordinate:   $args[4]\n";
    print "Y-Coordinate:   $args[5]\n";
    print "Top Level:      $args[6]\n";

    my $t1 = "FOOBAR" . $args[3];
    my $t2 = "DragInitButton" . $args[3];

    return Tkx::list("FOOBAR", "copy", $t2);        # need FOOBAR - to
+ match register?
}

#
# Command called when drag terminates (ie when user release drag icon)
+.
#
# If the drop does not occurs, the target and the operation are empty 
+string and the result is 0.
#
sub DragEndCmdButton
{
    my @args = (@_);
 
    print "\tDragEndCmdButton:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drag Source:    $args[3]\n";
    print "Drop Target:    $args[4]\n";
    print "Operation:      $args[5]\n";
    print "Type of Data:   $args[6]\n";
    print "Dragged Data:   $args[7]\n";
    print "Result of Drop: $args[8]\n";
}

#
# This command is called when user release the drag icon over a valid 
+drop target widget.
#
sub DropCmdEntry
{
    my @args = (@_);
 
    print "\tDropCmdEntry:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drop Target:    $args[3]\n";
    print "Drag Source:    $args[4]\n";
    print "X-Coordinate:   $args[5]\n";
    print "Y-Coordinate:   $args[6]\n";
    print "Operation:      $args[7]\n";
    print "Type of Data:   $args[8]\n";
    print "Dragged Data:   $args[9]\n";

    return Tkx::list("FOOBAR", "copy", "entry");    # passed to -drage
+ndcmd
}

#
# This command can be used to provide a dynamic drag while drag-over e
+vents.
# While a drag occurs, events <Enter>, <Motion> and <Leave> are caught
+.
#
# Here is a list of events and associated actions on a DropSite widget
+.
# This example assumes that dragged data type is valid for the drop ta
+rget.
# status is the status of the drag on a DropSite. Its value is:
#
# Event     Old status  Action                                        
+      New status
# --------------------------------------------------------------------
+----------------
# <Enter>   -           if DropSite has dropovercmd, call it with ente
+r     result of dropovercmd
#                       else                                          
+      1
# <Motion>  0 or 1                                                    
+      unchanged
#           2 or 3      call dropovercmd with motion                  
+      result of dropovercmd
# <Leave>   0 or 1                                                    
+      -
#           2 or 3      call dropovercmd with leave                   
+      -
# <Drop>    0           call dragendcmd of drag source                
+      -
#           1           call dropcmd and call dragendcmd of drag sourc
+e
#           2           call dropovercmd with leave and call dragendcm
+d of drag source
#           3           call dropcmd and call dragendcmd of drag sourc
+e
#
sub DropOverCmdEntry
{
    my @args = (@_);
 
    print "\tDropOverCmdEntry:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drop Target:    $args[3]\n";
    print "Drag Source:    $args[4]\n";
    print "Event:          $args[5]\n";
    print "X-Coordinate:   $args[6]\n";
    print "Y-Coordinate:   $args[7]\n";
    print "Operation:      $args[8]\n";
    print "Type of Data:   $args[9]\n";
    print "Dragged Data:   $args[10]\n";

    # Return values:
    # 0 if widget refuse this drag. Command will not be recalled on mo
+tion/leave event.
    # 1 if widget accept this drag. Command will not be recalled on mo
+tion/leave event.
    # 2 if widget refuse this drag. Command will be recalled on each m
+otion event to reevaluate.
    # 3 if widget accept this drag. Command will be recalled on each m
+otion event to reevaluate.
    return 1;
}

[download]
The following is the result of running the script and dragging the 1st button and dropping it on the 2nd button, and then dragging the 3rd button and dropping it on the entry widget. 
Tkx-1-0.0s-dnd6.pl-14: package require BWidget
Tkx-2-0.0s-dnd6.pl-22: wm title . {BWidgets Demo for Drag 'n Drop enab
+led buttons.}
CreateButton: 1
Tkx-3-0.0s-dnd6.pl-40: Bitmap::get new
Tkx-4-0.0s-dnd6.pl-40: Button .b1 -image image1 -text {1.) Drag} -comm
+and perl::callback
Tkx-5-0.0s-dnd6.pl-41: pack .b1
enable DND for .b1
Tkx-6-0.0s-dnd6.pl-48: DragSite::include button DragSiteIncludeButton.
+b1 <B1-Motion>
Tkx-7-0.0s-dnd6.pl-49: list copy  move  link
Tkx-8-0.0s-dnd6.pl-49: list FOOBAR [list copy {} move {} link {}]
Tkx-9-0.0s-dnd6.pl-49: DropSite::register .b1 -dropcmd perl::callback 
+-droptypes [list FOOBAR {copy {} move {} link {}}]
Tkx-10-0.0s-dnd6.pl-52: DragSite::register .b1 -dragevent 1 -draginitc
+md perl::callback -dragendcmd perl::callback
CreateButton: 2
Tkx-11-0.0s-dnd6.pl-40: Bitmap::get file
Tkx-12-0.1s-dnd6.pl-40: Button .b2 -image image2 -text {2.) and} -comm
+and perl::callback
Tkx-13-0.1s-dnd6.pl-41: pack .b2
enable DND for .b2
Tkx-14-0.1s-dnd6.pl-48: DragSite::include button DragSiteIncludeButton
+.b2 <B1-Motion>
Tkx-15-0.1s-dnd6.pl-49: list copy  move  link
Tkx-16-0.1s-dnd6.pl-49: list FOOBAR [list copy {} move {} link {}]
Tkx-17-0.1s-dnd6.pl-49: DropSite::register .b2 -dropcmd perl::callback
+ -droptypes [list FOOBAR {copy {} move {} link {}}]
Tkx-18-0.1s-dnd6.pl-52: DragSite::register .b2 -dragevent 1 -draginitc
+md perl::callback -dragendcmd perl::callback
CreateButton: 3
Tkx-19-0.1s-dnd6.pl-40: Bitmap::get copy
Tkx-20-0.1s-dnd6.pl-40: Button .b3 -image image3 -text {3.) Drop} -com
+mand perl::callback
Tkx-21-0.1s-dnd6.pl-41: pack .b3
enable DND for .b3
Tkx-22-0.1s-dnd6.pl-48: DragSite::include button DragSiteIncludeButton
+.b3 <B1-Motion>
Tkx-23-0.1s-dnd6.pl-49: list copy  move  link
Tkx-24-0.1s-dnd6.pl-49: list FOOBAR [list copy {} move {} link {}]
Tkx-25-0.1s-dnd6.pl-49: DropSite::register .b3 -dropcmd perl::callback
+ -droptypes [list FOOBAR {copy {} move {} link {}}]
Tkx-26-0.1s-dnd6.pl-52: DragSite::register .b3 -dragevent 1 -draginitc
+md perl::callback -dragendcmd perl::callback
CreateButton: 4
Tkx-27-0.1s-dnd6.pl-40: Bitmap::get redo
Tkx-28-0.1s-dnd6.pl-40: Button .b4 -image image4 -text {4.) Demo} -com
+mand perl::callback
Tkx-29-0.1s-dnd6.pl-41: pack .b4
enable DND for .b4
Tkx-30-0.1s-dnd6.pl-48: DragSite::include button DragSiteIncludeButton
+.b4 <B1-Motion>
Tkx-31-0.1s-dnd6.pl-49: list copy  move  link
Tkx-32-0.1s-dnd6.pl-49: list FOOBAR [list copy {} move {} link {}]
Tkx-33-0.1s-dnd6.pl-49: DropSite::register .b4 -dropcmd perl::callback
+ -droptypes [list FOOBAR {copy {} move {} link {}}]
Tkx-34-0.1s-dnd6.pl-52: DragSite::register .b4 -dragevent 1 -draginitc
+md perl::callback -dragendcmd perl::callback
CreateEntry
Tkx-35-0.1s-dnd6.pl-63: entry ..e -width 20 -textvariable SCALAR(0x183
+01a0)
Tkx-36-0.1s-dnd6.pl-66: pack .e -padx 5 -pady 5
enable DND for .e
Tkx-37-0.1s-dnd6.pl-71: DragSite::include entry FOOBAR <B1-Motion>
Tkx-38-0.1s-dnd6.pl-72: list copy  move  link
Tkx-39-0.1s-dnd6.pl-72: list FOOBAR [list copy {} move {} link {}]
Tkx-40-0.1s-dnd6.pl-72: DropSite::register .e -dropcmd perl::callback 
+-dropovercmd perl::callback -droptypes [list FOOBAR {copy {} m
ove {} link {}}]
Tkx-41-0.1s-dnd6.pl-27: winfo children .
Tkx-42-0.1s-dnd6.pl-27: Button .b -text {Exit Demo} -command perl::cal
+lback
Tkx-43-0.1s-dnd6.pl-27: pack .b -padx 5 -pady 5
        DragInitCmdButton:
args[0]:        $VAR1 = undef;
args[1]:        $VAR1 = bless( do{\(my $o = 26882256)}, 'Tcl' );
args[2]:        $VAR1 = '::perl::CODE(0x1aee6ec)';
Drag Source:    .b1
X-Coordinate:   122
Y-Coordinate:   74
Top Level:      .drag
Tkx-44-3.4s-dnd6.pl-130: list FOOBAR copy DragInitButton.b1
        DropCmdButton:
args[0]:        $VAR1 = undef;
args[1]:        $VAR1 = bless( do{\(my $o = 26882256)}, 'Tcl' );
args[2]:        $VAR1 = '::perl::CODE(0x1aee194)';
Drop Target:    .b2
Drag Source:    .b1
X-Coordinate:   112
Y-Coordinate:   97
Operation:      default
Type of Data:   FOOBAR
Dragged Data:   DragInitButton.b1
Tkx-45-5.3s-dnd6.pl-99: list DropCmdButton copy DropCmdButton.b2
        DragEndCmdButton:
args[0]:        $VAR1 = undef;
args[1]:        $VAR1 = bless( do{\(my $o = 26882256)}, 'Tcl' );
args[2]:        $VAR1 = '::perl::CODE(0x1aee8e4)';
Drag Source:    .b1
Drop Target:    .b2
Operation:      copy
Type of Data:   FOOBAR
Dragged Data:   DragInitButton.b1
Result of Drop: DropCmdButton copy DropCmdButton.b2
        DragInitCmdButton:
args[0]:        $VAR1 = undef;
args[1]:        $VAR1 = bless( do{\(my $o = 26882256)}, 'Tcl' );
args[2]:        $VAR1 = '::perl::CODE(0x1aee6ec)';
Drag Source:    .b3
X-Coordinate:   123
Y-Coordinate:   115
Top Level:      .drag
Tkx-46-13.0s-dnd6.pl-130: list FOOBAR copy DragInitButton.b3
        DropOverCmdEntry:
args[0]:        $VAR1 = undef;
args[1]:        $VAR1 = bless( do{\(my $o = 26882256)}, 'Tcl' );
args[2]:        $VAR1 = '::perl::CODE(0x1aeedf4)';
Drop Target:    .e
Drag Source:    .b3
Event:          enter
X-Coordinate:   157
Y-Coordinate:   159
Operation:      default
Type of Data:   FOOBAR
Dragged Data:   DragInitButton.b3
        DropCmdEntry:
args[0]:        $VAR1 = undef;
args[1]:        $VAR1 = bless( do{\(my $o = 26882256)}, 'Tcl' );
args[2]:        $VAR1 = '::perl::CODE(0x1aeeb54)';
Drop Target:    .e
Drag Source:    .b3
X-Coordinate:   148
Y-Coordinate:   164
Operation:      default
Type of Data:   FOOBAR
Dragged Data:   DragInitButton.b3
Tkx-47-14.8s-dnd6.pl-173: list FOOBAR copy entry
        DragEndCmdButton:
args[0]:        $VAR1 = undef;
args[1]:        $VAR1 = bless( do{\(my $o = 26882256)}, 'Tcl' );
args[2]:        $VAR1 = '::perl::CODE(0x1aee8e4)';
Drag Source:    .b3
Drop Target:    .e
Operation:      copy
Type of Data:   FOOBAR
Dragged Data:   DragInitButton.b3
Result of Drop: FOOBAR copy entry
Tkx-48-18.6s-Tcl.pm-512: destroy .

[download]
Dave

Replies are listed 'Best First'.
Re^9: Drag and Drop in Tkx
by David S (Sexton) on Feb 22, 2010 at 21:54 UTC
    With some help from you guys and some people at www.nntp.perl.org/group/perl.tcltk, I was able to get Drag and Drop to work from an external application (Windows Explorer) into my Perl/Tkx program. First I needed to get the tkdnd TCL files from sourceforge. Then, because of limitations on my work PC where we all have to use the same version of Perl, I could not install tkdnd, so I simply copied them to a directory on my drive (D:/dss/perl/tk/tkx/lib). Then, the following script works: 
    use strict;
use Tkx;

Tkx::lappend('::auto_path', 'D:/dss/perl/tk/tkx/lib');  # should be a 
+path everyone has
Tkx::package_require('tkdnd');

my $textVar = "drag here";

my $mw = Tkx::widget->new(".");
my $entry = $mw->new_entry(-name => ".current_dir", -textvariable => \
+$textVar);
$entry->g_pack(qw '-fill both -expand true');

Tkx::tkdnd__drop___target_register($entry,'*');
Tkx::bind ($entry, '<<Drop:DND_Files>>',  [ sub { AcceptDrop(shift); }
+, Tkx::Ev("%D")]);

Tkx::MainLoop;

sub AcceptDrop
{
    $textVar = shift;
    print "in AcceptDrop with '$textVar'\n";
}

    [download]
    Thanks for everyone's help!

    Dave

[reply]
[d/l]

In Section Seekers of Perl Wisdom