Re: GtkGC shared auto-release

[Torsten Schoenfeld <kaffeetisch gmx de>]

On Tue, 2008-01-01 at 21:37 -0500, muppet wrote:

> Should we just add this DESTROY override to the bindings?  (Taking  
> care to retain compatibility with code that calls ->release  
> explicitly, of course.)

Yes, I think that would make sense.  The only approach I can think of is
actually the one Kevin implemented.  Attached is an adaptation of it.
The in-place wrapping of Gtk2::GC methods makes it look and feel rather
dirty.  Is there a better way?

-- 
Bye,
-Torsten

Index: Gtk2.pm
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/Gtk2.pm,v
retrieving revision 1.116
diff -u -d -p -r1.116 Gtk2.pm
--- Gtk2.pm	9 Jan 2008 21:55:05 -0000	1.116
+++ Gtk2.pm	14 Jan 2008 23:24:24 -0000
@@ -200,6 +200,40 @@ sub connect_signals {
   }
 }
 
+package Gtk2::GC;
+
+# can't use base.pm as Gtk2::Gdk::GC hasn't been loaded yet
+our @ISA = qw(Gtk2::Gdk::GC);
+
+use constant COUNT_KEY => 'gtk2perl_gc_release_count';
+
+{
+  no warnings qw(redefine);
+
+  my $old_get = \&Gtk2::GC::get;
+  *Gtk2::GC::get = sub {
+    my $gc = $old_get->(@_);
+    $gc->{COUNT_KEY()}++;
+    return bless $gc, __PACKAGE__;
+  };
+
+  my $old_release = \&Gtk2::GC::release;
+  *Gtk2::GC::release = sub {
+    $_[1]->{COUNT_KEY()}--;
+    $old_release->(@_);
+  };
+
+  sub DESTROY {
+    my ($gc) = @_;
+    while ($gc->{COUNT_KEY()} > 0) {
+      $gc->{COUNT_KEY()}--;
+      $old_release->(__PACKAGE__, $gc);
+    }
+    $gc->SUPER::DESTROY;
+  }
+}
+
 package Gtk2;
 
 1;
Index: t/GtkGC.t
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/t/GtkGC.t,v
retrieving revision 1.1
diff -u -d -p -r1.1 GtkGC.t
--- t/GtkGC.t	19 Apr 2004 19:20:52 -0000	1.1
+++ t/GtkGC.t	14 Jan 2008 23:24:24 -0000
@@ -29,6 +29,22 @@ isa_ok($gc, "Gtk2::Gdk::GC");
 
 Gtk2::GC -> release($gc);
 
+# regression tests for the automatic releasing of GCs
+{
+  my $one = Gtk2::GC -> get(16, $colormap, $values);
+  Gtk2::GC -> get(16, $colormap, $values);
+  Gtk2::GC -> get(16, $colormap, $values);
+  Gtk2::GC -> release($one);
+  Gtk2::GC -> release($one);
+  Gtk2::GC -> release($one);
+
+  my $two = Gtk2::GC -> get(32, $colormap, $values);
+  Gtk2::GC -> get(32, $colormap, $values);
+  Gtk2::GC -> get(32, $colormap, $values);
+  # Gtk2::GC -> release($two) should now be called three times, but how do we
+  # verify that?
+}
+
 __END__
 
 Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the
Index: xs/GtkGC.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/xs/GtkGC.xs,v
retrieving revision 1.1
diff -u -d -p -r1.1 GtkGC.xs
--- xs/GtkGC.xs	19 Apr 2004 19:20:51 -0000	1.1
+++ xs/GtkGC.xs	14 Jan 2008 23:24:24 -0000
@@ -18,8 +18,7 @@ These functions provide access to a shar
 objects. When a new L<Gtk2::Gdk::GC> is needed, I<Gtk2::Gdk::GC::get> is called
 with the required depth, colormap and I<Gtk2::Gdk::GCValues>. If a
 L<Gtk2::Gdk::GC> with the required properties already exists then that is
-returned. If not, a new L<Gtk2::Gdk::GC> is created. When the L<Gtk2::Gdk::GC>
-is no longer needed, I<Gtk2::Gdk::GC::release> should be called.
+returned. If not, a new L<Gtk2::Gdk::GC> is created.
 
 [From: L<http://developer.gnome.org/doc/API/2.0/gtk/gtk-Graphics-Contexts.html>]
 
@@ -40,6 +39,8 @@ gtk_gc_get (class, depth, colormap, valu
     OUTPUT:
 	RETVAL
 
+=for apidoc __hide__
+=cut
 ## void gtk_gc_release (GdkGC *gc)
 void
 gtk_gc_release (class, gc)