File Coverage

blib/lib/Gtk2/Ex/ListModelConcat.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             # Copyright 2008, 2009, 2010 Kevin Ryde
2              
3             # This file is part of Gtk2-Ex-ListModelConcat.
4             #
5             # Gtk2-Ex-ListModelConcat is free software; you can redistribute it and/or
6             # modify it under the terms of the GNU General Public License as published
7             # by the Free Software Foundation; either version 3, or (at your option) any
8             # later version.
9             #
10             # Gtk2-Ex-ListModelConcat is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
13             # Public License for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Gtk2-Ex-ListModelConcat. If not, see .
17              
18              
19             package Gtk2::Ex::ListModelConcat;
20 2     2   1545 use 5.008;
  2         6  
  2         69  
21 2     2   9 use strict;
  2         2  
  2         48  
22 2     2   9 use warnings;
  2         5  
  2         49  
23             # 1.201 for drag_data_get() stack fix, and multi-column $model->get() fix
24 2     2   2776 use Gtk2 1.201;
  0            
  0            
25             use Carp;
26             use List::Util qw(min max);
27             use Scalar::Util 1.18; # 1.18 for pure-perl refaddr() fix
28             use Gtk2::Ex::TreeModel::ImplBits;
29              
30             # uncomment this to run the ### lines
31             #use Smart::Comments;
32              
33             our $VERSION = 10;
34              
35             use Glib::Object::Subclass
36             'Glib::Object',
37             interfaces => [ 'Gtk2::TreeModel',
38             'Gtk2::TreeDragSource',
39             'Gtk2::TreeDragDest',
40             # Gtk2::Buildable new in Gtk 2.12, omit if not available
41             Gtk2::Widget->isa('Gtk2::Buildable')
42             ? ('Gtk2::Buildable') : ()
43             ],
44             properties => [ Glib::ParamSpec->scalar
45             ('models',
46             'models',
47             'Arrayref of list model objects to concatenate.',
48             Glib::G_PARAM_READWRITE),
49              
50             Glib::ParamSpec->object
51             ('append-model',
52             'append-model',
53             'Append a model to the concatenation.',
54             'Gtk2::TreeModel',
55             ['writable']),
56             ];
57              
58             sub INIT_INSTANCE {
59             my ($self) = @_;
60             ### ListModelConcat INIT_INSTANCE()
61             Gtk2::Ex::TreeModel::ImplBits::random_stamp ($self);
62             $self->{'models'} = [];
63             }
64              
65             sub SET_PROPERTY {
66             my ($self, $pspec, $newval) = @_;
67             ### ListModelConcat SET_PROPERTY(): $pspec->get_name
68             ### $newval
69             my $pname = $pspec->get_name;
70              
71             if ($pname eq 'append_model') {
72             $self->append_model ($newval);
73             return;
74             }
75             if ($pname eq 'models') {
76             foreach my $model (@$newval) {
77             (Scalar::Util::blessed($model) && $model->isa('Gtk2::TreeModel'))
78             or croak 'ListModelConcat: sub-model is not a Gtk2::TreeModel';
79             }
80             my $models = $self->{'models'};
81             @$models = @$newval; # copy input
82              
83             require Glib::Ex::SignalIds;
84             my @signals;
85             $self->{'signals'} = \@signals;
86             my %done_reordered;
87              
88             foreach my $i (0 .. $#$models) {
89             my $model = $models->[$i];
90             my $userdata = [ $self, $i ];
91             # weaken to avoid a circular reference which would prevent a Concat
92             # containing models from being garbage collected
93             Scalar::Util::weaken ($userdata->[0]);
94              
95             # the reordered signal is only connected once if the model appears
96             # multiple times
97             my @reordered;
98             $done_reordered{Scalar::Util::refaddr($model)} ||= do {
99             push @reordered, $model->signal_connect
100             (rows_reordered => \&_do_rows_reordered, $userdata);
101             1;
102             };
103             push @signals, Glib::Ex::SignalIds->new
104             ($model,
105             $model->signal_connect (row_changed => \&_do_row_changed, $userdata),
106             $model->signal_connect (row_deleted => \&_do_row_deleted, $userdata),
107             $model->signal_connect (row_inserted=> \&_do_row_inserted,$userdata),
108             @reordered);
109             }
110             ### models now: $self->{'models'}
111              
112             } else {
113             $self->{$pname} = $newval; # per default GET_PROPERTY
114             }
115             }
116              
117             sub append_model {
118             my $self = shift;
119             ### ListModelConcat append_model(): @_
120             $self->set_property (models => [ @{$self->{'models'}}, @_ ]);
121             }
122              
123              
124             #------------------------------------------------------------------------------
125             # TreeModel interface
126              
127             # gtk_tree_model_get_flags
128             #
129             use constant GET_FLAGS => [ 'list-only' ];
130              
131             # gtk_tree_model_get_n_columns
132             #
133             sub GET_N_COLUMNS {
134             my ($self) = @_;
135             ### ListModelConcat GET_N_COLUMNS()
136             my $model = $self->{'models'}->[0]
137             || return 0; # when no models
138             return $model->get_n_columns;
139             }
140              
141             # gtk_tree_model_get_column_type
142             #
143             sub GET_COLUMN_TYPE {
144             my ($self, $col) = @_;
145             #### ListModelConcat GET_COLUMN_TYPE()
146             my $model = $self->{'models'}->[0] or _no_submodels('get_column_type');
147             return $model->get_column_type ($col);
148             }
149              
150             # gtk_tree_model_get_iter
151             #
152             sub GET_ITER {
153             my ($self, $path) = @_;
154             #### ListModelConcat GET_ITER(), path: $path->to_string
155             if ($path->get_depth != 1) { return undef; }
156             my ($index) = $path->get_indices;
157             if ($index >= _total_length($self)) { return undef; }
158             return _index_to_iter ($self, $index);
159             }
160              
161             # gtk_tree_model_get_path
162             #
163             sub GET_PATH {
164             my ($self, $iter) = @_;
165             #### ListModelConcat get_path
166             return Gtk2::TreePath->new_from_indices (_iter_to_index ($self, $iter));
167             }
168              
169             # gtk_tree_model_get_value
170             #
171             sub GET_VALUE {
172             my ($self, $iter, $col) = @_;
173             #### ListModelConcat get_value iter: $iter->[0],$iter->[1]
174             #### col: $col
175             my $index = _iter_to_index ($self, $iter);
176             my ($model, $subiter) = _index_to_subiter ($self, $index);
177             return $model->get_value ($subiter, $col);
178             }
179              
180             # gtk_tree_model_iter_next
181             #
182             sub ITER_NEXT {
183             my ($self, $iter) = @_;
184             #### ListModelConcat iter_next
185             my $index = _iter_to_index ($self, $iter);
186             $index++;
187             if ($index < _total_length($self)) {
188             return _index_to_iter ($self, $index);
189             } else {
190             return undef;
191             }
192             }
193              
194             # gtk_tree_model_iter_has_child
195             # my ($self, $iter) = @_;
196             # $iter never undef here, so always asking about an ordinary row, and
197             # there's nothing under the rows
198             #
199             use constant ITER_HAS_CHILD => 0;
200              
201             # gtk_tree_model_iter_n_children
202             #
203             sub ITER_N_CHILDREN {
204             my ($self, $iter) = @_;
205             ### ListModelConcat iter_n_children
206             if (defined $iter) {
207             return 0; # nothing under rows
208             } else {
209             return _total_length($self);
210             }
211             }
212              
213             # gtk_tree_model_iter_children
214             #
215             sub ITER_CHILDREN {
216             # my ($self, $iter) = @_;
217             ### ListModelConcat iter_children
218             push @_, 0;
219             goto &ITER_NTH_CHILD;
220             }
221              
222             # gtk_tree_model_iter_nth_child
223             #
224             sub ITER_NTH_CHILD {
225             my ($self, $iter, $n) = @_;
226             ### ListModelConcat iter_nth_child: $n
227             if (defined $iter) {
228             return undef;
229             }
230             if ($n < _total_length($self)) {
231             return _index_to_iter ($self, $n);
232             } else {
233             return undef;
234             }
235             }
236              
237             # gtk_tree_model_iter_parent
238             # my ($self, $iter) = @_;
239             # no parent rows in a list-only
240             #
241             use constant ITER_PARENT => undef;
242              
243              
244             #------------------------------------------------------------------------------
245             # iter conversions
246              
247             # return ($model, $subiter, $mnum)
248             sub convert_iter_to_child_iter {
249             my ($self, $iterobj) = @_;
250             return _index_to_subiter ($self, _iterobj_to_index($self,$iterobj));
251             }
252              
253             sub convert_child_iter_to_iter {
254             my ($self, $model, $subiter) = @_;
255             my $models = $self->{'models'};
256             for (my $mnum = 0; $mnum < @$models; $mnum++) {
257             if ($models->[$mnum] == $model) {
258             return $self->convert_childnum_iter_to_iter ($mnum, $subiter);
259             }
260             }
261             croak "ListModelConcat does not contain '$model'";
262             }
263             sub convert_childnum_iter_to_iter {
264             my ($self, $mnum, $subiter) = @_;
265             my $models = $self->{'models'};
266             my $model = $models->[$mnum] || croak "No model number $mnum";
267             my $subpath = $model->get_path ($subiter);
268             my ($subindex) = $subpath->get_indices;
269             my $positions = _model_positions($self);
270             return _index_to_iterobj ($self, $positions->[$mnum] + $subindex);
271             }
272              
273              
274             #------------------------------------------------------------------------------
275             # our iters
276              
277             sub _index_to_iter {
278             my ($self, $index) = @_;
279             return [ $self->{'stamp'}, $index, undef, undef ];
280             }
281             sub _iter_to_index {
282             my ($self, $iter) = @_;
283             if (! defined $iter) { return undef; }
284             if ($iter->[0] != $self->{'stamp'}) {
285             croak "iter is not for this ", ref($self),
286             " (stamp ", $iter->[0], " want ", $self->{'stamp'}, ")";
287             }
288             return $iter->[1];
289             }
290              
291             sub _iterobj_to_index {
292             my ($self, $iterobj) = @_;
293             if (! defined $iterobj) { croak 'ListModelConcat: iter cannot be undef'; }
294             return _iter_to_index ($self, $iterobj->to_arrayref ($self->{'stamp'}));
295             }
296             sub _index_to_iterobj {
297             my ($self, $index) = @_;
298             return Gtk2::TreeIter->new_from_arrayref (_index_to_iter ($self, $index));
299             }
300              
301              
302             #------------------------------------------------------------------------------
303             # sub-model lookups
304              
305             sub _model_positions {
306             my ($self) = @_;
307             return ($self->{'positions'} ||= do {
308             my $models = $self->{'models'};
309             my $pos = 0;
310             return ($self->{'positions'}
311             = [ 0, map { $pos += $_->iter_n_children(undef) } @$models ]);
312             });
313             }
314             sub _model_offset {
315             my ($self, $mnum) = @_;
316             my $positions = _model_positions ($self);
317             return $positions->[$mnum];
318             }
319             sub _total_length {
320             my ($self) = @_;
321             return _model_positions($self)->[-1];
322             }
323              
324             # return ($model, $subiter, $mnum)
325             sub _index_to_subiter {
326             my ($self, $index) = @_;
327             my ($model, $subindex, $mnum) = _index_to_subindex ($self, $index);
328             return ($model, $model->iter_nth_child(undef,$subindex), $mnum);
329             }
330              
331             # return ($model, $subindex, $mnum)
332             sub _index_to_subindex {
333             my ($self, $index) = @_;
334             if ($index < 0) {
335             croak 'ListModelConcat: invalid iter (negative index)';
336             }
337             my $models = $self->{'models'};
338             my $positions = _model_positions ($self);
339             if ($index >= $positions->[-1]) {
340             croak 'ListModelConcat: invalid iter (index too big)';
341             }
342             for (my $i = $#$positions - 1; $i >= 0; $i--) {
343             if ($positions->[$i] <= $index) {
344             return ($models->[$i], $index - $positions->[$i], $i);
345             }
346             }
347             croak 'ListModelConcat: invalid iter (no sub-models at all now)';
348             }
349              
350             # sub _bsearch {
351             # my ($aref, $target) = @_;
352             # my $lo = 0;
353             # my $hi = @$aref;
354             # for (;;) {
355             # my $mid = int (($lo + $hi) / 2);
356             # if ($mid == $lo) { return $mid; }
357             #
358             # my $elem = $aref->[$mid];
359             # if ($elem > $target) {
360             # $hi = $mid;
361             # } elsif ($elem < $target) {
362             # $lo = $mid+1;
363             # } else {
364             # return $mid;
365             # }
366             # }
367             # }
368              
369             sub _no_submodels {
370             my ($operation) = @_;
371             croak "ListModelConcat: no sub-models to $operation";
372             }
373              
374              
375             #------------------------------------------------------------------------------
376             # sub-model signals
377              
378             # 'row-changed' on the submodels
379             # called multiple times if a model is present multiple times
380             #
381             sub _do_row_changed {
382             my ($model, $subpath, $subiter, $userdata) = @_;
383             ### ListModelConcat row_changed handler
384             my ($self, $mnum)= @$userdata;
385             if (! $self) { return; }
386             if ($self->{'suppress_signals'}) { return; }
387             if ($subpath->get_depth != 1) { return; } # ignore non-toplevel
388              
389             my ($subindex) = $subpath->get_indices;
390             my $index = $subindex + _model_offset($self,$mnum);
391             my $path = Gtk2::TreePath->new_from_indices ($index);
392             my $iterobj = _index_to_iterobj ($self, $index);
393             $self->row_changed ($path, $iterobj);
394             }
395              
396             # 'row-inserted' on the submodels
397             # called multiple times if a model is present multiple times, going from
398             # first to last, which should present the positions correctly to the
399             # listeners, even if the data has all the inserts already done
400             #
401             sub _do_row_inserted {
402             my ($model, $subpath, $subiter, $userdata) = @_;
403             ### ListModelConcat row_inserted handler
404             my ($self, $mnum) = @$userdata;
405             if (! $self) { return; }
406             if ($self->{'suppress_signals'}) { return; }
407             if ($subpath->get_depth != 1) { return; } # ignore non-toplevel
408              
409             if (my $positions = $self->{'positions'}) {
410             foreach my $i ($mnum+1 .. $#$positions) {
411             $positions->[$i] ++;
412             }
413             }
414              
415             my ($subindex) = $subpath->get_indices;
416             my $index = $subindex + _model_offset($self,$mnum);
417             my $path = Gtk2::TreePath->new_from_indices ($index);
418             my $iterobj = _index_to_iterobj ($self, $index);
419             $self->row_inserted ($path, $iterobj);
420             }
421              
422             # 'row-deleted' on the submodels
423             # called multiple times if a model is present multiple times, going from
424             # first to last, which should present the positions correctly to the
425             # listeners, even if the data has all the inserts already done
426             #
427             sub _do_row_deleted {
428             my ($model, $subpath, $userdata) = @_;
429             my ($self, $mnum) = @$userdata;
430             ### ListModelConcat row_deleted handler
431             if (! $self) { return; }
432             if ($self->{'suppress_signals'}) { return; }
433             if ($subpath->get_depth != 1) { return; } # ignore non-toplevel
434              
435             if (my $positions = $self->{'positions'}) {
436             foreach my $i ($mnum+1 .. $#$positions) {
437             $positions->[$i] --;
438             }
439             }
440              
441             my ($subindex) = $subpath->get_indices;
442             my $index = $subindex + _model_offset($self,$mnum);
443             my $path = Gtk2::TreePath->new_from_indices ($index);
444             $self->row_deleted ($path);
445             }
446              
447             # 'rows-reordered' on the submodels
448             # called just once if a model is present multiple times, and a single
449             # rows-reordered with all changes generated here for listeners
450             #
451             sub _do_rows_reordered {
452             my ($model, $path, $iter, $subaref, $userdata) = @_;
453             my ($self, $mnum) = @$userdata;
454             if (! $self) { return; }
455             ### ListModelConcat rows_reordered handler
456             if ($self->{'suppress_signals'}) { return; }
457             if ($path->get_depth != 0) { return; } # ignore non-toplevel
458              
459             # array[newpos] = oldpos, ie. the array elem says where the row used to be
460             # before the reordering. $subaref says that of its sub-model portion of
461             # @array.
462             #
463             my @array = (0 .. _total_length($self) - 1);
464             my $models = $self->{'models'};
465             my $positions = _model_positions($self);
466             foreach my $i (0 .. $#$models) {
467             if ($models->[$i] == $model) {
468             my $offset = $positions->[$i];
469             foreach my $i (0 .. $#$subaref) {
470             $array[$offset + $i] = $subaref->[$i] + $offset;
471             }
472             }
473             }
474             $self->rows_reordered ($path, undef, @array);
475             }
476              
477              
478             #------------------------------------------------------------------------------
479             # Gtk2::ListStore compatible methods
480              
481              
482             # gtk_list_store_append
483             # new row at end, return iter pointing to it
484             sub append {
485             my ($self) = @_;
486             my $model = $self->{'models'}->[-1] or _no_submodels('append');
487             return $model->append
488             && _index_to_iterobj ($self, _total_length($self) - 1);
489             }
490              
491             # gtk_list_store_prepend
492             # new row at start, return iter pointing to it
493             sub prepend {
494             my ($self) = @_;
495             my $model = $self->{'models'}->[0] or _no_submodels('prepend');
496             return $model->prepend
497             && _index_to_iterobj ($self, 0);
498             }
499              
500             # The sub-models should generate row-deleted signals like Gtk2::ListModel
501             # does. Normally it's just repeated delete of item 0, though if a model
502             # appears more than once in the Concat the copies further on are reported
503             # too, which leads to a strange, though correct, sequence.
504             sub clear {
505             my ($self) = @_;
506             foreach my $model (@{$self->{'models'}}) {
507             $model->clear;
508             }
509             # new stamp to invalidate all existing iters like GtkListStore does
510             Gtk2::Ex::TreeModel::ImplBits::random_stamp ($self);
511             }
512              
513             sub set_column_types {
514             my ($self, @types) = @_;
515             foreach my $model (@{$self->{'models'}}) {
516             $model->set_column_types (@types);
517             }
518             }
519              
520             sub set {
521             my $self = shift;
522             my $iterobj = shift;
523             my ($model, $subiter) = $self->convert_iter_to_child_iter ($iterobj);
524             $model->set ($subiter, @_);
525             }
526             sub set_value {
527             my $self = shift;
528             my $iterobj = shift;
529             my ($model, $subiter) = $self->convert_iter_to_child_iter ($iterobj);
530             $model->set_value ($subiter, @_);
531             }
532              
533              
534             # insert before $index, or append if $index past last existing row
535             # insert_with_values the same, taking col=>value pairs
536             sub insert {
537             unshift @_, 'insert';
538             goto &_insert;
539             }
540             sub insert_with_values {
541             unshift @_, 'insert_with_values';
542             goto &_insert;
543             }
544             sub _insert {
545             my ($method, $self, $index, @args) = @_;
546             my ($model, $subindex, $mnum);
547             my $total_length = _total_length ($self);
548             if ($index >= $total_length) {
549             $index = $total_length; # in case wildly past end
550             my $models = $self->{'models'};
551             $model = $self->{'models'}->[-1]
552             or _no_submodels($method);
553             $mnum = $#$models;
554             $subindex = $index; # past end
555             } else {
556             ($model, $subindex, $mnum) = _index_to_subindex ($self, $index);
557             }
558             my $subiter = $model->$method ($subindex, @args);
559             return _subiter_to_iterobj ($self, $model, $subiter, $mnum);
560             }
561              
562             # insert after $iterobj, or at beginning if $iterobj undef (yes, the beginning)
563             sub insert_after {
564             unshift @_, 'insert_after', 0;
565             goto &_insert_beforeafter;
566             }
567             sub insert_before {
568             unshift @_, 'insert_before', -1;
569             goto &_insert_beforeafter;
570             }
571             sub _insert_beforeafter {
572             my ($method, $mnum, $self, $iterobj) = @_;
573             my ($model, $subiter);
574             if ($iterobj) {
575             ($model, $subiter, $mnum) = $self->convert_iter_to_child_iter ($iterobj);
576             } else {
577             my $models = $self->{'models'};
578             $model = $models->[$mnum] or _no_submodels($method);
579             if ($mnum) { $mnum = $#$models; }
580             $subiter = undef;
581             }
582             $subiter = $model->$method ($subiter);
583             return _subiter_to_iterobj ($self, $model, $subiter, $mnum);
584             }
585              
586             sub _subiter_to_iterobj {
587             my ($self, $model, $subiter, $mnum) = @_;
588             my $positions = _model_positions ($self);
589             my ($subindex) = $model->get_path($subiter)->get_indices;
590             my $index = $positions->[$mnum] + $subindex;
591             return _index_to_iterobj ($self, $index);
592             }
593              
594             sub iter_is_valid {
595             my ($self, $iter) = @_;
596             my $a = eval { $iter->to_arrayref($self->{'stamp'}) };
597             return ($a && $a->[1] < _total_length($self));
598             }
599              
600             # gtk_list_store_move_after
601             # $dst_iterobj undef means the start (yes, the start) of the list
602             sub move_after {
603             my ($self, $src_iterobj, $dst_iterobj) = @_;
604             my $src_index = _iterobj_to_index ($self, $src_iterobj);
605             my ($src_model, $src_subiter) = _index_to_subiter ($self, $src_index);
606              
607             my ($dst_index, $dst_model, $dst_subindex);
608             if (defined $dst_iterobj) {
609             $dst_index = _iterobj_to_index ($self, $dst_iterobj);
610             ($dst_model, $dst_subindex) = _index_to_subindex ($self, $dst_index);
611             } else {
612             $dst_index = -1;
613             $dst_model = $self->{'models'}->[0] or _no_submodels('insert_after');
614             $dst_subindex = 0;
615             }
616              
617             if ($src_model == $dst_model) {
618             my $dst_subiter
619             = $dst_iterobj && $dst_model->iter_nth_child (undef, $dst_subindex);
620             $src_model->move_after ($src_subiter, $dst_subiter);
621              
622             } else {
623             my $rem = _need_method ($src_model, 'remove');
624             my $ins = _need_method ($dst_model, 'insert_with_values');
625             my @row = _treemodel_extract_row ($src_model, $src_subiter);
626             my $dst_ins_subindex = ($dst_iterobj ? $dst_subindex + 1 : 0);
627              
628             { local $self->{'suppress_signals'} = 1;
629             $ins->($dst_model, $dst_ins_subindex, @row);
630             $rem->($src_model, $src_subiter);
631             }
632             delete $self->{'positions'}; # recalculate
633              
634             _move_after_reorder ($self, $src_index, $dst_index);
635             }
636             }
637              
638             # Emit a 'rows-reordered' signal for a move of row $src_index to after
639             # $dst_index. $dst_index can be -1 for the very start.
640             sub _move_after_reorder {
641             my ($self, $src_index, $dst_index) = @_;
642             my $path = Gtk2::TreePath->new;
643             my $last_index = _total_length($self) - 1;
644              
645             if ($dst_index >= $src_index) {
646             # upwards move eg. 0 to after 4 becomes 1,2,3,4,0
647             $self->rows_reordered
648             ($path, undef,
649             0 .. $src_index-1, # before, unchanged
650             $src_index+1 .. $dst_index, # shifted
651             $src_index, # moved row
652             $dst_index+1 .. $last_index); # after, unchanged
653              
654             } else {
655             # downwards move eg. 4 to after 0 becomes 0,4,1,2,3
656             $self->rows_reordered
657             ($path, undef,
658             0 .. $dst_index, # before, unchanged
659             $src_index, # moved row
660             $dst_index+1 .. $src_index-1, # shifted
661             $src_index+1 .. $last_index); # after, unchanged
662             }
663             }
664              
665             # gtk_list_store_move_before
666             # $dst_iterobj undef means the end (yes, the end) of the list
667             sub move_before {
668             my ($self, $src_iterobj, $dst_iterobj) = @_;
669             my $src_index = _iterobj_to_index ($self, $src_iterobj);
670             my ($src_model, $src_subiter) = _index_to_subiter ($self, $src_index);
671              
672             my ($dst_index, $dst_model, $dst_subindex);
673             if ($dst_iterobj) {
674             $dst_index = _iterobj_to_index ($self, $dst_iterobj);
675             ($dst_model, $dst_subindex) = _index_to_subindex ($self, $dst_index);
676             } else {
677             $dst_index = _total_length($self);
678             $dst_model = $self->{'models'}->[-1] or _no_submodels('insert_after');
679             $dst_subindex = $dst_index;
680             }
681              
682             if ($src_model == $dst_model) {
683             my $dst_subiter
684             = $dst_iterobj && $dst_model->iter_nth_child (undef, $dst_subindex);
685             $src_model->move_before ($src_subiter, $dst_subiter);
686              
687             } else {
688             my $rem = _need_method ($src_model, 'remove');
689             my $ins = _need_method ($dst_model, 'insert_with_values');
690             my @row = _treemodel_extract_row ($src_model, $src_subiter);
691              
692             { local $self->{'suppress_signals'} = 1;
693             $ins->($dst_model, $dst_subindex, @row);
694             $rem->($src_model, $src_subiter);
695             }
696             delete $self->{'positions'}; # recalculate
697              
698             _move_after_reorder ($self, $src_index, $dst_index-1);
699             }
700             }
701              
702             sub _need_method {
703             my ($model, $name) = @_;
704             return ($model->can($name)
705             || croak "ListModelConcat: submodel doesn't support '$name'");
706             }
707              
708             # gtk_list_store_remove
709             #
710             # Usually deleting a row just means our $index in $iterobj should stay the
711             # same, only with a check it wasn't the very last row deleted. But if the
712             # target $model appears more than once then deleting in its second or
713             # subsequent appearance will delete a row before and $index in $iterobj must
714             # be moved down. For that reason get a fresh @$positions after
715             # $model->remove.
716             #
717             sub remove {
718             my ($self, $iterobj) = @_;
719             if (! defined $iterobj) { croak 'Cannot remove iter "undef"'; }
720             my $index = _iterobj_to_index ($self, $iterobj);
721             my ($model, $subiter, $mnum) = _index_to_subiter ($self, $index);
722              
723             my $submore = $model->remove ($subiter);
724             my $positions = _model_positions($self);
725              
726             if ($submore) {
727             # $subiter has been updated to the next row, make an iter from it
728             my $subpath = $model->get_path ($subiter);
729             my ($subindex) = $subpath->get_indices;
730             $index = $positions->[$mnum] + $subindex;
731              
732             } else {
733             # nothing more in this $model, so we're at the start of the following
734             # model, unless it and all following are empty
735             if (defined ($index = $positions->[$mnum+1])) {
736             if ($index >= _total_length($self)) {
737             $index = undef;
738             }
739             }
740             }
741              
742             if (defined $index) {
743             $iterobj->set ([ $self->{'stamp'}, $index, undef, undef ]);
744             return 1; # more rows
745             } else {
746             # zap iter so it's not accidentally re-used (same as GtkListStore does)
747             $iterobj->set ([ 0, 0, undef, undef ]);
748             return 0; # no more rows
749             }
750             }
751              
752             # gtk_list_store_reorder
753             #
754             sub reorder {
755             my ($self, @neworder) = @_;
756              
757             my $len = _total_length($self);
758             if (@neworder != $len) {
759             croak 'ListModelConcat: new order array wrong length';
760             }
761              
762             my @row;
763             foreach my $newpos (0 .. $#neworder) {
764             my $oldpos = $neworder[$newpos];
765             if ($oldpos < 0 || $oldpos >= $len) {
766             croak "ListModelConcat: invalid old position in order array: $oldpos";
767             }
768             if ($oldpos != $newpos) {
769             my ($model, $subiter) = _index_to_subiter ($self, $oldpos);
770             $row[$oldpos] = [ _treemodel_extract_row ($model, $subiter) ];
771             }
772             }
773             { local $self->{'suppress_signals'} = 1;
774             foreach my $newpos (0 .. $#neworder) {
775             my $oldpos = $neworder[$newpos];
776             if ($oldpos != $newpos) {
777             my ($model, $subiter) = _index_to_subiter ($self, $newpos);
778             $model->set ($subiter, @{$row[$oldpos]});
779             }
780             }
781             }
782             $self->rows_reordered (Gtk2::TreePath->new, undef, @neworder);
783             }
784              
785             sub swap {
786             my ($self, $iterobj_a, $iterobj_b) = @_;
787             my $index_a = _iterobj_to_index ($self, $iterobj_a);
788             my $index_b = _iterobj_to_index ($self, $iterobj_b);
789              
790             my ($model_a, $subiter_a) = _index_to_subiter ($self, $index_a);
791             my ($model_b, $subiter_b) = _index_to_subiter ($self, $index_b);
792             if ($model_a == $model_b) {
793             $model_a->swap ($subiter_a, $subiter_b);
794              
795             } else {
796             my @row_a = _treemodel_extract_row ($model_a, $subiter_a);
797             my @row_b = _treemodel_extract_row ($model_b, $subiter_b);
798             { local $self->{'suppress_signals'} = 1;
799             $model_a->set ($subiter_a, @row_b);
800             $model_b->set ($subiter_b, @row_a); }
801              
802             my @array = (0 .. _total_length($self) - 1);
803             $array[$index_a] = $index_b; # $array[newpos] == oldpos
804             $array[$index_b] = $index_a;
805             $self->rows_reordered (Gtk2::TreePath->new, undef, @array);
806             }
807             }
808              
809             # return a list of values (0, 'col0', 1, 'col1', ...) which is the column
810             # number and its contents
811             sub _treemodel_extract_row {
812             my ($model, $iter) = @_;
813             my @row = $model->get($iter);
814             return map {; ($_,$row[$_]) } 0 .. $#row;
815             }
816              
817             #------------------------------------------------------------------------------
818             # Gtk2::TreeDragSource interface, drag source
819              
820             # gtk_tree_drag_source_row_draggable ($self, $path)
821             #
822             sub ROW_DRAGGABLE {
823             # my ($self, $path) = @_;
824             unshift @_, 'row_draggable';
825             goto &_drag_source;
826             }
827              
828             # gtk_tree_drag_source_drag_data_delete ($self, $path)
829             #
830             sub DRAG_DATA_DELETE {
831             # my ($self, $path) = @_;
832             unshift @_, 'drag_data_delete';
833             goto &_drag_source;
834             }
835              
836             # gtk_tree_drag_source_drag_data_get ($self, $path, $sel)
837             #
838             sub DRAG_DATA_GET {
839             # my ($self, $path, $sel) = @_;
840             unshift @_, 'drag_data_get';
841             goto &_drag_source;
842             }
843              
844             sub _drag_source {
845             my ($method, $self, $path, @sel_arg) = @_;
846             ### ListModelConcat: "\U$method\E path=".$path->to_string
847              
848             if ($path->get_depth != 1) {
849             ### no, not a toplevel row
850             return 0;
851             }
852             my ($index) = $path->get_indices;
853             my ($model, $subindex) = _index_to_subindex ($self, $index);
854              
855             if (! $model->isa('Gtk2::TreeDragSource')) {
856             ### no, submodel not a TreeDragSource
857             return 0;
858             }
859             my $subpath = Gtk2::TreePath->new_from_indices ($subindex);
860             ### submodel row_draggable subpath: $subpath->to_string
861             my $ret = $model->$method ($subpath, @sel_arg);
862             ### submodel result: $ret
863             return $ret;
864             }
865              
866             #------------------------------------------------------------------------------
867             # Gtk2::TreeDragDest interface, drag destination
868              
869             # gtk_tree_drag_dest_row_drop_possible
870             # gtk_tree_drag_dest_drag_data_received
871             #
872             sub ROW_DROP_POSSIBLE {
873             push @_, 'row_drop_possible';
874             goto &_drag_dest;
875             }
876             sub DRAG_DATA_RECEIVED {
877             push @_, 'drag_data_received';
878             goto &_drag_dest;
879             }
880             sub _drag_dest {
881             my ($self, $dst_path, $sel, $method) = @_;
882             ### ListModelConcat: "\U$method\E, to path=".$dst_path->to_string
883             ### type: $sel->type->name
884             ### 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 }
885              
886             if ($dst_path->get_depth != 1) {
887             ### no, not a toplevel row
888             return 0;
889             }
890             my ($dst_index) = $dst_path->get_indices;
891             my ($dst_submodel, $dst_subindex)
892             = _index_to_subindex_post ($self, $dst_index);
893              
894             if (! $dst_submodel->isa('Gtk2::TreeDragDest')) {
895             ### no, submodel not a TreeDragDest
896             return 0;
897             }
898             my $dst_subpath = Gtk2::TreePath->new_from_indices ($dst_subindex);
899             if (! $dst_submodel->$method ($dst_subpath, $sel)) {
900             ### no, submodel $method() false
901             return 0;
902             }
903             ### yes from submodel
904             return 1;
905             }
906              
907             # return ($model, $subindex), and allowing a $index which is past the end of
908             # $self to likewise give a subindex beyond the end of the last submodel
909             #
910             sub _index_to_subindex_post {
911             my ($self, $index) = @_;
912             my $positions = _model_positions ($self);
913             if ($index < $positions->[-1]) {
914             return _index_to_subindex ($self, $index);
915             }
916             my $model = $self->{'models'}->[-1]
917             or return (undef, undef); # no models at all
918             return ($model, $index - $positions->[-2]);
919             }
920              
921             #------------------------------------------------------------------------------
922             # Gtk2::Buildable interface
923              
924             sub ADD_CHILD {
925             my ($self, $builder, $child, $type) = @_;
926             ### ListModelConcat ADD_CHILD(): @_
927             $self->append_model ($child);
928             }
929              
930             1;
931             __END__