File Coverage

blib/lib/Gtk2/Ex/TiedMenuChildren.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# 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::TiedMenuChildren;
use 5.008;
use strict;
use warnings;
use Carp;
use Gtk2::Ex::ContainerBits;
use List::Util qw(min max);

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

our $VERSION = 5;

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

sub TIEARRAY {
  my ($class, $menu) = @_;
  return bless \$menu, $class;
}

# optional, not needed
# sub UNTIE { }

# tied object func
sub menu {
  return ${$_[0]};
}

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

# negative indices already normalized to >=0 by the time they get here
sub STORE {
  my ($self, $index, $new) = @_;
  #### TiedChildren STORE: [ $index, $new ]
  my $menu = $$self;

  if (my $old = $self->FETCH ($index)) {
    if ($old == $new) {
      return;  # already what's wanted
    }
    $menu->remove ($old);
  }

  if (defined $new) {
    $menu->insert ($new, $index);
  }
}

sub FETCHSIZE {
  my ($self) = @_;
  ### TiedChildren FETCHSIZE
  my @children = ($$self)->get_children;
  return scalar(@children);
}

# big negative sizes normalized to 0 by the time they get here
sub STORESIZE {
  my ($self, $want_size) = @_;
  ### TiedChildren STORESIZE: $want_size
  ###   currently: $self->FETCHSIZE

  my $menu = $$self;
  my @children = $menu->get_children;
  if ($want_size < @children) {
    Gtk2::Ex::ContainerBits::remove_widgets
        ($menu, splice (@children, $want_size));
  }
}

sub EXTEND {
}

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

sub DELETE {
  my ($self, $index) = @_;
  ### TiedChildren DELETE: $index
  my $menu = $$self;
  my $ret;
  if ($ret = $self->FETCH ($index)) {  # if such an element
    $menu->remove ($ret);
  }
  return $ret;
}

sub CLEAR {
  my ($self) = @_;
  ### TiedChildren CLEAR
  Gtk2::Ex::ContainerBits::remove_all ($$self);
}

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

sub POP {
  my ($self) = @_;
  ### TiedChildren POP
  my $menu = $$self;
  my $ret = ($menu->get_children)[-1];
  if (defined $ret) { # if not empty menu
    $menu->remove ($ret);
  }
  return $ret;
}

sub SHIFT {
  my ($self) = @_;
  return DELETE($self, 0);
}

# don't have to return the new size here, FETCHSIZE is called separately
sub UNSHIFT {
  my $self = shift;
  ### TiedChildren UNSHIFT
  my $menu = $$self;
  while (@_) {
    $menu->prepend (pop @_);
  }
}

sub SPLICE {
  my $self = shift;
  my $offset = shift;
  my $length = shift;
  my $menu = $$self;
  my @children = $menu->get_children;
  my $total = scalar @children;

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

  my @ret = splice (@children, $offset, $length);
  Gtk2::Ex::ContainerBits::remove_widgets ($menu, @ret);

  while (@_) {
    $menu->insert (pop @_, $offset);
  }
  ### ret: map {$_->get_name} @ret
  return (wantarray ? @ret : $ret[-1]);
}

1;
__END__