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 is needed, I is called with the required depth, colormap and I. If a L with the required properties already exists then that is -returned. If not, a new L is created. When the L -is no longer needed, I should be called. +returned. If not, a new L is created. [From: L] @@ -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)