[libnet-dbus-perl] 06/335: Added high level service+object API around low level bindings.
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:10 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 30ee7205a5fc74c9d30419c07b468e0298b2638d
Author: Daniel P. Berrange <dan at berrange.com>
Date: Sun Sep 26 22:35:23 2004 +0000
Added high level service+object API around low level bindings.
---
DBus.xs | 199 +++++++++++++++++++++++++++++++++++++--
Makefile.PL | 2 +-
examples/hello.pl | 15 +++
examples/list-services.pl | 25 +++++
examples/service.pl | 47 +++++++++
lib/DBus.pm | 102 +++++++++++++++++++-
lib/DBus/Bus.pm | 12 ++-
lib/DBus/Connection.pm | 45 +++++++--
lib/DBus/Iterator.pm | 63 +++++++++++++
lib/DBus/Message.pm | 74 +++++++++++++++
lib/DBus/Message/Error.pm | 9 +-
lib/DBus/Message/MethodCall.pm | 11 ++-
lib/DBus/Message/MethodReturn.pm | 5 +-
lib/DBus/Message/Signal.pm | 5 +-
lib/DBus/Object.pm | 73 ++++++++++++++
lib/DBus/Reactor.pm | 4 +-
lib/DBus/RemoteObject.pm | 54 +++++++++++
lib/DBus/RemoteService.pm | 37 ++++++++
lib/DBus/Service.pm | 25 +++++
19 files changed, 771 insertions(+), 36 deletions(-)
diff --git a/DBus.xs b/DBus.xs
index b7393b2..523cc06 100644
--- a/DBus.xs
+++ b/DBus.xs
@@ -180,7 +180,8 @@ _connection_callback (DBusServer *server,
return;
}
- /* The DESTROY method will de-ref it no matter what */
+ PD_DEBUG("Created connection in callback %x\n", new_connection);
+ /* The DESTROY method will de-ref it later */
dbus_connection_ref(new_connection);
value = sv_newmortal();
@@ -201,6 +202,59 @@ _connection_callback (DBusServer *server,
}
+DBusHandlerResult
+_message_filter(DBusConnection *con,
+ DBusMessage *msg,
+ void *data) {
+ SV *selfref;
+ HV *self;
+ SV *value;
+ int count;
+ int handled = 0;
+ dSP;
+
+ selfref = (SV*)dbus_connection_get_data(con, connection_data_slot);
+ self = (HV*)SvRV(selfref);
+
+ PD_DEBUG("Create message in filter %x\n", msg);
+ PD_DEBUG(" Type %d\n", dbus_message_get_type(msg));
+ PD_DEBUG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : "");
+ PD_DEBUG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : "");
+ PD_DEBUG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : "");
+ /* Will be de-refed in the DESTROY method */
+ dbus_message_ref(msg);
+ value = sv_newmortal();
+ sv_setref_pv(value, "DBus::C::Message", (void*)msg);
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs((SV*)selfref);
+ XPUSHs(value);
+ XPUSHs(data);
+ PUTBACK;
+
+ count = call_method("_message_filter", G_SCALAR);
+ /* XXX POPi prints use of uninitialized value ?!?!?! */
+if (0) {
+ if (count == 1) {
+ handled = POPi;
+ } else {
+ handled = 0;
+ }
+}
+ FREETMPS;
+ LEAVE;
+
+ return handled ? DBUS_HANDLER_RESULT_HANDLED : DBUS_HANDLER_RESULT_NOT_YET_HANDLED;
+}
+
+void
+_filter_release(void *data) {
+ SvREFCNT_dec(data);
+}
+
void
_path_unregister_callback(DBusConnection *con,
void *data) {
@@ -215,6 +269,13 @@ _path_message_callback(DBusConnection *con,
SV *value;
dSP;
+ PD_DEBUG("Got message in callback %x\n", msg);
+ PD_DEBUG(" Type %d\n", dbus_message_get_type(msg));
+ PD_DEBUG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : "");
+ PD_DEBUG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : "");
+ PD_DEBUG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : "");
+ /* Will be de-refed in the DESTROY method */
+ dbus_message_ref(msg);
value = sv_newmortal();
sv_setref_pv(value, "DBus::C::Message", (void*)msg);
@@ -279,6 +340,12 @@ BOOT:
REGISTER_CONSTANT(DBUS_TYPE_UINT32, TYPE_UINT32);
REGISTER_CONSTANT(DBUS_TYPE_UINT64, TYPE_UINT64);
+ REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_METHOD_CALL, MESSAGE_TYPE_METHOD_CALL);
+ REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_METHOD_RETURN, MESSAGE_TYPE_METHOD_RETURN);
+ REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_ERROR, MESSAGE_TYPE_ERROR);
+ REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_SIGNAL, MESSAGE_TYPE_SIGNAL);
+ REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_INVALID, MESSAGE_TYPE_INVALID);
+
constants = perl_get_hv("DBus::Watch::_constants", TRUE);
REGISTER_CONSTANT(DBUS_WATCH_READABLE, READABLE);
REGISTER_CONSTANT(DBUS_WATCH_WRITABLE, WRITABLE);
@@ -360,6 +427,7 @@ _send_with_reply_and_block(con, msg, timeout)
int timeout;
PREINIT:
DBusMessage *reply;
+ DBusMessageIter *iter;
DBusError error;
SV *h_sv;
CODE:
@@ -367,6 +435,13 @@ _send_with_reply_and_block(con, msg, timeout)
if (!(reply = dbus_connection_send_with_reply_and_block(con, msg, timeout, &error))) {
croak(error.message);
}
+ PD_DEBUG("Create msg reply %x\n", reply);
+ PD_DEBUG(" Type %d\n", dbus_message_get_type(reply));
+ PD_DEBUG(" Interface %s\n", dbus_message_get_interface(reply) ? dbus_message_get_interface(reply) : "");
+ PD_DEBUG(" Path %s\n", dbus_message_get_path(reply) ? dbus_message_get_path(reply) : "");
+ PD_DEBUG(" Member %s\n", dbus_message_get_member(reply) ? dbus_message_get_member(reply) : "");
+ // XXX needed ?
+ //dbus_message_ref(reply);
RETVAL = reply;
OUTPUT:
RETVAL
@@ -420,22 +495,39 @@ _set_timeout_callbacks(con)
}
void
-_register_message_handler(con, path, code)
+_register_object_path(con, path, code)
DBusConnection *con;
char *path;
SV *code;
- PREINIT:
- char *paths[2];
CODE:
- paths[0] = path;
- paths[1] = NULL;
-
SvREFCNT_inc(code);
- if (!(dbus_connection_register_object_path(con, paths, &_path_callback_vtable, code))) {
+ if (!(dbus_connection_register_object_path(con, path, &_path_callback_vtable, code))) {
croak("not enough memory to register object path");
}
void
+_add_filter(con, code)
+ DBusConnection *con;
+ SV *code;
+ CODE:
+ SvREFCNT_inc(code);
+ dbus_connection_add_filter(con, _message_filter, code, _filter_release);
+
+int
+dbus_bus_aquire_service(con, service_name)
+ DBusConnection *con;
+ char *service_name;
+ PREINIT:
+ DBusError error;
+ int reply;
+ CODE:
+ dbus_error_init(&error);
+ if (!(reply = dbus_bus_acquire_service(con, service_name, 0, &error))) {
+ croak(error.message);
+ }
+ RETVAL = reply;
+
+void
DESTROY(con)
DBusConnection *con;
CODE:
@@ -457,6 +549,7 @@ _open(address)
CODE:
dbus_error_init(&error);
server = dbus_server_listen(address, &error);
+ PD_DEBUG("Created server %x on address %s", server, address);
if (!server) {
// XXX fixme
//dbus_error_free(&error);
@@ -568,6 +661,8 @@ _create(type)
if (!msg) {
croak("No memory to allocate message");
}
+ PD_DEBUG("Create msg new %x\n", msg);
+ PD_DEBUG(" Type %d\n", dbus_message_get_type(msg));
RETVAL = msg;
OUTPUT:
RETVAL
@@ -586,6 +681,7 @@ set_auto_activation(msg, status)
CODE:
dbus_message_set_auto_activation(msg, status);
+
DBusMessageIter *
_iterator(msg)
DBusMessage *msg;
@@ -594,6 +690,7 @@ _iterator(msg)
SV *h_sv;
CODE:
iter = dbus_new(DBusMessageIter, 1);
+
dbus_message_iter_init(msg, iter);
RETVAL = iter;
OUTPUT:
@@ -606,9 +703,36 @@ void
DESTROY(msg)
DBusMessage *msg;
CODE:
- PD_DEBUG("Destroying message %x\n", msg);
+ PD_DEBUG("De-referencing message %x\n", msg);
+ PD_DEBUG(" Type %d\n", dbus_message_get_type(msg));
+ PD_DEBUG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : "");
+ PD_DEBUG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : "");
+ PD_DEBUG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : "");
dbus_message_unref(msg);
+int
+dbus_message_get_type(msg)
+ DBusMessage *msg;
+
+const char *
+dbus_message_get_interface(msg)
+ DBusMessage *msg;
+
+const char *
+dbus_message_get_path(msg)
+ DBusMessage *msg;
+
+const char *
+dbus_message_get_destination(msg)
+ DBusMessage *msg;
+
+const char *
+dbus_message_get_sender(msg)
+ DBusMessage *msg;
+
+const char *
+dbus_message_get_member(msg)
+ DBusMessage *msg;
MODULE = DBus::Message::Signal PACKAGE = DBus::Message::Signal
@@ -627,6 +751,11 @@ _create(path, interface, name)
if (!msg) {
croak("No memory to allocate message");
}
+ PD_DEBUG("Create msg new signal %x\n", msg);
+ PD_DEBUG(" Type %d\n", dbus_message_get_type(msg));
+ PD_DEBUG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : "");
+ PD_DEBUG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : "");
+ PD_DEBUG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : "");
RETVAL = msg;
OUTPUT:
RETVAL
@@ -649,6 +778,11 @@ _create(service, path, interface, method)
if (!msg) {
croak("No memory to allocate message");
}
+ PD_DEBUG("Create msg new method call %x\n", msg);
+ PD_DEBUG(" Type %d\n", dbus_message_get_type(msg));
+ PD_DEBUG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : "");
+ PD_DEBUG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : "");
+ PD_DEBUG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : "");
RETVAL = msg;
OUTPUT:
RETVAL
@@ -668,6 +802,11 @@ _create(call)
if (!msg) {
croak("No memory to allocate message");
}
+ PD_DEBUG("Create msg new method return %x\n", msg);
+ PD_DEBUG(" Type %d\n", dbus_message_get_type(msg));
+ PD_DEBUG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : "");
+ PD_DEBUG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : "");
+ PD_DEBUG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : "");
RETVAL = msg;
OUTPUT:
RETVAL
@@ -689,6 +828,11 @@ _create(replyto, name, message)
if (!msg) {
croak("No memory to allocate message");
}
+ PD_DEBUG("Create msg new error %x\n", msg);
+ PD_DEBUG(" Type %d\n", dbus_message_get_type(msg));
+ PD_DEBUG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : "");
+ PD_DEBUG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : "");
+ PD_DEBUG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : "");
RETVAL = msg;
OUTPUT:
RETVAL
@@ -811,6 +955,43 @@ next(iter)
OUTPUT:
RETVAL
+
+DBusMessageIter *
+get_array_iter(iter)
+ DBusMessageIter *iter;
+ PREINIT:
+ DBusMessageIter *array_iter;
+ int type;
+ CODE:
+ array_iter = dbus_new(DBusMessageIter, 1);
+ dbus_message_iter_init_array_iterator(iter, array_iter, &type);
+ RETVAL = array_iter;
+ OUTPUT:
+ RETVAL
+
+DBusMessageIter *
+get_dict_iter(iter)
+ DBusMessageIter *iter;
+ PREINIT:
+ DBusMessageIter *dict_iter;
+ CODE:
+ dict_iter = dbus_new(DBusMessageIter, 1);
+ dbus_message_iter_init_dict_iterator(iter, dict_iter);
+ RETVAL = dict_iter;
+ OUTPUT:
+ RETVAL
+
+char *
+get_dict_key(iter)
+ DBusMessageIter *iter;
+ PREINIT:
+ char *key;
+ CODE:
+ key = dbus_message_iter_get_dict_key(iter);
+ RETVAL = key;
+ OUTPUT:
+ RETVAL
+
dbus_bool_t
get_boolean(iter)
DBusMessageIter *iter;
diff --git a/Makefile.PL b/Makefile.PL
index 05bd2a3..9a3ac7b 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -17,7 +17,7 @@ foreach (@ARGV) {
} elsif (/^DBUS_DEBUG=0$/) {
$PD_DEBUG = "";
} elsif (/^DBUS_DEBUG=1$/) {
- $PD_DEBUG = "-PPD_DO_DEBUG";
+ $PD_DEBUG = "-DPD_DO_DEBUG";
}
}
diff --git a/examples/hello.pl b/examples/hello.pl
new file mode 100644
index 0000000..56e494c
--- /dev/null
+++ b/examples/hello.pl
@@ -0,0 +1,15 @@
+#/usr/bin/perl
+
+
+use DBus;
+
+
+my $bus = DBus->new($DBus::TYPE_SESSION);
+
+my $service = $bus->get_service("org.example.MyService",
+ $bus);
+
+my $object = $service->get_object("/org/example/MyObject",
+ "org.example.MyObject");
+
+print "Reply ", join("\n", $object->HelloWorld("Earth")), "\n";
diff --git a/examples/list-services.pl b/examples/list-services.pl
new file mode 100644
index 0000000..7e9562c
--- /dev/null
+++ b/examples/list-services.pl
@@ -0,0 +1,25 @@
+#!/usr/bin/perl
+
+use DBus;
+
+# Connect to the system bus
+my $bus = DBus->new($DBus::TYPE_SESSION);
+
+# Get the service provided by the dbus-daemon named org.freedesktop.DBus
+my $service = $bus->get_service("org.freedesktop.DBus");
+
+# Get a reference to the desktop bus' standard object, denoted
+# by the path /org/freedesktop/DBus. The object /org/freedesktop/DBus
+# implements the 'org.freedesktop.DBus' interface
+my $object = $service->get_object('/org/freedesktop/DBus',
+ 'org.freedesktop.DBus');
+
+# One of the member functions in the org.freedesktop.DBus interface
+# is ListServices(), which provides a list of all the other services
+# registered on this bus. Call it, and print the list.
+print "Before\n";
+my @service_list = $object->ListServices();
+print "After\n";
+print "Got ", join("\n", map { "'" . $_ . "'" } @service_list), "\n";
+
+
diff --git a/examples/service.pl b/examples/service.pl
new file mode 100644
index 0000000..7c4c88e
--- /dev/null
+++ b/examples/service.pl
@@ -0,0 +1,47 @@
+#!/usr/bin/perl
+
+use Carp qw(confess cluck);
+use DBus;
+use DBus::Service;
+use DBus::Reactor;
+
+#$SIG{__WARN__} = sub { cluck $_[0] };
+#$SIG{__DIE__} = sub { confess $_[0] };
+
+my $bus = DBus->new($DBus::TYPE_SESSION);
+
+my $service = DBus::Service->new("org.example.MyService",
+ $bus);
+
+my $object = MyObject->new($service);
+
+
+my $reactor = DBus::Reactor->new();
+print "Con ", $bus->{connection}, "\n";
+$reactor->manage($bus->{connection});
+
+print "Run reactor\n";
+$reactor->run();
+print "All done\n";
+
+package MyObject;
+
+use base qw(DBus::Object);
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new("/org/example/MyObject",
+ ["HelloWorld"],
+ @_);
+
+ bless $self, $class;
+
+ return $self;
+}
+
+sub HelloWorld {
+ my $self = shift;
+ my $place = shift;
+
+ return ("Hello", "World", $place);
+}
diff --git a/lib/DBus.pm b/lib/DBus.pm
index 0a33f1b..a737757 100644
--- a/lib/DBus.pm
+++ b/lib/DBus.pm
@@ -5,13 +5,113 @@ use strict;
use warnings;
use Carp;
-use AutoLoader;
+use DBus::Bus;
+use DBus::RemoteService;
our $VERSION = '0.0.1';
require XSLoader;
XSLoader::load('DBus', $VERSION);
+use vars qw($TYPE_SESSION $TYPE_SYSTEM);
+
+$TYPE_SESSION = &DBus::Bus::SESSION;
+$TYPE_SYSTEM = &DBus::Bus::SYSTEM;
+
+sub new {
+ my $class = shift;
+ my $self = {};
+ my $type = shift;
+
+ $self->{connection} = DBus::Bus->new(type => $type);
+ $self->{signals} = {};
+
+ bless $self, $class;
+
+ $self->{connection}->add_filter(sub { $self->_signal_func(@_) });
+
+ return $self;
+}
+
+
+sub get_service {
+ my $self = shift;
+ my $name = @_ ? shift : "org.freedesktop.Broadcast";
+
+ return DBus::RemoteService->new($self->{connection}, $name);
+}
+
+sub add_signal_receiver {
+ my $self = shift;
+ my $receiver = shift;
+ my $interface = @_ ? shift : "None";
+ my $service = @_ ? shift : "None";
+ my $path = @_ ? shift : "None";
+
+ my $rule = $self->_match_rule($interface, $service, $path);
+
+ $self->{receivers}->{$rule} = [] unless $self->{receivers}->{$rule};
+ push @{$self->{receivers}}, $receiver;
+
+ $self->{connection}->add_match($rule);
+}
+
+sub remove_signal_receiver {
+ my $self = shift;
+ my $receiver = shift;
+ my $interface = @_ ? shift : "None";
+ my $service = @_ ? shift : "None";
+ my $path = @_ ? shift : "None";
+
+ my $rule = $self->_match_rule($interface, $service, $path);
+
+ my @receivers;
+ foreach (@{$self->{receivers}->{$rule}}) {
+ if ($_ eq $receiver) {
+ $self->{connection}->remove_match($rule);
+ } else {
+ push @receivers, $_;
+ }
+ }
+ $self->{receivers}->{$rule} = \@receivers;
+}
+
+
+sub _match_rule {
+ my $self = shift;
+ my $interface = shift;
+ my $service = shift;
+ my $path = shift;
+
+ # FIXME: use the service here too!!!
+ return "type='signal',interface='$interface',path='$path'";
+}
+
+
+sub _signal_func {
+ my $self = shift;
+ my $connection = shift;
+ my $message = shift;
+
+ return 0 unless $message->isa("DBus::Message::Signal");
+
+ my $interface = $message->get_interface;
+ my $service = $message->get_sender;
+ my $path = $message->get_path;
+ my $member = $message->get_member;
+
+ my $rule = $self->_match_rule($interface, $service, $path);
+
+ my $handled = 0;
+ if (exists $self->{receivers}->{$rule}) {
+ foreach (@{$self->{receivers}->{$rule}}) {
+ &$_($interface, $member, $service, $path, $message);
+ $handled = 1;
+ }
+ }
+ return $handled;
+}
+
1;
__END__
diff --git a/lib/DBus/Bus.pm b/lib/DBus/Bus.pm
index a64d190..3b95c31 100644
--- a/lib/DBus/Bus.pm
+++ b/lib/DBus/Bus.pm
@@ -8,7 +8,7 @@ use Carp;
use DBus;
use DBus::Connection;
-our @ISA = qw(Exporter DBus::Connection);
+our @ISA = qw(DBus::Connection);
our $VERSION = '0.0.1';
@@ -17,7 +17,7 @@ sub new {
my $class = ref($proto) || $proto;
my %params = @_;
- my $connection = DBus::Bus::_open($params{type} ? $params{type} : confess "type parameter is required");
+ my $connection = DBus::Bus::_open(defined $params{type} ? $params{type} : confess "type parameter is required");
my $self = $class->SUPER::new(%params, connection => $connection);
@@ -26,6 +26,14 @@ sub new {
return $self;
}
+
+sub acquire_service {
+ my $self = shift;
+ my $service_name = shift;
+
+ $self->{connection}->dbus_bus_aquire_service($service_name);
+}
+
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function.
diff --git a/lib/DBus/Connection.pm b/lib/DBus/Connection.pm
index 228d57c..02da67f 100644
--- a/lib/DBus/Connection.pm
+++ b/lib/DBus/Connection.pm
@@ -177,7 +177,7 @@ sub send {
=pod
-=item my $reply = $con->send_with_reply_and_block($msg);
+=item my $reply = $con->send_with_reply_and_block($msg, $timeout);
Queues a message up for sending to the remote host
and blocks until it has been sent, and a corresponding
@@ -190,9 +190,20 @@ object.
sub send_with_reply_and_block {
my $self = shift;
my $msg = shift;
+ my $timeout = shift;
- my $reply = $self->{connection}->_send_with_reply_and_block($msg->{message});
- return DBus::Message::MethodReturn->new(message => $reply);
+ my $reply = $self->{connection}->_send_with_reply_and_block($msg->{message}, $timeout);
+
+ my $type = $reply->dbus_message_get_type;
+ if ($type == &DBus::Message::MESSAGE_TYPE_ERROR) {
+ return DBus::Message::Error->new(replyto => $msg,
+ message => $reply);
+ } elsif ($type == &DBus::Message::MESSAGE_TYPE_METHOD_RETURN) {
+ return DBus::Message::MethodReturn->new(call => $msg,
+ message => $reply);
+ } else {
+ confess "unknown method reply type $type";
+ }
}
@@ -344,7 +355,7 @@ sub set_timeout_callbacks {
=pod
-=item $con->register_message_handler($path, \&handler)
+=item $con->register_object_path($path, \&handler)
Registers a handler for messages whose path matches
that specified in the C<$path> parameter. The supplied
@@ -355,7 +366,7 @@ C<DBus::Message> class).
=cut
-sub register_message_handler {
+sub register_object_path {
my $self = shift;
my $path = shift;
my $code = shift;
@@ -363,11 +374,11 @@ sub register_message_handler {
my $callback = sub {
my $con = shift;
my $msg = shift;
-
+
&$code($con, DBus::Message->new(message => $msg));
};
-
- $self->{connection}->_register_message_handler($path, $callback);
+
+ $self->{connection}->_register_object_path($path, $callback);
}
@@ -440,6 +451,24 @@ sub get_max_received_size {
return $self->{connection}->dbus_connection_get_max_received_size;
}
+
+sub add_filter {
+ my $self = shift;
+ my $callback = shift;
+
+ $self->{connection}->_add_filter($callback);
+}
+
+
+sub _message_filter {
+ my $self = shift;
+ my $rawmsg = shift;
+ my $code = shift;
+
+ my $msg = DBus::Message->new(message => $rawmsg);
+ return &$code($self, $msg);
+}
+
1;
=pod
diff --git a/lib/DBus/Iterator.pm b/lib/DBus/Iterator.pm
index eb17fd6..90905a6 100644
--- a/lib/DBus/Iterator.pm
+++ b/lib/DBus/Iterator.pm
@@ -164,6 +164,69 @@ sub append_uint64 {
$self->_append_uint64(shift);
}
+
+sub get {
+ my $self = shift;
+
+ my $type = $self->get_arg_type;
+
+ if ($type == &DBus::Message::TYPE_STRING) {
+ return $self->get_string;
+ } elsif ($type == &DBus::Message::TYPE_INT32) {
+ return $self->get_int32;
+ } elsif ($type == &DBus::Message::TYPE_UINT32) {
+ return $self->get_uint32;
+ } elsif ($type == &DBus::Message::TYPE_INT64) {
+ return $self->get_int64;
+ } elsif ($type == &DBus::Message::TYPE_UINT64) {
+ return $self->get_uint64;
+ } elsif ($type == &DBus::Message::TYPE_ARRAY) {
+ my $iter = $self->get_array_iter();
+ my @value;
+ do {
+ push @value, $iter->get();
+ } while ($iter->next());
+ return @value;
+ } elsif ($type == &DBus::Message::TYPE_BOOLEAN) {
+ return $self->get_boolean;
+ } elsif ($type == &DBus::Message::TYPE_BYTE) {
+ return $self->get_byte;
+ } elsif ($type == &DBus::Message::TYPE_CUSTOM) {
+ confess "cannot handle DBus::Message::TYPE_CUSTOM";
+ } elsif ($type == &DBus::Message::TYPE_DICT) {
+ confess "cannot handle DBus::Message::TYPE_DICT";
+ } elsif ($type == &DBus::Message::TYPE_DOUBLE) {
+ return $self->get_double;
+ } elsif ($type == &DBus::Message::TYPE_INVALID) {
+ confess "cannot handle DBus::Message::TYPE_INVALID";
+ } elsif ($type == &DBus::Message::TYPE_NIL) {
+ return undef;
+ } elsif ($type == &DBus::Message::TYPE_OBJECT_PATH) {
+ confess "cannot handle DBus::Message::TYPE_OBJECT_PATH";
+ }
+}
+
+sub append {
+ my $self = shift;
+ my $value = shift;
+
+ if (ref($value)) {
+ if (ref($value) eq "ARRAY") {
+ } elsif (ref($value) eq "HASH") {
+ } else {
+ confess "Unknown reference type ", ref($value);
+ }
+ } else {
+ if ($value =~ /^[+-]?\d+$/) {
+ $self->append_int32($value);
+ } elsif ($value =~ /^([+-]?)(?=\d���\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
+ $self->append_double($value);
+ } else {
+ $self->append_string($value);
+ }
+ }
+}
+
1;
=pod
diff --git a/lib/DBus/Message.pm b/lib/DBus/Message.pm
index f0ba673..88618cc 100644
--- a/lib/DBus/Message.pm
+++ b/lib/DBus/Message.pm
@@ -40,6 +40,10 @@ use Carp;
use DBus;
use DBus::Iterator;
+use DBus::Message::Signal;
+use DBus::Message::MethodCall;
+use DBus::Message::MethodReturn;
+use DBus::Message::Error;
our $VERSION = '0.0.1';
@@ -53,10 +57,67 @@ sub new {
(DBus::Message::_create(exists $params{type} ? $params{type} : confess "type parameter is required"));
bless $self, $class;
+
+ if ($class eq "DBus::Message") {
+ $self->_specialize;
+ }
return $self;
}
+sub _specialize {
+ my $self = shift;
+
+ my $type = $self->get_type;
+ if ($type == &DBus::Message::MESSAGE_TYPE_METHOD_CALL) {
+ bless $self, "DBus::Message::MethodCall";
+ } elsif ($type == &DBus::Message::MESSAGE_TYPE_METHOD_RETURN) {
+ bless $self, "DBus::Message::MethodReturn";
+ } elsif ($type == &DBus::Message::MESSAGE_TYPE_ERROR) {
+ bless $self, "DBus::Message::Error";
+ } elsif ($type == &DBus::Message::MESSAGE_TYPE_SIGNAL) {
+ bless $self, "DBus::Message::Signal";
+ } else {
+ warn "Unknown message type $type\n";
+ }
+}
+
+sub get_type {
+ my $self = shift;
+
+ return $self->{message}->dbus_message_get_type;
+}
+
+sub get_interface {
+ my $self = shift;
+
+ return $self->{message}->dbus_message_get_interface;
+}
+
+sub get_path {
+ my $self = shift;
+
+ return $self->{message}->dbus_message_get_path;
+}
+
+sub get_destination {
+ my $self = shift;
+
+ return $self->{message}->dbus_message_get_destination;
+}
+
+sub get_sender {
+ my $self = shift;
+
+ return $self->{message}->dbus_message_get_sender;
+}
+
+sub get_member {
+ my $self = shift;
+
+ return $self->{message}->dbus_message_get_member;
+}
+
=pod
@@ -75,6 +136,19 @@ sub iterator {
}
+sub get_args_list {
+ my $self = shift;
+
+ my @ret;
+ my $iter = $self->iterator;
+
+ do {
+ push @ret, $iter->get;
+ } while ($iter->next);
+
+ return @ret;
+}
+
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function.
diff --git a/lib/DBus/Message/Error.pm b/lib/DBus/Message/Error.pm
index 8a65ece..29639ef 100644
--- a/lib/DBus/Message/Error.pm
+++ b/lib/DBus/Message/Error.pm
@@ -8,7 +8,7 @@ use Carp;
use DBus;
use DBus::Message;
-our @ISA = qw(Exporter DBus::Message);
+our @ISA = qw(DBus::Message);
our $VERSION = '0.0.1';
@@ -19,13 +19,14 @@ sub new {
my $replyto = exists $params{replyto} ? $params{replyto} : confess "replyto parameter is required";
- my $msg = DBus::Message::Error::_create
+ my $msg = exists $params{message} ? $params{message} :
+ DBus::Message::Error::_create
(
$replyto->{message},
($params{name} ? $params{name} : confess "name parameter is required"),
- ($params{message} ? $params{message} : confess "message parameter is required"));
+ ($params{description} ? $params{description} : confess "description parameter is required"));
- my $self = $class->SUPER::new(%params, message => $msg);
+ my $self = $class->SUPER::new(message => $msg);
bless $self, $class;
diff --git a/lib/DBus/Message/MethodCall.pm b/lib/DBus/Message/MethodCall.pm
index 0ea014c..7294084 100644
--- a/lib/DBus/Message/MethodCall.pm
+++ b/lib/DBus/Message/MethodCall.pm
@@ -17,14 +17,15 @@ sub new {
my $class = ref($proto) || $proto;
my %params = @_;
- my $msg = DBus::Message::MethodCall::_create
+ my $msg = exists $params{message} ? $params{message} :
+ DBus::Message::MethodCall::_create
(
- ($params{service} ? $params{service} : confess "service parameter is required"),
- ($params{path} ? $params{path} : confess "path parameter is required"),
+ ($params{service_name} ? $params{service_name} : confess "service_name parameter is required"),
+ ($params{object_path} ? $params{object_path} : confess "object_path parameter is required"),
($params{interface} ? $params{interface} : confess "interface parameter is required"),
- ($params{method} ? $params{method} : confess "method parameter is required"));
+ ($params{method_name} ? $params{method_name} : confess "method_name parameter is required"));
- my $self = $class->SUPER::new(%params, message => $msg);
+ my $self = $class->SUPER::new(message => $msg);
bless $self, $class;
diff --git a/lib/DBus/Message/MethodReturn.pm b/lib/DBus/Message/MethodReturn.pm
index d86ce65..bd5cc0f 100644
--- a/lib/DBus/Message/MethodReturn.pm
+++ b/lib/DBus/Message/MethodReturn.pm
@@ -19,9 +19,10 @@ sub new {
my $call = exists $params{call} ? $params{call} : confess "call parameter is required";
- my $msg = DBus::Message::MethodReturn::_create($call->{message});
+ my $msg = exists $params{message} ? $params{message} :
+ DBus::Message::MethodReturn::_create($call->{message});
- my $self = $class->SUPER::new(%params, message => $msg);
+ my $self = $class->SUPER::new(message => $msg);
bless $self, $class;
diff --git a/lib/DBus/Message/Signal.pm b/lib/DBus/Message/Signal.pm
index a779006..5259260 100644
--- a/lib/DBus/Message/Signal.pm
+++ b/lib/DBus/Message/Signal.pm
@@ -17,13 +17,14 @@ sub new {
my $class = ref($proto) || $proto;
my %params = @_;
- my $msg = DBus::Message::Signal::_create
+ my $msg = exists $params{message} ? $params{message} :
+ DBus::Message::Signal::_create
(
($params{path} ? $params{path} : confess "path parameter is required"),
($params{interface} ? $params{interface} : confess "interface parameter is required"),
($params{name} ? $params{name} : confess "name parameter is required"));
- my $self = $class->SUPER::new(%params, message => $msg);
+ my $self = $class->SUPER::new(message => $msg);
bless $self, $class;
diff --git a/lib/DBus/Object.pm b/lib/DBus/Object.pm
new file mode 100644
index 0000000..755d7c5
--- /dev/null
+++ b/lib/DBus/Object.pm
@@ -0,0 +1,73 @@
+package DBus::Object;
+
+use 5.006;
+use strict;
+use warnings;
+use Carp;
+
+use AutoLoader;
+
+our $VERSION = '0.0.1';
+
+use DBus::RemoteObject;
+
+sub new {
+ my $class = shift;
+ my $self = {};
+
+ $self->{object_path} = shift;
+
+ my $methods = shift;
+ $self->{methods} = {};
+ map { $self->{methods}->{$_} = 1 } @{$methods};
+
+ $self->{service} = shift;
+
+ bless $self, $class;
+
+ $self->{service}->{bus}->{connection}->
+ register_object_path($self->{object_path},
+ sub {
+ $self->_dispatch(@_);
+ });
+
+ return $self;
+}
+
+
+sub _dispatch {
+ my $self = shift;
+ my $connection = shift;
+ my $message = shift;
+
+ my $method_name = $message->get_member;
+ my @args = $message->get_args_list;
+
+ my $reply;
+ if ($self->can($method_name)) {
+ my @ret = eval {
+ $self->$method_name(@args);
+ };
+ if ($@) {
+ $reply = DBus::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => $@);
+ } else {
+ $reply = DBus::Message::MethodReturn->new(call => $message);
+ my $iter = $reply->iterator;
+ foreach my $ret (@ret) {
+ $iter->append($ret);
+ }
+ }
+ } else {
+ $reply = DBus::Message::Error->new(replyto => $message,
+ name => "org.freedesktop.DBus.Error.Failed",
+ description => "No such method " . ref($self) . "->" . $method_name);
+ }
+
+ $self->{service}->{bus}->{connection}->send($reply);
+}
+
+1;
+
+__END__
diff --git a/lib/DBus/Reactor.pm b/lib/DBus/Reactor.pm
index 74e6c15..4dd773f 100644
--- a/lib/DBus/Reactor.pm
+++ b/lib/DBus/Reactor.pm
@@ -150,7 +150,7 @@ C<dispatch> method periodically.
sub manage {
my $self = shift;
my $object = shift;
-
+
if ($object->can("set_watch_callbacks")) {
$object->set_watch_callbacks(sub {
my $object = shift;
@@ -212,7 +212,7 @@ sub _manage_watch_on {
my $object = shift;
my $watch = shift;
my $flags = $watch->get_flags;
-
+
if ($flags & &DBus::Watch::READABLE) {
$self->add_read($watch->get_fileno,
DBus::Callback->new(object => $watch,
diff --git a/lib/DBus/RemoteObject.pm b/lib/DBus/RemoteObject.pm
new file mode 100644
index 0000000..8a95b7d
--- /dev/null
+++ b/lib/DBus/RemoteObject.pm
@@ -0,0 +1,54 @@
+package DBus::RemoteObject;
+
+use 5.006;
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.0.1';
+our $AUTOLOAD;
+
+use DBus::Message::MethodCall;
+
+sub new {
+ my $class = shift;
+ my $self = {};
+
+ $self->{connection} = shift;
+ $self->{service_name} = shift;
+ $self->{object_path} = shift;
+ $self->{interface} = shift;
+
+ bless $self, $class;
+
+ return $self;
+}
+
+sub DESTROY {
+ # No op merely to stop AutoLoader trying to
+ # call DESTROY on remote object
+}
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $sub = $AUTOLOAD;
+
+ (my $method = $AUTOLOAD) =~ s/.*:://;
+ my $call = DBus::Message::MethodCall->new(service_name => $self->{service_name},
+ object_path => $self->{object_path},
+ method_name => $method,
+ interface => $self->{interface});
+
+ my $iter = $call->iterator;
+ foreach my $arg (@_) {
+ $iter->append($arg);
+ }
+
+ my $reply = $self->{connection}->send_with_reply_and_block($call, 5000);
+
+ return $reply->get_args_list;
+}
+
+
+1;
+
diff --git a/lib/DBus/RemoteService.pm b/lib/DBus/RemoteService.pm
new file mode 100644
index 0000000..b419fb2
--- /dev/null
+++ b/lib/DBus/RemoteService.pm
@@ -0,0 +1,37 @@
+package DBus::RemoteService;
+
+use 5.006;
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.0.1';
+
+use DBus::RemoteObject;
+
+
+sub new {
+ my $class = shift;
+ my $self = {};
+
+ $self->{connection} = shift;
+ $self->{service_name} = shift;
+
+ bless $self, $class;
+
+ return $self;
+}
+
+sub get_object {
+ my $self = shift;
+ my $object_path = shift;
+ my $interface = shift;
+
+ return DBus::RemoteObject->new($self->{connection},
+ $self->{service_name},
+ $object_path,
+ $interface);
+}
+
+1;
+
diff --git a/lib/DBus/Service.pm b/lib/DBus/Service.pm
new file mode 100644
index 0000000..4cae186
--- /dev/null
+++ b/lib/DBus/Service.pm
@@ -0,0 +1,25 @@
+package DBus::Service;
+
+
+sub new {
+ my $class = shift;
+ my $self = {};
+
+ $self->{service_name} = shift;
+ $self->{bus} = shift;
+
+ bless $self, $class;
+
+ $self->{bus}->{connection}->acquire_service($self->{service_name});
+
+ return $self;
+}
+
+
+sub service_name {
+ my $self = shift;
+ return $self->{service_name};
+}
+
+1;
+
--
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