[libnet-dbus-perl] 96/335: Added initial support for org.freedesktop.DBus.Properties
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:32 UTC 2015
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 fb91c2afbacb9621620a6b9963c3ef8c8adda539
Author: Daniel P. Berrange <dan at berrange.com>
Date: Thu Sep 8 21:00:23 2005 +0000
Added initial support for org.freedesktop.DBus.Properties
---
CHANGES | 10 ++
README | 4 +-
lib/Net/DBus.pm | 2 +-
lib/Net/DBus/Binding/Introspector.pm | 103 +++++++++++-
lib/Net/DBus/Exporter.pm | 30 +++-
lib/Net/DBus/Object.pm | 126 +++++++++++++--
lib/Net/DBus/RemoteObject.pm | 65 +++++---
t/40-introspector.t | 21 ++-
t/50-object-introspect.t | 12 ++
t/60-object-props.t | 292 +++++++++++++++++++++++++++++++++++
10 files changed, 629 insertions(+), 36 deletions(-)
diff --git a/CHANGES b/CHANGES
index 48b40f4..1f8ae95 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,4 +1,14 @@
+Changes since 0.32.1
+
+ - Fix unit tests broken in previous build
+
+ - Added patch to avoid leaking memory when throwing dbus
+ errors from the XS layer
+
+ - Added full support for org.freedesktop.DBus.Properties
+ in exported & remote objects.
+
Changes since 0.32.0
- The order of 'service_name' and 'bus' parameter to the
diff --git a/README b/README
index 60f0f71..50d4dde 100644
--- a/README
+++ b/README
@@ -1,5 +1,5 @@
-Net::DBus version 0.32.0
-========================
+ Net::DBus
+ =========
Net::DBus provides a Perl XS API to the dbus inter-application
messaging system. The Perl API covers the core base level
diff --git a/lib/Net/DBus.pm b/lib/Net/DBus.pm
index 89ba61e..e2a788e 100644
--- a/lib/Net/DBus.pm
+++ b/lib/Net/DBus.pm
@@ -70,7 +70,7 @@ use Carp;
BEGIN {
- our $VERSION = '0.32.1';
+ our $VERSION = '0.32.2';
require XSLoader;
XSLoader::load('Net::DBus', $VERSION);
}
diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
index 47ce55d..4449aea 100644
--- a/lib/Net/DBus/Binding/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -39,6 +39,7 @@ our %simple_type_map = (
"int64" => &Net::DBus::Binding::Message::TYPE_INT64,
"uint64" => &Net::DBus::Binding::Message::TYPE_UINT64,
"object" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
+ "variant" => &Net::DBus::Binding::Message::TYPE_VARIANT,
);
our %simple_type_rev_map = (
@@ -51,6 +52,7 @@ our %simple_type_rev_map = (
&Net::DBus::Binding::Message::TYPE_INT64 => "int64",
&Net::DBus::Binding::Message::TYPE_UINT64 => "uint64",
&Net::DBus::Binding::Message::TYPE_OBJECT_PATH => "object",
+ &Net::DBus::Binding::Message::TYPE_VARIANT => "variant",
);
our %compound_type_map = (
@@ -60,8 +62,6 @@ our %compound_type_map = (
);
-our $VERSION = '0.0.1';
-
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
@@ -70,6 +70,7 @@ sub new {
$self->{methods} = {};
$self->{signals} = {};
+ $self->{props} = {};
$self->{interfaces} = {};
bless $self, $class;
@@ -94,6 +95,9 @@ sub new {
foreach my $signal (keys %{$interface->{signals}}) {
$self->{signals}->{$signal} = $interface->{signals}->{$signal};
}
+ foreach my $prop (keys %{$interface->{props}}) {
+ $self->{props}->{$prop} = $interface->{props}->{$prop};
+ }
}
return $self;
@@ -106,6 +110,7 @@ sub add_interface {
$self->{interfaces}->{$name} = {
methods => {},
signals => {},
+ props => {},
} unless exists $self->{interfaces}->{$name};
}
@@ -136,6 +141,28 @@ sub has_signal {
}
+sub has_property {
+ my $self = shift;
+ my $name = shift;
+
+ if (@_) {
+ my $interface = shift;
+ return () unless exists $self->{interfaces}->{$interface};
+ return () unless exists $self->{interfaces}->{$interface}->{props}->{$name};
+ return ($interface);
+ } else {
+ my @interfaces;
+ foreach my $interface (keys %{$self->{interfaces}}) {
+
+ if (exists $self->{interfaces}->{$interface}->{props}->{$name}) {
+ push @interfaces, $interface;
+ }
+ }
+ return @interfaces;
+ }
+}
+
+
sub add_method {
my $self = shift;
my $name = shift;
@@ -163,6 +190,20 @@ sub add_signal {
}
+sub add_property {
+ my $self = shift;
+ my $name = shift;
+ my $type = shift;
+ my $access = shift;
+ my $interface = shift;
+
+ $self->add_interface($interface);
+
+ $self->{props}->{$name} = [$type, $access];
+ $self->{interfaces}->{$interface}->{props}->{$name} = $self->{props}->{$name};
+}
+
+
sub list_interfaces {
my $self = shift;
@@ -181,6 +222,12 @@ sub list_signals {
return keys %{$self->{interfaces}->{$interface}->{signals}};
}
+sub list_properties {
+ my $self = shift;
+ my $interface = shift;
+ return keys %{$self->{interfaces}->{$interface}->{props}};
+}
+
sub get_object_path {
my $self = shift;
return $self->{object_path};
@@ -208,6 +255,31 @@ sub get_signal_params {
}
+sub get_property_type {
+ my $self = shift;
+ my $interface = shift;
+ my $prop = shift;
+ return $self->{interfaces}->{$interface}->{props}->{$prop}->[0];
+}
+
+
+sub is_property_readable {
+ my $self = shift;
+ my $interface = shift;
+ my $prop = shift;
+ my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->[1];
+ return $access eq "readwrite" || $access eq "read" ? 1 : 0;
+}
+
+
+sub is_property_writable {
+ my $self = shift;
+ my $interface = shift;
+ my $prop = shift;
+ my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->[1];
+ return $access eq "readwrite" || $access eq "write" ? 1 : 0;
+}
+
sub _parse {
my $self = shift;
@@ -253,6 +325,7 @@ sub _parse_interface {
$self->{interfaces}->{$name} = {
methods => {},
signals => {},
+ props => {},
};
foreach my $child (@{$node->{Contents}}) {
@@ -262,6 +335,9 @@ sub _parse_interface {
} elsif (ref($child) eq "XML::Grove::Element" &&
$child->{Name} eq "signal") {
$self->_parse_signal($child, $name);
+ } elsif (ref($child) eq "XML::Grove::Element" &&
+ $child->{Name} eq "property") {
+ $self->_parse_property($child, $name);
}
}
}
@@ -369,6 +445,19 @@ sub _parse_signal {
\@params;
}
+sub _parse_property {
+ my $self = shift;
+ my $node = shift;
+ my $interface = shift;
+
+ my $name = $node->{Attributes}->{name};
+ my $access = $node->{Attributes}->{access};
+
+ $self->{interfaces}->{$interface}->{props}->{$name} =
+ [ $self->_parse_type([$node->{Attributes}->{type}]),
+ $access ];
+}
+
sub format {
my $self = shift;
@@ -412,6 +501,13 @@ sub to_xml {
$xml .= $indent . ' </signal>' . "\n";
}
+ foreach my $pname (sort { $a cmp $b } keys %{$interface->{props}}) {
+ my $type = $interface->{props}->{$pname}->[0];
+ my $access = $interface->{props}->{$pname}->[1];
+ $xml .= $indent . ' <property name="' . $pname . '" type="' .
+ $self->to_xml_type($type) . '" access="' . $access . '"/>' . "\n";
+ }
+
$xml .= $indent . ' </interface>' . "\n";
}
@@ -464,6 +560,7 @@ sub to_xml_type {
return $sig;
}
+# XXX we should be passing interface name along with method
sub encode {
my $self = shift;
my $message = shift;
@@ -522,6 +619,8 @@ sub convert {
return @out;
}
+
+# XXX we should be passing interface name along with methods
sub decode {
my $self = shift;
my $message = shift;
diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
index a54c783..5dbb44d 100644
--- a/lib/Net/DBus/Exporter.pm
+++ b/lib/Net/DBus/Exporter.pm
@@ -255,7 +255,7 @@ use warnings;
require Exporter;
@ISA = qw(Exporter);
- at EXPORT = qw(dbus_method dbus_signal);
+ at EXPORT = qw(dbus_method dbus_signal dbus_property);
sub import {
@@ -270,6 +270,7 @@ sub import {
$dbus_exports{$caller} = {
methods => {},
signals => {},
+ props => {},
};
die "usage: use Net::DBus::Exporter 'interface-name';" unless @_;
@@ -333,6 +334,10 @@ sub _dbus_introspector_add {
my ($params, $returns, $interface) = @{$exports->{methods}->{$method}};
$introspector->add_method($method, $params, $returns, $interface);
}
+ foreach my $prop (keys %{$exports->{props}}) {
+ my ($type, $access, $interface) = @{$exports->{props}->{$prop}};
+ $introspector->add_property($prop, $type, $access, $interface);
+ }
foreach my $signal (keys %{$exports->{signals}}) {
my ($params, $interface) = @{$exports->{signals}->{$signal}};
$introspector->add_signal($signal, $params, $interface);
@@ -372,6 +377,29 @@ sub dbus_method {
}
+sub dbus_property {
+ my $name = shift;
+ my $type = shift;
+ my $access = shift;
+
+ $access = "readwrite" unless defined $access;
+
+ my $caller = caller;
+ my $is = $dbus_exports{$caller};
+
+ my $interface;
+ if (@_) {
+ $interface = shift;
+ } elsif (!exists $is->{interface}) {
+ die "interface not specified & not default interface defined";
+ } else {
+ $interface = $is->{interface};
+ }
+
+ $is->{props}->{$name} = [$type, $access, $interface];
+}
+
+
sub dbus_signal {
my $name = shift;
my $params = shift;
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index e306dc7..1e07fcf 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -150,6 +150,9 @@ use Net::DBus::Binding::Message::MethodReturn;
dbus_method("Introspect", [], ["string"]);
+dbus_method("Get", ["string", "string"], ["variant"], "org.freedesktop.DBus.Properties");
+dbus_method("Set", ["string", "string", "variant"], [], "org.freedesktop.DBus.Properties");
+
sub new {
my $class = shift;
my $self = $class->_new(@_);
@@ -283,7 +286,23 @@ sub _dispatch {
my $reply;
my $method_name = $message->get_member;
- if ($self->can($method_name)) {
+ my $interface = $message->get_interface;
+ if ($interface eq "org.freedesktop.DBus.Introspectable") {
+ if ($method_name eq "Introspect" &&
+ $self->_introspector &&
+ $ENABLE_INTROSPECT) {
+ my $xml = $self->_introspector->format;
+ $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
+
+ $self->_introspector->encode($reply, "methods", $method_name, "returns", $xml);
+ }
+ } elsif ($interface eq "org.freedesktop.DBus.Properties") {
+ if ($method_name eq "Get") {
+ $reply = $self->_dispatch_prop_read($message);
+ } elsif ($method_name eq "Set") {
+ $reply = $self->_dispatch_prop_write($message);
+ }
+ } elsif ($self->can($method_name)) {
my $ins = $self->_introspector;
my @args;
if ($ins) {
@@ -307,14 +326,9 @@ sub _dispatch {
$reply->append_args_list(@ret);
}
}
- } elsif ($method_name eq "Introspect" &&
- $self->_introspector &&
- $ENABLE_INTROSPECT) {
- my $xml = $self->_introspector->format;
- $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
-
- $self->_introspector->encode($reply, "methods", $method_name, "returns", $xml);
- } else {
+ }
+
+ if (!$reply) {
$reply = Net::DBus::Binding::Message::Error->new(replyto => $message,
name => "org.freedesktop.DBus.Error.Failed",
description => "No such method " . ref($self) . "->" . $method_name);
@@ -323,6 +337,100 @@ sub _dispatch {
$self->get_service->get_bus->get_connection->send($reply);
}
+
+sub _dispatch_prop_read {
+ my $self = shift;
+ my $message = shift;
+ my $method_name = shift;
+
+ my $ins = $self->_introspector;
+
+ if (!$ins) {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "no introspection data exported for properties");
+ }
+
+ my ($pinterface, $pname) = $ins->decode($message, "methods", "Get", "params");
+
+ if (!$ins->has_property($pname, $pinterface)) {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "no property '$pname' exported in interface '$pinterface'");
+ }
+
+ if (!$ins->is_property_readable($pinterface, $pname)) {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "property '$pname' in interface '$pinterface' is not readable");
+ }
+
+ if ($self->can($pname)) {
+ my $value = eval {
+ $self->$pname;
+ };
+ if ($@) {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "error reading '$pname' in interface '$pinterface': $@");
+ } else {
+ my $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
+
+ $self->_introspector->encode($reply, "methods", "Get", "returns", $value);
+ return $reply;
+ }
+ } else {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "no method to read property '$pname' in interface '$pinterface'");
+ }
+}
+
+sub _dispatch_prop_write {
+ my $self = shift;
+ my $message = shift;
+ my $method_name = shift;
+
+ my $ins = $self->_introspector;
+
+ if (!$ins) {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "no introspection data exported for properties");
+ }
+
+ my ($pinterface, $pname, $pvalue) = $ins->decode($message, "methods", "Get", "params");
+
+ if (!$ins->has_property($pname, $pinterface)) {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "no property '$pname' exported in interface '$pinterface'");
+ }
+
+ if (!$ins->is_property_writable($pinterface, $pname)) {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "property '$pname' in interface '$pinterface' is not writable");
+ }
+
+ if ($self->can($pname)) {
+ eval {
+ $self->$pname($pvalue);
+ };
+ if ($@) {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "error writing '$pname' in interface '$pinterface': $@");
+ } else {
+ return Net::DBus::Binding::Message::MethodReturn->new(call => $message);
+ }
+ } else {
+ return Net::DBus::Binding::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "no method to write property '$pname' in interface '$pinterface'");
+ }
+}
+
sub _introspector {
my $self = shift;
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index c9b9fa5..a27e8b4 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -133,38 +133,63 @@ sub AUTOLOAD {
my $self = shift;
my $sub = $AUTOLOAD;
- (my $method = $AUTOLOAD) =~ s/.*:://;
-
+ (my $name = $AUTOLOAD) =~ s/.*:://;
+
my $interface = $self->{interface};
- if (!$interface) {
- my $ins = $self->_introspector;
- if (!$ins) {
+ my $ins = $self->_introspector;
+ if ($ins) {
+ my @interfaces = $ins->has_method($name);
+
+ if (@interfaces) {
+ if ($#interfaces > 0) {
+ warn "method with name '$name' is exported " .
+ "in multiple interfaces of '" . $self->get_object_path . "'" .
+ "calling first interface only\n";
+ }
+ return $self->_call_method($name, $interfaces[0], @_);
+ }
+ @interfaces = $ins->has_property($name);
+
+ if (@interfaces) {
+ if ($#interfaces > 0) {
+ warn "property with name '$name' is exported " .
+ "in multiple interfaces of '" . $self->get_object_path . "'" .
+ "calling first interface only\n";
+ }
+ if (@_) {
+ $self->_call_method("Set", "org.freedesktop.DBus.Properties", $interfaces[0], $name, $_[0]);
+ return ();
+ } else {
+ return $self->_call_method("Get", "org.freedesktop.DBus.Properties", $interfaces[0], $name);
+ }
+ }
+ die "no method or property with name '$name' is exported in object '" .
+ $self->get_object_path . "'\n";
+ } else {
+ if (!$interface) {
die "no introspection data available for '" . $self->get_object_path .
"', and object is not cast to any interface";
}
- my @interfaces = $ins->has_method($method);
-
- if ($#interfaces == -1) {
- die "no method with name '$method' is exported in object '" .
- $self->get_object_path . "'\n";
- } elsif ($#interfaces > 0) {
- warn "method with name '$method' is exported " .
- "in multiple interfaces of '" . $self->get_object_path . "'" .
- "calling first interface only\n";
- }
- $interface = $interfaces[0];
+ return $self->_call_method($name, $interface, @_);
}
+}
+
+
+sub _call_method {
+ my $self = shift;
+ my $name = shift;
+ my $interface = shift;
my $call = Net::DBus::Binding::Message::MethodCall->
new(service_name => $self->{service}->get_service_name(),
object_path => $self->{object_path},
- method_name => $method,
+ method_name => $name,
interface => $interface);
my $ins = $self->_introspector;
if ($ins) {
- $ins->encode($call, "methods", $method, "params", @_);
+ $ins->encode($call, "methods", $name, "params", @_);
} else {
$call->append_args_list(@_);
}
@@ -176,13 +201,15 @@ sub AUTOLOAD {
my @reply;
if ($ins) {
- @reply = $ins->decode($reply, "methods", $method, "returns");
+ @reply = $ins->decode($reply, "methods", $name, "returns");
} else {
@reply = $reply->get_args_list;
}
return wantarray ? @reply : $reply[0];
}
+sub _read_prop {
+}
1;
diff --git a/t/40-introspector.t b/t/40-introspector.t
index 5ec1c8b..57fa95e 100644
--- a/t/40-introspector.t
+++ b/t/40-introspector.t
@@ -26,7 +26,12 @@ TEST_ONE: {
},
signals => {
"meltdown" => ["int32", "byte"],
- }
+ },
+ props => {
+ "name" => ["string", "readwrite"],
+ "email" => ["string", "read"],
+ "age" => ["int32", "read"],
+ },
}
});
@@ -54,6 +59,9 @@ TEST_ONE: {
<arg type="i"/>
<arg type="y"/>
</signal>
+ <property name="age" type="i" access="read"/>
+ <property name="email" type="s" access="read"/>
+ <property name="name" type="s" access="readwrite"/>
</interface>
</node>
EOF
@@ -83,7 +91,11 @@ EOF
params => ["int32", "uint32"],
return => [],
}
- }
+ },
+ props => {
+ "title" => ["string", "readwrite"],
+ "salary" => ["int32", "read"],
+ },
},
},
children => [
@@ -104,6 +116,8 @@ EOF
<arg type="i" direction="in"/>
<arg type="u" direction="in"/>
</method>
+ <property name="salary" type="i" access="read"/>
+ <property name="title" type="s" access="readwrite"/>
</interface>
<interface name="org.example.SomeInterface">
<method name="goodbye">
@@ -140,6 +154,9 @@ EOF
<arg type="i"/>
<arg type="y"/>
</signal>
+ <property name="age" type="i" access="read"/>
+ <property name="email" type="s" access="read"/>
+ <property name="name" type="s" access="readwrite"/>
</interface>
</node>
</node>
diff --git a/t/50-object-introspect.t b/t/50-object-introspect.t
index 0959edf..96910c5 100644
--- a/t/50-object-introspect.t
+++ b/t/50-object-introspect.t
@@ -24,6 +24,18 @@ my $xml_expect = <<EOF;
<arg type="s" direction="out"/>
</method>
</interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
</node>
EOF
diff --git a/t/60-object-props.t b/t/60-object-props.t
new file mode 100644
index 0000000..e300822
--- /dev/null
+++ b/t/60-object-props.t
@@ -0,0 +1,292 @@
+# -*- perl -*-
+use Test::More tests => 13;
+
+use strict;
+use warnings;
+
+BEGIN {
+ use_ok('Net::DBus::Binding::Introspector');
+ use_ok('Net::DBus::Object');
+};
+
+package MyObject;
+
+use base qw(Net::DBus::Object);
+use Net::DBus::Exporter qw(org.example.MyObject);
+
+use Class::MethodMaker [ scalar => ["name", "email", "age" ]];
+
+dbus_property("name", "string");
+dbus_property("email", "string", "read");
+dbus_property("age", "int32" ,"write");
+
+package main;
+
+my $service = new DummyService();
+my $object = MyObject->new($service, "/org/example/MyObject");
+
+my $introspector = $object->_introspector;
+
+my $xml_got = $introspector->format();
+
+my $xml_expect = <<EOF;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/org/example/MyObject">
+ <interface name="org.example.MyObject">
+ <property name="age" type="i" access="write"/>
+ <property name="email" type="s" access="read"/>
+ <property name="name" type="s" access="readwrite"/>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
+</node>
+EOF
+
+is($xml_got, $xml_expect, "xml data matches");
+
+GET_NAME: {
+ 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 => "Get");
+
+ my $iter = $msg->iterator(1);
+ $iter->append_string("org.example.MyObject");
+ $iter->append_string("name");
+
+ $object->name("John Doe");
+
+ $object->_dispatch($service->get_bus->get_connection, $msg);
+ my $reply = $service->get_bus->get_connection->next_message;
+
+ isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+
+ my ($value) = $reply->get_args_list;
+ is($value, "John Doe", "name is John Doe");
+}
+
+GET_BOGUS: {
+ 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 => "Get");
+
+ my $iter = $msg->iterator(1);
+ $iter->append_string("org.example.MyObject");
+ $iter->append_string("bogus");
+
+ $object->name("John Doe");
+
+ $object->_dispatch($service->get_bus->get_connection, $msg);
+ my $reply = $service->get_bus->get_connection->next_message;
+
+ isa_ok($reply, "Net::DBus::Binding::Message::Error");
+}
+
+sub GET_SET_NAME: {
+ my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
+ object_path => "/org/example/MyObject",
+ interface => "org.freedesktop.DBus.Properties",
+ method_name => "Get");
+
+ my $iter = $msg1->iterator(1);
+ $iter->append_string("org.example.MyObject");
+ $iter->append_string("name");
+
+ $object->name("John Doe");
+
+ $object->_dispatch($service->get_bus->get_connection, $msg1);
+ my $reply = $service->get_bus->get_connection->next_message;
+
+ isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+
+ my ($value) = $reply->get_args_list;
+ is($value, "John Doe", "name is John Doe");
+
+
+ my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
+ object_path => "/org/example/MyObject",
+ interface => "org.freedesktop.DBus.Properties",
+ method_name => "Set");
+
+ $iter = $msg2->iterator(1);
+ $iter->append_string("org.example.MyObject");
+ $iter->append_string("name");
+ $iter->append_string("Jane Doe");
+
+ $object->_dispatch($service->get_bus->get_connection, $msg2);
+ $reply = $service->get_bus->get_connection->next_message;
+
+ isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+
+
+ $object->_dispatch($service->get_bus->get_connection, $msg1);
+ $reply = $service->get_bus->get_connection->next_message;
+
+ isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+
+ ($value) = $reply->get_args_list;
+ is($value, "Jane Doe", "name is Jane Doe");
+}
+
+
+SET_AGE: {
+ my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
+ object_path => "/org/example/MyObject",
+ interface => "org.freedesktop.DBus.Properties",
+ method_name => "Get");
+
+ my $iter = $msg1->iterator(1);
+ $iter->append_string("org.example.MyObject");
+ $iter->append_string("age");
+
+
+ my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
+ object_path => "/org/example/MyObject",
+ interface => "org.freedesktop.DBus.Properties",
+ method_name => "Set");
+
+ $iter = $msg2->iterator(1);
+ $iter->append_string("org.example.MyObject");
+ $iter->append_string("age");
+ $iter->append_int32(21);
+
+ $object->_dispatch($service->get_bus->get_connection, $msg2);
+ my $reply = $service->get_bus->get_connection->next_message;
+
+ isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+
+
+ $object->_dispatch($service->get_bus->get_connection, $msg1);
+ $reply = $service->get_bus->get_connection->next_message;
+
+ isa_ok($reply, "Net::DBus::Binding::Message::Error");
+
+ is($object->age, 21, "age is 21");
+}
+
+
+GET_EMAIL: {
+ my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
+ object_path => "/org/example/MyObject",
+ interface => "org.freedesktop.DBus.Properties",
+ method_name => "Get");
+
+ my $iter = $msg1->iterator(1);
+ $iter->append_string("org.example.MyObject");
+ $iter->append_string("email");
+
+ $object->email('john at example.com');
+
+ my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
+ object_path => "/org/example/MyObject",
+ interface => "org.freedesktop.DBus.Properties",
+ method_name => "Set");
+
+ $iter = $msg2->iterator(1);
+ $iter->append_string("org.example.MyObject");
+ $iter->append_string("email");
+ $iter->append_string('jane at example.com');
+
+ $object->_dispatch($service->get_bus->get_connection, $msg2);
+ my $reply = $service->get_bus->get_connection->next_message;
+
+ isa_ok($reply, "Net::DBus::Binding::Message::Error");
+
+
+ $object->_dispatch($service->get_bus->get_connection, $msg1);
+ $reply = $service->get_bus->get_connection->next_message;
+
+ isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+
+ is($object->age, 21, "age is 21");
+
+ my ($value) = $reply->get_args_list;
+ is($value, 'john at example.com', 'email is john at example.com');
+}
+
+
+package DummyService;
+
+sub new {
+ my $class = shift;
+ my $self = {};
+
+ $self->{bus} = DummyBus->new();
+
+ bless $self, $class;
+
+ return $self;
+}
+
+sub get_bus {
+ my $self = shift;
+ return $self->{bus};
+}
+
+package DummyBus;
+
+sub new {
+ my $class = shift;
+ my $self = {};
+
+ $self->{connection} = DummyConnection->new();
+
+ bless $self, $class;
+
+ return $self;
+}
+
+sub get_connection {
+ my $self = shift;
+ return $self->{connection};
+}
+
+
+package DummyConnection;
+
+sub new {
+ my $class = shift;
+ my $self = {};
+
+ $self->{msgs} = [];
+
+ bless $self, $class;
+
+ return $self;
+}
+
+
+sub send {
+ my $self = shift;
+ my $msg = shift;
+
+ push @{$self->{msgs}}, $msg;
+}
+
+sub next_message {
+ my $self = shift;
+
+ return shift @{$self->{msgs}};
+}
+
+sub register_object_path {
+ my $self = shift;
+ # nada
+}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git
More information about the Pkg-perl-cvs-commits
mailing list