[perl-Glib-Object-Introspection] Handle GInitiallyUnowned return values from callbacks more specifically

[Torsten SchÃnfeld <tsch src gnome org>]

commit 8753c08c82bd18c59e5eecc8802f9eecb5695701
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date:   Fri Feb 8 01:35:27 2013 +0100

    Handle GInitiallyUnowned return values from callbacks more specifically
    
    Only add an additional ref if the object would otherwise be destroyed.  Also,
    warn when this happens.

 gperl-i11n-invoke-perl.c                       |   16 --
 gperl-i11n-marshal-interface.c                 |   17 ++-
 t/{vfunc-implementation.t => vfunc-chaining.t} |    0
 t/vfunc-ref-counting.t                         |  237 ++++++++++++++++++++++++
 4 files changed, 250 insertions(+), 20 deletions(-)
---
diff --git a/gperl-i11n-invoke-perl.c b/gperl-i11n-invoke-perl.c
index e2828d8..f4e2e9e 100644
--- a/gperl-i11n-invoke-perl.c
+++ b/gperl-i11n-invoke-perl.c
@@ -369,22 +369,6 @@ _prepare_perl_invocation_info (GPerlI11nInvocationInfo *iinfo,
 	iinfo->return_type_transfer = g_callable_info_get_caller_owns (info);
 
 	iinfo->dynamic_stack_offset = 0;
-
-	/* If the callback is supposed to return a GInitiallyUnowned object
-	 * then we must enforce GI_TRANSFER_EVERYTHING.  Otherwise, if the Perl
-	 * code returns a newly created object, FREETMPS would finalize it. */
-	if (g_type_info_get_tag (iinfo->return_type_info) == GI_TYPE_TAG_INTERFACE &&
-	    iinfo->return_type_transfer == GI_TRANSFER_NOTHING)
-	{
-		GIBaseInfo *interface = g_type_info_get_interface (iinfo->return_type_info);
-		if (GI_IS_REGISTERED_TYPE_INFO (interface) &&
-		    g_type_is_a (get_gtype (interface),
-		                 G_TYPE_INITIALLY_UNOWNED))
-		{
-			iinfo->return_type_transfer = GI_TRANSFER_EVERYTHING;
-		}
-		g_base_info_unref (interface);
-	}
 }
 
 static void
diff --git a/gperl-i11n-marshal-interface.c b/gperl-i11n-marshal-interface.c
index 09025d0..223bb14 100644
--- a/gperl-i11n-marshal-interface.c
+++ b/gperl-i11n-marshal-interface.c
@@ -124,10 +124,19 @@ sv_to_interface (GIArgInfo * arg_info,
 		} else {
 			arg->v_pointer = gperl_get_object_check (sv, get_gtype (interface));
 		}
-		if (arg->v_pointer && transfer >= GI_TRANSFER_CONTAINER) {
-			g_object_ref (arg->v_pointer);
-			if (G_IS_INITIALLY_UNOWNED (arg->v_pointer)) {
-				g_object_force_floating (arg->v_pointer);
+		if (arg->v_pointer) {
+			GObject *object = arg->v_pointer;
+			if (transfer == GI_TRANSFER_NOTHING &&
+			    object->ref_count == 1 &&
+			    SvTEMP (sv) && SvREFCNT (SvRV (sv)) == 1)
+			{
+				cwarn ("*** Asked to hand out object without ownership transfer, "
+				       "but object is about to be destroyed; "
+				       "adding an additional reference for safety");
+				transfer = GI_TRANSFER_EVERYTHING;
+			}
+			if (transfer >= GI_TRANSFER_CONTAINER) {
+				g_object_ref (arg->v_pointer);
 			}
 		}
 		break;
diff --git a/t/vfunc-implementation.t b/t/vfunc-chaining.t
similarity index 100%
rename from t/vfunc-implementation.t
rename to t/vfunc-chaining.t
diff --git a/t/vfunc-ref-counting.t b/t/vfunc-ref-counting.t
new file mode 100644
index 0000000..f3c26a5
--- /dev/null
+++ b/t/vfunc-ref-counting.t
@@ -0,0 +1,237 @@
+#!/usr/bin/env perl
+
+BEGIN { require './t/inc/setup.pl' };
+
+use strict;
+use warnings;
+use Scalar::Util;
+
+plan skip_all => 'Need gobject-introspection 1.35.5'
+  unless check_gi_version (1, 35, 5);
+plan tests => 68;
+
+my @packages = qw/WeakNonFloater WeakFloater StrongNonFloater StrongFloater/;
+my %package_to_subclass = (
+  WeakNonFloater => 'NonFloatingObjectSubclass',
+  WeakFloater => 'FloatingObjectSubclass',
+  StrongNonFloater => 'NonFloatingObjectSubclass',
+  StrongFloater => 'FloatingObjectSubclass',
+);
+my %package_to_warner = (
+  WeakNonFloater => sub { die $_[0] if -1 == index $_[0], 'Asked to hand out object' },
+  WeakFloater => sub { die $_[0] if -1 == index $_[0], 'Asked to hand out object' },
+  StrongNonFloater => sub { die $_[0] },
+  StrongFloater => sub { die $_[0] },
+);
+my %package_to_ref_count_offset = (
+  WeakNonFloater => 0,
+  WeakFloater => 0,
+  StrongNonFloater => 1,
+  StrongFloater => 1,
+);
+my %package_to_ref_gone = (
+  WeakNonFloater => Glib::TRUE,
+  WeakFloater => Glib::TRUE,
+  StrongNonFloater => Glib::FALSE,
+  StrongFloater => Glib::FALSE,
+);
+my %package_to_floating = (
+  WeakNonFloater => Glib::FALSE,
+  WeakFloater => Glib::TRUE,
+  StrongNonFloater => Glib::FALSE,
+  StrongFloater => Glib::TRUE,
+);
+
+# Test that the invocant is not leaked.
+foreach my $package (@packages) {
+  {
+    my $nf = $package->new;
+    $nf->get_ref_info_for_vfunc_return_object_transfer_full;
+    Scalar::Util::weaken ($nf);
+    is ($nf, undef, "no leak for $package");
+  }
+}
+
+# Test transfer-none&return/out semantics.
+foreach my $package (@packages) {
+  local $SIG{__WARN__} = $package_to_warner{$package};
+  foreach my $method (qw/get_ref_info_for_vfunc_return_object_transfer_none
+                         get_ref_info_for_vfunc_out_object_transfer_none/)
+  {
+    my $nf = $package->new;
+    my ($ref_count, $is_floating) = $nf->$method;
+    is ($ref_count, 1, "transfer-none&return/out: ref count for $package");
+    ok (!$is_floating, "transfer-none&return/out: floating for $package");
+  }
+}
+
+# Test transfer-full&return/out semantics.
+foreach my $package (@packages) {
+  foreach my $method (qw/get_ref_info_for_vfunc_return_object_transfer_full
+                         get_ref_info_for_vfunc_out_object_transfer_full/)
+  {
+    my $nf = $package->new;
+    my ($ref_count, $is_floating) = $nf->$method;
+    is ($ref_count, 1 + $package_to_ref_count_offset{$package},
+        "transfer-full&return/out: ref count for $package");
+    ok (!$is_floating, "transfer-full&return/out: floating for $package");
+    is ($nf->is_ref_gone, $package_to_ref_gone{$package},
+        "transfer-full&return/out: ref gone for $package");
+  }
+}
+
+# Test transfer-none&in semantics.
+foreach my $package (@packages) {
+  {
+    my $nf = $package->new;
+    my ($ref_count, $is_floating) =
+      $nf->get_ref_info_for_vfunc_in_object_transfer_none ($package_to_subclass{$package});
+    SKIP: {
+      skip 'ref count test; need newer Glib', 1
+        unless $Glib::VERSION > 1.290;
+      is ($ref_count, 1 + $package_to_ref_count_offset{$package},
+          "transfer-none&in: ref count for $package");
+    }
+    is ($is_floating, $package_to_floating{$package},
+        "transfer-none&in: floating for $package");
+    is ($nf->is_ref_gone, $package_to_ref_gone{$package},
+        "transfer-none&in: ref gone for $package");
+  }
+}
+
+# Test transfer-full&in semantics.
+foreach my $package (@packages) {
+  {
+    my $nf = $package->new;
+    my ($ref_count, $is_floating) =
+      $nf->get_ref_info_for_vfunc_in_object_transfer_full ($package_to_subclass{$package});
+    SKIP: {
+      skip 'ref count test; need newer Glib', 1
+        unless $Glib::VERSION > 1.290;
+      is ($ref_count, 0 + $package_to_ref_count_offset{$package},
+          "transfer-full&in: ref count for $package");
+    }
+    ok (!$is_floating, "transfer-full&in: floating for $package");
+    is ($nf->is_ref_gone, $package_to_ref_gone{$package},
+        "transfer-full&in: ref gone for $package");
+  }
+}
+
+# --------------------------------------------------------------------------- #
+
+{
+  package NonFloatingObjectSubclass;
+  use Glib::Object::Subclass 'Glib::Object';
+}
+
+{
+  package FloatingObjectSubclass;
+  use Glib::Object::Subclass 'Glib::InitiallyUnowned';
+}
+
+{
+  package Base;
+  use Glib::Object::Subclass 'GI::Object';
+
+  sub VFUNC_RETURN_OBJECT_TRANSFER_NONE {
+    my ($self) = @_;
+    my $o = $self->_create;
+    $self->_store ($o);
+    return $o;
+  }
+  sub VFUNC_RETURN_OBJECT_TRANSFER_FULL {
+    my ($self) = @_;
+    my $o = $self->_create;
+    $self->_store ($o);
+    return $o;
+  }
+  sub VFUNC_OUT_OBJECT_TRANSFER_NONE {
+    my ($self) = @_;
+    my $o = $self->_create;
+    $self->_store ($o);
+    return $o;
+  }
+  sub VFUNC_OUT_OBJECT_TRANSFER_FULL {
+    my ($self) = @_;
+    my $o = $self->_create;
+    $self->_store ($o);
+    return $o;
+  }
+  sub VFUNC_IN_OBJECT_TRANSFER_NONE {
+    my ($self, $o) = @_;
+    $self->_store ($o);
+  }
+  sub VFUNC_IN_OBJECT_TRANSFER_FULL {
+    my ($self, $o) = @_;
+    $self->_store ($o);
+  }
+
+  sub is_ref_gone {
+    my ($self) = @_;
+    not defined $self->_retrieve;
+  }
+}
+{
+  package WeakNonFloater;
+  use Glib::Object::Subclass 'Base';
+
+  sub _create {
+    NonFloatingObjectSubclass->new;
+  }
+  sub _store {
+    my ($self, $o) = @_;
+    Scalar::Util::weaken ($self->{_ref} = $o);
+  }
+  sub _retrieve {
+    my ($self) = @_;
+    $self->{_ref};
+  }
+}
+{
+  package WeakFloater;
+  use Glib::Object::Subclass 'Base';
+
+  sub _create {
+    FloatingObjectSubclass->new;
+  }
+  sub _store {
+    my ($self, $o) = @_;
+    Scalar::Util::weaken ($self->{_ref} = $o);
+  }
+  sub _retrieve {
+    my ($self) = @_;
+    $self->{_ref};
+  }
+}
+{
+  package StrongNonFloater;
+  use Glib::Object::Subclass 'Base';
+
+  sub _create {
+    NonFloatingObjectSubclass->new;
+  }
+  sub _store {
+    my ($self, $o) = @_;
+    $self->{_ref} = $o;
+  }
+  sub _retrieve {
+    my ($self) = @_;
+    $self->{_ref};
+  }
+}
+{
+  package StrongFloater;
+  use Glib::Object::Subclass 'Base';
+
+  sub _create {
+    FloatingObjectSubclass->new;
+  }
+  sub _store {
+    my ($self, $o) = @_;
+    $self->{_ref} = $o;
+  }
+  sub _retrieve {
+    my ($self) = @_;
+    $self->{_ref};
+  }
+}