Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked

Perl/Tk remote drag-and-drop

by Anonymous Monk
on Jun 26, 2003 at 00:50 UTC ( #269065=perlquestion: print w/replies, xml ) Need Help??
Anonymous Monk has asked for the wisdom of the Perl Monks concerning the following question:

I was wondering if anyone had any code or links to any code that illustrated the process of getting a perl/tk widget to accept a dnd event from another application?

The only sources I have found on the whole of the internet are listed in the FAQ, section 10.22, namely ... and

The second article deals with local drops only, and the first - while mentioning remote drops - provides a script which does not seem to work.

In brief, I am unable to get any perl/tk widget to "accept" the drop - I drag a file over it from a XDND-compatible file-manager (ROX) and the window refuses to accept the file - or at least, the file icon does not gain a "+" sign indicating I can drop it, and my script refuses to respond to the drop event.

If there are any code examples that illustrate this, please let me know (I've searched google, lycos, and even freshmeat (looking at all perl/tk apps - none use remote drops) ... and I'm beginning to wonder if *anyone* has ever written anything that uses remote drops!!)

Replies are listed 'Best First'.
Re: Perl/Tk remote drag-and-drop
by crouchingpenguin (Priest) on Jun 26, 2003 at 01:49 UTC

    Not sure if it has drag and drop relevance, but take a look at Tk::send

    NAME send - Execute a command in a different application SYNOPSIS $result = $widget->send(?options,?app=>cmd?arg arg ...?)

    Update: has an article on remote dnd

    "Never be afraid to try something new. Remember, amateurs built the ark. Professionals built the Titanic."
Re: Perl/Tk remote drag-and-drop
by Anonymous Monk on Jun 26, 2003 at 09:57 UTC

    OK, I found this test application from the DragDrop directory (site_test, I think). It works great under ActivePerl on Win32 ... but it seriously doesn't work on my Mandrake 9.1 home desktop, nor can I make it work.

    The first problem I encounter is that the Tk::DragDrop::*Site/Drop modules are not loading correctly, I have to explicitly add

    use Tk::DragDrop::XDNDSite;
    use Tk::DragDrop::XDNDDrop;

    use Tk::DragDrop::SunSite;
    use Tk::DragDrop::SunDrop;

    use Tk::DragDrop::KDESite;
    use Tk::DragDrop::KDEDrop;

    ... which doesn't seem right (but I don't know much about how perl decides to decompress certain modules and not others, so I can't debug this)

    But more importantly, the application window still does not accept drops from other apps. I've tried MozillaFirebird as well - another XDND supporting application, and anything I drag to the perl/Tk window is just not accepted ... (How humiliating - a perl app works better in Win32 than it does under linux ...:)

    ----- ----- #!/usr/local/bin/perl -w use Tk; use strict; use Tk::DropSite; use vars qw($kind $STRING $FILE_NAME); BEGIN { $kind = ($^O eq 'MSWin32' or ($^O eq 'cygwin' and $Tk::platform eq 'M +SWin32'))? ['Win32'] : ['Sun','XDND','KDE'] } use Tk::DropSite @$kind; use Tk::DragDrop @$kind; use Tk::Menubar; sub enter_leave { my ($ds,$flag) = @_; $ds->configure(-relief => ($flag) ? 'sunken' : 'ridge'); return 1; } my $top = MainWindow->new(); my $mb = $top->Menubar; $mb->Menubutton(-text => '~File', -menuitems => [ [ Button => 'E~xit', -command => [ destroy => $top]], ]); my $but = $top->Frame->pack; my $lb = $top->Scrolled('Listbox',-width => 40)->pack(-side => 'bottom +'); $but->Button('-text' => "Primary Targets", '-command' => [\&ShowTarget +s,$lb,'PRIMARY'])->pack('-side'=>'left'); $but->Button('-text' => "Quit", '-command' => ['destroy',$top])->pack( +'-side'=>'right'); my $filename = "/tmp/SomethingSilly"; open(FOO,">$filename"); print FOO "Hi There\n"; close(FOO); my $src = $top->Frame->pack; foreach my $k ('Local',@$kind,'Any') { # next if $k eq 'KDE'; my $thing = $src->Message('-text' => "$k Source")->pack(-side => 'le +ft'); my @list; @list = (-sitetypes => $k) unless $k eq 'Any'; $thing->DragDrop(-event => '<B1-Motion>', @list, -handlers => [ [-type => 'text/plain',[\&string_handler,"This is t +ext/plain"]], [-type => 'FILE_NAME',[\&string_handler,$filename]] +, [[\&string_handler,"This is STRING"]] ]); } my $dst = $top->Frame->pack; foreach my $k ('Local',@$kind,'Any') { my @list; @list = (-droptypes => $k) unless $k eq 'Any'; my $sun = $dst->Message('-text' => "$k Drops here", '-relief' => 'ri +dge' )->pack(-side => 'left'); $sun->DropSite(-dropcommand => [\&ShowTargets,$lb], -entercommand => [\&enter_leave,$sun], @list); } my $str = $top->Frame->pack(-fill => 'x'); foreach my $targ (qw(STRING FILE_NAME)) { no strict 'refs'; my $l = $str->Label(-anchor => 'e', -justify => 'right', -text => $t +arg); my $v = $str->Label(-anchor => 'w', -justify => 'left', -relief => ' +groove', -textvariable => \${$targ}); Tk::grid($l,$v,-sticky => 'ew'); } $str->gridColumnconfigure(0,-weight => 0); $str->gridColumnconfigure(1,-weight => 1); sub string_handler { my ($text,$offset,$max) = @_; return substr($text,$offset,$max); } MainLoop; use Data::Dumper; sub ShowTargets { my $lb = shift; my $seln = shift; my $own = $lb->SelectionExists('-selection'=>$seln); printf "owner of $seln is %x\n",$own; my @targ = $lb->SelectionGet('-selection'=>$seln,'TARGETS'); $lb->delete(0,'end'); $lb->insert('end',@targ); $STRING = $FILE_NAME = ''; foreach (@targ) { if (/FILE_NAME/) { $FILE_NAME = $lb->SelectionGet('-selection'=>$seln,'FILE_NAME'); } if (/_SUN/ && !/(END|ACK|DONE|YIELD)/) { my @info; Tk::catch { @info = $lb->SelectionGet('-selection'=>$seln,$_) }; if ($@) { print "Cannot get $_\n"; } else { print "$_:",Dumper(\@info); } } if (m#^(STRING|text/plain)$#) { my $string = $lb->SelectionGet('-selection'=>$seln,$_); $string = substr($string,0,37)."..." if length($string) > 40; $STRING = $string; } } }

      A few years late, but I'll record my findings here as I could not find the complete answer anywhere else (and trial and error has been kind to me).

      First, to get a DropSite to accept drops, you have to provide a list of -droptypes for it to accept. This will also cause Perl to load the Tk::DragDrop::*Site/Drop modules as needed.

      $sun->DropSite( -droptypes => ['KDE','XDND','Sun'], ... );

      To get the data from the drop, use SelectionGet and set the selection type. The selection type is passed as the first argument to the -dropcommand.

      $sun->DropSite( -droptypes => ['KDE','XDND','Sun'], -dropcommand => sub { $data = $sun->SelectionGet(-selection => $_[0]); } }

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://269065]
Approved by tilly
[Corion]: A good weekstart to everybody. I hope you had a good Pentecost
marto was working yesterday
[Corion]: marto: Ow :(
[marto]: Corion, not to worry, it was ok :)
[Corion]: I "just" had a call from a friend whom I host the website for, and they were quite hectic yet uninformed about what they'd have to change for GDPR... This felt like work to me, but at least I got that call in a café, not in the office
[Corion]: But hopefully today I'll be a bit calmer and call them and update their website with what little they need to change for GDPR. Having a "business front page" as website means you collect and handle very little PII ;)

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (7)
As of 2018-05-22 07:52 GMT
Find Nodes?
    Voting Booth?