[libnet-dbus-perl] 281/335: Implement GetAll method on properties interface

[Intrigeri]

This is an automated email from the git hooks/post-receive script.

intrigeri pushed a commit to branch experimental
in repository libnet-dbus-perl.

commit 3534207392465dcf4c0c0bcb81cadaec8b7d807d
Author: Daniel P. Berrange <dan at berrange.com>
Date:   Tue Jun 28 22:10:50 2011 +0100

    Implement GetAll method on properties interface
---
 AUTHORS                |  1 +
 lib/Net/DBus/Object.pm | 40 ++++++++++++++++++++++++++++++++++++++++
 t/60-object-props.t    | 21 ++++++++++++++++++++-
 3 files changed, 61 insertions(+), 1 deletion(-)

diff --git a/AUTHORS b/AUTHORS
index 0ad65e6..3065b00 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -14,6 +14,7 @@ from
     Jack <ms419-at-freezone-dot-co-dot-uk>
     Dave Belser <dbelser-at-aerosat-dot-com>
     Stefan Pfetzing <dreamind at dreamind.de>
+    Pavel Strashkin <pavel.strashkin at gmail.com>
 
     [...send patches to get your name here!]
 
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 64345c1..af5d5ad 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -131,6 +131,7 @@ use Net::DBus::Exporter "org.freedesktop.DBus.Introspectable";
 dbus_method("Introspect", [], ["string"]);
 
 dbus_method("Get", ["string", "string"], [["variant"]], "org.freedesktop.DBus.Properties");
+dbus_method("GetAll", ["string"], [["dict", "string", ["variant"]]], "org.freedesktop.DBus.Properties");
 dbus_method("Set", ["string", "string", ["variant"]], [], "org.freedesktop.DBus.Properties");
 
 =item my $object = Net::DBus::Object->new($service, $path)
@@ -485,6 +486,8 @@ sub _dispatch {
     } elsif ($interface eq "org.freedesktop.DBus.Properties") {
 	if ($method_name eq "Get") {
 	    $reply = $self->_dispatch_prop_read($connection, $message);
+	} elsif ($method_name eq "GetAll") {
+	    $reply = $self->_dispatch_all_prop_read($connection, $message);
 	} elsif ($method_name eq "Set") {
 	    $reply = $self->_dispatch_prop_write($connection, $message);
 	}
@@ -578,6 +581,43 @@ sub _dispatch_prop_read {
     }
 }
 
+sub _dispatch_all_prop_read {
+    my $self = shift;
+    my $connection = shift;
+    my $message = shift;
+
+    my $ins = $self->_introspector;
+
+    if (!$ins) {
+	return $connection->make_error_message($message,
+					       "org.freedesktop.DBus.Error.Failed",
+					       "no introspection data exported for properties");
+    }
+
+    my ($pinterface) = $ins->decode($message, "methods", "Get", "params");
+
+    my %values = ();
+    foreach my $pname ($ins->list_properties($pinterface)) {
+    	unless ($ins->is_property_readable($pinterface, $pname)) {
+		next; # skip write-only properties
+	}
+
+	$values{$pname} = eval {
+	    $self->$pname;
+	};
+	if ($@) {
+	    return $connection->make_error_message($message,
+						   "org.freedesktop.DBus.Error.Failed",
+						   "error reading '$pname' in interface '$pinterface': $@");
+	}
+    }
+
+    my $reply = $connection->make_method_return_message($message);
+
+    $self->_introspector->encode($reply, "methods", "Get", "returns", \%values);
+    return $reply;
+}
+
 sub _dispatch_prop_write {
     my $self = shift;
     my $connection = shift;
diff --git a/t/60-object-props.t b/t/60-object-props.t
index 003e2ed..368e879 100644
--- a/t/60-object-props.t
+++ b/t/60-object-props.t
@@ -1,5 +1,5 @@
 # -*- perl -*-
-use Test::More tests => 16;
+use Test::More tests => 18;
 
 use strict;
 use warnings;
@@ -270,3 +270,22 @@ SET_HEIGHT: {
     ok($object->height > 1.410 &&
        $object->height < 1.420, "height is 1.414");
 }
+
+GET_ALL: {
+    my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
+							   object_path => "/org/example/MyObject",
+							   interface => "org.freedesktop.DBus.Properties",
+							   method_name => "GetAll");
+
+    my $iter = $msg->iterator(1);
+    $iter->append_string("org.example.MyObject");
+    $iter->append_string("name");
+
+    my $reply = $bus->get_connection->send_with_reply_and_block($msg);
+
+    is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
+
+    my ($value) = $reply->get_args_list;
+    # we use sort because there is no strict order of keys(...) call result
+    is_deeply([sort(keys(%$value))], [sort("name", "email", "parents")], "all readable properties have been received");
+}

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git