#!/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});
    TODO: {
      local $TODO = $package =~ /^Weak/
        ? 'ref count test unreliable due to unpredictable behavior of perl-Glib'
        : undef;
      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});
    TODO: {
      local $TODO = $package =~ /^Weak/
        ? 'ref count test unreliable due to unpredictable behavior of perl-Glib'
        : undef;
      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};
  }
}