# -*- perl -*-

use Test::More tests => 56;

use strict;
use warnings;

BEGIN { 
    use_ok('Net::DBus::Binding::Introspector') or die;
    use_ok('Net::DBus::Object') or die;
    use_ok('Net::DBus::Test::MockObject') or die;
};


TEST_NO_INTROSPECT: {
    my ($bus, $object, $robject, $myobject, $otherobject) = &setup;

    $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", 
			 error => { name => "org.freedesktop.DBus.Error.Failed",
				    description => "No such method" });

    &test_method_fail("raw, no introspect", $robject, "Test");
    &test_method_reply("myobject, no introspect",$myobject, "Test", "TestedMyObject");
    &test_method_fail("otherobject, no introspect",$otherobject, "Test");

    &test_method_fail("raw, no introspect",$robject, "Bogus");
    &test_method_fail("myobject, no introspect",$myobject, "Bogus");
    &test_method_fail("otherobject, no introspect",$otherobject, "Bogus");

    &test_method_fail("raw, no introspect",$robject, "PolyTest");
    &test_method_reply("myobject, no introspect",$myobject, "PolyTest", "PolyTestedMyObject");
    &test_method_reply("otherobject, no introspect",$otherobject, "PolyTest", "PolyTestedOtherObject");

    &test_method_fail("raw, no introspect", $robject, "Deprecated");
    &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation");
    &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
}

TEST_MISSING_INTROSPECT: {
    my ($bus, $object, $robject, $myobject, $otherobject) = &setup;

    my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);    
    $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", 
			 reply => { return => [ $ins->format ] });
    

    &test_method_fail("raw, missing introspect",$robject, "Test");
    &test_method_reply("myobject, missing introspect",$myobject, "Test", "TestedMyObject");
    &test_method_fail("otherobject, missing introspect",$otherobject, "Test");

    &test_method_fail("raw, missing introspect",$robject, "Bogus");
    &test_method_fail("myobject, missing introspect",$myobject, "Bogus");
    &test_method_fail("otherobject, missing introspect",$otherobject, "Bogus");

    &test_method_fail("raw, missing introspect",$robject, "PolyTest");
    &test_method_reply("myobject, missing introspect",$myobject, "PolyTest", "PolyTestedMyObject");
    &test_method_reply("otherobject, missing introspect",$otherobject, "PolyTest", "PolyTestedOtherObject");

    &test_method_fail("raw, no introspect", $robject, "Deprecated");
    &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation");
    &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
}

TEST_FULL_INTROSPECT: {
    my ($bus, $object, $robject, $myobject, $otherobject) = &setup;

    my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
    $ins->add_method("Test", [], ["string"], "org.example.MyObject", {}, []);
    $ins->add_method("PolyTest", [], ["string"], "org.example.MyObject", {}, []);
    $ins->add_method("PolyTest", [], ["string"], "org.example.OtherObject", {}, []);
    $ins->add_method("Deprecated", [], ["string"], "org.example.MyObject", { deprecated => 1 }, []);
    $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", 
			 reply => { return => [ $ins->format ] });
    

    &test_method_reply("raw, full introspect",$robject, "Test", "TestedMyObject");
    &test_method_reply("myobject, full introspect",$myobject, "Test", "TestedMyObject");
    &test_method_fail("otherobject, full introspect",$otherobject, "Test");

    &test_method_fail("raw, full introspect",$robject, "Bogus");
    &test_method_fail("myobject, full introspect",$myobject, "Bogus");
    &test_method_fail("otherobject, full introspect",$otherobject, "Bogus");

    &test_method_fail("raw, full introspect",$robject, "PolyTest");
    &test_method_reply("myobject, full introspect",$myobject, "PolyTest", "PolyTestedMyObject");
    &test_method_reply("otherobject, full introspect",$otherobject, "PolyTest", "PolyTestedOtherObject");
    
    {
	my $warned = 0;
	local $SIG{__WARN__} = sub {
	    if ($_[0] eq "method 'Deprecated' in interface org.example.MyObject on object /org/example/MyObject is deprecated\n") {
		$warned = 1;
	    }
	};
	&test_method_reply("raw, no introspect", $robject, "Deprecated", "TestedDeprecation");
	ok($warned, "deprecation warning generated");
	$warned = 0;
	&test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation");
	ok($warned, "deprecation warning generated");
	$warned = 0;
	&test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
	ok(!$warned, "deprecation warning generated");
    }
}


sub setup {
    my $bus = Net::DBus->test;
    my $service = $bus->export_service("org.cpan.Net.Bus.test");
    
    my $object = Net::DBus::Test::MockObject->new($service, "/org/example/MyObject");
    
    my $rservice = $bus->get_service("org.cpan.Net.Bus.test");
    my $robject = $rservice->get_object("/org/example/MyObject");
    my $myobject = $robject->as_interface("org.example.MyObject");
    my $otherobject = $robject->as_interface("org.example.OtherObject");

    $object->seed_action("org.example.MyObject", "Test", reply => { return => [ "TestedMyObject" ] });
    $object->seed_action("org.example.MyObject", "PolyTest", reply => { return => [ "PolyTestedMyObject" ] });
    $object->seed_action("org.example.OtherObject", "PolyTest", reply => { return => [ "PolyTestedOtherObject" ] });
    $object->seed_action("org.example.MyObject", "Deprecated", reply => { return => [ "TestedDeprecation" ]});
    $object->seed_action("org.example.MyObject", "TestNoReturn");
    
    return ($bus, $object, $robject, $myobject, $otherobject);
}

sub test_method_noreply {
    my $tag = shift;
    my $object = shift;
    my $method = shift;
    
    my $actual = eval {
	$object->$method;
    };
    is($@, "", "error is not thrown by '$method' ($tag)");
    ok(!$actual, "return from '$method' is undefined ($tag)");
}

sub test_method_reply {
    my $tag = shift;
    my $object = shift;
    my $method = shift;
    my $expect = shift;
    
    my $actual = eval {
	$object->$method;
    };
    is($@, "", "error is not thrown by '$method' ($tag)");
    is($actual, $expect, "return from '$method' is '$actual' ($tag)");
}

sub test_method_fail {
    my $tag = shift;
    my $object = shift;
    my $method = shift;
    
    my $actual = eval {
	$object->$method;
    };
    ok($@, "error is thrown by '$method' ($tag)");
}