Thanks Vadim,
What you sent still doesn't handle dropping from an external source
(windows explorer). I added more to the script to try to understand
what it is doing. Still don't understand all the rules as far as what
gets passed around (the "FOO_BAR" text in your example). Still can't
get external drops. I took out the Tkx::package_require('tile'), just
in case it was causing problems.
<code>
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'-padx 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::list('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::list('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
-dragendcmd
}
#
# Command called when drag initiates. When the event of option dragevent
occurs on path.
#
# If the command returns an empty string, then the drag will be
suppressed.
# 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 operation,
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
-dragendcmd
}
#
# This command can be used to provide a dynamic drag while drag-over
events.
# 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
target.
# 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 enter
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 source
# 2 call dropovercmd with leave and call dragendcmd
of drag source
# 3 call dropcmd and call dragendcmd of drag source
#
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
motion/leave event.
# 1 if widget accept this drag. Command will not be recalled on
motion/leave event.
# 2 if widget refuse this drag. Command will be recalled on each
motion event to reevaluate.
# 3 if widget accept this drag. Command will be recalled on each
motion event to reevaluate.
return 1;
}
</code>
When I run the script and drag the 1st button and drop on the 2nd
button, and then drag the 3rd button and drop on the entry widget, I get
the following:
<code>
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
enabled 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}
-command 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 -draginitcmd
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}
-command 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 -draginitcmd
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}
-command 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 -draginitcmd
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}
-command 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 -draginitcmd
perl::callback -dragendcmd perl::callback
CreateEntry
Tkx-35-0.1s-dnd6.pl-63: entry ..e -width 20 -textvariable
SCALAR(0x18301a0)
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::callback
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 .
</code>
Dave
