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; }
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 .
Dave

In reply to Re^8: Drag and Drop in Tkx by David S
in thread Drag and Drop in Tkx by David S

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.