With some help from www.perlmonks.org
<BLOCKED::http://www.perlmonks.org> , I have the following. It handles
the drag part of a widget in the window, but the drop part doesn't do
anything. I ultimately want to be able to drag a file from windows
explorer and have the filename (and path) recognized in the widget.
Can't get 'drop' to work in Perl/Tkx. Any help would be appreciated.
Dave
________________________________
#!/usr/bin/perl --
use strict;
use warnings;
use Tkx;
my $text = "abc";
Main(@ARGV);
exit(0);
sub Main {
local $Tkx::TRACE = 64;
Tkx::package_require('tile');
Tkx::package_require('BWidget');
eval { Tkx::tile__setTheme('xpnative'); 1 }
|| eval { Tkx::ttk__setTheme('xpnative'); 1 };
drawGUI();
Tkx::MainLoop();
}
sub drawGUI
{
our $t = Tkx::widget->new(".");
$t->g_wm_title("BWidgets Demo for Drag 'n Drop enabled buttons.");
$t = $t->new_ttk__frame( -name => '.f' );
$t->g_pack(qw '-fill both -expand true');
for my $i ( 1 .. 4 )
{
my $m = (qw' 0 Drag and Drop Demo ')[$i];
my $bb = $t->new_ttk__button(-name => "$t.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"; });
$bb->g_pack;
}
enableDnD( map { "$t.b$_" } 1 .. 4 );
$t->new_ttk__button(-text => "Exit Demo",
-command => [ \&Tkx::destroy, '.' ])->g_pack(qw
'-padx 5 -pady 5');
my $entry = $t->new_ttk__entry(-width => 20, -textvariable =>
\$text);
Tkx::DropSite__register($entry,
-dropcmd => \&dropcmdEntry,
-dropovercmd => \&dropovercmdEntry,
-droptypes => {"text", {"copy", "none"}});
$entry->g_pack(qw '-padx 5 -pady 5');
}
sub enableDnD
{
for my $w (@_)
{
Tkx::DropSite__register($w,
-dropcmd => \&dropButtonCmd);
Tkx::DragSite__register($w,
-dragevent => 1,
-draginitcmd => \&dragInitCmd,
-dragendcmd => \&dragEndCmd);
}
}
sub dropButtonCmd
{
my @args = (@_);
print "in dropButtonCmd\n";
for (my $i = 0; $i < scalar @args; $i++)
{
print "arg $i = '$args[$i]'\n" if defined $args[$i];
}
return "abc";
}
sub dragInitCmd
{
my @args = (@_);
print "in dragInitCmd\n";
for (my $i = 0; $i < scalar @args; $i++)
{
print "arg $i = '$args[$i]'\n" if defined $args[$i];
}
my $data = "\"Button " . $args[3] . "\"";
return ("text", ("copy"), $data);
}
sub dragEndCmd
{
my @args = (@_);
print "in dragEndCmd\n";
for (my $i = 0; $i < scalar @args; $i++)
{
print "arg $i = '$args[$i]'\n" if defined $args[$i];
}
}
sub dropcmdEntry
{
print "dropcmdEntry\n";
return "entry";
}
sub dropovercmdEntry
{
print "dropovercmdEntry\n";
}
________________________________
When I run the script and drag one of the buttons around, I get
something like the following, but I can't seem to get the drop commands
to ever fire.
Tkx-1-0.0s-dnd2.pl-13: package require tile
Tkx-2-0.1s-dnd2.pl-14: package require BWidget
Tkx-3-0.1s-dnd2.pl-15: tile::setTheme xpnative
Tkx-4-0.1s-dnd2.pl-24: wm title . {BWidgets Demo for Drag 'n Drop
enabled buttons.}
Tkx-5-0.1s-dnd2.pl-26: ttk::frame .f
Tkx-6-0.1s-dnd2.pl-27: pack .f -fill both -expand true
Tkx-7-0.1s-dnd2.pl-35: Bitmap::get new
Tkx-8-0.1s-dnd2.pl-35: ttk::button .f.b1 -image image1 -text {1.) Drag}
-command perl::callback
Tkx-9-0.1s-dnd2.pl-36: pack .f.b1
Tkx-10-0.1s-dnd2.pl-35: Bitmap::get file
Tkx-11-0.1s-dnd2.pl-35: ttk::button .f.b2 -image image2 -text {2.) and}
-command perl::callback
Tkx-12-0.1s-dnd2.pl-36: pack .f.b2
Tkx-13-0.1s-dnd2.pl-35: Bitmap::get copy
Tkx-14-0.1s-dnd2.pl-35: ttk::button .f.b3 -image image3 -text {3.) Drop}
-command perl::callback
Tkx-15-0.1s-dnd2.pl-36: pack .f.b3
Tkx-16-0.1s-dnd2.pl-35: Bitmap::get redo
Tkx-17-0.1s-dnd2.pl-35: ttk::button .f.b4 -image image4 -text {4.) Demo}
-command perl::callback
Tkx-18-0.1s-dnd2.pl-36: pack .f.b4
Tkx-19-0.1s-dnd2.pl-56: DropSite::register .f.b1 -dropcmd perl::callback
Tkx-20-0.1s-dnd2.pl-58: DragSite::register .f.b1 -dragevent 1
-draginitcmd perl::callback -dragendcmd perl::callback
Tkx-21-0.1s-dnd2.pl-56: DropSite::register .f.b2 -dropcmd perl::callback
Tkx-22-0.1s-dnd2.pl-58: DragSite::register .f.b2 -dragevent 1
-draginitcmd perl::callback -dragendcmd perl::callback
Tkx-23-0.2s-dnd2.pl-56: DropSite::register .f.b3 -dropcmd perl::callback
Tkx-24-0.2s-dnd2.pl-58: DragSite::register .f.b3 -dragevent 1
-draginitcmd perl::callback -dragendcmd perl::callback
Tkx-25-0.2s-dnd2.pl-56: DropSite::register .f.b4 -dropcmd perl::callback
Tkx-26-0.2s-dnd2.pl-58: DragSite::register .f.b4 -dragevent 1
-draginitcmd perl::callback -dragendcmd perl::callback
Tkx-27-0.2s-dnd2.pl-41: winfo children .f
Tkx-28-0.2s-dnd2.pl-41: ttk::button .f.b -text {Exit Demo} -command
perl::callback
Tkx-29-0.2s-dnd2.pl-41: pack .f.b -padx 5 -pady 5
Tkx-30-0.2s-dnd2.pl-44: winfo children .f
Tkx-31-0.2s-dnd2.pl-44: ttk::entry .f.e -width 20 -textvariable
SCALAR(0x1830104)
Tkx-32-0.2s-dnd2.pl-45: DropSite::register .f.e -dropcmd perl::callback
-dropovercmd perl::callback -droptypes HASH(0x1b1e38c)
Tkx-33-0.2s-dnd2.pl-49: pack .f.e -padx 5 -pady 5
in dragInitCmd
arg 1 = 'Tcl=SCALAR(0x189f2fc)'
arg 2 = '::perl::CODE(0x18c6bb8)'
arg 3 = '.f.b1'
arg 4 = '181'
arg 5 = '145'
arg 6 = '.drag'
in dragEndCmd
arg 1 = 'Tcl=SCALAR(0x189f2fc)'
arg 2 = '::perl::CODE(0x18c6cb4)'
arg 3 = '.f.b1'
arg 4 = ''
arg 5 = ''
arg 6 = 'Button .f.b1'
arg 7 = ''
arg 8 = '0'
________________________________
From: Swingle David-QWHM86
Sent: Tuesday, January 26, 2010 12:46 PM
To: 'tcltk@perl.org'
Subject: Drag-n-Drop in Perl/Tkx
I'm converting Perl/Tk to Perl/Tkx and I'm struggling with getting Drag
and Drop to work in Perl/Tkx. I had found help for DND in Perl/Tk and
use in in a large script I wrote, but for simplicity, here is a simple
Perl/Tk script that supports DND:
use strict;
use Tk;
use Tk::Pane;
my $textVariable = "my text";
my $mw = MainWindow->new;
my $frame = $mw->Frame()->pack(-side => 'top', -expand => 1, -fill =>
'x');
$frame->Label(-text => "My Label",
-anchor => 'w',
-width => 10)->pack(-ipady => 1,
-side => 'left');
my $entry = $frame->Entry(-textvariable => \$textVariable,
-width => 40)->pack(-side => 'left');
$frame->DropSite(-dropcommand => [\&AcceptDrop, $frame],
-droptypes => ('Win32'));
MainLoop;
sub AcceptDrop
{
my ($widget, $selection) = @_;
my $filename;
$filename = $widget->SelectionGet(-selection => $selection,
'STRING');
$textVariable = $filename;
}
Is there an easy way to convert this simple script to use Tkx? I know
there was a post about this in the past, but I couldn't figure out
exactly what was meant. For example, in that post there was
$interp->packageRequire('tkdnd', '2.0');
But $interp wasn't initialized to anything.
I'm using perl, v5.8.8, binary build 822.
Thanks,
David
