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