view release on metacpan or  search on metacpan

lib/Glib/Ex/TieProperties.pm  view on Meta::CPAN

# 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 <http://www.gnu.org/licenses/>.


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

our $VERSION = 17;

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__

=for stopwords Glib-Ex-ObjectBits Ryde hashref TieProperties boolean Ryde

=head1 NAME

Glib::Ex::TieProperties -- tied hash for Glib object property access

=for test_synopsis my ($object)

=head1 SYNOPSIS

 use Glib::Ex::TieProperties;
 my %hash;
 tie %hash, 'Glib::Ex::TieProperties', $object;

 # or an anonymous hashref
 my $href = Glib::Ex::TieProperties->new ($object);

=head1 DESCRIPTION

C<Glib::Ex::TieProperties> accesses properties of a given C<Glib::Object>
through a tied hash.  The keys are the property names and fetching and
storing values operates on the property values.

If you're just getting and setting properties then the Object C<get()> and
C<set()> methods are enough.  But a good use for a tie is to apply C<local>
settings within a block, to be undone by a C<set()> back to their previous
values no matter how the block is left (C<goto>, C<return>, C<die>, etc).

    {
      tie my(%aprops), 'Glib::Ex::TieProperties', $adjustment;
      local $aprops{'page-increment'} = 100;
      do_page_up();
    }

With C<new()> to create a tied hashref a single long C<local> expression is
possible

    # usually allow-shrink is not a good idea, have it temporarily
    local Glib::Ex::TieProperties->new($toplevel)->{'allow-shrink'} = 1;
    some_resize();

You can even be creative with hash slices for multiple settings in one
statement.

    # how big is $toplevel if $widget width is forced
    {
      tie my(%wprops), 'Glib::Ex::TieProperties', $widget;
      local @wprops{'width-request','height-request'} = (100, 200);
      my $req = $toplevel->size_request;