[gimp-perl] Gimp::Base->existing and become now check validity; test that.

[Ed J <edj src gnome org>]

commit dc71a24230f01eaba7ac52ffc95a9513f9e7a4ed
Author: Ed J <edj src gnome org>
Date:   Tue Jun 3 04:08:32 2014 +0100

    Gimp::Base->existing and become now check validity; test that.

 Gimp.pm |   52 ++++++++++++++++++++++++++++++++++++++++++++--------
 t/run.t |   14 ++++++++++++++
 2 files changed, 58 insertions(+), 8 deletions(-)
---
diff --git a/Gimp.pm b/Gimp.pm
index c34db15..88c245e 100644
--- a/Gimp.pm
+++ b/Gimp.pm
@@ -374,15 +374,38 @@ sub compare($$)           { $_[0]->[0] eq $_[1]->[0] and
                          $_[0]->[2] eq $_[1]->[2] }
 sub new($$$$)          { shift; [ _] }
 use overload '""' => sub { ref($_[0])."->new([ {[ join ', ', @{$_[0]} ]}])"; };
+sub id                 { goto &name; }
 }
 
 {
 package Gimp::Base;
 use overload '""' => sub { ref($_[0]).'->existing('.${$_[0]}.')'; };
-sub existing($$)       { my $id = $_[1]; bless \$id, $_[0]; }
-sub become($$)         { bless $_[0], $_[1]; }
+sub existing($$) {
+  my $id = $_[1];
+  my $self = bless \$id, $_[0];
+  Gimp::croak "$id not valid $_[0]" unless $self->is_valid;
+  $self;
+}
+sub become($$) {
+  warn "$$-".__PACKAGE__."::become(@_)" if $Gimp::verbose >= 2;
+  my ($self, $class) = @_;
+  my $old_class = ref $self;
+  bless $self, $class;
+  unless ($self->is_valid) {
+    warn "$$-$self->is_valid false" if $Gimp::verbose >= 2;
+    bless $self, $old_class;
+    Gimp::croak "$_[0] not valid $class"
+  }
+}
+sub id { ${+shift} }
 }
 
+sub Gimp::Channel::is_valid { shift->is_channel }
+sub Gimp::Drawable::is_valid { shift->is_drawable }
+sub Gimp::Layer::is_valid { shift->is_layer }
+sub Gimp::Selection::is_valid { shift->is_selection }
+sub Gimp::Vectors::is_valid { shift->is_vectors }
+
 1;
 __END__
 =head1 NAME
@@ -808,17 +831,30 @@ Methods:
 =head4 $object->become($class)
 
 Allows an object of one class to change its class to another, but with
-the same ID. No checking is performed. It is intended for use in plugins,
-e.g. where GIMP passes a C<Gimp::Drawable>, but you need a C<Gimp::Layer>:
+the same ID. If a method call of C<is_valid> returns false, an exception
+will be thrown. It is intended for use in plugins, e.g. where GIMP passes
+a C<Gimp::Drawable>, but you need a C<Gimp::Layer>:
 
-  my ($image, $layer, $color) = @_;
-  die "Can only operate on a layer\n" unless $layer->is_layer;
-  $layer->become('Gimp::Layer'); # now can call layer methods on it
+  my ($image, $drawable, $color) = @_;
+  $drawable->become('Gimp::Layer'); # now can call layer methods on it
 
 =head4 $class->existing($id)
 
 Allows you to instantiate a Gimp-Perl object with the given C<$class>
-and C<$id>. Again, no checking is performed.
+and C<$id>. The same check as above is done, throwing an exception
+if failed.
+
+=head4 $object->id
+
+Returns the underlying GIMP identifier, an integer.
+
+=head4 $object->is_valid
+
+Returns true if the object is a valid object of the relevant class.
+Subclasses use appropriate GIMP functions: e.g. Gimp::Layer uses
+C<gimp_item_is_layer>.
+
+=head4 stringify
 
 It also provides a "stringify" overload method, so debugging output can
 be more readable.
diff --git a/t/run.t b/t/run.t
index 7caad80..9463f4a 100644
--- a/t/run.t
+++ b/t/run.t
@@ -46,6 +46,20 @@ cmp_ok(ref($vectors), 'eq', 'Gimp::Vectors', 'vectors object returned');
 my $vectorstring = $vectors->export_to_string; # takes VECTORS as input - QED
 like($vectorstring, qr/<path id="hi"/, 'vector string plausible');
 
+my $i2 = $i->duplicate;
+eval { $i2->become('Gimp::Channel') };
+ok($@, 'image become channel exception');
+isa_ok($i2, 'Gimp::Image', 'still image');
+eval { $i2->become('Gimp::Image') };
+is($@, '', 'image become image succeeds');
+
+my $l2 = $i->get_active_layer;
+eval { $l2->become('Gimp::Layer') };
+is($@, '', 'layer become layer succeeds');
+eval { $l2->become('Gimp::Channel') };
+ok($@, 'layer become channel exception');
+
+$i2->delete;
 ok(!$i->delete, 'remove image');
 
 Gimp::Net::server_quit;