File Coverage

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

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


# maybe:
# multiplier factor [$obj,'prop',mul=>2]
# get_method => name or subr
# set_method => name or subr
# paramspec  => $pspec

package Glib::Ex::ConnectProperties;
use 5.008;
use strict;
use warnings;
use Carp;
use Glib;
use Scalar::Util;
use Module::Load;
use Glib::Ex::SignalIds 5; # version 5 for add()

our $VERSION = 19;

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


# Hard/weak refs are as follows.
#
# * Readable property in new() permanent linkage -- the $object signal
#   connection has a hard ref to $elem, and $elem->{'self'} has a hard ref
#   to $self, so $elem is kept alive while $object lives.  The entry for
#   $elem within connp $self->{'array'} is weak so that $elem goes away when
#   $object is destroyed.
#
# * Readable property in dynamic() linkage -- $elem->{'self'} is weak, which
#   means $self can be garbage collected.  Each $elem is still kept alive by
#   the signal connection, but $self->DESTROY drops those connections.
#
# * Write-only property -- there's no signal connection, and $self has a
#   hard ref to $elem, with nothing from $elem back to $self.  The
#   write-onlys don't keep $self alive, only the readables.  Once the last
#   readable object is destroyed the $self and write-onlys are destroyed.
#
# In all cases $elem->{'object'} is only a weak ref to the target $object so
# a ConnectProperties never keeps a target object alive.
#
# When $self->{'array'} gets down to just one element (one readable one)
# it'd be possible to discard it as there's nowhere for its "notify" to
# propagate values to.  But maybe an add() could be made to extend an
# existing linkage, in which case would still want that last element.  Maybe
# could go dynamic() style when down to one element, so if nothing else
# cares about the linkage then destroy the lot.
#

sub new {
  my ($class, @array) = @_;
  ### ConnectProperties new()

  if (@array < 2) {
    croak 'ConnectProperties: new() must have two or more object/property pairs';
  }

  # validate property names before making signal connections
  foreach my $elem (@array) {
    my ($object, $pname, @params) = @$elem;

    # for reference ParamSpec demands pname first char [A-Za-z] and then any
    # non [A-Za-z0-9-] crunched by canonical_key() to "-"s
    my $flavour;
    if ($pname =~ /(.*?)#(.*)/) {
      $pname = $2;
      ($flavour = $1) =~ tr/-/_/;
    } else {
      $flavour = 'object';
    }
    my $elem_class = "Glib::Ex::ConnectProperties::Element::$flavour";
    ### $elem_class
    Module::Load::load ($elem_class);

    # replacing element in @array
    $elem = $elem_class->new (object => $object,
                              pname  => $pname,
                              @params);
    $elem->check_property;
  }
  my $self = bless { array => \@array }, $class;
  my $first_readable_elem;

  foreach my $elem (@array) {
    if (my $h = delete $elem->{'hash_in'}) {
      ### hash_in func: "@{[keys %$h]}"
      $elem->{'func_in'} = _make_hash_func ($h);
    }
    if (my $h = delete $elem->{'hash_out'}) {
      ### hash_out func: "@{[keys %$h]}"
      $elem->{'func_out'} = _make_hash_func ($h);
    }

    if (delete $elem->{'bool_not'}) {
      $elem->{'func_in'} =  $elem->{'func_out'} = \&_bool_not;
    }

    Scalar::Util::weaken ($elem->{'object'});

    if (! delete $elem->{'write_only'} && $elem->is_readable) {
      $first_readable_elem ||= $elem;
      $elem->{'self'} = $self;
      $elem->connect_signals;
      Scalar::Util::weaken ($elem);  # the element of $self->{'array'}
    }
  }

  # set initially from first readable, in case not already the same
  if ($first_readable_elem) {
    ### initial propagate
    _do_read_handler ($first_readable_elem->{'object'}, $first_readable_elem);
  }
  return $self;
}

sub dynamic {
  my $self = shift->new(@_);
  foreach my $elem (@{$self->{'array'}}) {
    Scalar::Util::weaken ($elem->{'self'});
  }
  return $self;
}

# For a permanent new() style connection DESTROY is only reached when all
# readable objects are gone already, so there's nothing to disconnect.  But
# a dynamic() is garbage collected with signal connections still present,
# hence an explicit disconnect() here.
#
sub DESTROY {
  my ($self) = @_;
  $self->disconnect;
}

sub disconnect {
  my ($self) = @_;
  my $array = $self->{'array'};
  ### ConnectProperties disconnect: "$self ".scalar(@$array)." elems"
  while (my $elem = pop @$array) {
    $elem->disconnect;
  }
}

my $value_validate_method
  = (
     # Perl-Glib 1.200, value_validate() not wrapped
     ! Glib::ParamSpec->can('value_validate')
     ? sub {
       my ($pspec, $value) = @_;
       return (0,$value); # unmodified, original value, always wantarray
     }

     # Perl-Glib 1.220, value_validate() buggy on non ref counted boxed types
     : ! eval{Glib->VERSION(1.240);1}
     ? sub {
       my ($pspec, $value) = @_;
       my $type = $pspec->get_value_type;
       if ($type->isa('Glib::Boxed') && ! $type->isa('Glib::Scalar')) {
         return (0,$value); # unmodified, original value, always wantarray
       }
       return $pspec->value_validate ($value);
     }

     # Perl-Glib 1.240, value_validate() good
     : 'value_validate');

# 'notify' or read_signal handler from a connected object
sub _do_read_handler {
  my $from_elem = $_[-1];
  my $self = $from_elem->{'self'};

  ### ConnectProperties _do_read_handler: "$self $_[0]/" . ($from_elem->{'pname'} || '[false]')
  ###   notify_in_progress: $self->{'notify_in_progress'}

  if ($self->{'notify_in_progress'}) { return; }
  local $self->{'notify_in_progress'} = 1;

  my $from_val = $from_elem->get_value;
  ###   from_value to propagate: $from_val
  if (my $func = $from_elem->{'func_out'}) {
    $from_val = $func->($from_val);
    ###   func_out becomes: $from_val
  }

  my $array = $self->{'array'};
  for (my $i = 0; $i < @$array; $i++) {
    my ($to_elem, $to_object);

    unless (($to_elem = $array->[$i])
            && ($to_object = $to_elem->{'object'})) {
      ###   elem gone, dropping: $i
      splice @$array, $i--, 1;
      next;
    }
    if ($to_elem == $from_elem         # not ourselves
        || $to_elem->{'read_only'}) {  # forced not write
      next;
    }

    my $to_pspec = $to_elem->find_property
      || do {
        ### no to_pspec (such as no container child property yet, etc)
        next;
      };
    my $to_flags = $to_pspec->get_flags;

    # skip non-writable targets
    ($to_flags & 'writable') || next;

    my $to_val = $from_val;
    if (my $func = $to_elem->{'func_in'}) {
      $to_val = $func->($to_val);
      ###   func_in becomes: $to_val
    }

    # value_validate() to clamp $to_val for $to_pspec
    # value_validate() is wrapped in Glib 1.220, remove the check when ready
    # to demand that version
    # In 1.240 may have to keep a new non ref counted boxed return from
    # func_in() alive if value_validate() makes an alias, hence
    # $to_val_keepalive.
    #
    my $to_val_keepalive = $to_val;
    (undef, $to_val) = $to_pspec->$value_validate_method($to_val);

    # skip if target already contains $to_val, to avoid extra 'notify's
    if ($to_flags & 'readable') {
      if (_pspec_equal ($to_pspec, $to_elem->get_value, $to_val)) {
        ###   suppress already equal: "$to_object/".($to_elem->{'pname'} || '[false]')
        next;
      }
    }

    ###   store to: "$to_object/". ($to_elem->{'pname'} || '[false]')
    $to_elem->set_value ($to_val);
  }

  return $from_elem->{'read_signal_return'};
}

sub _pspec_equal {
  my ($pspec, $x, $y) = @_;

  # Glib::Param::Boxed values_cmp() is only by pointer value, so try to do
  # better by looking for an equal() or compare() method on the value type.
  # This is only for the exact pspec 'Glib::Param::Boxed'.  If you make a
  # subclass for a flavour of boxed object you should implement a values_cmp
  # for everyone to use.
  #
  if (ref $pspec eq 'Glib::Param::Boxed') {
    my $value_type = $pspec->get_value_type;  # string class name

    if (my $func = $value_type->can('Glib_Ex_ConnectProperties_equal')) {
      return $func->($x, $y);
    }

    # Gtk2::Gdk::Region and Gtk2::Gdk::Color have 'equal' (and GdkFont would
    # too but it's not wrapped as of Gtk2 1.221).  Gtk2::TreePath has a
    # 'compare' method.  Those methods don't much like undef (NULL), and
    # presume that other similar methods won't either, so guard against
    # that.
    #
    if (my $func = $value_type->can('equal')) {
      if (! defined $x || ! defined $y) {
        return ((defined $x) == (defined $y)); # undef==undef, else not equal
      }
      return $func->($x, $y);
    }
    if (my $func = $value_type->can('compare')) {
      if (! defined $x || ! defined $y) {
        return ((defined $x) == (defined $y)); # undef==undef, else not equal
      }
      return ($func->($x, $y) == 0);
    }
  }

  # values_cmp() wrapped in Glib 1.220, will remove the fallback when ready
  # to demand that version
  my $func = ($pspec->can('values_cmp')
              || $pspec->can('Glib_Ex_ConnectProperties_values_cmp')
              || croak 'ConnectProperties: oops, where\'s the values_cmp fallback?');
  return ($func->($pspec, $x, $y) == 0);
}

sub _make_hash_func {
  my ($h) = @_;
  ### _make_hash_func()
  ### $h
  if (defined(tied($h))) {
    return sub { $h->{$_[0]} };
  } else {
    return sub { defined $_[0] ? $h->{$_[0]} : undef };
  }
}
sub _bool_not {
  return ! $_[0];
}

#------------------------------------------------------------------------------
# equality refinements for Glib::Param::Boxed
#
# This is just a Glib_Ex_ConnectProperties_equal() func added into the
# package of the applicable type.  Not a documented feature yet.  Might
# prefer paramspec subclasses offering a suitable values_cmp() which
# everyone could use, rather than special stuff here.

# Glib::ParamSpec->scalar just makes a Glib::Param::Boxed so values_cmp is
# by the SV address, which will be almost always different.  Try instead a
# compare by 'eq'.  It won't look into arrays etc, but you probably should
# setup a new ParamSpec type to make that happen properly.
#
sub Glib::Scalar::Glib_Ex_ConnectProperties_equal {
  my ($x, $y) = @_;
  if (! defined $x || ! defined $y) { return ((defined $x) == (defined $y)) }
  return ($x eq $y);
}

# Glib::Strv at the perl level as arrayref of strings, or undef.
# In Gtk2::AboutDialog it's just a Glib::Param::Boxed, compare by value.
#
# undef is not equal to an empty array, the same as GParamSpecValueArray has
# NULL not equal to a zero length array in param_value_array_values_cmp().
# There's probably no difference in actual use though ...
#
sub Glib::Strv::Glib_Ex_ConnectProperties_equal {
  my ($x, $y) = @_;
  if (! defined $x || ! defined $y) { return ((defined $x) == (defined $y)); }
  if (@$x != @$y) { return 0; }
  foreach my $i (0 .. $#$x) {
    if ($x->[$i] ne $y->[$i]) { return 0; }
  }
  return 1;
}

# Gtk2::Gdk::Cursor, by type, with possibly undef
#
sub Gtk2::Gdk::Cursor::Glib_Ex_ConnectProperties_equal {
  my ($x, $y) = @_;
  if (! defined $x || ! defined $y) { return ((defined $x) == (defined $y)); }

  my $xtype = $x->type;
  if ($xtype eq 'cursor-is-pixmap') {
    return $x == $y;  # can't look into pixmap contents
  } else {
    return $xtype eq $y->type;  # standard cursors by type
  }
}

# Gtk2::Border at the perl level is a hashref of fields, or undef.
# In Gtk2::Entry it's just a Glib::Param::Boxed, compare here by values.
# Apart from Gtk2::Entry it's thankfully rare.
#
sub Gtk2::Border::Glib_Ex_ConnectProperties_equal {
  my ($x, $y) = @_;
  if (! defined $x || ! defined $y) { return ((defined $x) == (defined $y)); }

  return ($x->{'left'}      == $y->{'left'}
          && $x->{'right'}  == $y->{'right'}
          && $x->{'top'}    == $y->{'top'}
          && $x->{'bottom'} == $y->{'bottom'});
}

#------------------------------------------------------------------------------
# values_cmp fallback

BEGIN {
  if (! Glib::ParamSpec->can('values_cmp')) {
    no warnings 'once';

    # overall fallback: integers, characters by number; Glib::Object's by ref;
    # Glib::Boxed by value (fairly useless most of the time)
    *Glib::ParamSpec::Glib_Ex_ConnectProperties_values_cmp = sub {
      my ($pspec, $x, $y) = @_;
      if (! defined $x || ! defined $y) { return ((defined $x) <=> (defined $y))}
      return ($x <=> $y);
    };

    # string and enum by alphabetical
    # no Glib::Param::GType since values_cmp() exists whenever that one will ...
    *Glib::Param::String::Glib_Ex_ConnectProperties_values_cmp
      = *Glib::Param::Enum::Glib_Ex_ConnectProperties_values_cmp
        = sub {
          my ($pspec, $x, $y) = @_;
          if (! defined $x || ! defined $y) {
            return ((defined $x) <=> (defined $y));
          }
          return ($x cmp $y);
        };

    # bools allowing any 0, '', undef
    *Glib::Param::Boolean::Glib_Ex_ConnectProperties_values_cmp = sub {
      my ($pspec, $x, $y) = @_;
      return ((! $x) <=> (! $y));
    };

    # double following epsilon
    *Glib::Param::Double::Glib_Ex_ConnectProperties_values_cmp = sub {
      my ($pspec, $x, $y) = @_;
      my $epsilon = $pspec->get_epsilon;
      if ($x < $y) {
        return -($y-$x > $epsilon);
      } else {
        return ($x-$y > $epsilon);
      }
    };

    # float truncated to single precision before comparing, and following epsilon
    *Glib::Param::Float::Glib_Ex_ConnectProperties_values_cmp = sub {
      my ($pspec, $x, $y) = @_;
      ($x, $y) = unpack 'f2', pack ('f2', $x, $y);
      my $epsilon = $pspec->get_epsilon;
      if ($x < $y) {
        return -($y-$x > $epsilon);
      } else {
        return ($x-$y > $epsilon);
      }
    };
  }
}

1;
__END__