Gtk2::Ex::TiedListColumn - tie an array to a column of a list TreeModel

 use Gtk2::Ex::TiedListColumn;
 # any sort of model ...
 my $my_model = Gtk2::ListStore->new ('Glib::String');

 my @array;
 tie @array, 'Gtk2::Ex::TiedListColumn', $my_model, 0;

 my $aref = Gtk2::Ex::TiedListColumn->new ($my_model, 5);

# Copyright 2008, 2009, 2010 Kevin Ryde

# This file is part of Gtk2-Ex-TiedListColumn.
#
# Gtk2-Ex-TiedListColumn 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-TiedListColumn 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-TiedListColumn.  If not, see <http://www.gnu.org/licenses/>.


package Gtk2::Ex::TiedListColumn;
use 5.008;
use strict;
use warnings;
use Carp;
use List::Util qw(min max);

our $VERSION = 5;

use constant DEBUG => 0;

sub new {
  my ($class, $model, $column) = @_;
  tie (my @array, $class, $model, $column);
  return \@array;
}

sub TIEARRAY {
  my ($class, $model, $column) = @_;
  return bless { model  => $model,
                 column => ($column||0)
               }, $class;
}
# optional, not needed
# sub UNTIE { }

# tied object funcs
sub model {
  my ($self) = @_;
  return $self->{'model'};
}
sub column {
  my ($self) = @_;
  return $self->{'column'};
}

# negative indices already normalized to >=0 by the time they get here
sub FETCH {
  my ($self, $index) = @_;
  if (DEBUG >= 2) { print "FETCH $index\n"; }
  my $model = $self->{'model'};
  my $iter = $model->get_iter (Gtk2::TreePath->new ($index))
    || return undef;
  return $model->get_value ($iter, $self->{'column'});
}

# negative indices already normalized to >=0 by the time they get here
sub STORE {
  my ($self, $index, $value) = @_;
  if (DEBUG) { print "STORE $index $value\n"; }
  my $model = $self->{'model'};
  my $iter = $model->get_iter (Gtk2::TreePath->new ($index));
  if (! $iter) {
    my $len = $model->iter_n_children (undef);
    while ($len <= $index) {
      $iter = $model->insert ($len);
      $len++;
    }
  }
  $model->set_value ($iter, $self->{'column'}, $value);
}

sub FETCHSIZE {
  my ($self) = @_;
  if (DEBUG) { print "FETCHSIZE\n"; }
  my $model = $self->{'model'};
  return $model->iter_n_children (undef);
}

# big negatives already normalized to 0 by the time they get here
sub STORESIZE {
  my ($self, $want_size) = @_;
  if (DEBUG) { print "STORESIZE $want_size, currently ",
                 $self->{'model'}->iter_n_children (undef),"\n"; }
  my $model = $self->{'model'};
  my $got_size = $model->iter_n_children (undef);
  while ($got_size < $want_size) {
    $model->append;
    $got_size++;
  }
  while ($got_size > $want_size) {
    my $iter = $model->get_iter (Gtk2::TreePath->new($got_size-1));
    $model->remove ($iter);
    $got_size--;
  }
}

sub EXTEND {
}

# negative indices already normalized to >=0 by the time they get here
sub EXISTS {
  my ($self, $index) = @_;
  if (DEBUG) { print "EXISTS $index\n"; }
  my $model = $self->{'model'};
  return $index < $model->iter_n_children(undef);
}

sub DELETE {
  my ($self, $index) = @_;
  if (DEBUG) { print "DELETE $index\n"; }
  my $model = $self->{'model'};

  my $iter = $model->get_iter (Gtk2::TreePath->new ($index))
    || return undef;
  my $ret = $model->get_value ($iter);
  my $len = $model->iter_n_children (undef);
  if ($index == $len-1) {
    $model->remove ($iter);
  } else {
    $model->set ($iter, $self->{'column'}, undef);
  }
  return $ret;
}

sub CLEAR {
  my ($self) = @_;
  if (DEBUG) { print "CLEAR\n"; }
  my $model = $self->{'model'};
  $model->clear;
}

sub PUSH {
  my $self = shift;
  my $model = $self->{'model'};
  my $column = $self->{'column'};
  my $pos = $model->iter_n_children (undef);
  foreach my $value (@_) {
    $model->insert_with_values ($pos++, $column, $value);
  }
}

sub POP {
  my ($self) = @_;
  if (DEBUG) { print "POP\n"; }
  my $model = $self->{'model'};
  my $len = $model->iter_n_children (undef) || return undef; # if empty
  my $iter = $model->iter_nth_child (undef, $len-1);
  my $value = $model->get_value ($iter, $self->{'column'});
  $model->remove ($iter);
  return $value;
}

sub SHIFT {
  my ($self) = @_;
  my $model = $self->{'model'};
  my $iter = $model->get_iter_first || return undef; # if empty
  my $value = $model->get_value ($iter, $self->{'column'});
  $model->remove ($iter);
  return $value;
}

# don't have to return the new size here, FETCHSIZE is called separately
sub UNSHIFT {
  my $self = shift;
  if (DEBUG) { print "UNSHIFT\n"; }
  my $model = $self->{'model'};
  my $column = $self->{'column'};
  my $pos = 0;
  foreach my $value (@_) {
    $model->insert_with_values ($pos++, $column, $value);
  }
}

sub SPLICE {
  my $self = shift;
  my $offset = shift;
  my $length = shift;
  if (DEBUG) { print "SPLICE ",defined $offset ? $offset : 'undef',
                 " ", defined $length ? $length : 'undef', "\n"; }

  my $model = $self->{'model'};
  my $column = $self->{'column'};
  my $total = $model->iter_n_children (undef);

  # carp similar to "use warnings" on ordinary arrays
  if (! defined $offset) {
    $offset = 0;
  } elsif ($offset < -$total) {
    carp "TiedListColumn: offset $offset before start of array";
    $offset = 0;
  } elsif ($offset < 0) {
    $offset += $total;
  } elsif ($offset > $total) {
    carp "TiedListColumn: offset $offset past end of array";
    $offset = $total;
  }

  if (! defined $length) {
    $length = $total - $offset;
  } elsif ($length < 0) {
    $length = max (0, $total + $length - $offset);
  } else {
    $length = min ($length, $total - $offset);
  }

  if (DEBUG) { print "  norm to $offset, $length\n"; }

  my @ret;
  if ($length > 0) {
    my $iter = $model->iter_nth_child (undef, $offset);
    if (wantarray) {
      $#ret = $length-1;
      foreach my $i (0 .. $length-1) {
        $ret[$i] = $model->get_value ($iter, $column);
        $model->remove ($iter) or last;
      }

    } else {
      $ret[0] = undef;
      foreach (0 .. $length-2) {
        if (! $model->remove ($iter)) {
          $iter = undef;
          last;
        }
      }
      if ($iter) {
        $ret[0] = $model->get_value ($iter, $column);
        $model->remove ($iter);
      }
    }
  }

  foreach my $value (@_) {
    $model->insert_with_values ($offset++, $column, $value);
  }

  # here in scalar context $ret[0] is the last removed as per what splice()
  # should return
  return (wantarray ? @ret : $ret[0]);
}

1;
__END__