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

Reply via email to