File Coverage

blib/lib/Glib/Ex/TieProperties.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 2009, 2010, 2011, 2012, 2014 Kevin Ryde

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


package Glib::Ex::TieProperties;
use 5.008;
use strict;
use warnings;
use Carp;
use Glib;

our $VERSION = 16;

use constant DEBUG => 0;

sub new {
  tie my(%hash), shift, @_;
  return \%hash;
}
sub in_object {
  my ($class, $obj, %option) = @_;
  $option{'weak'} = 1;
  my $field = delete $option{'field'};
  if (! defined $field) { $field = 'property'; }
  tie my(%hash), $class, $obj, %option;
  return ($obj->{$field} = \%hash);
}
sub object {
  return $_[0]->[0];
}

# $self is an arrayref, created as one element just for _OBJ, with a second
# for _KEYS on-demand..
#
# $self->[_OBJ] is the target Glib::Object
#
# $self->[_KEYS] is an arrayref of keys (string property names) to return
# from FIRSTKEY/NEXTKEY, with NEXTKEY shifting off one per call.
#
use constant { _OBJ => 0,
               _KEYS => 1 };

# Think about:
#   error_on_fetch
#   error_on_store
#
sub TIEHASH {
  my ($class, $obj, %option) = @_;
  (ref $obj) || croak "$class needs an object to tie";
  my $self = bless [ $obj ], $class;
  if ($option{'weak'}) {
    require Scalar::Util;
    Scalar::Util::weaken ($self->[_OBJ]);
  }
  return $self;
}
sub FETCH  {
  my ($self, $key) = @_;
  if (my $obj = $self->[_OBJ]) {                  # when not weakened away
    if (my $pspec = $obj->find_property ($key)) { # when known property
      if ($pspec->{'flags'} >= 'readable') {      # when readable
        return $obj->get_property($key);
      }
    }
  }
  return undef; # otherwise
}
sub STORE  {
  my ($self, $key, $value) = @_;
  my $obj = $self->[_OBJ] || return;  # do nothing if weakened away
  $obj->set_property ($key, $value);
}
sub EXISTS {
  my ($self, $key) = @_;
  my $obj = $self->[_OBJ] || return 0;  # if weakened away
  return defined ($obj->find_property($key));
}
sub DELETE { croak 'Cannot delete object properties' }
BEGIN {
  no warnings;
  *CLEAR = \&DELETE;
}

sub FIRSTKEY {
  my ($self) = @_;
  my $obj = $self->[_OBJ] || return undef;  # if weakened away
  @{$self->[_KEYS]} = map {$_->{'name'}} $obj->list_properties;
  goto &NEXTKEY;
}
sub NEXTKEY {
  return shift @{$_[0]->[_KEYS]};
}

# Return true if at least one property, this new in 5.8.3.
# Mimic the "8/8" bucket of a real hash because it's easy enough to do.
#
# It's pretty wasteful getting the full list of pspecs then throwing them
# away, but g_object_class_list_properties() is about the only way to check
# if there's any, and $obj->list_properties() is the only interface to that
# function.
#
sub SCALAR {
  my ($self) = @_;
  if (my $obj = $self->[_OBJ]) {      # when not weakened away
    my @pspecs = $obj->list_properties;
    if (my $len = scalar(@pspecs)) {  # buckets only if not empty
      return "$len/$len";
    }
  }
  return 0; # false for no properties
}

1;
__END__