File Coverage

blib/lib/Gtk2/Ex/TiedTreePath.pm

Criterion	Covered	Total	%
statement	9	93	9.6
branch	0	10	0.0
condition			n/a
subroutine	3	21	14.2
pod	2	2	100.0
total	14	126	11.1

# Copyright 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 .


package Gtk2::Ex::TiedTreePath;
use 5.008;
use strict;
use warnings;

our $VERSION = 5;

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

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

sub TIEARRAY {
  my ($class, $path) = @_;
  return bless \$path, $class;
}
# optional, not needed
# sub UNTIE { }

# tied object method
sub path {
  return ${$_[0]};
}

# negative indices already normalized to >=0 by the time they get here
sub FETCH {
  my ($self, $index) = @_;
  ### TiedTreePath FETCH: $index
  return (($$self)->get_indices)[$index];
}

# negative indices already normalized to >=0 by the time they get here
sub STORE {
  my ($self, $index, $value) = @_;
  ### TiedTreePath STORE: [$index, $value]
  my $path = $$self;
  my $depth = $path->get_depth;
  if ($index >= $depth) {
    foreach ($depth .. $index-1) {
      $path->append_index (0);
    }
    $path->append_index ($value);
  } else {
    my @array = $path->get_indices;
    foreach ($index .. $depth-1) {
      $path->up;
    }
    $path->append_index ($value);
    foreach my $i ($index+1 .. $depth-1) {
      $path->append_index ($array[$i]);
    }
  }
}

sub _path_clear {
  my ($path) = @_;
  while ($path->up) {}
}
sub _path_set_indices {
  my $path = shift;
  _path_clear ($path);
  while (@_) { $path->append_index (shift @_); }
}

sub FETCHSIZE {
  my ($self) = @_;
  ### TiedTreePath FETCHSIZE
  return ($$self)->get_depth;
}

# big negative sizes normalized to 0 by the time they get here
sub STORESIZE {
  my ($self, $want_size) = @_;
  ### TiedTreePath STORESIZE: $want_size
  my $path = $$self;
  my $depth = $path->get_depth;
  foreach ($want_size .. $depth-1) {   # shorten
    $path->up;
  }
  foreach ($depth .. $want_size-1) {   # lengthen
    $path->append_index (0);
  }
}

sub EXTEND {
}

# negative indices already normalized to >=0 by the time they get here
sub EXISTS {
  my ($self, $index) = @_;
  ### TiedTreePath EXISTS: $index
  return ($index < ($$self)->get_depth);
}

# normalized to 0 <= $index <= FETCHSIZE-1 by the time get here
sub DELETE {
  my ($self, $index) = @_;
  ### TiedTreePath DELETE: $index
  my $path = $$self;
  my $ret;

  if ($index < (my $depth = $path->get_depth)) {
    $ret = ($path->get_indices)[$index];
    if ($index == $depth-1) {
      $path->up;
    } else {
      $self->STORE ($index, 0);
    }
  }
  return $ret;
}

sub CLEAR {
  my ($self) = @_;
  ### TiedTreePath CLEAR
  _path_clear ($$self);
}

sub PUSH {
  my $self = shift;
  my $path = $$self;
  while (@_) {
    $path->append_index (shift @_);
  }
}

sub POP {
  my ($self) = @_;
  ### TiedTreePath POP
  my $path = $$self;
  my $ret = ($path->get_indices)[-1];
  $path->up;
  return $ret;
}

sub SHIFT {
  my ($self) = @_;
  ### TiedTreePath SHIFT
  my $path = $$self;
  my @array = $path->get_indices;
  if (! @array) { return; }
  my $ret = shift @array;
  ###   $ret
  _path_set_indices ($path, @array);
  return $ret;
}

# don't have to return the new size here, FETCHSIZE is called separately
sub UNSHIFT {
  my $self = shift;
  ### TiedTreePath UNSHIFT
  my $path = $$self;
  push @_, $path->get_indices;
  _path_set_indices ($path, @_);
}

sub SPLICE {
  my $self = shift;
  my $offset = shift;
  my $length = shift;
  ### TiedTreePath SPLICE: [$offset,$length]

  my $path = $$self;
  my @array = $path->get_indices;
  if (wantarray) {
    my @ret = splice @array, $offset, $length, @_;
    _path_set_indices ($path, @array);
    return @ret;
  } else {
    my $ret = splice @array, $offset, $length, @_;
    _path_set_indices ($path, @array);
    return $ret;
  }
}

1;
__END__