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 de226ccfe3d8755b742d57df3f4bd8744cba8bed Author: Daniel P. Berrange <d...@berrange.com> Date: Thu Aug 5 08:14:18 2004 +0000 Initial commit --- .hgignore | 6 + DBus.xs | 633 +++++++++++++++++++++++++++++++++++++++ Makefile.PL | 29 ++ README | 38 +++ lib/DBus.pm | 56 ++++ lib/DBus/Bus.pm | 51 ++++ lib/DBus/Connection.pm | 122 ++++++++ lib/DBus/Iterator.pm | 63 ++++ lib/DBus/Message.pm | 109 +++++++ lib/DBus/Message/Error.pm | 35 +++ lib/DBus/Message/MethodCall.pm | 34 +++ lib/DBus/Message/MethodReturn.pm | 31 ++ lib/DBus/Message/Signal.pm | 34 +++ lib/DBus/Reactor.pm | 245 +++++++++++++++ lib/DBus/Server.pm | 132 ++++++++ lib/DBus/Watch.pm | 32 ++ t/1.t | 52 ++++ t/2.t | 24 ++ t/3.t | 24 ++ t/4.t | 21 ++ t/5.t | 39 +++ t/6.t | 58 ++++ typemap | 78 +++++ 23 files changed, 1946 insertions(+) diff --git a/.hgignore b/.hgignore new file mode 100644 index 0000000..0d149c2 --- /dev/null +++ b/.hgignore @@ -0,0 +1,6 @@ +(^|/)CVS($|/) +(^|/)\.hg($|/) +(^|/)\.hgtags($|/) +^state$ +^state.old$ +^state.journal$ diff --git a/DBus.xs b/DBus.xs new file mode 100644 index 0000000..8c20349 --- /dev/null +++ b/DBus.xs @@ -0,0 +1,633 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <dbus/dbus.h> + + +dbus_bool_t +_watch_generic(DBusWatch *watch, void *data, char *key) { + HV *self = (HV*)SvRV((SV*)data); + SV **call; + SV *h_sv1; + SV *h_sv2; + dSP; +printf("In watxh %x %x %s\n", data, self, key); + + call = hv_fetch(self, key, strlen(key), 0); + + if (!call) { +printf("Could not find call %s\n", key); + return FALSE; + } + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs((SV*)data); + h_sv2 = sv_newmortal(); + sv_setref_pv(h_sv2, "DBus::C::Watch", (void*)watch); + XPUSHs(h_sv2); + PUTBACK; + + call_sv(*call, G_DISCARD); + + FREETMPS; + LEAVE; +} + +dbus_bool_t +_watch_server_add(DBusWatch *watch, void *data) { + return _watch_generic(watch, data, "add_watch"); +} +void +_watch_server_remove(DBusWatch *watch, void *data) { + _watch_generic(watch, data, "remove_watch"); +} +void +_watch_server_toggled(DBusWatch *watch, void *data) { + _watch_generic(watch, data, "toggled_watch"); +} + +void +_connection_callback (DBusServer *server, + DBusConnection *new_connection, + void *data) { + HV *self = (HV *)SvRV((SV*)data); + SV **call; + SV *proto; + SV *name; + SV *value; + SV *h_sv; + dSP; + + call = hv_fetch(self, "_callback", strlen("_callback"), 0); + + if (!call) { + return; + } + + dbus_connection_ref(new_connection); + + value = sv_newmortal(); + sv_setref_pv(value, "DBus::C::Connection", (void*)new_connection); + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs((SV*)data); + XPUSHs(value); + PUTBACK; + + call_sv(*call, G_DISCARD); + + FREETMPS; + LEAVE; +} + +void +_populate_constant(HV *href, char *name, int val) +{ + hv_store(href, name, strlen(name), newSViv(val), 0); +} + +#define REGISTER_CONSTANT(name, key) _populate_constant(constants, #key, name) + +MODULE = DBus PACKAGE = DBus + +PROTOTYPES: ENABLE +BOOT: + { + HV *constants; + + /* not the 'standard' way of doing perl constants, but a lot easier to maintain */ + + constants = perl_get_hv("DBus::Bus::_constants", TRUE); + REGISTER_CONSTANT(DBUS_BUS_SYSTEM, SYSTEM); + REGISTER_CONSTANT(DBUS_BUS_SESSION, SESSION); + REGISTER_CONSTANT(DBUS_BUS_ACTIVATION, ACTIVATION); + + constants = perl_get_hv("DBus::Message::_constants", TRUE); + REGISTER_CONSTANT(DBUS_TYPE_ARRAY, TYPE_ARRAY); + REGISTER_CONSTANT(DBUS_TYPE_BOOLEAN, TYPE_BOOLEAN); + REGISTER_CONSTANT(DBUS_TYPE_BYTE, TYPE_BYTE); + REGISTER_CONSTANT(DBUS_TYPE_CUSTOM, TYPE_CUSTOM); + REGISTER_CONSTANT(DBUS_TYPE_DICT, TYPE_DICT); + REGISTER_CONSTANT(DBUS_TYPE_DOUBLE, TYPE_DOUBLE); + REGISTER_CONSTANT(DBUS_TYPE_INT32, TYPE_INT32); + REGISTER_CONSTANT(DBUS_TYPE_INT64, TYPE_INT64); + REGISTER_CONSTANT(DBUS_TYPE_INVALID, TYPE_INVALID); + REGISTER_CONSTANT(DBUS_TYPE_NIL, TYPE_NIL); + REGISTER_CONSTANT(DBUS_TYPE_OBJECT_PATH, TYPE_OBJECT_PATH); + REGISTER_CONSTANT(DBUS_TYPE_STRING, TYPE_STRING); + REGISTER_CONSTANT(DBUS_TYPE_UINT32, TYPE_UINT32); + REGISTER_CONSTANT(DBUS_TYPE_UINT64, TYPE_UINT64); + + constants = perl_get_hv("DBus::Watch::_constants", TRUE); + REGISTER_CONSTANT(DBUS_WATCH_READABLE, READABLE); + REGISTER_CONSTANT(DBUS_WATCH_WRITABLE, WRITABLE); + REGISTER_CONSTANT(DBUS_WATCH_ERROR, ERROR); + REGISTER_CONSTANT(DBUS_WATCH_HANGUP, HANGUP); + } + + +MODULE = DBus::Connection PACKAGE = DBus::Connection + +PROTOTYPES: ENABLE + +void +_open(address) + char *address; + PREINIT: + DBusError error; + DBusConnection *con; + SV *h_sv; + PPCODE: + dbus_error_init(&error); + con = dbus_connection_open(address, &error); + if (!con) { + // XXX fixme + //dbus_error_free(&error); + croak(error.message); + } + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "DBus::C::Connection", (void*)con); + + PUSHs(h_sv); + +MODULE = DBus::C::Connection PACKAGE = DBus::C::Connection + +void +dbus_connection_disconnect(con) + DBusConnection *con; + +int +dbus_connection_get_is_connected(con) + DBusConnection *con; + +void +dbus_connection_flush(con) + DBusConnection *con; + +int +_send(con, msg) + DBusConnection *con; + DBusMessage *msg; + PREINIT: + dbus_uint32_t serial; + CODE: + if (!dbus_connection_send(con, msg, &serial)) { + croak("not enough memory to send message"); + } + RETVAL = serial; + OUTPUT: + RETVAL + +void +_set_watch_callbacks(con, self) + DBusConnection *con; + SV *self; + PPCODE: + SvREFCNT_inc(self); + if (!dbus_connection_set_watch_functions(con, + _watch_server_add, + _watch_server_remove, + _watch_server_toggled, + self, NULL)) { + croak("not enough memory to set watch functions on connection"); + } + +void +dbus_connection_unref(con) + DBusConnection *con; + + +MODULE = DBus::Server PACKAGE = DBus::Server + +PROTOTYPES: ENABLE + +void +_open(address) + char *address; + PREINIT: + DBusError error; + DBusServer *server; + SV *h_sv; + PPCODE: + dbus_error_init(&error); + server = dbus_server_listen(address, &error); + if (!server) { + // XXX fixme + //dbus_error_free(&error); + croak(error.message); + } + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "DBus::C::Server", (void*)server); + + if (!dbus_server_set_auth_mechanisms(server, NULL)) { + croak("not enough memory to server auth mechanisms"); + } + + PUSHs(h_sv); + +MODULE = DBus::C::Server PACKAGE = DBus::C::Server + +void +dbus_server_disconnect(server) + DBusServer *server; + +int +dbus_server_get_is_connected(server) + DBusServer *server; + +void +_set_watch_callbacks(server, self) + DBusServer *server; + SV *self; + PPCODE: + SvREFCNT_inc(self); + printf("Setting2 %x %x %x\n", server, self, SvRV(self)); + if (!dbus_server_set_watch_functions(server, + _watch_server_add, + _watch_server_remove, + _watch_server_toggled, + self, NULL)) { + croak("not enough memory to set watch functions on server"); + } + + +void +_set_connection_callback(server, self) + DBusServer *server; + SV *self; + PPCODE: + SvREFCNT_inc(self); + printf("Setting %x %x %x\n", server, self, SvRV(self)); + dbus_server_set_new_connection_function(server, + _connection_callback, + self, NULL); + +void +dbus_server_unref(server) + DBusServer *server; + + +MODULE = DBus::Bus PACKAGE = DBus::Bus + +PROTOTYPES: ENABLE + +void +_open(type) + DBusBusType type; + PREINIT: + DBusError error; + DBusConnection *con; + SV *h_sv; + PPCODE: + dbus_error_init(&error); + con = dbus_bus_get(type, &error); + if (!con) { + // XXX fixme + //dbus_error_free(error); + croak(error.message); + } + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "DBus::C::Connection", (void*)con); + + PUSHs(h_sv); + +MODULE = DBus::Message PACKAGE = DBus::Message + +PROTOTYPES: ENABLE + +void +_create(type) + IV type; + PREINIT: + DBusMessage *msg; + SV *h_sv; + PPCODE: + msg = dbus_message_new(type); + if (!msg) { + croak("No memory to allocate message"); + } + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg); + + PUSHs(h_sv); + +void +set_no_reply(msg, status) + DBusMessage *msg; + dbus_bool_t status; + PPCODE: + dbus_message_set_no_reply(msg, status); + +void +set_auto_activation(msg, status) + DBusMessage *msg; + dbus_bool_t status; + PPCODE: + dbus_message_set_auto_activation(msg, status); + +void +_destroy(msg) + DBusMessage *msg; + PPCODE: + dbus_message_unref(msg); + +void +_iterator(msg) + DBusMessage *msg; + PREINIT: + DBusMessageIter *iter; + SV *h_sv; + PPCODE: + iter = dbus_new(DBusMessageIter, 1); + dbus_message_iter_init(msg, iter); + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "DBus::C::Iterator", iter); + PUSHs(h_sv); + +MODULE = DBus::Message::Signal PACKAGE = DBus::Message::Signal + +PROTOTYPES: ENABLE + +void +_create(path, interface, name) + char *path; + char *interface; + char *name; + PREINIT: + DBusMessage *msg; + SV *h_sv; + PPCODE: + msg = dbus_message_new_signal(path, interface, name); + if (!msg) { + croak("No memory to allocate message"); + } + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg); + + PUSHs(h_sv); + +MODULE = DBus::Message::MethodCall PACKAGE = DBus::Message::MethodCall + +PROTOTYPES: ENABLE + +void +_create(service, path, interface, method) + char *service; + char *path; + char *interface; + char *method; + PREINIT: + DBusMessage *msg; + SV *h_sv; + PPCODE: + msg = dbus_message_new_method_call(service, path, interface, method); + if (!msg) { + croak("No memory to allocate message"); + } + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg); + + PUSHs(h_sv); + +MODULE = DBus::Message::MethodReturn PACKAGE = DBus::Message::MethodReturn + +PROTOTYPES: ENABLE + +void +_create(call) + DBusMessage *call; + PREINIT: + DBusMessage *msg; + SV *h_sv; + PPCODE: + msg = dbus_message_new_method_return(call); + if (!msg) { + croak("No memory to allocate message"); + } + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg); + + PUSHs(h_sv); + +MODULE = DBus::Message::Error PACKAGE = DBus::Message::Error + +PROTOTYPES: ENABLE + +void +_create(replyto, name, message) + DBusMessage *replyto; + char *name; + char *message; + PREINIT: + DBusMessage *msg; + SV *h_sv; + PPCODE: + msg = dbus_message_new_error(replyto, name, message); + if (!msg) { + croak("No memory to allocate message"); + } + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg); + + PUSHs(h_sv); + + +MODULE = DBus::C::Watch PACKAGE = DBus::C::Watch + +int +get_fileno(watch) + DBusWatch *watch; + CODE: + RETVAL = dbus_watch_get_fd(watch); + OUTPUT: + RETVAL + +unsigned int +get_flags(watch) + DBusWatch *watch; + CODE: + RETVAL = dbus_watch_get_flags(watch); + OUTPUT: + RETVAL + +dbus_bool_t +is_enabled(watch) + DBusWatch *watch; + CODE: + RETVAL = dbus_watch_get_enabled(watch); + OUTPUT: + RETVAL + +void +handle(watch, flags) + DBusWatch *watch; + unsigned int flags; + PPCODE: + printf("Handling event %d\n", flags); + dbus_watch_handle(watch, flags); + +MODULE = DBus::Iterator PACKAGE = DBus::Iterator + +int +get_arg_type(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_arg_type(iter); + OUTPUT: + RETVAL + +dbus_bool_t +has_next(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_has_next(iter); + OUTPUT: + RETVAL + +dbus_bool_t +next(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_next(iter); + OUTPUT: + RETVAL + +dbus_bool_t +get_boolean(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_boolean(iter); + OUTPUT: + RETVAL + +unsigned char +get_byte(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_byte(iter); + OUTPUT: + RETVAL + +dbus_int32_t +get_int32(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_int32(iter); + OUTPUT: + RETVAL + +dbus_uint32_t +get_uint32(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_uint32(iter); + OUTPUT: + RETVAL + +dbus_int64_t +get_int64(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_int64(iter); + OUTPUT: + RETVAL + +dbus_uint64_t +get_uint64(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_uint64(iter); + OUTPUT: + RETVAL + +double +get_double(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_double(iter); + OUTPUT: + RETVAL + +char * +get_string(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_string(iter); + OUTPUT: + RETVAL + + +void +append_nil(iter) + DBusMessageIter *iter; + PPCODE: + dbus_message_iter_append_nil(iter); + +void +append_boolean(iter, val) + DBusMessageIter *iter; + dbus_bool_t val; + PPCODE: + dbus_message_iter_append_boolean(iter, val); + +void +append_byte(iter, val) + DBusMessageIter *iter; + unsigned char val; + PPCODE: + dbus_message_iter_append_byte(iter, val); + +void +append_int32(iter, val) + DBusMessageIter *iter; + dbus_int32_t val; + PPCODE: + dbus_message_iter_append_int32(iter, val); + +void +append_uint32(iter, val) + DBusMessageIter *iter; + dbus_uint32_t val; + PPCODE: + dbus_message_iter_append_uint32(iter, val); + +void +append_int64(iter, val) + DBusMessageIter *iter; + dbus_int64_t val; + PPCODE: + dbus_message_iter_append_int64(iter, val); + +void +append_uint64(iter, val) + DBusMessageIter *iter; + dbus_uint64_t val; + PPCODE: + dbus_message_iter_append_uint64(iter, val); + +void +append_double(iter, val) + DBusMessageIter *iter; + double val; + PPCODE: + dbus_message_iter_append_double(iter, val); + +void +append_string(iter, val) + DBusMessageIter *iter; + char *val; + PPCODE: + dbus_message_iter_append_string(iter, val); + +void +dbus_free(iter) + DBusMessageIter *iter; + +MODULE = DBus PACKAGE = DBus diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..5f6c2b5 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,29 @@ +use 5.006; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. + +WriteMakefile( + 'NAME' => 'DBus', + 'VERSION_FROM' => 'lib/DBus.pm', # finds $VERSION + 'PREREQ_PM' => {'Test::More' => 0}, # e.g., Module::Name => 1.1 + ($] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => 'lib/DBus.pm', # retrieve abstract from module + AUTHOR => 'Daniel Berrange <d...@berrange.com>') : ()), + 'LIBS' => ['-L/home/dan/usr/dbus-cvs/lib -ldbus-1'], # e.g., '-lm' + 'DEFINE' => '-DDBUS_API_SUBJECT_TO_CHANGE', # e.g., '-DHAVE_SOMETHING' + 'INC' => '-I. -I/home/dan/usr/dbus-cvs/include/dbus-1.0 -I/home/dan/usr/dbus-cvs/lib/dbus-1.0/include', # e.g., '-I. -I/usr/include/other' + # Un-comment this if you add C files to link with later: + # 'OBJECT' => '$(O_FILES)', # link all the C files too +); + +package MY; + +sub libscan + { + my ($self, $path) = @_; + ($path =~ /\~$/) ? undef : $path; + } + + +__END__ diff --git a/README b/README new file mode 100644 index 0000000..1bc7ea7 --- /dev/null +++ b/README @@ -0,0 +1,38 @@ +DBus version 0.01 +================= + +The README is used to introduce the module and provide instructions on +how to install the module, any machine dependencies it may have (for +example C compilers and installed libraries) and any other information +that should be provided before the module is installed. + +A README file is required for CPAN modules since CPAN extracts the +README file from a module distribution so that people browsing the +archive can use it get an idea of the modules uses. It is usually a +good idea to provide version information here so that people can +decide whether fixes for the module are worth downloading. + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + + Test::More + +COPYRIGHT AND LICENCE + +Put the correct copyright and licence information here. + +Copyright (C) 2004 Daniel Berrange + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + diff --git a/lib/DBus.pm b/lib/DBus.pm new file mode 100644 index 0000000..afecea7 --- /dev/null +++ b/lib/DBus.pm @@ -0,0 +1,56 @@ +package DBus; + +use 5.006; +use strict; +use warnings; +use Carp; + +use AutoLoader; + +our $VERSION = '0.01'; + +require XSLoader; +XSLoader::load('DBus', $VERSION); + +1; +__END__ + +=head1 NAME + +DBus - Perl extension for the DBus message system + +=head1 SYNOPSIS + + use DBus::Connection; + use DBus::Server; + +=head1 ABSTRACT + +DBus provides a Perl API for the DBus message system. + +=head1 DESCRIPTION + +DBus provides a Perl API for the DBus message system. +There is no need to access this module directly. It is +used by other DBus::* module to trigger the autoloading +of the XS module containing the interface to the DBus +API + +=head1 SEE ALSO + +L<DBus::Connection>, L<DBus::Server>, L<DBus::Message>, L<DBus::Reactor>, +L<DBus::Bus>, L<DBus::Watch>, L<DBus::Iterator>, +L<dbus-monitor(1)>, L<dbus-daemon-1(1)>, L<dbus-send(1)>, L<http://dbus.freedesktop.org>, + +=head1 AUTHOR + +Daniel Berrange E<lt>d...@berrange.come<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Daniel Berrange + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/DBus/Bus.pm b/lib/DBus/Bus.pm new file mode 100644 index 0000000..a64d190 --- /dev/null +++ b/lib/DBus/Bus.pm @@ -0,0 +1,51 @@ +package DBus::Bus; + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; +use DBus::Connection; + +our @ISA = qw(Exporter DBus::Connection); + +our $VERSION = '0.0.1'; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $connection = DBus::Bus::_open($params{type} ? $params{type} : confess "type parameter is required"); + + my $self = $class->SUPER::new(%params, connection => $connection); + + bless $self, $class; + + return $self; +} + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + + croak "&DBus::Bus::constant not defined" if $constname eq '_constant'; + + if (!exists $DBus::Bus::_constants{$constname}) { + croak "no such constant \$DBus::Bus::$constname"; + } + + { + no strict 'refs'; + *$AUTOLOAD = sub { $DBus::Bus::_constants{$constname} }; + } + goto &$AUTOLOAD; +} + +1; + diff --git a/lib/DBus/Connection.pm b/lib/DBus/Connection.pm new file mode 100644 index 0000000..42f750d --- /dev/null +++ b/lib/DBus/Connection.pm @@ -0,0 +1,122 @@ +=pod + +=head1 NAME + +DBus::Connection - A connection between client and server + +=head1 SYNOPSIS + +Creating a connection to a server and sending a message + + use DBus::Connection; + + my $con = DBus::Connection->new(address => "unix:path=/path/to/socket"); + + $con->send($message); + +=head1 DESCRIPTION + +An outgoing connection to a server, or an incoming connection +from a client. + +=cut + +package DBus::Connection; + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; + +our $VERSION = '0.0.1'; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + $self->{address} = exists $params{address} ? $params{address} : (exists $params{connection} ? "" : confess "address parameter is required"); + $self->{connection} = exists $params{connection} ? $params{connection} : DBus::Connection::_open($self->{address}); + + bless $self, $class; + + return $self; +} + + +sub is_connected { + my $self = shift; + + return $self->{connection}->dbus_connection_get_is_connected(); +} + + +sub disconnect { + my $self = shift; + + $self->{connection}->dbus_connection_disconnect(); +} + + +sub flush { + my $self = shift; + + $self->{connection}->dbus_connection_flush(); +} + + +sub send { + my $self = shift; + my $msg = shift; + + return $self->{connection}->_send($msg->{message}); +} + + +sub set_watch_callbacks { + my $self = shift; + my $add = shift; + my $remove = shift; + my $toggled = shift; + + $self->{add_watch} = $add; + $self->{remove_watch} = $remove; + $self->{toggled_watch} = $toggled; + + $self->{connection}->_set_watch_callbacks($self); +} + + +sub DESTROY { + my $self = shift; + + print "DESTROy $self $self->{connection}\n"; + if ($self->{connection}->dbus_connection_get_is_connected()) { + $self->{connection}->dbus_connection_disconnect(); + } + $self->{connection}->dbus_connection_unref(); +} + +1; + +=pod + +=head1 SEE ALSO + +L<DBus::Server>, L<DBus::Bus>, L<DBus::Message::Signal>, L<DBus::Message::MethodCall>, L<DBus::Message::MethodReturn>, L<DBus::Message::Error> + +=head1 AUTHOR + +Daniel Berrange E<lt>d...@berrange.come<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Daniel Berrange + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/DBus/Iterator.pm b/lib/DBus/Iterator.pm new file mode 100644 index 0000000..bdb75cf --- /dev/null +++ b/lib/DBus/Iterator.pm @@ -0,0 +1,63 @@ +=pod + +=head1 NAME + +DBus::Iterator - Reading and writing message parameters + +=head1 SYNOPSIS + +Creating a new message + + my $msg = new DBus::Message::Signal; + my $iterator = $msg->iterator; + + $iterator->append_boolean(1); + $iterator->append_byte(123); + +=head1 DESCRIPTION + +Provides an iterator for reading and writing messages +parameters. + +=cut + +package DBus::Iterator; + + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; + +our $VERSION = '0.0.1'; + + +sub DESTROY { + my $self = shift; + + $self->dbus_free(); +} + + +1; + +=pod + +=head1 SEE ALSO + +L<DBus::Message> + +=head1 AUTHOR + +Daniel Berrange E<lt>d...@berrange.come<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Daniel Berrange + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/DBus/Message.pm b/lib/DBus/Message.pm new file mode 100644 index 0000000..b34cbff --- /dev/null +++ b/lib/DBus/Message.pm @@ -0,0 +1,109 @@ +=pod + +=head1 NAME + +DBus::Message - Base class for messages + +=head1 SYNOPSIS + +Sending a message + + my $msg = new DBus::Message::Signal; + my $iterator = $msg->iterator; + + $iterator->append_byte(132); + $iterator->append_int32(14241); + + $connection->send($msg); + +=head1 DESCRIPTION + +Provides a base class for the different kinds of +message that can be sent/received. Instances of +this class are never instantiated directly, rather +one of the four sub-types L<DBus::Message::Signal>, +L<DBus::Message::MethodCall>, L<DBus::Message::MethodReturn>, +L<DBus::Message::Error> should be used. + +=cut + +package DBus::Message; + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; +use DBus::Iterator; + +our $VERSION = '0.0.1'; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + $self->{message} = exists $params{message} ? $params{message} : + (DBus::Message::_create(exists $params{type} ? $params{type} : confess "type parameter is required")); + + bless $self, $class; + + return $self; +} + + +sub iterator { + my $self = shift; + + return DBus::Message::_iterator($self->{message}); +} + +sub DESTROY { + my $self = shift; + + DBus::Message::_destroy($self->{message}); +} + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + + croak "&DBus::Message::constant not defined" if $constname eq '_constant'; + + if (!exists $DBus::Message::_constants{$constname}) { + croak "no such constant \$DBus::Message::$constname"; + } + + { + no strict 'refs'; + *$AUTOLOAD = sub { $DBus::Message::_constants{$constname} }; + } + goto &$AUTOLOAD; +} + +1; + +=pod + +=head1 SEE ALSO + +L<DBus::Server>, L<DBus::Connection>, L<DBus::Message::Signal>, L<DBus::Message::MethodCall>, L<DBus::Message::MethodReturn>, L<DBus::Message::Error> + +=head1 AUTHOR + +Daniel Berrange E<lt>d...@berrange.come<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Daniel Berrange + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/DBus/Message/Error.pm b/lib/DBus/Message/Error.pm new file mode 100644 index 0000000..e997a7e --- /dev/null +++ b/lib/DBus/Message/Error.pm @@ -0,0 +1,35 @@ +package DBus::Message::Error; + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; +use DBus::Message; + +our @ISA = qw(Exporter DBus::Message); + +our $VERSION = '0.0.1'; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $replyto = exists $params{replyto} ? $params{replyto} : confess "replyto parameter is required"; + + my $msg = DBus::Message::Error::_create + ( + $replyto->{message}, + $params{name} ? $params{name} : confess "name parameter is required", + $params{message} ? $params{message} : confess "message parameter is required"); + + my $self = $class->SUPER::new(%params, message => $msg); + + bless $self, $class; + + return $self; +} + +1; diff --git a/lib/DBus/Message/MethodCall.pm b/lib/DBus/Message/MethodCall.pm new file mode 100644 index 0000000..0ea014c --- /dev/null +++ b/lib/DBus/Message/MethodCall.pm @@ -0,0 +1,34 @@ +package DBus::Message::MethodCall; + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; +use DBus::Message; + +our @ISA = qw(Exporter DBus::Message); + +our $VERSION = '0.0.1'; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $msg = DBus::Message::MethodCall::_create + ( + ($params{service} ? $params{service} : confess "service parameter is required"), + ($params{path} ? $params{path} : confess "path parameter is required"), + ($params{interface} ? $params{interface} : confess "interface parameter is required"), + ($params{method} ? $params{method} : confess "method parameter is required")); + + my $self = $class->SUPER::new(%params, message => $msg); + + bless $self, $class; + + return $self; +} + +1; diff --git a/lib/DBus/Message/MethodReturn.pm b/lib/DBus/Message/MethodReturn.pm new file mode 100644 index 0000000..d86ce65 --- /dev/null +++ b/lib/DBus/Message/MethodReturn.pm @@ -0,0 +1,31 @@ +package DBus::Message::MethodReturn; + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; +use DBus::Message; + +our @ISA = qw(Exporter DBus::Message); + +our $VERSION = '0.0.1'; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $call = exists $params{call} ? $params{call} : confess "call parameter is required"; + + my $msg = DBus::Message::MethodReturn::_create($call->{message}); + + my $self = $class->SUPER::new(%params, message => $msg); + + bless $self, $class; + + return $self; +} + +1; diff --git a/lib/DBus/Message/Signal.pm b/lib/DBus/Message/Signal.pm new file mode 100644 index 0000000..a779006 --- /dev/null +++ b/lib/DBus/Message/Signal.pm @@ -0,0 +1,34 @@ +package DBus::Message::Signal; + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; +use DBus::Message; + +our @ISA = qw(Exporter DBus::Message); + +our $VERSION = '0.0.1'; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $msg = 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); + + bless $self, $class; + + return $self; +} + + +1; diff --git a/lib/DBus/Reactor.pm b/lib/DBus/Reactor.pm new file mode 100644 index 0000000..d0e685c --- /dev/null +++ b/lib/DBus/Reactor.pm @@ -0,0 +1,245 @@ +package DBus::Reactor; + +use 5.006; +use strict; +use warnings; +use Carp; +use DBus::Watch; + +our $VERSION = '0.0.1'; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + $self->{fds} = { + read => {}, + write => {}, + exception => {} + }; + + bless $self, $class; + + return $self; +} + + +sub manage { + my $self = shift; + my $connection = shift; + + $connection->set_watch_callbacks(sub { + my $connection = shift; + my $watch = shift; + print "On $watch " . $watch->get_fileno . " " . $watch->get_flags . "\n"; + $self->_manage_on($watch); + }, sub { + my $connection = shift; + my $watch = shift; + print "Off $watch " . $watch->get_fileno . " " . $watch->get_flags . "\n"; + $self->_manage_off($watch); + }, sub { + my $connection = shift; + my $watch = shift; + print "Toggle $watch " . $watch->get_fileno . " " . $watch->get_flags . " " . $watch->is_enabled() . "\n"; + $self->_manage_state($watch); + }); +} + + + +sub _manage_on { + my $self = shift; + my $watch = shift; + my $flags = $watch->get_flags; + + if ($flags & &DBus::Watch::READABLE) { + $self->add_read($watch->get_fileno, $watch, "handle", [&DBus::Watch::READABLE], $watch->is_enabled); + } + if ($flags & &DBus::Watch::WRITABLE) { + $self->add_write($watch->get_fileno, $watch, "handle", [&DBus::Watch::WRITABLE], $watch->is_enabled); + } + $self->add_exception($watch->get_fileno, $watch, "handle", [&DBus::Watch::ERROR], $watch->is_enabled); +} + +sub _manage_off { + my $self = shift; + my $watch = shift; + my $flags = $watch->get_flags; + + if ($flags & &DBus::Watch::READABLE) { + $self->remove_read($watch->get_fileno); + } + if ($flags & &DBus::Watch::WRITABLE) { + $self->remove_write($watch->get_fileno); + } + $self->remove_exception($watch->get_fileno); +} + +sub _manage_state { + my $self = shift; + my $watch = shift; + my $flags = $watch->get_flags; + + if ($flags & &DBus::Watch::READABLE) { + $self->toggle_read($watch->get_fileno, $watch->is_enabled); + } + if ($flags & &DBus::Watch::WRITABLE) { + $self->toggle_write($watch->get_fileno, $watch->is_enabled); + } + $self->toggle_exception($watch->get_fileno, $watch->is_enabled); +} + + +sub run { + my $self = shift; + + while ($self->step) {}; +} + +sub step { + my $self = shift; + + my ($ri, $ric) = $self->_bits("read"); + my ($wi, $wic) = $self->_bits("write"); + my ($ei, $eic) = $self->_bits("exception"); + my ($ro, $wo, $eo); + + print "$ric $wic $eic\n"; + + if (!$ric && !$wic && !$eic) { + print "No handles to listen on. Exiting\n"; + return 0; + } + + my ($n, $timeleft) = select($ro=$ri,$wo=$wi,$eo=$ei, undef); + + if ($n) { + $self->_dispatch("read", $ro); + $self->_dispatch("write", $wo); + $self->_dispatch("error", $eo); + } + + return 1; +} + +sub _bits { + my $self = shift; + my $type = shift; + my $vec = ''; + + my $count = 0; + foreach (keys %{$self->{fds}->{$type}}) { + next unless $self->{fds}->{$type}->{$_}->{enabled}; + + $count++; + vec($vec, $_, 1) = 1; + } + return ($vec, $count); +} + +sub _dispatch { + my $self = shift; + my $type = shift; + my $vec = shift; + foreach my $fd (keys %{$self->{fds}->{$type}}) { + next unless $self->{fds}->{$type}->{$fd}->{enabled}; + + if (vec($vec, $fd, 1)) { + my $rec = $self->{fds}->{$type}->{$fd}; + my $object = $rec->{object}; + my $code = $rec->{code}; + my $args = $rec->{args}; + + print "Dispatch $type on $fd to $object $code ", join(',', @{$args}), "\n"; + + $object->$code(@{$args}); + } + } +} + + +sub add_read { + my $self = shift; + $self->_add("read", @_); +} + +sub add_write { + my $self = shift; + $self->_add("write", @_); +} + +sub add_exception { + my $self = shift; + $self->_add("exception", @_); +} + +sub _add { + my $self = shift; + my $type = shift; + my $fd = shift; + my $obj = shift; + my $code = shift; + my $args = shift; + my $enabled = shift; + + $self->{fds}->{$type}->{$fd} = { + object => $obj, + code => $code, + args => $args, + enabled => $enabled + }; +} + +sub remove_read { + my $self = shift; + $self->_remove("read", @_); +} + +sub remove_write { + my $self = shift; + $self->_remove("write", @_); +} + +sub remove_exception { + my $self = shift; + $self->_remove("exception", @_); +} + +sub _remove { + my $self = shift; + my $type = shift; + my $fd = shift; + + delete $self->{fds}->{$type}->{$fd}; +} + +sub toggle_read { + my $self = shift; + $self->_toggle("read", @_); +} + +sub toggle_write { + my $self = shift; + $self->_toggle("write", @_); +} + +sub toggle_exception { + my $self = shift; + $self->_toggle("exception", @_); +} + +sub _toggle { + my $self = shift; + my $type = shift; + my $fd = shift; + my $enabled = shift; + + $self->{fds}->{$type}->{$fd}->{enabled} = $enabled; +} + + +1; +__END__ diff --git a/lib/DBus/Server.pm b/lib/DBus/Server.pm new file mode 100644 index 0000000..2f6a6f5 --- /dev/null +++ b/lib/DBus/Server.pm @@ -0,0 +1,132 @@ +=pod + +=head1 NAME + +DBus::Connection - A connection between client and server + +=head1 SYNOPSIS + +Creating a server and accepting client connections + + use DBus::Server; + + my $server = DBus::Server->new(address => "unix:path=/path/to/socket"); + + $server->connection_callback(&new_connection); + + sub new_connection { + my $connection = shift; + + .. work with new connection... + } + +=head1 DESCRIPTION + +A server for receiving connection from client programs + +=cut + +package DBus::Server; + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; +use DBus::Connection; + +our $VERSION = '0.0.1'; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + $self->{address} = exists $params{address} ? $params{address} : confess "address parameter is required"; + $self->{server} = DBus::Server::_open($self->{address}); + + bless $self, $class; + + $self->{_callback} = sub { + my $server = shift; + my $rawcon = shift; + my $con = DBus::Connection->new(connection => $rawcon); + + if ($server->{connection_callback}) { + &{$server->{connection_callback}}($server, $con); + } + }; + + return $self; +} + + +sub is_connected { + my $self = shift; + + return $self->{server}->dbus_server_get_is_connected(); +} + + +sub disconnect { + my $self = shift; + + return $self->{server}->dbus_server_disconnect(); +} + +sub set_watch_callbacks { + my $self = shift; + my $add = shift; + my $remove = shift; + my $toggled = shift; + + $self->{add_watch} = $add; + $self->{remove_watch} = $remove; + $self->{toggled_watch} = $toggled; + + $self->{server}->_set_watch_callbacks($self); +} + +sub set_connection_callback { + my $self = shift; + my $callback = shift; + + $self->{connection_callback} = $callback; + print("callback $self $callback\n"); + $self->{server}->_set_connection_callback($self); +} + +sub DESTROY { + my $self = shift; + + print "DESTROy $self $self->{server}\n"; + if ($self->{server}->dbus_server_get_is_connected()) { + $self->{server}->dbus_server_disconnect(); + } + $self->{server}->dbus_server_unref(); +} + + +1; + + +=pod + +=head1 SEE ALSO + +L<DBus::Connection>, L<DBus::Bus>, L<DBus::Message::Signal>, L<DBus::Message::MethodCall>, L<DBus::Message::MethodReturn>, L<DBus::Message::Error> + +=head1 AUTHOR + +Daniel Berrange E<lt>d...@berrange.come<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Daniel Berrange + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/DBus/Watch.pm b/lib/DBus/Watch.pm new file mode 100644 index 0000000..27db551 --- /dev/null +++ b/lib/DBus/Watch.pm @@ -0,0 +1,32 @@ +package DBus::Watch; + +use 5.006; +use strict; +use warnings; +use Carp; + +use DBus; + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + + croak "&DBus::Watch::constant not defined" if $constname eq '_constant'; + + if (!exists $DBus::Watch::_constants{$constname}) { + croak "no such constant \$DBus::Watch::$constname"; + } + + { + no strict 'refs'; + *$AUTOLOAD = sub { $DBus::Watch::_constants{$constname} }; + } + goto &$AUTOLOAD; +} + +1; +__END__ diff --git a/t/1.t b/t/1.t new file mode 100644 index 0000000..e9f79bc --- /dev/null +++ b/t/1.t @@ -0,0 +1,52 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl 1.t' + +######################### + +# change 'tests => 6' to 'tests => last_test_to_print'; + +use Test::More tests => 6; +BEGIN { + use_ok('DBus::Watch'); + use_ok('DBus::Message'); + use_ok('DBus::Bus'); + }; + + +my $fail = 0; +foreach my $constname (qw( + SYSTEM SESSION ACTIVATION)) { + next if (eval "my \$a = &DBus::Bus::$constname; 1"); + print "# fail: $@"; + $fail = 1; +} +ok( $fail == 0 , 'DBus::Bus Constants' ); + +$fail = 0; +foreach my $constname (qw( + TYPE_ARRAY TYPE_BOOLEAN + TYPE_BYTE TYPE_CUSTOM TYPE_DICT + TYPE_DOUBLE TYPE_INT32 TYPE_INT64 + TYPE_INVALID TYPE_NIL TYPE_OBJECT_PATH + TYPE_STRING TYPE_UINT32 TYPE_UINT64)) { + next if (eval "my \$a = &DBus::Message::$constname; 1"); + print "# fail: $@"; + $fail = 1; +} +ok( $fail == 0 , 'DBus::Message Constants' ); + +$fail = 0; +foreach my $constname (qw( + READABLE WRITABLE + ERROR HANGUP)) { + next if (eval "my \$a = &DBus::Watch::$constname; 1"); + print "# fail: $@"; + $fail = 1; +} + +ok( $fail == 0 , 'DBus::Watch Constants' ); +######################### + +# Insert your test code below, the Test::More module is use()ed here so read +# its man page ( perldoc Test::More ) for help writing this test script. + diff --git a/t/2.t b/t/2.t new file mode 100644 index 0000000..f2e106a --- /dev/null +++ b/t/2.t @@ -0,0 +1,24 @@ + +use Test::More tests => 4; +BEGIN { use_ok('DBus::Connection'); + use_ok('DBus::Reactor'); + }; + +$ENV{DBUS_VERBOSE} = 1; + +#my $con = DBus::Connection->new(address => "unix:path=/var/run/dbus/system_bus_socket"); +my $con = DBus::Connection->new(address => "unix:path=/tmp/dbus-perl-test"); + +ok($con, "Connection"); + +ok($con->is_connected, "Is Connected"); + +my $reactor = DBus::Reactor->new(); +$reactor->manage($con); +ok(1, "watches"); + +$reactor->run(); + +$con->disconnect; + +ok(!$con->is_connected, "Not Connected"); diff --git a/t/3.t b/t/3.t new file mode 100644 index 0000000..ee47541 --- /dev/null +++ b/t/3.t @@ -0,0 +1,24 @@ +use Test::More tests => 5; +BEGIN { + use_ok('DBus'); + use_ok('DBus::Bus'); + use_ok('DBus::Reactor'); + }; + + +my $con = DBus::Bus->new(type => &DBus::Bus::SYSTEM); + +ok($con, "Connection"); + +ok($con->is_connected, "Is Connected"); + +my $reactor = DBus::Reactor->new(); +$reactor->manage($con); +ok(1, "watches"); + +$reactor->run(); + +$con->disconnect; + +ok(!$con->is_connected, "Not Connected"); + diff --git a/t/4.t b/t/4.t new file mode 100644 index 0000000..1f05129 --- /dev/null +++ b/t/4.t @@ -0,0 +1,21 @@ +use Test::More tests => 7; +BEGIN { + use_ok('DBus::Bus'); + use_ok('DBus::Message::Signal'); + use_ok('DBus::Message::MethodCall'); + }; + + +my $con = DBus::Bus->new(type => &DBus::Bus::SYSTEM); + +ok($con, "Connection"); + +my $signal = DBus::Message::Signal->new(path => "foo/bar", interface => "bar.wizz", name => "wizz"); + +my $serial = $con->send($signal); + +ok($serial, "serial"); + +$con->flush(); + +ok(1, "flush"); diff --git a/t/5.t b/t/5.t new file mode 100644 index 0000000..73005d2 --- /dev/null +++ b/t/5.t @@ -0,0 +1,39 @@ +use Test::More tests => 5; +BEGIN { use_ok('DBus::Server'); use_ok('DBus'); use_ok('DBus::Reactor') }; + +$ENV{DBUS_VERBOSE} = 1; + +my $con = DBus::Server->new(address => "unix:path=/tmp/dbus-perl-test"); + +ok($con, "Server"); + +ok($con->is_connected, "Is Connected"); + +$con->set_connection_callback(\&new_con); + +my $reactor = DBus::Reactor->new(); + +$reactor->manage($con); + +ok(1, "watches"); + +$reactor->run(); + + +$con->disconnect; + +ok(!$con->is_connected, "Not Connected"); + +my %cons; + +sub new_con { + my $server = shift; + my $connection = shift; + + $cons{$connection} = $connection; + + $reactor->manage($connection); + + print "Got $server $connection\n"; +} + diff --git a/t/6.t b/t/6.t new file mode 100644 index 0000000..2d6a667 --- /dev/null +++ b/t/6.t @@ -0,0 +1,58 @@ +use Test::More tests => 5; +BEGIN { + use_ok('DBus'); + use_ok('DBus::Connection'); + use_ok('DBus::Message::Signal'); + use_ok('DBus::Reactor'); + }; + + +my $con = DBus::Connection->new(address => "unix:path=/tmp/dbus-perl-test"); +#my $con = DBus::Bus->new(type => DBus::DBUS_BUS_SYSTEM); + +ok($con, "Connection"); + +ok($con->is_connected, "Is Connected"); + +my $msg = DBus::Message::Signal->new(path => "/foo/bar/Wizz", + interface => "com.blah.Example", + name => "Eeek"); + +my $iter = $msg->iterator(); +$iter->append_boolean(1); +$iter->append_byte(43); +$iter->append_int32(123); +$iter->append_uint32(456); +$iter->append_int64(12345645645); +$iter->append_uint64(12312312312); +$iter->append_string("Hello world"); +$iter->append_double(1.424141); + +$iter = $msg->iterator(); +ok($iter->get_boolean() == 1, "boolean"); +ok($iter->next(), "next"); +ok($iter->get_byte() == 43, "byte"); +ok($iter->next(), "next"); +ok($iter->get_int32() == 123, "int32"); +ok($iter->next(), "next"); +ok($iter->get_uint32() == 456, "uint32"); +ok($iter->next(), "next"); +ok($iter->get_int64() == 12345645645, "int64"); +ok($iter->next(), "next"); +ok($iter->get_uint64() == 12312312312, "uint64"); +ok($iter->next(), "next"); +ok($iter->get_string() eq "Hello world", "string"); +ok($iter->next(), "next"); +ok($iter->get_double() == 1.424141, "double"); + +my $reactor = DBus::Reactor->new(); +$reactor->manage($con); +ok(1, "watches"); + +$con->send($msg); + +$reactor->run(); + +$con->disconnect; + +ok(!$con->is_connected, "Not Connected"); diff --git a/typemap b/typemap new file mode 100644 index 0000000..e2428e4 --- /dev/null +++ b/typemap @@ -0,0 +1,78 @@ +TYPEMAP +DBusConnection* O_OBJECT_connection +DBusServer* O_OBJECT_server +DBusMessage* O_OBJECT_message +DBusWatch* O_OBJECT_watch +DBusMessageIter* O_OBJECT_messageiter +DBusBusType T_IV +dbus_bool_t T_IV +dbus_int32_t T_IV +dbus_uint32_t T_IV +dbus_int64_t T_IV +dbus_uint64_t T_IV + +INPUT +O_OBJECT_connection + if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) + $var = ($type)SvIV((SV*)SvRV( $arg )); + else { + warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); + XSRETURN_UNDEF; + } + +OUTPUT +O_OBJECT_connection + sv_setref_pv( $arg, "DBus::C::Connection", (void*)$var ); + +INPUT +O_OBJECT_server + if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) + $var = ($type)SvIV((SV*)SvRV( $arg )); + else { + warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); + XSRETURN_UNDEF; + } + +OUTPUT +O_OBJECT_server + sv_setref_pv( $arg, "DBus::C::Server", (void*)$var ); + +INPUT +O_OBJECT_message + if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) + $var = ($type)SvIV((SV*)SvRV( $arg )); + else { + warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); + XSRETURN_UNDEF; + } + +OUTPUT +O_OBJECT_message + sv_setref_pv( $arg, "DBus::C::Message", (void*)$var ); + + +INPUT +O_OBJECT_watch + if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) + $var = ($type)SvIV((SV*)SvRV( $arg )); + else { + warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); + XSRETURN_UNDEF; + } + +OUTPUT +O_OBJECT_watch + sv_setref_pv( $arg, "DBus::C::Watch", (void*)$var ); + +INPUT +O_OBJECT_messageiter + if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) + $var = ($type)SvIV((SV*)SvRV( $arg )); + else { + warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); + XSRETURN_UNDEF; + } + +OUTPUT +O_OBJECT_messageiter + sv_setref_pv( $arg, "DBus::C::MessageIter", (void*)$var ); -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits