in reply to Re: Drag & Drop Problem
in thread Drag & Drop Problem

Alrighty. Modified and updated that. 

use Tk;
use Tk::HList;
use Tk::Pane;
use Tk::DragDrop;
use Tk::DropSite;

use strict;
use warnings;

my $mw = MainWindow->new;



my $eyeball = '
    /* XPM */
    static char * eyeball[] = {
    "32 12 4 1",
    "   c None",
    "@  c #000000",
    "x  c #ffffff",
    "o  c #3f3fff",
    "                @@@@@@@@@       ",
    "              @@@@@@@@@@@@@     ",
    "             @@xxxxxxxxxxx@@    ",
    "            @@xxxx@@@@@@xxx@@   ",
    "            @@xxx@@oooo@@xxx@@  ",
    "            @@xx@@oooooo@@xx@@  ",
    "            @@xx@@oooooo@@xx@@  ",
    "            @@xxx@@oooo@@xxx@@  ",
    "             @@xxx@@@@@@xxx@@   ",
    "              @@xxxxxxxxxx@@    ",
    "               @@@@@@@@@@@@     ",
    "                 @@@@@@@@       ",
';


my $psym = make_image($mw, $eyeball);

my $pane = $mw->Scrolled('Pane',
                         -width => 800,
                         -height => 400,
                         -sticky => 'nsew',
                         -scrollbars => 'os',
           )->pack(-fill => 'both',
             -expand => 1);

addCol(1);
addCol(2);
addCol(3);

sub addCol {

    my $id = shift;

    my $width = 200;

    my $frame = $pane->Frame(
                            -relief => "ridge",
                            -bd     => 1,
                            -width  => $width,
                        )->pack(-side => 'left',
                         -fill => 'both',
                         -expand => 1,
         );

    # DnD SUPPORT!

    #my $frame1 = $frame->Frame()->pack();
    #my $frame2 = $frame->Frame()->pack();

    my $adjuster = $pane->Adjuster();
    $adjuster->packAfter($frame, -side => 'left');

    my $label = $frame->Label(-width => 30, -text  => "Test" . $id, -b
+g => "lightgray",
                        )->pack(-fill => "both");
#    my $label = $frame->Button(-width => 30, -text  => "Test" . $id,
#                                -command => sub { print "!!!!!!!!!!!!
+"; },
#                        )->pack(-fill => "both");


    my $press = sub {
        my ($c_src, $label_obj, $drag_source) = @_;
        #$drag_id = $c_src_id;
        #my $type = $c_src->type($drag_id);
        $drag_source->configure(-text => $label_obj->cget(-text));
    };

    my $drag_source = $label->DragDrop(
            -event     => '<B1-Motion>',
            -sitetypes => [qw/Local/],
            #-image     => $psym,
    );

    $label->bind('<ButtonPress-1>' => [$press, $label, $drag_source]);

    #_dragOrSort($button);

    #my $can = $frame->Canvas(-bg => 'skyblue')->pack();


    my $hlist = $frame->Scrolled("HList",
            -scrollbars => 'osoe',
            -selectmode => 'extended'
            )->pack(-fill => "both", -expand => 1);


    my $drop = $hlist->DropSite(
        -droptypes    => [qw(Local)],
        -dropcommand  => [\&perform_drop,    $label],
        -entercommand => [\&hover_over_drop, $label],
#        -dropcommand  => [\&perform_drop,    $can, $label],
#        -entercommand => [\&hover_over_drop, $can, $label],
    );
    my $drop2 = $label->DropSite(
        -droptypes    => [qw(Local)],
        -dropcommand  => [\&perform_drop,    $label],
        -entercommand => [\&hover_over_drop, $label],
#        -dropcommand  => [\&perform_drop,    $can, $label],
#        -entercommand => [\&hover_over_drop, $can, $label],
    );

}

MainLoop;



#
#  Inputs:  $1 ... the top-level widget
#           $2 ... the image data
#
# Outputs:  $1 ... a pointer to the image for use with other widgets
#
sub make_image {
    my ($w, $data) = @_;
    my $img = $w->Pixmap(-data, $data);
    return $img;
}


#
#  Inputs:  $1 ... the widget being hovered over
#           $2 ... nonzero if entering, zero if leaving
#           $3 ... label over
#
sub hover_over_drop {
    my ($drop_site, $b_entry, $x_pos, $label_obj) = @_;
    $drop_site->configure(-bg => $b_entry == 1 ? 'gray' : 'lightgray')
+;

    if ($b_entry) {
         #print $label_obj . "\n";
        #$label_obj->cget(-text);
    }
}


#
#  Inputs:  $1 ... the widget being dropped into
#           $2 ... the widget being dropped
#
sub perform_drop {
    my ($drop_site, $x_pos, $drop_obj) = @_;

    #use Data::Dumper;
    #print Dumper(@_);

    #$pane->idletasks;
    #$pane->update;

    #$x_pos->configure(-bg => 'yellow');
    #$drop_site->configure(-bg => 'yellow');
    #$drop_site->configure(-bg => 'skyblue');
    #print "Debug:  Now do something with drop_obj $drop_obj " . $drop
+_obj->cget(-text) . "\n";
}

sub _dragOrSort {
    my ($w, $c) = @_;

    #my $w = $pane;

    #unless ($w->cget('-moveable')) {
    #if ($c->cget('-sortable')) {
    #    $w->sort (undef, $c);
    #}
    #return;
    #}

    my $h = shift;  # The heading button of the column.

    my $start_mouse_x = $h->pointerx;
    my $y_pos = $h->rooty;  # This is constant through the whole opera
+tion.
    my $width = $h->width;
    my $left_limit = $w->rootx - 1;

    # Find the rightmost, visible column
    my $right_end = 0;
    foreach (@{$w->{'_columns'}}) {
    if ($_->rootx + $_->width > $right_end) {
        $right_end = $_->rootx + $_->width;
    }
    }
    my $right_limit = $right_end + 1;

    # Create a "copy" of the heading button, put it in a toplevel that
+ matches
    # the size of the button, put the toplevel on top of the button.
    my $tl=$w->Toplevel;
    $tl->overrideredirect(1);
    $tl->geometry(sprintf("%dx%d+%d+%d",
              $h->width, $h->height, $h->rootx, $y_pos));

    my $b=$tl->Button
    (map{defined($_->[4]) ? ($_->[0]=>$_->[4]) : ()} $h->configure)
        ->pack(-expand=>1,-fill=>'both');

    # Move the toplevel with the mouse (as long as Button-1 is down).
    $h->bind("<Motion>", sub {
    my $new_x = $h->rootx - ($start_mouse_x - $h->pointerx);
    unless ($new_x + $width/2 < $left_limit ||
        $new_x + $width/2 > $right_limit)
    {
        $tl->geometry(sprintf("+%d+%d",$new_x,$y_pos));
    }
    });

    $h->bind("<ButtonRelease-1>", sub {
    my $rootx = $tl->rootx;
    my $x = $rootx + ($tl->width/2);
    $tl->destroy;    # Don't need this anymore...
    $h->bind("<Motion>",'');  # Cancel binding

    if ($h->rootx == $rootx) {
        # Button NOT moved, sort the column....
        if ($c->cget('-sortable')) {
        $w->sort(undef, $c);
        }
        return;
    }

    # Button moved.....
    # Decide where to put the column. If the center of the dragged
    # button is on the left half of another heading, insert it -before
    # the column, otherwise insert it -after the column.
    foreach (@{$w->{'_columns'}}) {
        if ($_->ismapped) {
        my $left = $_->rootx;
        my $right = $left + $_->width;
        if ($left <= $x && $x <= $right) {
            if ($x - $left < $right - $x) {
            $w->columnShow($c,-before=>$_);
            } else {
            $w->columnShow($c,'-after'=>$_);
            }
            $w->update;
            $w->Callback(-configurecommand => $w);
        }
        }
    }
    });
}

[download]
One problem with this I've noticed. If I resize the columns, the drag and drop it still thinks the columns are the size they were! If I drap-n-drop one time, and try again, it works. So, how to fix this?

Oh, and I dont really get why I cant send the reference to the label into "hover_over_drop" and "perform_drop". All I get is "XdndSelection". Whats up with that? _dragOrSort is taken from Tk::MlistBox. Not really used yet. Just there for reference if needed to be used later. Btw, love such "hacks" as the eyeball!

Replies are listed 'Best First'.
Re^3: Drag & Drop Problem
by liverpole (Monsignor) on May 22, 2006 at 18:44 UTC
    As far as resizing columns, the only thing I can suggest is maybe you need to call a subroutine in response to pane resize events, and in that subroutine reissue the call to DropSite.  As I said in my disclaimer, I'm not really familiar with DragDrop yet, and it doesn't look like it's especially well-commented.

    With respect to sending the reference to the label into "hover_over_drop" and "perform_drop", can you show the exact code you're using to try to do that?  It may just be (and this is an "off-the-wall" guess) that you have the wrong number of parameters to the subroutine where you're using the reference.

    The "eyeball" hack, I have to admit, was just supposed to be a "bullseye"-like icon, but when I ran the code, it looked more like an "eyeball" than anything else!

    s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
[reply]
      Haven't solved the resizeing problem yet, so if you feel up to it, you can check that out.

      With the reference I meant that I was expecting the reference to $label created in the addCol to be send... but seems to be the one hovering over instead...

      I changed to: 
          my $drop = $hlist->DropSite(
        -droptypes    => [qw(Local)],
        -dropcommand  => sub { perform_drop($label, @_) }, # New!
        -entercommand => sub { hover_over_drop($label, @_) }, # New!

      [download]
      Just so I could see what was going on, and not possible loose the things send by the callback. But with this it still seems to be the label I was hoovering over... I wanted the label I was draging! Ofcource, there are other ways. Saveing the one dragged into some global variable... (easier and looks better in the module), but shouldn't passing the scalar to the sub work aswell? I mean, the $label is created in the same sub as that ->DropSite is mentioned. But it's still not the same label everytime, as it should be?

      So, basicly, how can I pass the reference to the label I'm DRAGING? :)
      Try this: 
      sub hover_over_drop {
    my ($label_obj, $b_entry, $x_pos) = @_;
    $label_obj->configure(-bg => $b_entry == 1 ? 'gray' : 'lightgray')
+;

    #use Data::Dumper;
    #print Dumper(@_);

    if ($b_entry) {
         #print $label_obj . "\n";
        print $label_obj->cget(-text) . "\n";
    }
}

      [download]
      And you see that the text is changing...
      For instance, draging column #3 prints:
      Test3 
Test3 
Test2 
Test1 
Test2 
Test3

      [download]
      But, I was hoping for only "Test3".
[reply]
[d/l]
[select]
        So, basicly, how can I pass the reference to the label I'm DRAGING? :)

        I admit that this is confusing at first.  But when you think about it, it makes perfect sense.

        What's happening is that you have 3 separate callbacks to hover_over_drop, so when you leave pane 1 to enter pane 2, you're now executing the callback on behalf of the second invokation of DropSite.

        To get around this, you'll need to do 2 things.  First, create a global variable "$drag_obj" at the top of the program and assign it to zero. 

        my $drag_obj = 0;

        [download]
        Next, in the subroutine hover_over_drop(), the very first time that the subroutine is called, you assign $drag_obj to the label being dragged: 
        sub hover_over_drop {
    my ($label_obj, $b_entry, $x_pos) = @_;
                                                                      
+          
    $label_obj->configure(-bg => $b_entry == 1 ? 'gray' : 'lightgray')
+;
                                                                      
+          
    if ($b_entry) {
        if (!$drag_obj) {
            print "First time:  ";
            $drag_obj = $label_obj;
        } else {
            print " Next time:  ";
        }
        printf "Dragging(%s)  Callback for(%s)\n",
            $drag_obj->cget(-text),
            $label_obj->cget(-text);
    }
}

        [download]
        Finally, you have to release the global variable $drag_obj when it's actually dropped.  This you can do in perform_drop(): 
        sub perform_drop {
    my ($drop_site, $x_pos, $drop_obj) = @_;
                                                                      
+          
    $drag_obj or die "Whoops -- \$drag_obj undefined (shouldn't happen
+!)\n";
    printf "Drop label:  %s\n", $drag_obj->cget(-text);
    $drag_obj = 0;
}

        [download]

        I did a small amount of testing to verify that I couldn't drag the label from one column and have hover_over_drop() pick up the wrong label.  It seems to work reliably with my changes applied.

        As for the resize issue, see if you can make some progress on that yourself, and let me know if you need more help if you get stuck.  It's not obvious to me why the resize anomaly is even occurring in the first place, but it clearly is.

        One final suggestion -- when I "googled" for "perl/tk dropsite documentation", I found one link which said: 

        More information can be found in the DragDrop directory in the source 
+distribution of Perl/Tk. There are some sample scripts: local_test, m
+otion_test and site_test. And if there are still open questions: use 
+the force, read the source!

        [download]
        If you haven't already done so, see if those sample scripts are helpful.

        Good luck!

        s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
[reply]
[d/l]
[select]

In Section Seekers of Perl Wisdom