multiple-item drag-and-drop (implementation)

[Jeff 'japhy' Pinyan <japhy perlmonk org>]

Below is code I've come up with to allow the movement of multiple items 
from one TreeView to another.  It should be self-explanatory.  It uses the 
Storable module for freeze() and thaw() for storing a reference.  I 
haven't yet implemented a custom d-n-d icon, but expect to soon.  Once 
I've got that, it will be pretty much identical to the "standard" TreeView 
drag-and-drop model -- it even does scrolling.

$self here is my ListSwap object.  get_drag_action() is a method returning 
a value which determines whether the source and destination are doing 
move, copy, or both.  get_can_move() returns a function that returns true 
if the datum is ok to move or copy.

I'd like to thank muppet for his help, and for directing to me to a killer 
tutorial that got me 80% of the way here.  That URL is

  http://live.gnome.org/GnomeLove/DragNDropTutorial

Here's my code:

    my $entry = ['Glib::Scalar', 'same-app', 1];
    my $drag_action = $self->get_drag_action;
    my $func = $self->get_can_move;
    my @drag;
    push @drag, 'move' if $drag_action & GTK_LS_DND_MOVE;
    push @drag, 'copy' if $drag_action & GTK_LS_DND_COPY;

    for (@trees) {
      $_->drag_source_set('GDK_BUTTON1_MASK', \ drag, $entry);

      $_->signal_connect('drag-data-get' => sub {
        my ($tree, $dnd, $sel) = @_;
        my $model = $tree->get_model;
        my @data = $tree->get_selection->get_selected_rows or return;
        my @valid;

        for (@data) {
          my $iter = $model->get_iter($_);
          my $info = $model->get($iter, 0);
          push @valid, $info if !$func or $self->$func($info);
        }

        return unless @valid;

        $sel->set($sel->target, 8, freeze(\ valid));
      });

      $_->signal_connect('drag-data-delete' => sub {
        my ($tree, $dnd) = @_;
        my $model = $tree->get_model;
        my @data = $tree->get_selection->get_selected_rows;

        for (reverse @data) {
          my $iter = $model->get_iter($_);
          my $info = $model->get($iter, 0);
          $model->remove($iter) if !$func or $self->$func($info);
        }

        $tree->get_selection->unselect_all;
      });

      $_->drag_dest_set(['motion', 'highlight'], \ drag, $entry);

      $_->signal_connect('drag-data-received' => sub {
        my ($tree, $dnd, $x, $y, $sel) = @_;
        my ($path, $how) = $tree->get_dest_row_at_pos($x, $y);
        my $model = $tree->get_model;
        my $data = $sel->data or return;
        my $delete = $dnd->action() eq 'move';
        my $iter;

        $data = thaw($data);

        if ($path) {
          $iter = $model->get_iter($path);
          if ($how eq 'after' or $how eq 'into-or-after') {
            $iter = $model->insert_after($iter);
          }
          else { $iter = $model->insert_before($iter) }
        }
        else { $iter = $model->append }

        $model->set($iter, 0, shift @$data);
        $model->set($iter = $model->insert_after($iter), 0, $_) for @$data;
        $dnd->finish(1, $delete, time);
      });

      $_->signal_connect('drag-drop' => sub {
        my ($tree, $dnd, $x, $y, $when) = @_;
        if (my $targ = $dnd->targets) {
          $tree->drag_get_data($dnd, $targ, $when);
          return 1;
        }
        return;
      });

      $_->signal_connect('drag-motion' => sub {
        my ($tree, $dnd, $x, $y, $t) = @_;
        my ($path, $how) = $tree->get_dest_row_at_pos($x, $y) or return;
        my $scroll = $tree->parent;
        my ($w, $h) = @$scroll{'w','h'};
        $tree->set_drag_dest_row($path, $how);

        my $adj = $scroll->get_vadjustment;
        my $step = $adj->step_increment;

        if ($y > $h - $step/2) {
          my $v = $adj->value + $step;
          my $m = $adj->upper - $adj->page_size;
          $adj->set_value($v > $m ? $m : $v);
        }
        elsif ($y < ($tree->get_headers_visible ? $step : $step/2)) {
          my $v = $adj->value - $step;
          my $m = $adj->lower;
          $adj->set_value($v < $m ? $m : $v);
        }

        return 1;
      });

--
Jeff "japhy" Pinyan         %  How can we ever be the sold short or
RPI Acacia Brother #734     %  the cheated, we who for every service
http://japhy.perlmonk.org/  %  have long ago been overpaid?
http://www.perlmonks.org/   %    -- Meister Eckhart