[libnet-dbus-perl] 210/335: Re-factor code which creates message objects, to use factory methods on the Connection class. The mock connection now uses a pure perl message/iterator object, avoiding assertion failures in dbus
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:58 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 eca4acacb5f003526bf29f7a6e081d7840aa998d
Author: Daniel P. Berrange <berrange at redhat.com>
Date: Wed Jul 5 18:33:08 2006 -0400
Re-factor code which creates message objects, to use factory methods on the Connection class. The mock connection now uses a pure perl message/iterator object, avoiding assertion failures in dbus
---
lib/Net/DBus.pm | 2 +-
lib/Net/DBus/Binding/Connection.pm | 128 ++++-
lib/Net/DBus/Binding/PendingCall.pm | 9 +-
lib/Net/DBus/Object.pm | 100 ++--
lib/Net/DBus/RemoteObject.pm | 33 +-
lib/Net/DBus/Test/MockConnection.pm | 131 ++++-
lib/Net/DBus/Test/MockIterator.pm | 958 ++++++++++++++++++++++++++++++++++++
lib/Net/DBus/Test/MockMessage.pm | 444 +++++++++++++++++
lib/Net/DBus/Test/MockObject.pm | 41 +-
t/56-scalar-param-typing.t | 2 +
t/60-object-props.t | 12 +-
t/65-object-magic.t | 5 +-
t/70-errors.t | 4 +-
13 files changed, 1742 insertions(+), 127 deletions(-)
diff --git a/lib/Net/DBus.pm b/lib/Net/DBus.pm
index e70a6c7..0de90ae 100644
--- a/lib/Net/DBus.pm
+++ b/lib/Net/DBus.pm
@@ -483,7 +483,7 @@ sub _signal_func {
my $connection = shift;
my $message = shift;
- return 0 unless $message->isa("Net::DBus::Binding::Message::Signal");
+ return 0 unless $message->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL;
my $interface = $message->get_interface;
my $sender = $message->get_sender;
diff --git a/lib/Net/DBus/Binding/Connection.pm b/lib/Net/DBus/Binding/Connection.pm
index 9df661f..6c15c0f 100644
--- a/lib/Net/DBus/Binding/Connection.pm
+++ b/lib/Net/DBus/Binding/Connection.pm
@@ -74,7 +74,10 @@ use strict;
use warnings;
use Net::DBus;
+use Net::DBus::Binding::Message::MethodCall;
use Net::DBus::Binding::Message::MethodReturn;
+use Net::DBus::Binding::Message::Error;
+use Net::DBus::Binding::Message::Signal;
use Net::DBus::Binding::PendingCall;
=item my $con = Net::DBus::Binding::Connection->new(address => "unix:path=/path/to/socket");
@@ -175,7 +178,7 @@ any).
sub send {
my $self = shift;
my $msg = shift;
-
+
return $self->{connection}->_send($msg->{message});
}
@@ -198,11 +201,9 @@ sub send_with_reply_and_block {
my $type = $reply->dbus_message_get_type;
if ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) {
- return Net::DBus::Binding::Message::Error->new(replyto => $msg,
- message => $reply);
+ return $self->make_raw_message($reply);
} elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN) {
- return Net::DBus::Binding::Message::MethodReturn->new(call => $msg,
- message => $reply);
+ return $self->make_raw_message($reply);
} else {
die "unknown method reply type $type";
}
@@ -226,7 +227,8 @@ sub send_with_reply {
my $reply = $self->{connection}->_send_with_reply($msg->{message}, $timeout);
- return Net::DBus::Binding::PendingCall->new(method_call => $msg,
+ return Net::DBus::Binding::PendingCall->new(connection => $self,
+ method_call => $msg,
pending_call => $reply);
}
@@ -262,7 +264,7 @@ sub borrow_message {
my $self = shift;
my $msg = $self->{connection}->dbus_connection_borrow_message();
- return Net::DBus::Binding::Message->new(message => $msg);
+ return $self->make_raw_message($msg);
}
=item $con->return_message($msg)
@@ -310,7 +312,7 @@ sub pop_message {
my $self = shift;
my $msg = $self->{connection}->dbus_connection_pop_message();
- return Net::DBus::Binding::Message->new(message => $msg);
+ return $self->make_raw_message($msg);
}
=item $con->set_watch_callbacks(\&add_watch, \&remove_watch, \&toggle_watch);
@@ -383,7 +385,7 @@ sub register_object_path {
my $con = shift;
my $msg = shift;
- &$code($con, Net::DBus::Binding::Message->new(message => $msg));
+ &$code($con, $self->make_raw_message($msg));
};
$self->{connection}->_register_object_path($path, $callback);
}
@@ -423,7 +425,7 @@ sub register_fallback {
my $con = shift;
my $msg = shift;
- &$code($con, Net::DBus::Binding::Message->new(message => $msg));
+ &$code($con, $self->make_raw_message($msg));
};
$self->{connection}->_register_fallback($path, $callback);
@@ -515,10 +517,114 @@ sub _message_filter {
my $rawmsg = shift;
my $code = shift;
- my $msg = Net::DBus::Binding::Message->new(message => $rawmsg);
+ my $msg = $self->make_raw_message($rawmsg);
return &$code($self, $msg);
}
+
+=item my $msg = $con->make_raw_message($rawmsg)
+
+Creates a new message, initializing it from the low level C message
+object provided by the C<$rawmsg> parameter. The returned object
+will be cast to the appropriate subclass of L<Net::DBus::Binding::Message>.
+
+=cut
+
+sub make_raw_message {
+ my $self = shift;
+ my $rawmsg = shift;
+
+ return Net::DBus::Binding::Message->new(message => $rawmsg);
+}
+
+
+=item my $msg = $con->make_error_message(
+ replyto => $method_call, name => $name, description => $description);
+
+Creates a new message, representing an error which occurred during
+the handling of the method call object passed in as the C<replyto>
+parameter. The C<name> parameter is the formal name of the error
+condition, while the C<description> is a short piece of text giving
+more specific information on the error.
+
+=cut
+
+
+sub make_error_message {
+ my $self = shift;
+ my $replyto = shift;
+ my $name = shift;
+ my $description = shift;
+ print "Fsck $name $description\n";
+ return Net::DBus::Binding::Message::Error->new(replyto => $replyto,
+ name => $name,
+ description => $description);
+}
+
+=item my $call = $con->make_method_call_message(
+ $service_name, $object_path, $interface, $method_name);
+
+Create a message representing a call on the object located at
+the path C<$object_path> within the client owning the well-known
+name given by C<$service_name>. The method to be invoked has
+the name C<$method_name> within the interface specified by the
+C<$interface> parameter.
+
+=cut
+
+
+sub make_method_call_message {
+ my $self = shift;
+ my $service_name = shift;
+ my $object_path = shift;
+ my $interface = shift;
+ my $method_name = shift;
+
+ return Net::DBus::Binding::Message::MethodCall->new(service_name => $service_name,
+ object_path => $object_path,
+ interface => $interface,
+ method_name => $method_name);
+}
+
+=item my $msg = $con->make_method_return_message(
+ replyto => $method_call);
+
+Create a message representing a reply to the method call passed in
+the C<replyto> parameter.
+
+=cut
+
+
+sub make_method_return_message {
+ my $self = shift;
+ my $replyto = shift;
+
+ return Net::DBus::Binding::Message::MethodReturn->new(call => $replyto);
+}
+
+
+=item my $signal = $con->make_signal_message(
+ object_path => $path, interface => $interface, signal_name => $name);
+
+Creates a new message, representing a signal [to be] emitted by
+the object located under the path given by the C<object_path>
+parameter. The name of the signal is given by the C<signal_name>
+parameter, and is scoped to the interface given by the
+C<interface> parameter.
+
+=cut
+
+sub make_signal_message {
+ my $self = shift;
+ my $object_path = shift;
+ my $interface = shift;
+ my $signal_name = shift;
+
+ return Net::DBus::Binding::Message::Signal->new(object_path => $object_path,
+ interface => $interface,
+ signal_name => $signal_name);
+}
+
1;
=pod
diff --git a/lib/Net/DBus/Binding/PendingCall.pm b/lib/Net/DBus/Binding/PendingCall.pm
index dfb1f0f..e061359 100644
--- a/lib/Net/DBus/Binding/PendingCall.pm
+++ b/lib/Net/DBus/Binding/PendingCall.pm
@@ -71,6 +71,7 @@ sub new {
my %params = @_;
my $self = {};
+ $self->{connection} = exists $params{connection} ? $params{connection} : die "connection parameter is required";
$self->{method_call} = exists $params{method_call} ? $params{method_call} : die "method_call parameter is required";
$self->{pending_call} = exists $params{pending_call} ? $params{pending_call} : die "pending_call parameter is required";
@@ -132,11 +133,11 @@ sub get_reply {
my $reply = $self->{pending_call}->dbus_pending_call_steal_reply();
my $type = $reply->dbus_message_get_type;
if ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) {
- return Net::DBus::Binding::Message::Error->new(replyto => $self->{method_call},
- message => $reply);
+ return $self->{connection}->make_error_message($self->{method_call},
+ $reply);
} elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN) {
- return Net::DBus::Binding::Message::MethodReturn->new(call => $self->{method_call},
- message => $reply);
+ return $self->{connection}->make_method_return_message($self->{method_call},
+ $reply);
} else {
die "unknown method reply type $type";
}
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 58db7f7..0691aec 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -127,8 +127,6 @@ BEGIN {
}
use Net::DBus::Exporter "org.freedesktop.DBus.Introspectable";
-use Net::DBus::Binding::Message::Error;
-use Net::DBus::Binding::Message::MethodReturn;
dbus_method("Introspect", [], ["string"]);
@@ -300,9 +298,11 @@ sub emit_signal_in {
die "object is disconnected from the bus" unless $self->is_connected;
- my $signal = Net::DBus::Binding::Message::Signal->new(object_path => $self->get_object_path,
- interface => $interface,
- signal_name => $name);
+ my $con = $self->get_service->get_bus->get_connection;
+
+ my $signal = $con->make_signal_message($self->get_object_path,
+ $interface,
+ $name);
if ($destination) {
$signal->set_destination($destination);
}
@@ -313,7 +313,7 @@ sub emit_signal_in {
} else {
$signal->append_args_list(@args);
}
- $self->get_service->get_bus->get_connection->send($signal);
+ $con->send($signal);
# Short circuit locally registered callbacks
if (exists $self->{callbacks}->{$interface} &&
@@ -456,15 +456,15 @@ sub _dispatch {
$self->_introspector &&
$ENABLE_INTROSPECT) {
my $xml = $self->_introspector->format;
- $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
+ $reply = $connection->make_method_return_message($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);
+ $reply = $self->_dispatch_prop_read($connection, $message);
} elsif ($method_name eq "Set") {
- $reply = $self->_dispatch_prop_write($message);
+ $reply = $self->_dispatch_prop_write($connection, $message);
}
} elsif ($self->can($method_name)) {
my $ins = $self->_introspector;
@@ -481,11 +481,11 @@ sub _dispatch {
if ($@) {
my $name = UNIVERSAL::isa($@, "Net::DBus::Error") ? $@->name : "org.freedesktop.DBus.Error.Failed";
my $desc = UNIVERSAL::isa($@, "Net::DBus::Error") ? $@->message : $@;
- $reply = Net::DBus::Binding::Message::Error->new(replyto => $message,
- name => $name,
- description => $desc);
+ $reply = $connection->make_error_message($message,
+ $name,
+ $desc);
} else {
- $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
+ $reply = $connection->make_method_return_message($message);
if ($ins) {
$self->_introspector->encode($reply, "methods", $method_name, "returns", @ret);
} else {
@@ -495,9 +495,9 @@ sub _dispatch {
}
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);
+ $reply = $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "No such method " . ref($self) . "->" . $method_name);
}
if ($message->get_no_reply()) {
@@ -510,29 +510,29 @@ sub _dispatch {
sub _dispatch_prop_read {
my $self = shift;
+ my $connection = 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");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "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'");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "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");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "property '$pname' in interface '$pinterface' is not readable");
}
if ($self->can($pname)) {
@@ -540,47 +540,47 @@ sub _dispatch_prop_read {
$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': $@");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "error reading '$pname' in interface '$pinterface': $@");
} else {
- my $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
+ my $reply = $connection->make_method_return_message($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'");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "no method to read property '$pname' in interface '$pinterface'");
}
}
sub _dispatch_prop_write {
my $self = shift;
+ my $connection = 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");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "no introspection data exported for properties");
}
my ($pinterface, $pname, $pvalue) = $ins->decode($message, "methods", "Set", "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'");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "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");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "property '$pname' in interface '$pinterface' is not writable");
}
if ($self->can($pname)) {
@@ -588,16 +588,16 @@ sub _dispatch_prop_write {
$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': $@");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "error writing '$pname' in interface '$pinterface': $@");
} else {
- return Net::DBus::Binding::Message::MethodReturn->new(call => $message);
+ return $connection->make_method_return_message($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'");
+ return $connection->make_error_message($message,
+ "org.freedesktop.DBus.Error.Failed",
+ "no method to write property '$pname' in interface '$pinterface'");
}
}
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index 4f6b4f9..e9fa0bb 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -55,7 +55,6 @@ use warnings;
our $AUTOLOAD;
-use Net::DBus::Binding::Message::MethodCall;
use Net::DBus::Binding::Introspector;
use Net::DBus::ASyncReply;
use Net::DBus::Annotation qw(:call);
@@ -162,18 +161,17 @@ sub get_child_object {
sub _introspector {
my $self = shift;
+
unless ($self->{introspected}) {
- my $call = Net::DBus::Binding::Message::MethodCall->
- new(service_name => $self->{service}->get_service_name(),
- object_path => $self->{object_path},
- method_name => "Introspect",
- interface => "org.freedesktop.DBus.Introspectable");
+ my $con = $self->{service}->get_bus()->get_connection();
+
+ my $call = $con->make_method_call_message($self->{service}->get_service_name(),
+ $self->{object_path},
+ "org.freedesktop.DBus.Introspectable",
+ "Introspect");
my $xml = eval {
- my $reply = $self->{service}->
- get_bus()->
- get_connection()->
- send_with_reply_and_block($call, 60 * 1000);
+ my $reply = $con->send_with_reply_and_block($call, 60 * 1000);
my $iter = $reply->iterator;
return $iter->get(&Net::DBus::Binding::Message::TYPE_STRING);
@@ -348,17 +346,18 @@ sub _call_method {
my $interface = shift;
my $introspect = shift;
+ my $con = $self->{service}->get_bus()->get_connection();
+
my $ins = $introspect ? $self->_introspector : undef;
if ($ins &&
$ins->is_method_deprecated($name, $interface)) {
warn "method '$name' in interface $interface on object " . $self->get_object_path . " is deprecated\n";
}
- my $call = Net::DBus::Binding::Message::MethodCall->
- new(service_name => $self->{service}->get_service_name(),
- object_path => $self->{object_path},
- method_name => $name,
- interface => $interface);
+ my $call = $con->make_method_call_message($self->{service}->get_service_name(),
+ $self->{object_path},
+ $interface,
+ $name);
#$call->set_destination($self->get_service->get_owner_name);
@@ -369,9 +368,7 @@ sub _call_method {
}
if ($mode == dbus_call_sync) {
- my $reply = $self->{service}->
- get_bus()->
- get_connection()->
+ my $reply = $con->
send_with_reply_and_block($call, 60 * 1000);
my @reply;
diff --git a/lib/Net/DBus/Test/MockConnection.pm b/lib/Net/DBus/Test/MockConnection.pm
index 078bc7c..8085b55 100644
--- a/lib/Net/DBus/Test/MockConnection.pm
+++ b/lib/Net/DBus/Test/MockConnection.pm
@@ -62,7 +62,11 @@ package Net::DBus::Test::MockConnection;
use strict;
use warnings;
+use Net::DBus::Test::MockMessage;
+use Net::DBus::Binding::Message::MethodCall;
use Net::DBus::Binding::Message::MethodReturn;
+use Net::DBus::Binding::Message::Error;
+use Net::DBus::Binding::Message::Signal;
=item my $con = Net::DBus::Test::MockConnection->new()
@@ -103,13 +107,13 @@ by the C<dispatch> method.
sub send {
my $self = shift;
my $msg = shift;
-
- if ($msg->isa("Net::DBus::Binding::Message::MethodCall")) {
+
+ if ($msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_CALL) {
$self->_call_method($msg);
- } elsif ($msg->isa("Net::DBus::Binding::Message::MethodReturn") ||
- $msg->isa("Net::DBus::Binding::Message::Error")) {
+ } elsif ($msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN ||
+ $msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) {
push @{$self->{replies}}, $msg;
- } elsif ($msg->isa("Net::DBus::Binding::Message::Signal")) {
+ } elsif ($msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL) {
push @{$self->{signals}}, $msg;
} else {
die "unhandled type of message " . ref($msg);
@@ -162,14 +166,13 @@ sub send_with_reply_and_block {
die "too many replies received";
}
- if (ref($reply) eq "Net::DBus::Binding::Message::Error") {
+ if ($reply->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) {
my $iter = $reply->iterator;
my $desc = $iter->get_string;
- my $err = { name => $reply->get_error_name,
- message => $desc };
- bless $err, "Net::DBus::Error";
- die $err;
+ die Net::DBus::Error->new(name => $reply->get_error_name,
+ message => $desc);
}
+
return $reply;
}
@@ -318,7 +321,7 @@ sub _call_method {
}
if ($msg->get_path eq "/org/freedesktop/DBus") {
if ($msg->get_member eq "GetNameOwner") {
- my $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $msg);
+ my $reply = $self->make_method_return_message($msg);
my $iter = $reply->iterator(1);
$iter->append(":1.1");
$self->send($reply);
@@ -327,6 +330,112 @@ sub _call_method {
}
}
+=item my $msg = $con->make_error_message($replyto, $name, $description)
+
+Creates a new message, representing an error which occurred during
+the handling of the method call object passed in as the C<$replyto>
+parameter. The C<$name> parameter is the formal name of the error
+condition, while the C<$description> is a short piece of text giving
+more specific information on the error.
+
+=cut
+
+sub make_error_message {
+ my $self = shift;
+ my $replyto = shift;
+ my $name = shift;
+ my $description = shift;
+
+ if (1) {
+ return Net::DBus::Test::MockMessage->new_error(replyto => $replyto,
+ error_name => $name,
+ error_description => $description);
+ } else {
+ return Net::DBus::Binding::Message::Error->new(replyto => $replyto,
+ name => $name,
+ description => $description);
+ }
+}
+
+=item my $call = $con->make_method_call_message(
+ $service_name, $object_path, $interface, $method_name);
+
+Create a message representing a call on the object located at
+the path C<$object_path> within the client owning the well-known
+name given by C<$service_name>. The method to be invoked has
+the name C<$method_name> within the interface specified by the
+C<$interface> parameter.
+
+=cut
+
+sub make_method_call_message {
+ my $self = shift;
+ my $service_name = shift;
+ my $object_path = shift;
+ my $interface = shift;
+ my $method_name = shift;
+
+ if (1) {
+ return Net::DBus::Test::MockMessage->new_method_call(destination => $service_name,
+ path => $object_path,
+ interface => $interface,
+ member => $method_name);
+ } else {
+ return Net::DBus::Binding::Message::MethodCall->new(service_name => $service_name,
+ object_path => $object_path,
+ interface => $interface,
+ method_name => $method_name);
+ }
+}
+
+=item my $msg = $con->make_method_return_message($replyto)
+
+Create a message representing a reply to the method call message passed in
+the C<$replyto> parameter.
+
+=cut
+
+
+sub make_method_return_message {
+ my $self = shift;
+ my $replyto = shift;
+
+ if (1) {
+ return Net::DBus::Test::MockMessage->new_method_return(replyto => $replyto);
+ } else {
+ return Net::DBus::Binding::Message::MethodReturn->new(call => $replyto);
+ }
+}
+
+
+=item my $msg = $con->make_signal_message($object_path, $interface, $signal_name);
+
+Creates a new message, representing a signal [to be] emitted by
+the object located under the path given by the C<$object_path>
+parameter. The name of the signal is given by the C<$signal_name>
+parameter, and is scoped to the interface given by the
+C<$interface> parameter.
+
+=cut
+
+sub make_signal_message {
+ my $self = shift;
+ my $object_path = shift;
+ my $interface = shift;
+ my $signal_name = shift;
+
+ if (1) {
+ return Net::DBus::Test::MockMessage->new_signal(object_path => $object_path,
+ interface => $interface,
+ signal_name => $signal_name);
+ } else {
+ return Net::DBus::Binding::Message::Signal->new(object_path => $object_path,
+ interface => $interface,
+ signal_name => $signal_name);
+ }
+}
+
+
1;
=pod
diff --git a/lib/Net/DBus/Test/MockIterator.pm b/lib/Net/DBus/Test/MockIterator.pm
new file mode 100644
index 0000000..d2beff8
--- /dev/null
+++ b/lib/Net/DBus/Test/MockIterator.pm
@@ -0,0 +1,958 @@
+# -*- perl -*-
+#
+# Copyright (C) 2004-2006 Daniel P. Berrange
+#
+# This program is free software; You can redistribute it and/or modify
+# it under the same terms as Perl itself. Either:
+#
+# a) the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any
+# later version,
+#
+# or
+#
+# b) the "Artistic License"
+#
+# The file "COPYING" distributed along with this file provides full
+# details of the terms and conditions of the two licenses.
+
+=pod
+
+=head1 NAME
+
+Net::DBus::Test::MockIterator - Iterator over a mock message
+
+=head1 SYNOPSIS
+
+Creating a new message
+
+ my $msg = new Net::DBus::Test::MockMessage
+ my $iterator = $msg->iterator;
+
+ $iterator->append_boolean(1);
+ $iterator->append_byte(123);
+
+
+Reading from a mesage
+
+ my $msg = ...get it from somewhere...
+ my $iter = $msg->iterator();
+
+ my $i = 0;
+ while ($iter->has_next()) {
+ $iter->next();
+ $i++;
+ if ($i == 1) {
+ my $val = $iter->get_boolean();
+ } elsif ($i == 2) {
+ my $val = $iter->get_byte();
+ }
+ }
+
+=head1 DESCRIPTION
+
+This module provides a "mock" counterpart to the L<Net::DBus::Binding::Iterator>
+object which is capable of iterating over mock message objects. Instances of this
+module are not created directly, instead they are obtained via the C<iterator>
+method on the L<Net::DBus::Test::MockMessage> module.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Net::DBus::Test::MockIterator;
+
+
+use 5.006;
+use strict;
+use warnings;
+
+sub _new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ my %params = @_;
+
+ $self->{data} = exists $params{data} ? $params{data} : die "data parameter is required";
+ $self->{append} = exists $params{append} ? $params{append} : 0;
+ $self->{position} = 0;
+
+ bless $self, $class;
+
+ return $self;
+}
+
+=item $res = $iter->has_next()
+
+Determines if there are any more fields in the message
+itertor to be read. Returns a positive value if there
+are more fields, zero otherwise.
+
+=cut
+
+sub has_next {
+ my $self = shift;
+
+ if ($self->{position} < $#{$self->{data}}) {
+ return 1;
+ }
+ return 0;
+}
+
+
+=item $success = $iter->next()
+
+Skips the iterator onto the next field in the message.
+Returns a positive value if the current field pointer
+was successfully advanced, zero otherwise.
+
+=cut
+
+sub next {
+ my $self = shift;
+
+ if ($self->{position} < $#{$self->{data}}) {
+ $self->{position}++;
+ return 1;
+ }
+ return 0;
+}
+
+=item my $val = $iter->get_boolean()
+
+=item $iter->append_boolean($val);
+
+Read or write a boolean value from/to the
+message iterator
+
+=cut
+
+sub get_boolean {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_BOOLEAN);
+}
+
+sub append_boolean {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_BOOLEAN, $_[0] ? 1 : "");
+}
+
+=item my $val = $iter->get_byte()
+
+=item $iter->append_byte($val);
+
+Read or write a single byte value from/to the
+message iterator.
+
+=cut
+
+sub get_byte {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_BYTE);
+}
+
+sub append_byte {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_BYTE, $_[0]);
+}
+
+
+=item my $val = $iter->get_string()
+
+=item $iter->append_string($val);
+
+Read or write a UTF-8 string value from/to the
+message iterator
+
+
+=cut
+
+sub get_string {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_STRING);
+}
+
+sub append_string {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_STRING, $_[0]);
+}
+
+=item my $val = $iter->get_object_path()
+
+=item $iter->append_object_path($val);
+
+Read or write a UTF-8 string value, whose contents is
+a valid object path, from/to the message iterator
+
+
+=cut
+
+sub get_object_path {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH);
+}
+
+sub append_object_path {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH, $_[0]);
+}
+
+=item my $val = $iter->get_signature()
+
+=item $iter->append_signature($val);
+
+Read or write a UTF-8 string, whose contents is a
+valid type signature, value from/to the message iterator
+
+
+=cut
+
+sub get_signature {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_SIGNATURE);
+}
+
+sub append_signature {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_SIGNATURE, $_[0]);
+}
+
+=item my $val = $iter->get_int16()
+
+=item $iter->append_int16($val);
+
+Read or write a signed 16 bit value from/to the
+message iterator
+
+
+=cut
+
+sub get_int16 {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_INT16);
+}
+
+sub append_int16 {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_INT16, int($_[0]));
+}
+
+=item my $val = $iter->get_uint16()
+
+=item $iter->append_uint16($val);
+
+Read or write an unsigned 16 bit value from/to the
+message iterator
+
+
+=cut
+
+sub get_uint16 {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT16);
+}
+
+sub append_uint16 {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_UINT16, int($_[0]));
+}
+
+=item my $val = $iter->get_int32()
+
+=item $iter->append_int32($val);
+
+Read or write a signed 32 bit value from/to the
+message iterator
+
+
+=cut
+
+sub get_int32 {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_INT32);
+}
+
+sub append_int32 {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_INT32, int($_[0]));
+}
+
+=item my $val = $iter->get_uint32()
+
+=item $iter->append_uint32($val);
+
+Read or write an unsigned 32 bit value from/to the
+message iterator
+
+
+=cut
+
+sub get_uint32 {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT32);
+}
+
+sub append_uint32 {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_UINT32, int($_[0]));
+}
+
+=item my $val = $iter->get_int64()
+
+=item $iter->append_int64($val);
+
+Read or write a signed 64 bit value from/to the
+message iterator. An error will be raised if this
+build of Perl does not support 64 bit integers
+
+
+=cut
+
+sub get_int64 {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_INT64);
+}
+
+sub append_int64 {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_INT64, int($_[0]));
+}
+
+=item my $val = $iter->get_uint64()
+
+=item $iter->append_uint64($val);
+
+Read or write an unsigned 64 bit value from/to the
+message iterator. An error will be raised if this
+build of Perl does not support 64 bit integers
+
+
+=cut
+
+sub get_uint64 {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT64);
+}
+
+sub append_uint64 {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_UINT64, int($_[0]));
+}
+
+=item my $val = $iter->get_double()
+
+=item $iter->append_double($val);
+
+Read or write a double precision floating point value
+from/to the message iterator
+
+=cut
+
+sub get_double {
+ my $self = shift;
+ return $self->_get(&Net::DBus::Binding::Message::TYPE_DOUBLE);
+}
+
+sub append_double {
+ my $self = shift;
+ $self->_append(&Net::DBus::Binding::Message::TYPE_DOUBLE, $_[0]);
+}
+
+
+
+=item my $value = $iter->get()
+
+=item my $value = $iter->get($type);
+
+Get the current value pointed to by this iterator. If the optional
+C<$type> parameter is supplied, the wire type will be compared with
+the desired type & a warning output if their differ. The C<$type>
+value must be one of the C<Net::DBus::Binding::Message::TYPE*>
+constants.
+
+=cut
+
+sub get {
+ my $self = shift;
+ my $type = shift;
+
+ if (defined $type) {
+ if (ref($type)) {
+ if (ref($type) eq "ARRAY") {
+ # XXX we should recursively validate types
+ $type = $type->[0];
+ if ($type eq &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ $type = &Net::DBus::Binding::Message::TYPE_ARRAY;
+ }
+ } else {
+ die "unsupport type reference $type";
+ }
+ }
+
+ my $actual = $self->get_arg_type;
+ if ($actual != $type) {
+ # "Be strict in what you send, be leniant in what you accept"
+ # - ie can't rely on python to send correct types, eg int32 vs uint32
+ #die "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)";
+ warn "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)";
+ $type = $actual;
+ }
+ } else {
+ $type = $self->get_arg_type;
+ }
+
+ if ($type == &Net::DBus::Binding::Message::TYPE_STRING) {
+ return $self->get_string;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) {
+ return $self->get_boolean;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) {
+ return $self->get_byte;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) {
+ return $self->get_int16;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) {
+ return $self->get_uint16;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) {
+ return $self->get_int32;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) {
+ return $self->get_uint32;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) {
+ return $self->get_int64;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) {
+ return $self->get_uint64;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) {
+ return $self->get_double;
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_ARRAY) {
+ my $array_type = $self->get_element_type();
+ if ($array_type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ return $self->get_dict();
+ } else {
+ return $self->get_array($array_type);
+ }
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRUCT) {
+ return $self->get_struct();
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_VARIANT) {
+ return $self->get_variant();
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ die "dictionary can only occur as part of an array type";
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_INVALID) {
+ die "cannot handle Net::DBus::Binding::Message::TYPE_INVALID";
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
+ return $self->get_object_path();
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) {
+ return $self->get_signature();
+ } else {
+ die "unknown argument type '" . chr($type) . "' ($type)";
+ }
+}
+
+=item my $hashref = $iter->get_dict()
+
+If the iterator currently points to a dictionary value, unmarshalls
+and returns the value as a hash reference.
+
+=cut
+
+sub get_dict {
+ my $self = shift;
+
+ my $iter = $self->_recurse();
+ my $type = $iter->get_arg_type();
+ my $dict = {};
+ while ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ my $entry = $iter->get_struct();
+ if ($#{$entry} != 1) {
+ die "Dictionary entries must be structs of 2 elements. This entry has " . ($#{$entry}+1) ." elements";
+ }
+
+ $dict->{$entry->[0]} = $entry->[1];
+ $iter->next();
+ $type = $iter->get_arg_type();
+ }
+ return $dict;
+}
+
+=item my $hashref = $iter->get_array()
+
+If the iterator currently points to an array value, unmarshalls
+and returns the value as a array reference.
+
+=cut
+
+sub get_array {
+ my $self = shift;
+ my $array_type = shift;
+
+ my $iter = $self->_recurse();
+ my $type = $iter->get_arg_type();
+ my $array = [];
+ while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) {
+ if ($type != $array_type) {
+ die "Element $type not of array type $array_type";
+ }
+
+ my $value = $iter->get($type);
+ push @{$array}, $value;
+ $iter->next();
+ $type = $iter->get_arg_type();
+ }
+ return $array;
+}
+
+=item my $hashref = $iter->get_variant()
+
+If the iterator currently points to a variant value, unmarshalls
+and returns the value contained in the variant.
+
+=cut
+
+sub get_variant {
+ my $self = shift;
+
+ my $iter = $self->_recurse();
+ return $iter->get();
+}
+
+
+=item my $hashref = $iter->get_struct()
+
+If the iterator currently points to an struct value, unmarshalls
+and returns the value as a array reference. The values in the array
+correspond to members of the struct.
+
+=cut
+
+sub get_struct {
+ my $self = shift;
+
+ my $iter = $self->_recurse();
+ my $type = $iter->get_arg_type();
+ my $struct = [];
+ while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) {
+ my $value = $iter->get($type);
+ push @{$struct}, $value;
+ $iter->next();
+ $type = $iter->get_arg_type();
+ }
+ return $struct;
+}
+
+=item $iter->append($value)
+
+=item $iter->append($value, $type)
+
+Appends a value to the message associated with this iterator. The
+value is marshalled into wire format, according to the following
+rules.
+
+If the C<$value> is an instance of L<Net::DBus::Binding::Value>,
+the embedded data type is used.
+
+If the C<$type> parameter is supplied, that is taken to represent
+the data type. The type must be one of the C<Net::DBus::Binding::Message::TYPE_*>
+constants.
+
+Otherwise, the data type is chosen to be a string, dict or array
+according to the perl data types SCALAR, HASH or ARRAY.
+
+=cut
+
+sub append {
+ my $self = shift;
+ my $value = shift;
+ my $type = shift;
+
+ if (ref($value) eq "Net::DBus::Binding::Value") {
+ $type = $value->type;
+ $value = $value->value;
+ }
+
+ if (!defined $type) {
+ $type = $self->guess_type($value);
+ }
+
+ if (ref($type) eq "ARRAY") {
+ my $maintype = $type->[0];
+ my $subtype = $type->[1];
+
+ if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ $self->append_dict($value, $subtype);
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) {
+ $self->append_struct($value, $subtype);
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) {
+ $self->append_array($value, $subtype);
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) {
+ $self->append_variant($value, $subtype);
+ } else {
+ die "Unsupported compound type ", $maintype, " ('", chr($maintype), "')";
+ }
+ } else {
+ # XXX is this good idea or not
+ $value = '' unless defined $value;
+
+ if ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) {
+ $self->append_boolean($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) {
+ $self->append_byte($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRING) {
+ $self->append_string($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) {
+ $self->append_int16($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) {
+ $self->append_uint16($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) {
+ $self->append_int32($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) {
+ $self->append_uint32($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) {
+ $self->append_int64($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) {
+ $self->append_uint64($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) {
+ $self->append_double($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
+ $self->append_object_path($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) {
+ $self->append_signature($value);
+ } else {
+ die "Unsupported scalar type ", $type, " ('", chr($type), "')";
+ }
+ }
+}
+
+
+=item my $type = $iter->guess_type($value)
+
+Make a best guess at the on the wire data type to use for
+marshalling C<$value>. If the value is a hash reference,
+the dictionary type is returned; if the value is an array
+reference the array type is returned; otherwise the string
+type is returned.
+
+=cut
+
+sub guess_type {
+ my $self = shift;
+ my $value = shift;
+
+ if (ref($value)) {
+ if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) {
+ my $type = $value->type;
+ if (ref($type) && ref($type) eq "ARRAY") {
+ my $maintype = $type->[0];
+ my $subtype = $type->[1];
+
+ if (!defined $subtype) {
+ if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ $subtype = [ $self->guess_type(($value->value())[0]->[0]),
+ $self->guess_type(($value->value())[0]->[1]) ];
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) {
+ $subtype = [ $self->guess_type(($value->value())[0]->[0]) ];
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) {
+ $subtype = [ map { $self->guess_type($_) } @{($value->value())[0]} ];
+ } else {
+ die "Unguessable compound type '$maintype' ('", chr($maintype), "')\n";
+ }
+ }
+ return [$maintype, $subtype];
+ } else {
+ return $type;
+ }
+ } elsif (ref($value) eq "HASH") {
+ my $key = (keys %{$value})[0];
+ my $val = $value->{$key};
+ # XXX Basically impossible to decide between DICT & STRUCT
+ return [ &Net::DBus::Binding::Message::TYPE_DICT_ENTRY,
+ [ &Net::DBus::Binding::Message::TYPE_STRING, $self->guess_type($val)] ];
+ } elsif (ref($value) eq "ARRAY") {
+ return [ &Net::DBus::Binding::Message::TYPE_ARRAY,
+ [$self->guess_type($value->[0])] ];
+ } else {
+ die "cannot marshall reference of type " . ref($value);
+ }
+ } else {
+ # XXX Should we bother trying to guess integer & floating point types ?
+ # I say sod it, because strongly typed languages will support introspection
+ # and loosely typed languages won't care about the difference
+ return &Net::DBus::Binding::Message::TYPE_STRING;
+ }
+}
+
+=item my $sig = $iter->format_signature($type)
+
+Given a data type representation, construct a corresponding
+signature string
+
+=cut
+
+sub format_signature {
+ my $self = shift;
+ my $type = shift;
+ my ($sig, $t, $i);
+
+ $sig = "";
+ $i = 0;use Data::Dumper;
+
+ if (ref($type) eq "ARRAY") {
+ while ($i <= $#{$type}) {
+ $t = $$type[$i];
+
+ if (ref($t) eq "ARRAY") {
+ $sig .= $self->format_signature($t);
+ } elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ $sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY);
+ $sig .= "{" . $self->format_signature($$type[++$i]) . "}";
+ } elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) {
+ $sig .= "(" . $self->format_signature($$type[++$i]) . ")";
+ } else {
+ $sig .= chr($t);
+ }
+
+ $i++;
+ }
+ } else {
+ $sig .= chr ($type);
+ }
+
+ return $sig;
+}
+
+=item $iter->append_array($value, $type)
+
+Append an array of values to the message. The C<$value> parameter
+must be an array reference, whose elements all have the same data
+type specified by the C<$type> parameter.
+
+=cut
+
+sub append_array {
+ my $self = shift;
+ my $array = shift;
+ my $type = shift;
+
+ if (!defined($type)) {
+ $type = [$self->guess_type($array->[0])];
+ }
+
+ die "array must only have one type"
+ if $#{$type} > 0;
+
+ my $sig = $self->format_signature($type);
+ my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
+
+ foreach my $value (@{$array}) {
+ $iter->append($value, $type->[0]);
+ }
+}
+
+
+=item $iter->append_struct($value, $type)
+
+Append a struct to the message. The C<$value> parameter
+must be an array reference, whose elements correspond to
+members of the structure. The C<$type> parameter encodes
+the type of each member of the struct.
+
+=cut
+
+sub append_struct {
+ my $self = shift;
+ my $struct = shift;
+ my $type = shift;
+
+ if (defined($type) &&
+ $#{$struct} != $#{$type}) {
+ die "number of values does not match type";
+ }
+
+ my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_STRUCT, "");
+
+ my @type = defined $type ? @{$type} : ();
+ foreach my $value (@{$struct}) {
+ $iter->append($value, shift @type);
+ }
+}
+
+=item $iter->append_dict($value, $type)
+
+Append a dictionary to the message. The C<$value> parameter
+must be an hash reference.The C<$type> parameter encodes
+the type of the key and value of the hash.
+
+=cut
+
+sub append_dict {
+ my $self = shift;
+ my $hash = shift;
+ my $type = shift;
+
+ my $sig;
+
+ $sig = "{";
+ $sig .= $self->format_signature($type);
+ $sig .= "}";
+
+ my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
+
+ foreach my $key (keys %{$hash}) {
+ my $value = $hash->{$key};
+ my $entry = $iter->_open_container(&Net::DBus::Binding::Message::TYPE_DICT_ENTRY, $sig);
+
+ $entry->append($key, $type->[0]);
+ $entry->append($value, $type->[1]);
+ }
+}
+
+=item $iter->append_variant($value)
+
+Append a value to the message, encoded as a variant type. The
+C<$value> can be of any type, however, the variant will be
+encoded as either a string, dictionary or array according to
+the rules of the C<guess_type> method.
+
+=cut
+
+sub append_variant {
+ my $self = shift;
+ my $value = shift;
+ my $type = shift;
+
+ if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) {
+ $type = [$self->guess_type($value)];
+ $value = $value->value;
+ } elsif (!defined $type || !defined $type->[0]) {
+ $type = [$self->guess_type($value)];
+ }
+ die "variant must only have one type"
+ if defined $type && $#{$type} > 0;
+
+ my $sig = $self->format_signature($type->[0]);
+ my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_VARIANT, $sig);
+ $iter->append($value, $type->[0]);
+}
+
+
+=item my $type = $iter->get_arg_type
+
+Retrieves the type code of the value pointing to by this iterator.
+The returned code will correspond to one of the constants
+C<Net::DBus::Binding::Message::TYPE_*>
+
+=cut
+
+sub get_arg_type {
+ my $self = shift;
+
+ return &Net::DBus::Binding::Message::TYPE_INVALID
+ if $self->{position} > $#{$self->{data}};
+
+ my $data = $self->{data}->[$self->{position}];
+ return $data->[0];
+}
+
+=item my $type = $iter->get_element_type
+
+If the iterator points to an array, retrieves the type code of
+array elements. The returned code will correspond to one of the
+constants C<Net::DBus::Binding::Message::TYPE_*>
+
+=cut
+
+sub get_element_type {
+ my $self = shift;
+
+ die "current element is not valid" if $self->{position} > $#{$self->{data}};
+
+ my $data = $self->{data}->[$self->{position}];
+ if ($data->[0] != &Net::DBus::Binding::Message::TYPE_ARRAY) {
+ die "current element is not an array";
+ }
+ return $data->[2];
+}
+
+
+
+sub _recurse {
+ my $self = shift;
+
+ die "_recurse call is not valid for writable iterator" if $self->{append};
+
+ die "current element is not valid" if $self->{position} > $#{$self->{data}};
+
+ my $data = $self->{data}->[$self->{position}];
+
+ my $type = $data->[0];
+ if ($type != &Net::DBus::Binding::Message::TYPE_STRUCT &&
+ $type != &Net::DBus::Binding::Message::TYPE_ARRAY &&
+ $type != &Net::DBus::Binding::Message::TYPE_VARIANT) {
+ die "current data element is not a container";
+ }
+
+ return $self->_new(data => $data->[1],
+ append => 0);
+}
+
+
+sub _append {
+ my $self = shift;
+ my $type = shift;
+ my $data = shift;
+
+ die "iterator is not open for append" unless $self->{append};
+
+ push @{$self->{data}}, [$type, $data];
+}
+
+
+sub _open_container {
+ my $self = shift;
+ my $type = shift;
+ my $sig = shift;
+
+ my $data = [];
+
+ push @{$self->{data}}, [$type, $data, $sig];
+
+ return $self->_new(data => $data,
+ append => 1);
+}
+
+
+
+sub _get {
+ my $self = shift;
+ my $type = shift;
+
+ die "iterator is not open for reading" if $self->{append};
+
+ die "current element is not valid" if $self->{position} > $#{$self->{data}};
+
+ my $data = $self->{data}->[$self->{position}];
+
+ die "data type does not match" unless $data->[0] == $type;
+
+ return $data->[1];
+}
+
+1;
+
+=pod
+
+=back
+
+=head1 BUGS
+
+It doesn't completely replicate the API of L<Net::DBus::Binding::Iterator>,
+merely enough to make the high level bindings work in a test scenario.
+
+=head1 SEE ALSO
+
+L<Net::DBus::Test::MockMessage>, L<Net::DBus::Binding::Iterator>,
+L<http://www.mockobjects.com/Faq.html>
+
+=head1 COPYRIGHT
+
+Copyright 2006 Daniel Berrange <dan at berrange.com>
+
+=cut
diff --git a/lib/Net/DBus/Test/MockMessage.pm b/lib/Net/DBus/Test/MockMessage.pm
new file mode 100644
index 0000000..24d59ed
--- /dev/null
+++ b/lib/Net/DBus/Test/MockMessage.pm
@@ -0,0 +1,444 @@
+# -*- perl -*-
+#
+# Copyright (C) 2006 Daniel P. Berrange
+#
+# This program is free software; You can redistribute it and/or modify
+# it under the same terms as Perl itself. Either:
+#
+# a) the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any
+# later version,
+#
+# or
+#
+# b) the "Artistic License"
+#
+# The file "COPYING" distributed along with this file provides full
+# details of the terms and conditions of the two licenses.
+
+=pod
+
+=head1 NAME
+
+Net::DBus::Test::MockMessage - Fake a message object when unit testing
+
+=head1 SYNOPSIS
+
+Sending a message
+
+ my $msg = new Net::DBus::Test::MockMessage;
+ my $iterator = $msg->iterator;
+
+ $iterator->append_byte(132);
+ $iterator->append_int32(14241);
+
+ $connection->send($msg);
+
+=head1 DESCRIPTION
+
+This module provides a "mock" counterpart to the L<Net::DBus::Binding::Message>
+class. It is basically a pure Perl fake message object providing the same
+contract as the real message object. It is intended for use internally by the
+testing APIs.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Net::DBus::Test::MockMessage;
+
+use 5.006;
+use strict;
+use warnings;
+
+use vars qw($SERIAL);
+
+BEGIN {
+ $SERIAL = 1;
+}
+
+use Net::DBus::Binding::Message;
+use Net::DBus::Test::MockIterator;
+
+=item my $call = Net::DBus::Test::MockMessage->new_method_call(
+ service_name => $service, object_path => $object,
+ interface => $interface, method_name => $name);
+
+Create a message representing a call on the object located at
+the path C<object_path> within the client owning the well-known
+name given by C<service_name>. The method to be invoked has
+the name C<method_name> within the interface specified by the
+C<interface> parameter.
+
+=cut
+
+sub new_method_call {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_CALL, @_);
+
+ bless $self, $class;
+
+ return $self;
+}
+
+=item my $msg = Net::DBus::Test::MockMessage->new_method_return(
+ replyto => $method_call);
+
+Create a message representing a reply to the method call passed in
+the C<replyto> parameter.
+
+=cut
+
+sub new_method_return {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN, @_);
+
+ bless $self, $class;
+
+ return $self;
+}
+
+=item my $signal = Net::DBus::Test::MockMessage->new_signal(
+ object_path => $path, interface => $interface, signal_name => $name);
+
+Creates a new message, representing a signal [to be] emitted by
+the object located under the path given by the C<object_path>
+parameter. The name of the signal is given by the C<signal_name>
+parameter, and is scoped to the interface given by the
+C<interface> parameter.
+
+=cut
+
+sub new_signal {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL, @_);
+
+ bless $self, $class;
+
+ return $self;
+}
+
+=item my $msg = Net::DBus::Test::MockMessage->new_error(
+ replyto => $method_call, name => $name, description => $description);
+
+Creates a new message, representing an error which occurred during
+the handling of the method call object passed in as the C<replyto>
+parameter. The C<name> parameter is the formal name of the error
+condition, while the C<description> is a short piece of text giving
+more specific information on the error.
+
+=cut
+
+sub new_error {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR, @_);
+
+ bless $self, $class;
+
+ return $self;
+}
+
+sub _new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my %params = @_;
+ my $self = {};
+
+ $self->{type} = exists $params{type} ? $params{type} : die "type parameter is required";
+ $self->{interface} = exists $params{interface} ? $params{interface} : undef;
+ $self->{path} = exists $params{path} ? $params{path} : undef;
+ $self->{destination} = exists $params{destination} ? $params{destination} : undef;
+ $self->{sender} = exists $params{sender} ? $params{sender} : undef;
+ $self->{member} = exists $params{member} ? $params{member} : undef;
+ $self->{error_name} = exists $params{error_name} ? $params{error_name} : undef;
+ $self->{data} = [];
+ $self->{no_reply} = 0;
+ $self->{serial} = $SERIAL++;
+ $self->{replyserial} = exists $params{replyto} ? $params{replyto}->get_serial : 0;
+
+ bless $self, $class;
+
+ if ($self->{type} == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) {
+ my $desc = exists $params{error_description} ? $params{error_description} : "";
+ my $iter = $self->iterator(1);
+ $iter->append_string($desc);
+ }
+
+ return $self;
+}
+
+
+=item my $type = $msg->get_type
+
+Retrieves the type code for this message. The returned value corresponds
+to one of the four C<Net::DBus::Test::MockMessage::MESSAGE_TYPE_*> constants.
+
+=cut
+
+sub get_type {
+ my $self = shift;
+
+ return $self->{type};
+}
+
+=item my $name = $msg->get_error_name
+
+Returns the formal name of the error, as previously passed in via
+the C<name> parameter in the constructor.
+
+=cut
+
+sub get_error_name {
+ my $self = shift;
+ return $self->{error_name};
+}
+
+=item my $interface = $msg->get_interface
+
+Retrieves the name of the interface targetted by this message, possibly
+an empty string if there is no applicable interface for this message.
+
+=cut
+
+sub get_interface {
+ my $self = shift;
+
+ return $self->{interface};
+}
+
+=item my $path = $msg->get_path
+
+Retrieves the object path associated with the message, possibly an
+empty string if there is no applicable object for this message.
+
+=cut
+
+sub get_path {
+ my $self = shift;
+
+ return $self->{path};
+}
+
+=item my $name = $msg->get_destination
+
+Retrieves the uniqe or well-known bus name for client intended to be
+the recipient of the message. Possibly returns an empty string if
+the message is being broadcast to all clients.
+
+=cut
+
+sub get_destination {
+ my $self = shift;
+
+ return $self->{destination};
+}
+
+=item my $name = $msg->get_sender
+
+Retireves the unique name of the client sending the message
+
+=cut
+
+sub get_sender {
+ my $self = shift;
+
+ return $self->{sender};
+}
+
+=item my $serial = $msg->get_serial
+
+Retrieves the unique serial number of this message. The number
+is guarenteed unique for as long as the connection over which
+the message was sent remains open. May return zero, if the message
+is yet to be sent.
+
+=cut
+
+sub get_serial {
+ my $self = shift;
+
+ return $self->{serial};
+}
+
+=item my $name = $msg->get_member
+
+For method calls, retrieves the name of the method to be invoked,
+while for signals, retrieves the name of the signal.
+
+=cut
+
+sub get_member {
+ my $self = shift;
+
+ return $self->{member};
+}
+
+
+=item $msg->set_sender($name)
+
+Set the name of the client sending the message. The name must
+be the unique name of the client.
+
+=cut
+
+sub set_sender {
+ my $self = shift;
+
+ $self->{sender} = shift;
+}
+
+=item $msg->set_destination($name)
+
+Set the name of the intended recipient of the message. This is
+typically used for signals to switch them from broadcast to
+unicast.
+
+=cut
+
+sub set_destination {
+ my $self = shift;
+ $self->{destination} = shift;
+}
+
+=item my $iterator = $msg->iterator;
+
+Retrieves an iterator which can be used for reading or
+writing fields of the message. The returned object is
+an instance of the C<Net::DBus::Binding::Iterator> class.
+
+=cut
+
+sub iterator {
+ my $self = shift;
+ my $append = @_ ? shift : 0;
+
+ return Net::DBus::Test::MockIterator->_new(data => $self->{data},
+ append => $append);
+}
+
+=item $boolean = $msg->get_no_reply()
+
+Gets the flag indicating whether the message is expecting
+a reply to be sent.
+
+=cut
+
+sub get_no_reply {
+ my $self = shift;
+
+ return $self->{no_reply};
+}
+
+=item $msg->set_no_reply($boolean)
+
+Toggles the flag indicating whether the message is expecting
+a reply to be sent. All method call messages expect a reply
+by default. By toggling this flag the communication latency
+is reduced by removing the need for the client to wait
+
+=cut
+
+
+sub set_no_reply {
+ my $self = shift;
+
+ $self->{no_reply} = shift;
+}
+
+=item my @values = $msg->get_args_list
+
+De-marshall all the values in the body of the message, using the
+message signature to identify data types. The values are returned
+as a list.
+
+=cut
+
+sub get_args_list {
+ my $self = shift;
+
+ my @ret;
+ my $iter = $self->iterator;
+ if ($iter->get_arg_type() != &Net::DBus::Binding::Message::TYPE_INVALID) {
+ do {
+ push @ret, $iter->get();
+ } while ($iter->next);
+ }
+
+ return @ret;
+}
+
+=item $msg->append_args_list(@values)
+
+Append a set of values to the body of the message. Values will
+be encoded as either a string, list or dictionary as appropriate
+to their Perl data type. For more specific data typing needs,
+the L<Net::DBus::Binding::Iterator> object should be used instead.
+
+=cut
+
+sub append_args_list {
+ my $self = shift;
+ my @args = @_;
+
+ my $iter = $self->iterator(1);
+ foreach my $arg (@args) {
+ $iter->append($arg);
+ }
+}
+
+=item my $sig = $msg->get_signature
+
+Retrieves a string representing the type signature of the values
+packed into the body of the message.
+
+=cut
+
+
+sub get_signature {
+ my $self = shift;
+
+ my @bits = map { $self->_do_get_signature($_) } @{$self->{data}};
+ return join ("", @bits);
+}
+
+sub _do_get_signature {
+ my $self = shift;
+ my $element = shift;
+
+ if ($element->[0] == &Net::DBus::Binding::Message::TYPE_ARRAY) {
+ return chr(&Net::DBus::Binding::Message::TYPE_ARRAY) . $element->[2];
+ } elsif ($element->[0] == &Net::DBus::Binding::Message::TYPE_STRUCT) {
+ my @bits = map { $self->_do_get_signature($_) } @{$element->[1]};
+ return "{" . join("", @bits) . "}";
+ } elsif ($element->[0] == &Net::DBus::Binding::Message::TYPE_VARIANT) {
+ return chr(&Net::DBus::Binding::Message::TYPE_VARIANT);
+ } else {
+ return chr($element->[0]);
+ }
+}
+
+1;
+
+=pod
+
+=back
+
+=head1 SEE ALSO
+
+L<Net::DBus::Binding::Message>, L<Net::DBus::Test::MockConnection>, L<Net::DBus::Test::MockIterator>
+
+=head1 AUTHOR
+
+Daniel Berrange E<lt>dan at berrange.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004 by Daniel Berrange
+
+=cut
diff --git a/lib/Net/DBus/Test/MockObject.pm b/lib/Net/DBus/Test/MockObject.pm
index a1ce762..a93a983 100644
--- a/lib/Net/DBus/Test/MockObject.pm
+++ b/lib/Net/DBus/Test/MockObject.pm
@@ -80,9 +80,6 @@ package Net::DBus::Test::MockObject;
use strict;
use warnings;
-use Net::DBus::Binding::Message::MethodReturn;
-use Net::DBus::Binding::Message::Error;
-
=item my $object = Net::DBus::Test::MockObject->new($service, $path, $interface);
Create a new mock object, attaching to the service defined by the C<$service>
@@ -233,31 +230,33 @@ sub _dispatch {
my $interface = $message->get_interface;
my $method = $message->get_member;
+ my $con = $self->get_service->get_bus->get_connection;
+
if (!exists $self->{actions}->{$method}) {
- my $error = Net::DBus::Binding::Message::Error->new(replyto => $message,
- name => "org.freedesktop.DBus.Failed",
- description => "no action seeded for method " . $message->get_member);
- $self->get_service->get_bus->get_connection->send($error);
+ my $error = $con->make_error_message($message,
+ "org.freedesktop.DBus.Failed",
+ "no action seeded for method " . $message->get_member);
+ $con->send($error);
return;
}
my $action;
if ($interface) {
if (!exists $self->{actions}->{$method}->{$interface}) {
- my $error = Net::DBus::Binding::Message::Error->new(replyto => $message,
- name => "org.freedesktop.DBus.Failed",
- description => "no action with correct interface seeded for method " . $message->get_member);
- $self->get_service->get_bus->get_connection->send($error);
+ my $error = $con->make_error_message($message,
+ "org.freedesktop.DBus.Failed",
+ "no action with correct interface seeded for method " . $message->get_member);
+ $con->send($error);
return;
}
$action = $self->{actions}->{$method}->{$interface};
} else {
my @interfaces = keys %{$self->{actions}->{$method}};
if ($#interfaces > 0) {
- my $error = Net::DBus::Binding::Message::Error->new(replyto => $message,
- name => "org.freedesktop.DBus.Failed",
- description => "too many actions seeded for method " . $message->get_member);
- $self->get_service->get_bus->get_connection->send($error);
+ my $error = $con->make_error_message($message,
+ "org.freedesktop.DBus.Failed",
+ "too many actions seeded for method " . $message->get_member);
+ $con->send($error);
return;
}
$action = $self->{actions}->{$method}->{$interfaces[0]};
@@ -276,17 +275,17 @@ sub _dispatch {
$self->{message} = $message;
if (exists $action->{error}) {
- my $error = Net::DBus::Binding::Message::Error->new(replyto => $message,
- name => $action->{error}->{name},
- description => $action->{error}->{description});
- $self->get_service->get_bus->get_connection->send($error);
+ my $error = $con->make_error_message($message,
+ $action->{error}->{name},
+ $action->{error}->{description});
+ $con->send($error);
} elsif (exists $action->{reply}) {
- my $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
+ my $reply = $con->make_method_return_message($message);
my $iter = $reply->iterator(1);
foreach my $value (@{$action->{reply}->{return}}) {
$iter->append($value);
}
- $self->get_service->get_bus->get_connection->send($reply);
+ $con->send($reply);
}
}
diff --git a/t/56-scalar-param-typing.t b/t/56-scalar-param-typing.t
index 5dd73e8..1b7b6ce 100644
--- a/t/56-scalar-param-typing.t
+++ b/t/56-scalar-param-typing.t
@@ -2,6 +2,8 @@
use Test::More tests => 382;
+use Carp qw(confess);
+$SIG{__DIE__} = sub { confess $_[0] };
use strict;
use warnings;
diff --git a/t/60-object-props.t b/t/60-object-props.t
index 1923147..e3fe15f 100644
--- a/t/60-object-props.t
+++ b/t/60-object-props.t
@@ -95,7 +95,7 @@ GET_NAME: {
my $reply = $bus->get_connection->send_with_reply_and_block($msg);
- isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+ is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
my ($value) = $reply->get_args_list;
is($value, "John Doe", "name is John Doe");
@@ -133,7 +133,7 @@ sub GET_SET_NAME: {
my $reply1 = $bus->get_connection->send_with_reply_and_block($msg1);
- isa_ok($reply1, "Net::DBus::Binding::Message::MethodReturn");
+ is($reply1->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
my ($value1) = $reply1->get_args_list;
is($value1, "John Doe", "name is John Doe");
@@ -151,12 +151,12 @@ sub GET_SET_NAME: {
my $reply2 = $bus->get_connection->send_with_reply_and_block($msg2);
- isa_ok($reply2, "Net::DBus::Binding::Message::MethodReturn");
+ is($reply2->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
my $reply3 = $bus->get_connection->send_with_reply_and_block($msg1);
- isa_ok($reply3, "Net::DBus::Binding::Message::MethodReturn");
+ is($reply3->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
my ($value2) = $reply3->get_args_list;
is($value2, "Jane Doe", "name is Jane Doe");
@@ -186,7 +186,7 @@ SET_AGE: {
my $reply1 = $bus->get_connection->send_with_reply_and_block($msg2);
- isa_ok($reply1, "Net::DBus::Binding::Message::MethodReturn");
+ is($reply1->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
my $reply2 = eval {
@@ -227,7 +227,7 @@ GET_EMAIL: {
my $reply2 = $bus->get_connection->send_with_reply_and_block($msg1);
- isa_ok($reply2, "Net::DBus::Binding::Message::MethodReturn");
+ is($reply2->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
is($object->age, 21, "age is 21");
diff --git a/t/65-object-magic.t b/t/65-object-magic.t
index 660c00d..9b6b69d 100644
--- a/t/65-object-magic.t
+++ b/t/65-object-magic.t
@@ -87,8 +87,7 @@ CALLER: {
$msg->set_sender(":1.1");
my $reply = $bus->get_connection->send_with_reply_and_block($msg);
-
- isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+ is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
is($object->test_get_caller, ":1.1", "caller is :1.1");
}
@@ -102,7 +101,7 @@ SERIAL: {
my $reply = $bus->get_connection->send_with_reply_and_block($msg);
- isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+ is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
is($object->test_get_serial, $msg->get_serial, "serial matches");
}
diff --git a/t/70-errors.t b/t/70-errors.t
index 3552591..466125a 100644
--- a/t/70-errors.t
+++ b/t/70-errors.t
@@ -53,5 +53,5 @@ eval {
};
my $error = $@;
isa_ok($error, "Net::DBus::Error");
-is($error->name, "org.example.music.UnknownFormat");
-is($error->message, "Unknown track encoding format");
+is($error->name, "org.example.music.UnknownFormat", "error name is set");
+is($error->message, "Unknown track encoding format", "error description is set");
--
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