First one, bacically feeds original demo to Tcl interpreter, and starting MainLoop (remember you still have very easy access to Tk widgets with perlTk syntax...)
use strict; use Tcl::Tk; my $mw = Tcl::Tk::tkinit; $mw->interp->Eval(<<'EOS'); package require tkdnd ## Iconify ".". We are going to add windows and call update many times +. ## Avoid some interesting visual effects :-) wm withdraw . #--------------------------------------------------------------------- +--------- # Step 1: A simple Drag Source #--------------------------------------------------------------------- +--------- # create the source window label .source -text "source" -relief groove -bd 2 -width 20 pack .source -pady 5 # tells the DND protocol source can deliver textual data dnd bindsource .source text/plain {return "testing DND"} # bind the DND operation on left button bind .source <1> {dnd drag %W} #--------------------------------------------------------------------- +--------- # Step 1: A simple Drop Target accepting plain text #--------------------------------------------------------------------- +--------- # defines the target window label .text_plain -text "drop plain text" -relief raised -bd 1 -width +20 pack .text_plain -pady 5 # Before registering a drop target, we always have to make sure the # corresponding widget has been created: update idle # tells the DND protocol target can handle textual data dnd bindtarget .text_plain text/plain <Drop> \ {%W configure -text %D; status "\[target1\] type='%T', action='%A'" after 2000 {%W configure -text "drop plain text"}} #--------------------------------------------------------------------- +--------- # Step 2: Management of multiple types on the source #--------------------------------------------------------------------- +--------- # defines an other type on source dnd bindsource .source TK_COLOR {return "pink"} # defines a target window label .target2 -text "drop color" -relief raised -bd 1 -width 20 \ -bg lightyellow pack .target2 -pady 5 # tells the DND protocol target can handle color data dnd bindtarget .target2 TK_COLOR <Drop> { status "\[target2\] type='%T', data='%D', action='%A'" .target2 configure -bg %D after 2000 ".target2 configure -bg lightyellow" } #===================================================================== +========= # END #===================================================================== +========= proc status {msg} { .status configure -text $msg } proc init {} { wm title . "Simple Drag & Drop Demo..." label .status -relief sunken -bd 1 -width 60 -anchor w pack .status -side bottom -fill x pack [frame .sep -height 10] -side bottom -fill x pack propagate .status 0 } init update wm deiconify . EOS # Tcl inclusion for GUI finished here; you can work with widgets here +like: # my $lab = $mw->interp->widget('.status'); # $lab->configure(-text=>'new text here...'); Tcl::Tk::MainLoop;
2nd method is reworked a bit to be more Perl-looking:
use strict; use Tcl::Tk; my $mw = Tcl::Tk::tkinit; my $interp = $mw->interp; $interp->invoke('package', 'require', 'tkdnd'); ## Iconify ".". We are going to add windows and call update many times +. ## Avoid some interesting visual effects :-) #wm withdraw . #--------------------------------------------------------------------- +--------- # Step 1: A simple Drag Source #--------------------------------------------------------------------- +--------- # create the source window my $lab_source = $mw->Label(-text=>"source", qw/-relief groove -bd 2 - +width 20/)->pack(-pady=>5); # tells the DND protocol source can deliver textual data $interp->call('dnd','bindsource', $lab_source->path, 'text/plain', q{r +eturn "testing DND"}); # bind the DND operation on left button $interp->call('bind', $lab_source->path, '<1>', 'dnd drag %W'); #--------------------------------------------------------------------- +--------- # Step 1: A simple Drop Target accepting plain text #--------------------------------------------------------------------- +--------- # defines the target window my $lab_text_plain = $mw->Label(-text=>"drop plain text", qw/-relief r +aised -bd 1 -width 20/)->pack(-pady=>5); # Before registering a drop target, we always have to make sure the # corresponding widget has been created: $interp->update('idle'); # tells the DND protocol target can handle textual data $interp->call('dnd','bindtarget', $lab_text_plain, 'text/plain', '<Dro +p>', \\'WDTA', sub { my (undef,$int,$sub) = (shift,shift,shift); my ($W,$D,$T,$A) = (@_); # Ev vars my $receiver_widget = $int->widget($W); $receiver_widget->configure(-text=>$D); status("[target1] type='$T', action='$A'"); $int->after(2000, sub {$receiver_widget->configure(-text=>"drop pl +ain text")}); }); #--------------------------------------------------------------------- +--------- # Step 2: Management of multiple types on the source #--------------------------------------------------------------------- +--------- # defines an other type on source $interp->call('dnd','bindsource', $lab_source->path, 'TK_COLOR', q{ret +urn "pink"}); # defines a target window my $lab_t2 = $mw->Label(-text=>"drop color", qw/-relief raised -bd 1 - +width 20 -bg lightyellow/) ->pack(-pady=>5); # tells the DND protocol target can handle color data $interp->call('dnd','bindtarget', $lab_t2, 'TK_COLOR', '<Drop>', , \\ +'WDTA', sub { my (undef,$int,$sub) = (shift,shift,shift); my ($W,$D,$T,$A) = (@_); # Ev vars $lab_t2->configure(-bg=>$D); status("[target1] type='$T', action='$A'"); $int->after(2000, sub {$lab_t2->configure(-bg=>'lightyellow')}); }); #===================================================================== +========= # END #===================================================================== +========= $interp->wm('title','.',"Simple Drag & Drop Demo..."); my $lab_stat = $mw->Label(qw/-relief sunken -bd 1 -width 60 -anchor w/ +)->pack(qw/-side bottom -fill x/); $mw->Frame(-height=>10)->pack(qw/-side bottom -fill x/); sub status { my $msg = shift; $lab_stat->configure(-text=>$msg); } $mw->update; $interp->MainLoop;
Best regards,
Courage, the Cowardly Dog
In reply to Re: Tcl::Tk GUI working - Help with TkDnD through perl?
by Courage
in thread Tk Drag and Drop Between Applications
by Ardemus
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |