File Coverage

blib/lib/Gtk2/Ex/ListModelConcat.pm

Criterion	Covered	Total	%
statement	9	11	81.8
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	13	15	86.6

# Copyright 2008, 2009, 2010, 2015, 2016 Kevin Ryde

# This file is part of Gtk2-Ex-ListModelConcat.
#
# Gtk2-Ex-ListModelConcat is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# Gtk2-Ex-ListModelConcat is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Gtk2-Ex-ListModelConcat.  If not, see .


package Gtk2::Ex::ListModelConcat;
use 5.008;
use strict;
use warnings;
# 1.201 for drag_data_get() stack fix, and multi-column $model->get() fix
use Gtk2 1.201;
use Carp;
use List::Util qw(min max);
use Scalar::Util 1.18; # 1.18 for pure-perl refaddr() fix
use Gtk2::Ex::TreeModel::ImplBits;

# uncomment this to run the ### lines
#use Smart::Comments;

our $VERSION = 11;

use Glib::Object::Subclass
  'Glib::Object',
  interfaces => [ 'Gtk2::TreeModel',
                  'Gtk2::TreeDragSource',
                  'Gtk2::TreeDragDest',
                  # Gtk2::Buildable new in Gtk 2.12, omit if not available
                  Gtk2::Widget->isa('Gtk2::Buildable')
                  ? ('Gtk2::Buildable') : ()
                ],
  properties => [ Glib::ParamSpec->scalar
                  ('models',
                   'Models',
                   'Arrayref of list model objects to concatenate.',
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->object
                  ('append-model',
                   'Append model',
                   'Append a model to the concatenation.',
                   'Gtk2::TreeModel',
                   ['writable']),
                ];

sub INIT_INSTANCE {
  my ($self) = @_;
  ### ListModelConcat INIT_INSTANCE()
  Gtk2::Ex::TreeModel::ImplBits::random_stamp ($self);
  $self->{'models'} = [];
}

sub SET_PROPERTY {
  my ($self, $pspec, $newval) = @_;
  ### ListModelConcat SET_PROPERTY(): $pspec->get_name
  ### $newval
  my $pname = $pspec->get_name;

  if ($pname eq 'append_model') {
    $self->append_model ($newval);
    return;
  }
  if ($pname eq 'models') {
    foreach my $model (@$newval) {
      (Scalar::Util::blessed($model) && $model->isa('Gtk2::TreeModel'))
        or croak 'ListModelConcat: sub-model is not a Gtk2::TreeModel';
    }
    my $models = $self->{'models'};
    @$models = @$newval;  # copy input

    require Glib::Ex::SignalIds;
    my @signals;
    $self->{'signals'} = \@signals;
    my %done_reordered;

    foreach my $i (0 .. $#$models) {
      my $model = $models->[$i];
      my $userdata = [ $self, $i ];
      # weaken to avoid a circular reference which would prevent a Concat
      # containing models from being garbage collected
      Scalar::Util::weaken ($userdata->[0]);

      # the reordered signal is only connected once if the model appears
      # multiple times
      my @reordered;
      $done_reordered{Scalar::Util::refaddr($model)} ||= do {
        push @reordered, $model->signal_connect
          (rows_reordered => \&_do_rows_reordered, $userdata);
        1;
      };
      push @signals, Glib::Ex::SignalIds->new
        ($model,
         $model->signal_connect (row_changed => \&_do_row_changed, $userdata),
         $model->signal_connect (row_deleted => \&_do_row_deleted, $userdata),
         $model->signal_connect (row_inserted=> \&_do_row_inserted,$userdata),
         @reordered);
    }
    ### models now: $self->{'models'}

  } else {
    $self->{$pname} = $newval;  # per default GET_PROPERTY
  }
}

sub append_model {
  my $self = shift;
  ### ListModelConcat append_model(): @_
  $self->set_property (models => [ @{$self->{'models'}}, @_ ]);
}


#------------------------------------------------------------------------------
# TreeModel interface

# gtk_tree_model_get_flags
#
use constant GET_FLAGS => [ 'list-only' ];

# gtk_tree_model_get_n_columns
#
sub GET_N_COLUMNS {
  my ($self) = @_;
  ### ListModelConcat GET_N_COLUMNS()
  my $model = $self->{'models'}->[0]
    || return 0; # when no models
  return $model->get_n_columns;
}

# gtk_tree_model_get_column_type
#
sub GET_COLUMN_TYPE {
  my ($self, $col) = @_;
  #### ListModelConcat GET_COLUMN_TYPE()
  my $model = $self->{'models'}->[0] or _no_submodels('get_column_type');
  return $model->get_column_type ($col);
}

# gtk_tree_model_get_iter
#
sub GET_ITER {
  my ($self, $path) = @_;
  #### ListModelConcat GET_ITER(), path: $path->to_string
  if ($path->get_depth != 1) { return undef; }
  my ($index) = $path->get_indices;
  if ($index >= _total_length($self)) { return undef; }
  return _index_to_iter ($self, $index);
}

# gtk_tree_model_get_path
#
sub GET_PATH {
  my ($self, $iter) = @_;
  #### ListModelConcat get_path
  return Gtk2::TreePath->new_from_indices (_iter_to_index ($self, $iter));
}

# gtk_tree_model_get_value
#
sub GET_VALUE {
  my ($self, $iter, $col) = @_;
  #### ListModelConcat get_value iter: $iter->[0],$iter->[1]
  #### col: $col
  my $index = _iter_to_index ($self, $iter);
  my ($model, $subiter) = _index_to_subiter ($self, $index);
  return $model->get_value ($subiter, $col);
}

# gtk_tree_model_iter_next
#
sub ITER_NEXT {
  my ($self, $iter) = @_;
  #### ListModelConcat iter_next
  my $index = _iter_to_index ($self, $iter);
  $index++;
  if ($index < _total_length($self)) {
    return _index_to_iter ($self, $index);
  } else {
    return undef;
  }
}

# gtk_tree_model_iter_has_child
# my ($self, $iter) = @_;
# $iter never undef here, so always asking about an ordinary row, and
# there's nothing under the rows
#
use constant ITER_HAS_CHILD => 0;

# gtk_tree_model_iter_n_children
#
sub ITER_N_CHILDREN {
  my ($self, $iter) = @_;
  ### ListModelConcat iter_n_children
  if (defined $iter) {
    return 0;  # nothing under rows
  } else {
    return _total_length($self);
  }
}

# gtk_tree_model_iter_children
#
sub ITER_CHILDREN {
  # my ($self, $iter) = @_;
  ### ListModelConcat iter_children
  push @_, 0;
  goto &ITER_NTH_CHILD;
}

# gtk_tree_model_iter_nth_child
#
sub ITER_NTH_CHILD {
  my ($self, $iter, $n) = @_;
  ### ListModelConcat iter_nth_child: $n
  if (defined $iter) {
    return undef;
  }
  if ($n < _total_length($self)) {
    return _index_to_iter ($self, $n);
  } else {
    return undef;
  }
}

# gtk_tree_model_iter_parent
# my ($self, $iter) = @_;
# no parent rows in a list-only
#
use constant ITER_PARENT => undef;


#------------------------------------------------------------------------------
# iter conversions

# return ($model, $subiter, $mnum)
sub convert_iter_to_child_iter {
  my ($self, $iterobj) = @_;
  return _index_to_subiter ($self, _iterobj_to_index($self,$iterobj));
}

sub convert_child_iter_to_iter {
  my ($self, $model, $subiter) = @_;
  my $models = $self->{'models'};
  for (my $mnum = 0; $mnum < @$models; $mnum++) {
    if ($models->[$mnum] == $model) {
      return $self->convert_childnum_iter_to_iter ($mnum, $subiter);
    }
  }
  croak "ListModelConcat does not contain '$model'";
}
sub convert_childnum_iter_to_iter {
  my ($self, $mnum, $subiter) = @_;
  my $models = $self->{'models'};
  my $model = $models->[$mnum] || croak "No model number $mnum";
  my $subpath = $model->get_path ($subiter);
  my ($subindex) = $subpath->get_indices;
  my $positions = _model_positions($self);
  return _index_to_iterobj ($self, $positions->[$mnum] + $subindex);
}


#------------------------------------------------------------------------------
# our iters

sub _index_to_iter {
  my ($self, $index) = @_;
  return [ $self->{'stamp'}, $index, undef, undef ];
}
sub _iter_to_index {
  my ($self, $iter) = @_;
  if (! defined $iter) { return undef; }
  if ($iter->[0] != $self->{'stamp'}) {
    croak "iter is not for this ", ref($self),
      " (stamp ", $iter->[0], " want ", $self->{'stamp'}, ")";
  }
  return $iter->[1];
}

sub _iterobj_to_index {
  my ($self, $iterobj) = @_;
  if (! defined $iterobj) { croak 'ListModelConcat: iter cannot be undef'; }
  return _iter_to_index ($self, $iterobj->to_arrayref ($self->{'stamp'}));
}
sub _index_to_iterobj {
  my ($self, $index) = @_;
  return Gtk2::TreeIter->new_from_arrayref (_index_to_iter ($self, $index));
}


#------------------------------------------------------------------------------
# sub-model lookups

sub _model_positions {
  my ($self) = @_;
  return ($self->{'positions'} ||= do {
    my $models = $self->{'models'};
    my $pos = 0;
    return ($self->{'positions'}
            = [ 0, map { $pos += $_->iter_n_children(undef) } @$models ]);
  });
}
sub _model_offset {
  my ($self, $mnum) = @_;
  my $positions = _model_positions ($self);
  return $positions->[$mnum];
}
sub _total_length {
  my ($self) = @_;
  return _model_positions($self)->[-1];
}

# return ($model, $subiter, $mnum)
sub _index_to_subiter {
  my ($self, $index) = @_;
  my ($model, $subindex, $mnum) = _index_to_subindex ($self, $index);
  return ($model, $model->iter_nth_child(undef,$subindex), $mnum);
}

# return ($model, $subindex, $mnum)
sub _index_to_subindex {
  my ($self, $index) = @_;
  if ($index < 0) {
    croak 'ListModelConcat: invalid iter (negative index)';
  }
  my $models = $self->{'models'};
  my $positions = _model_positions ($self);
  if ($index >= $positions->[-1]) {
    croak 'ListModelConcat: invalid iter (index too big)';
  }
  for (my $i = $#$positions - 1; $i >= 0; $i--) {
    if ($positions->[$i] <= $index) {
      return ($models->[$i], $index - $positions->[$i], $i);
    }
  }
  croak 'ListModelConcat: invalid iter (no sub-models at all now)';
}

# sub _bsearch {
#   my ($aref, $target) = @_;
#   my $lo = 0;
#   my $hi = @$aref;
#   for (;;) {
#     my $mid = int (($lo + $hi) / 2);
#     if ($mid == $lo) { return $mid; }
#
#     my $elem = $aref->[$mid];
#     if ($elem > $target) {
#       $hi = $mid;
#     } elsif ($elem < $target) {
#       $lo = $mid+1;
#     } else {
#       return $mid;
#     }
#   }
# }

sub _no_submodels {
  my ($operation) = @_;
  croak "ListModelConcat: no sub-models to $operation";
}


#------------------------------------------------------------------------------
# sub-model signals

# 'row-changed' on the submodels
# called multiple times if a model is present multiple times
#
sub _do_row_changed {
  my ($model, $subpath, $subiter, $userdata) = @_;
  ### ListModelConcat row_changed handler
  my ($self, $mnum)= @$userdata;
  if (! $self) { return; }
  if ($self->{'suppress_signals'}) { return; }
  if ($subpath->get_depth != 1) { return; }  # ignore non-toplevel

  my ($subindex) = $subpath->get_indices;
  my $index = $subindex + _model_offset($self,$mnum);
  my $path = Gtk2::TreePath->new_from_indices ($index);
  my $iterobj = _index_to_iterobj ($self, $index);
  $self->row_changed ($path, $iterobj);
}

# 'row-inserted' on the submodels
# called multiple times if a model is present multiple times, going from
# first to last, which should present the positions correctly to the
# listeners, even if the data has all the inserts already done
#
sub _do_row_inserted {
  my ($model, $subpath, $subiter, $userdata) = @_;
  ### ListModelConcat row_inserted handler
  my ($self, $mnum) = @$userdata;
  if (! $self) { return; }
  if ($self->{'suppress_signals'}) { return; }
  if ($subpath->get_depth != 1) { return; }  # ignore non-toplevel

  if (my $positions = $self->{'positions'}) {
    foreach my $i ($mnum+1 .. $#$positions) {
      $positions->[$i] ++;
    }
  }

  my ($subindex) = $subpath->get_indices;
  my $index = $subindex + _model_offset($self,$mnum);
  my $path = Gtk2::TreePath->new_from_indices ($index);
  my $iterobj = _index_to_iterobj ($self, $index);
  $self->row_inserted ($path, $iterobj);
}

# 'row-deleted' on the submodels
# called multiple times if a model is present multiple times, going from
# first to last, which should present the positions correctly to the
# listeners, even if the data has all the inserts already done
#
sub _do_row_deleted {
  my ($model, $subpath, $userdata) = @_;
  my ($self, $mnum) = @$userdata;
  ### ListModelConcat row_deleted handler
  if (! $self) { return; }
  if ($self->{'suppress_signals'}) { return; }
  if ($subpath->get_depth != 1) { return; }  # ignore non-toplevel

  if (my $positions = $self->{'positions'}) {
    foreach my $i ($mnum+1 .. $#$positions) {
      $positions->[$i] --;
    }
  }

  my ($subindex) = $subpath->get_indices;
  my $index = $subindex + _model_offset($self,$mnum);
  my $path = Gtk2::TreePath->new_from_indices ($index);
  $self->row_deleted ($path);
}

# 'rows-reordered' on the submodels
# called just once if a model is present multiple times, and a single
# rows-reordered with all changes generated here for listeners
#
sub _do_rows_reordered {
  my ($model, $path, $iter, $subaref, $userdata) = @_;
  my ($self, $mnum) = @$userdata;
  if (! $self) { return; }
  ### ListModelConcat rows_reordered handler
  if ($self->{'suppress_signals'}) { return; }
  if ($path->get_depth != 0) { return; } # ignore non-toplevel

  # array[newpos] = oldpos, ie. the array elem says where the row used to be
  # before the reordering.  $subaref says that of its sub-model portion of
  # @array.
  #
  my @array = (0 .. _total_length($self) - 1);
  my $models = $self->{'models'};
  my $positions = _model_positions($self);
  foreach my $i (0 .. $#$models) {
    if ($models->[$i] == $model) {
      my $offset = $positions->[$i];
      foreach my $i (0 .. $#$subaref) {
        $array[$offset + $i] = $subaref->[$i] + $offset;
      }
    }
  }
  $self->rows_reordered ($path, undef, @array);
}


#------------------------------------------------------------------------------
# Gtk2::ListStore compatible methods


# gtk_list_store_append
# new row at end, return iter pointing to it
sub append {
  my ($self) = @_;
  my $model = $self->{'models'}->[-1] or _no_submodels('append');
  return $model->append
    && _index_to_iterobj ($self, _total_length($self) - 1);
}

# gtk_list_store_prepend
# new row at start, return iter pointing to it
sub prepend {
  my ($self) = @_;
  my $model = $self->{'models'}->[0] or _no_submodels('prepend');
  return $model->prepend
    && _index_to_iterobj ($self, 0);
}

# The sub-models should generate row-deleted signals like Gtk2::ListModel
# does.  Normally it's just repeated delete of item 0, though if a model
# appears more than once in the Concat the copies further on are reported
# too, which leads to a strange, though correct, sequence.
sub clear {
  my ($self) = @_;
  foreach my $model (@{$self->{'models'}}) {
    $model->clear;
  }
  # new stamp to invalidate all existing iters like GtkListStore does
  Gtk2::Ex::TreeModel::ImplBits::random_stamp ($self);
}

sub set_column_types {
  my ($self, @types) = @_;
  foreach my $model (@{$self->{'models'}}) {
    $model->set_column_types (@types);
  }
}

sub set {
  my $self = shift;
  my $iterobj = shift;
  my ($model, $subiter) = $self->convert_iter_to_child_iter ($iterobj);
  $model->set ($subiter, @_);
}
sub set_value {
  my $self = shift;
  my $iterobj = shift;
  my ($model, $subiter) = $self->convert_iter_to_child_iter ($iterobj);
  $model->set_value ($subiter, @_);
}


# insert before $index, or append if $index past last existing row
# insert_with_values the same, taking col=>value pairs
sub insert {
  unshift @_, 'insert';
  goto &_insert;
}
sub insert_with_values {
  unshift @_, 'insert_with_values';
  goto &_insert;
}
sub _insert {
  my ($method, $self, $index, @args) = @_;
  my ($model, $subindex, $mnum);
  my $total_length = _total_length ($self);
  if ($index >= $total_length) {
    $index = $total_length; # in case wildly past end
    my $models = $self->{'models'};
    $model = $self->{'models'}->[-1]
      or _no_submodels($method);
    $mnum = $#$models;
    $subindex = $index; # past end
  } else {
    ($model, $subindex, $mnum) = _index_to_subindex ($self, $index);
  }
  my $subiter = $model->$method ($subindex, @args);
  return _subiter_to_iterobj ($self, $model, $subiter, $mnum);
}

# insert after $iterobj, or at beginning if $iterobj undef (yes, the beginning)
sub insert_after {
  unshift @_, 'insert_after', 0;
  goto &_insert_beforeafter;
}
sub insert_before {
  unshift @_, 'insert_before', -1;
  goto &_insert_beforeafter;
}
sub _insert_beforeafter {
  my ($method, $mnum, $self, $iterobj) = @_;
  my ($model, $subiter);
  if ($iterobj) {
    ($model, $subiter, $mnum) = $self->convert_iter_to_child_iter ($iterobj);
  } else {
    my $models = $self->{'models'};
    $model = $models->[$mnum] or _no_submodels($method);
    if ($mnum) { $mnum = $#$models; }
    $subiter = undef;
  }
  $subiter = $model->$method ($subiter);
  return _subiter_to_iterobj ($self, $model, $subiter, $mnum);
}

sub _subiter_to_iterobj {
  my ($self, $model, $subiter, $mnum) = @_;
  my $positions = _model_positions ($self);
  my ($subindex) = $model->get_path($subiter)->get_indices;
  my $index = $positions->[$mnum] + $subindex;
  return _index_to_iterobj ($self, $index);
}

sub iter_is_valid {
  my ($self, $iter) = @_;
  my $a = eval { $iter->to_arrayref($self->{'stamp'}) };
  return ($a && $a->[1] < _total_length($self));
}

# gtk_list_store_move_after
# $dst_iterobj undef means the start (yes, the start) of the list
sub move_after {
  my ($self, $src_iterobj, $dst_iterobj) = @_;
  my $src_index = _iterobj_to_index ($self, $src_iterobj);
  my ($src_model, $src_subiter) = _index_to_subiter ($self, $src_index);

  my ($dst_index, $dst_model, $dst_subindex);
  if (defined $dst_iterobj) {
    $dst_index = _iterobj_to_index ($self, $dst_iterobj);
    ($dst_model, $dst_subindex) = _index_to_subindex ($self, $dst_index);
  } else {
    $dst_index = -1;
    $dst_model = $self->{'models'}->[0] or _no_submodels('insert_after');
    $dst_subindex = 0;
  }

  if ($src_model == $dst_model) {
    my $dst_subiter
      = $dst_iterobj && $dst_model->iter_nth_child (undef, $dst_subindex);
    $src_model->move_after ($src_subiter, $dst_subiter);

  } else {
    my $rem = _need_method ($src_model, 'remove');
    my $ins = _need_method ($dst_model, 'insert_with_values');
    my @row = _treemodel_extract_row ($src_model, $src_subiter);
    my $dst_ins_subindex = ($dst_iterobj ? $dst_subindex + 1 : 0);

    { local $self->{'suppress_signals'} = 1;
      $ins->($dst_model, $dst_ins_subindex, @row);
      $rem->($src_model, $src_subiter);
    }
    delete $self->{'positions'};  # recalculate

    _move_after_reorder ($self, $src_index, $dst_index);
  }
}

# Emit a 'rows-reordered' signal for a move of row $src_index to after
# $dst_index.  $dst_index can be -1 for the very start.
sub _move_after_reorder {
  my ($self, $src_index, $dst_index) = @_;
  my $path = Gtk2::TreePath->new;
  my $last_index = _total_length($self) - 1;

  if ($dst_index >= $src_index) {
    # upwards move eg. 0 to after 4 becomes 1,2,3,4,0
    $self->rows_reordered
      ($path, undef,
       0 .. $src_index-1,            # before, unchanged
       $src_index+1 .. $dst_index,   # shifted
       $src_index,                   # moved row
       $dst_index+1 .. $last_index); # after, unchanged

  } else {
    # downwards move eg. 4 to after 0 becomes 0,4,1,2,3
    $self->rows_reordered
      ($path, undef,
       0 .. $dst_index,              # before, unchanged
       $src_index,                   # moved row
       $dst_index+1 .. $src_index-1, # shifted
       $src_index+1 .. $last_index); # after, unchanged
  }
}

# gtk_list_store_move_before
# $dst_iterobj undef means the end (yes, the end) of the list
sub move_before {
  my ($self, $src_iterobj, $dst_iterobj) = @_;
  my $src_index = _iterobj_to_index ($self, $src_iterobj);
  my ($src_model, $src_subiter) = _index_to_subiter ($self, $src_index);

  my ($dst_index, $dst_model, $dst_subindex);
  if ($dst_iterobj) {
    $dst_index = _iterobj_to_index ($self, $dst_iterobj);
    ($dst_model, $dst_subindex) = _index_to_subindex ($self, $dst_index);
  } else {
    $dst_index = _total_length($self);
    $dst_model = $self->{'models'}->[-1] or _no_submodels('insert_after');
    $dst_subindex = $dst_index;
  }

  if ($src_model == $dst_model) {
    my $dst_subiter
      = $dst_iterobj && $dst_model->iter_nth_child (undef, $dst_subindex);
    $src_model->move_before ($src_subiter, $dst_subiter);

  } else {
    my $rem = _need_method ($src_model, 'remove');
    my $ins = _need_method ($dst_model, 'insert_with_values');
    my @row = _treemodel_extract_row ($src_model, $src_subiter);

    { local $self->{'suppress_signals'} = 1;
      $ins->($dst_model, $dst_subindex, @row);
      $rem->($src_model, $src_subiter);
    }
    delete $self->{'positions'};  # recalculate

    _move_after_reorder ($self, $src_index, $dst_index-1);
  }
}

sub _need_method {
  my ($model, $name) = @_;
  return ($model->can($name)
          || croak "ListModelConcat: submodel doesn't support '$name'");
}

# gtk_list_store_remove
#
# Usually deleting a row just means our $index in $iterobj should stay the
# same, only with a check it wasn't the very last row deleted.  But if the
# target $model appears more than once then deleting in its second or
# subsequent appearance will delete a row before and $index in $iterobj must
# be moved down.  For that reason get a fresh @$positions after
# $model->remove.
#
sub remove {
  my ($self, $iterobj) = @_;
  if (! defined $iterobj) { croak 'Cannot remove iter "undef"'; }
  my $index = _iterobj_to_index ($self, $iterobj);
  my ($model, $subiter, $mnum) = _index_to_subiter ($self, $index);

  my $submore = $model->remove ($subiter);
  my $positions = _model_positions($self);

  if ($submore) {
    # $subiter has been updated to the next row, make an iter from it
    my $subpath = $model->get_path ($subiter);
    my ($subindex) = $subpath->get_indices;
    $index = $positions->[$mnum] + $subindex;

  } else {
    # nothing more in this $model, so we're at the start of the following
    # model, unless it and all following are empty
    if (defined ($index = $positions->[$mnum+1])) {
      if ($index >= _total_length($self)) {
        $index = undef;
      }
    }
  }

  if (defined $index) {
    $iterobj->set ([ $self->{'stamp'}, $index, undef, undef ]);
    return 1; # more rows
  } else {
    # zap iter so it's not accidentally re-used (same as GtkListStore does)
    $iterobj->set ([ 0, 0, undef, undef ]);
    return 0; # no more rows
  }
}

# gtk_list_store_reorder
#
sub reorder {
  my ($self, @neworder) = @_;

  my $len = _total_length($self);
  if (@neworder != $len) {
    croak 'ListModelConcat: new order array wrong length';
  }

  my @row;
  foreach my $newpos (0 .. $#neworder) {
    my $oldpos = $neworder[$newpos];
    if ($oldpos < 0 || $oldpos >= $len) {
      croak "ListModelConcat: invalid old position in order array: $oldpos";
    }
    if ($oldpos != $newpos) {
      my ($model, $subiter) = _index_to_subiter ($self, $oldpos);
      $row[$oldpos] = [ _treemodel_extract_row ($model, $subiter) ];
    }
  }
  { local $self->{'suppress_signals'} = 1;
    foreach my $newpos (0 .. $#neworder) {
      my $oldpos = $neworder[$newpos];
      if ($oldpos != $newpos) {
        my ($model, $subiter) = _index_to_subiter ($self, $newpos);
        $model->set ($subiter, @{$row[$oldpos]});
      }
    }
  }
  $self->rows_reordered (Gtk2::TreePath->new, undef, @neworder);
}

sub swap {
  my ($self, $iterobj_a, $iterobj_b) = @_;
  my $index_a = _iterobj_to_index ($self, $iterobj_a);
  my $index_b = _iterobj_to_index ($self, $iterobj_b);

  my ($model_a, $subiter_a) = _index_to_subiter ($self, $index_a);
  my ($model_b, $subiter_b) = _index_to_subiter ($self, $index_b);
  if ($model_a == $model_b) {
    $model_a->swap ($subiter_a, $subiter_b);

  } else {
    my @row_a = _treemodel_extract_row ($model_a, $subiter_a);
    my @row_b = _treemodel_extract_row ($model_b, $subiter_b);
    { local $self->{'suppress_signals'} = 1;
      $model_a->set ($subiter_a, @row_b);
      $model_b->set ($subiter_b, @row_a); }

    my @array = (0 .. _total_length($self) - 1);
    $array[$index_a] = $index_b;   # $array[newpos] == oldpos
    $array[$index_b] = $index_a;
    $self->rows_reordered (Gtk2::TreePath->new, undef, @array);
  }
}

# return a list of values (0, 'col0', 1, 'col1', ...) which is the column
# number and its contents
sub _treemodel_extract_row {
  my ($model, $iter) = @_;
  my @row = $model->get($iter);
  return map {; ($_,$row[$_]) } 0 .. $#row;
}

#------------------------------------------------------------------------------
# Gtk2::TreeDragSource interface, drag source

# gtk_tree_drag_source_row_draggable ($self, $path)
#
sub ROW_DRAGGABLE {
  # my ($self, $path) = @_;
  unshift @_, 'row_draggable';
  goto &_drag_source;
}

# gtk_tree_drag_source_drag_data_delete ($self, $path)
#
sub DRAG_DATA_DELETE {
  # my ($self, $path) = @_;
  unshift @_, 'drag_data_delete';
  goto &_drag_source;
}

# gtk_tree_drag_source_drag_data_get ($self, $path, $sel)
#
sub DRAG_DATA_GET {
  # my ($self, $path, $sel) = @_;
  unshift @_, 'drag_data_get';
  goto &_drag_source;
}

sub _drag_source {
  my ($method, $self, $path, @sel_arg) = @_;
  ### ListModelConcat: "\U$method\E path=".$path->to_string

  if ($path->get_depth != 1) {
    ### no, not a toplevel row
    return 0;
  }
  my ($index) = $path->get_indices;
  my ($model, $subindex) = _index_to_subindex ($self, $index);

  if (! $model->isa('Gtk2::TreeDragSource')) {
    ### no, submodel not a TreeDragSource
    return 0;
  }
  my $subpath = Gtk2::TreePath->new_from_indices ($subindex);
  ### submodel row_draggable subpath: $subpath->to_string
  my $ret = $model->$method ($subpath, @sel_arg);
  ### submodel result: $ret
  return $ret;
}

#------------------------------------------------------------------------------
# Gtk2::TreeDragDest interface, drag destination

# gtk_tree_drag_dest_row_drop_possible
# gtk_tree_drag_dest_drag_data_received
#
sub ROW_DROP_POSSIBLE {
  push @_, 'row_drop_possible';
  goto &_drag_dest;
}
sub DRAG_DATA_RECEIVED {
  push @_, 'drag_data_received';
  goto &_drag_dest;
}
sub _drag_dest {
  my ($self, $dst_path, $sel, $method) = @_;
  ### ListModelConcat: "\U$method\E, to path=".$dst_path->to_string
  ### type: $sel->type->name
  ### sel row: $sel->type->name eq 'GTK_TREE_MODEL_ROW' && do { my ($src_model, $src_path) = $sel->get_row_drag_data; "  src_model=$src_model src_path=".$src_path->to_string }

  if ($dst_path->get_depth != 1) {
    ### no, not a toplevel row
    return 0;
  }
  my ($dst_index) = $dst_path->get_indices;
  my ($dst_submodel, $dst_subindex)
    = _index_to_subindex_post ($self, $dst_index);

  if (! $dst_submodel->isa('Gtk2::TreeDragDest')) {
    ### no, submodel not a TreeDragDest
    return 0;
  }
  my $dst_subpath = Gtk2::TreePath->new_from_indices ($dst_subindex);
  if (! $dst_submodel->$method ($dst_subpath, $sel)) {
    ### no, submodel $method() false
    return 0;
  }
  ### yes from submodel
  return 1;
}

# return ($model, $subindex), and allowing a $index which is past the end of
# $self to likewise give a subindex beyond the end of the last submodel
#
sub _index_to_subindex_post {
  my ($self, $index) = @_;
  my $positions = _model_positions ($self);
  if ($index < $positions->[-1]) {
    return _index_to_subindex ($self, $index);
  }
  my $model = $self->{'models'}->[-1]
    or return (undef, undef);  # no models at all
  return ($model, $index - $positions->[-2]);
}

#------------------------------------------------------------------------------
# Gtk2::Buildable interface

sub ADD_CHILD {
  my ($self, $builder, $child, $type) = @_;
  ### ListModelConcat ADD_CHILD(): @_
  $self->append_model ($child);
}

1;
__END__