File Coverage

blib/lib/Gtk2/Ex/TableBits.pm

Criterion	Covered	Total	%
statement	12	26	46.1
branch	0	8	0.0
condition	0	3	0.0
subroutine	4	6	66.6
pod	1	1	100.0
total	17	44	38.6

# Copyright 2008, 2009, 2010, 2011, 2012 Kevin Ryde

# This file is part of Gtk2-Ex-WidgetBits.
#
# Gtk2-Ex-WidgetBits 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-WidgetBits 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-WidgetBits.  If not, see .


package Gtk2::Ex::TableBits;
use 5.008;
use strict;
use warnings;
use Scalar::Util 'refaddr';

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

our $VERSION = 48;

my @attach_pnames = ('left-attach',
                     'right-attach',
                     'top-attach',
                     'bottom-attach',
                     'x-options',
                     'y-options',
                     'x-padding',
                     'y-padding');

sub update_attach {
  my ($table, $child, @args) = @_;
  ### TableBits update_attach: "$child", @args

  if (! _child_is_attached_at($table, $child, @args)) {
    ### must re-attach ...
    if (my $parent = $child->get_parent) {
      $parent->remove ($child);
    }
    $table->attach ($child, @args);
  }
}

# or maybe a func which just checked the attach positions, not the table too
sub _child_is_attached_at {
  my ($table, $child, @args) = @_;
  {
    my $parent = $child->get_parent;
    if (! $parent || refaddr($parent) != refaddr($table)) {
      # parent is not the desired $table
      return 0;
    }
  }
  # Note: compare with "==" operator here, not with "!=".  Glib::Flags
  # "!=" is only in Perl-Gtk2 1.200 and higher.  "x-options" and
  # "y-options" are Gtk2::AttachOptions flags.
  foreach my $pname (@attach_pnames) {
    unless ($table->child_get_property($child,$pname)
            == shift @args) {
      return 0;
    }
  }
  return 1;
}

1;
__END__