[libnet-dbus-perl] 199/335: Added support for asynchronous method call/replies. Bumped version for new release
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:55 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 67278e429132a23f0b5a62ac5b5032c2362840aa
Author: Daniel P. Berrange <berrange at redhat.com>
Date: Sat Jun 3 16:31:05 2006 -0400
Added support for asynchronous method call/replies. Bumped version for new release
---
CHANGES | 21 ++++++
lib/Net/DBus.pm | 2 +-
lib/Net/DBus/ASyncReply.pm | 168 +++++++++++++++++++++++++++++++++++++++++++
lib/Net/DBus/Annotation.pm | 133 ++++++++++++++++++++++++++++++++++
lib/Net/DBus/Object.pm | 102 +++++++++++++-------------
lib/Net/DBus/RemoteObject.pm | 86 ++++++++++++++--------
t/55-method-calls.t | 15 +---
typemap | 14 ++++
8 files changed, 446 insertions(+), 95 deletions(-)
diff --git a/CHANGES b/CHANGES
index ec5bbd4..693e0c0 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,4 +1,25 @@
+Changes since 0.33.1
+
+ - Fixed handling of variants in introspection data
+
+ - Added binding for the DBusPendingCall C object
+
+ - Added some missing RPM dependancies on XML libs, and on minimum
+ required dbus version
+
+ - Added support for doing asynchronous method calls, and fire-and-
+ forgot calls for methods whose return status is not desired. Use
+ the constants in Net::DBus::Annotation module to indicate desired
+ call mode. Default is to do synchronous blocking calls.
+
+ - Added support for the 16-bit integer, signature and object path
+ data types
+
+ - Made introspection of root objects compliant with upsteam spec,
+ by calling introspect on the root object, "/", rather than a
+ Perl specific magic object path.
+
Changes since 0.32.3
- Constructor for Net::DBus::Object allows another Net::DBus::Object
diff --git a/lib/Net/DBus.pm b/lib/Net/DBus.pm
index dd579e4..d2ab82b 100644
--- a/lib/Net/DBus.pm
+++ b/lib/Net/DBus.pm
@@ -92,7 +92,7 @@ use Carp;
BEGIN {
- our $VERSION = '0.33.1';
+ our $VERSION = '0.33.2';
require XSLoader;
XSLoader::load('Net::DBus', $VERSION);
}
diff --git a/lib/Net/DBus/ASyncReply.pm b/lib/Net/DBus/ASyncReply.pm
new file mode 100644
index 0000000..03895e8
--- /dev/null
+++ b/lib/Net/DBus/ASyncReply.pm
@@ -0,0 +1,168 @@
+# -*- perl -*-
+#
+# Copyright (C) 2006 Daniel P. Berrange
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+#
+# $Id: RemoteObject.pm,v 1.20 2006/01/27 15:34:24 dan Exp $
+
+=pod
+
+=head1 NAME
+
+Net::DBus::ASyncReply - asynchronous method reply handler
+
+=head1 SYNOPSIS
+
+ use Net::DBus::Annotation qw(:call);
+
+ my $object = $service->get_object("/org/example/systemMonitor");
+
+ # List processes & get on with other work until
+ # the list is returned.
+ my $asyncreply = $object->list_processes(dbus_call_async, "someuser");
+
+ while (!$asyncreply->is_ready) {
+ ... do some background work..
+ }
+
+ my $processes = $asyncreply->get_result;
+
+
+=head1 DESCRIPTION
+
+This object provides a handler for receiving asynchronous
+method replies. An asynchronous reply object is generated
+when making remote method call with the C<dbus_call_async>
+annotation set.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Net::DBus::ASyncReply;
+
+use strict;
+use warnings;
+
+
+sub _new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ my %params = @_;
+
+ $self->{pending_call} = $params{pending_call} ? $params{pending_call} : die "pending_call parameter is required";
+ $self->{introspector} = $params{introspector} ? $params{introspector} : undef;
+ $self->{method_name} = $params{method_name} ? $params{method_name} : ($self->{introspector} ? die "method_name is parameter required for introspection" : undef);
+
+ bless $self, $class;
+
+ return $self;
+}
+
+
+=item $asyncreply->discard_result;
+
+Indicates that the caller is no longer interested in
+recieving the reply & that it should be discarded. After
+calling this method, this object should not be used again.
+
+=cut
+
+sub discard_result {
+ my $self = shift;
+
+ $self->{pending_call}->cancel;
+}
+
+
+=item $asyncreply->wait_for_result;
+
+Blocks the caller waiting for completion of the of the
+asynchronous reply. Upon returning from this method, the
+result can be obtained with the C<get_result> method.
+
+=cut
+
+sub wait_for_result {
+ my $self = shift;
+
+ $self->{pending_call}->block;
+}
+
+=item my $boolean = $asyncreply->is_ready;
+
+Returns a true value if the asynchronous reply is now
+complete (or a timeout has occurred). When this method
+returns true, the result can be obtained with the C<get_result>
+method.
+
+=cut
+
+sub is_ready {
+ my $self = shift;
+
+ return $self->{pending_call}->get_completed;
+}
+
+
+=item my @data = $asyncreply->get_result;
+
+Retrieves the data associated with the asynchronous reply.
+If a timeout occurred, then this method will throw an
+exception. This method can only be called once the reply
+is complete, as indicated by the C<is_ready> method
+returning a true value. After calling this method, this
+object should no longer be used.
+
+=cut
+
+sub get_result {
+ my $self = shift;
+
+ my $reply = $self->{pending_call}->get_reply;
+
+ my @reply;
+ if ($self->{introspector}) {
+ @reply = $self->{introspector}->decode($reply, "methods", $self->{method_name}, "returns");
+ } else {
+ @reply = $reply->get_args_list;
+ }
+
+ return wantarray ? @reply : $reply[0];
+}
+
+1;
+
+=pod
+
+=back
+
+=head1 AUTHOR
+
+Daniel Berrange <dan at berrange.com>
+
+=head1 COPYRIGHT
+
+Copright (C) 2006, Daniel Berrange.
+
+=head1 SEE ALSO
+
+L<Net::DBus>, L<Net::DBus::RemoteObject>, L<Net::DBus::Annotation>
+
+=cut
diff --git a/lib/Net/DBus/Annotation.pm b/lib/Net/DBus/Annotation.pm
new file mode 100644
index 0000000..c0b0f49
--- /dev/null
+++ b/lib/Net/DBus/Annotation.pm
@@ -0,0 +1,133 @@
+# -*- perl -*-
+#
+# Copyright (C) 2006 Daniel P. Berrange
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+#
+# $Id: RemoteObject.pm,v 1.20 2006/01/27 15:34:24 dan Exp $
+
+=pod
+
+=head1 NAME
+
+Net::DBus::Annotation - annotations for changing behaviour of APIs
+
+=head1 SYNOPSIS
+
+ use Net::DBus::Annotation qw(:call);
+
+ my $object = $service->get_object("/org/example/systemMonitor");
+
+ # Block until processes are listed
+ my $processes = $object->list_processes("someuser");
+
+ # Just throw away list of processes, pretty pointless
+ # in this example, but useful if the method doesn't have
+ # a return value
+ $object->list_processes(dbus_call_noreply, "someuser");
+
+ # List processes & get on with other work until
+ # the list is returned.
+ my $asyncreply = $object->list_processes(dbus_call_async, "someuser");
+
+ ... some time later...
+ my $processes = $asyncreply->get_data;
+
+=head1 DESCRIPTION
+
+This module provides a number of annotations which will be useful
+when dealing with the DBus APIs. There are annotations for switching
+remote calls between sync, async and no-reply mode. More annotations
+may be added over time.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Net::DBus::Annotation;
+
+use strict;
+use warnings;
+
+our $CALL_SYNC = "sync";
+our $CALL_ASYNC = "async";
+our $CALL_NOREPLY = "noreply";
+
+bless \$CALL_SYNC, __PACKAGE__;
+bless \$CALL_ASYNC, __PACKAGE__;
+bless \$CALL_NOREPLY, __PACKAGE__;
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(dbus_call_sync dbus_call_async dbus_call_noreply);
+our %EXPORT_TAGS = (call => [qw(dbus_call_sync dbus_call_async dbus_call_noreply)]);
+
+=item dbus_call_sync
+
+Requests that a method call be performed synchronously, waiting
+for the reply or error return to be received before continuing.
+
+=cut
+
+sub dbus_call_sync() {
+ return \$CALL_SYNC;
+}
+
+
+=item dbus_call_async
+
+Requests that a method call be performed a-synchronously, returning
+a pending call object, which will collect the reply when it eventually
+arrives.
+
+=cut
+
+sub dbus_call_async() {
+ return \$CALL_ASYNC;
+}
+
+=item dbus_call_noreply
+
+Requests that a method call be performed a-synchronously, discarding
+any possible reply or error message.
+
+=cut
+
+sub dbus_call_noreply() {
+ return \$CALL_NOREPLY;
+}
+
+1;
+
+=pod
+
+=back
+
+=head1 AUTHOR
+
+Daniel Berrange <dan at berrange.com>
+
+=head1 COPYRIGHT
+
+Copright (C) 2006, Daniel Berrange.
+
+=head1 SEE ALSO
+
+L<Net::DBus>, L<Net::DBus::RemoteObject>
+
+=cut
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 0af5e01..5269bd5 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -97,11 +97,11 @@ This the base of all objects which are exported to the
message bus. It provides the core support for type introspection
required for objects exported to the message. When sub-classing
this object, methods can be created & tested as per normal Perl
-modules. Then just as the L<Exporter> module is used to export
-methods within a script, the L<Net::DBus::Exporter> module is
+modules. Then just as the L<Exporter> module is used to export
+methods within a script, the L<Net::DBus::Exporter> module is
used to export methods (and signals) to the message bus.
-All packages inheriting from this, will automatically have the
+All packages inheriting from this, will automatically have the
interface C<org.freedesktop.DBus.Introspectable> registered
with L<Net::DBus::Exporter>, and the C<Introspect> method within
this exported.
@@ -153,10 +153,10 @@ method on the L<Net::DBus> object.
sub new {
my $class = shift;
my $self = {};
-
+
my $parent = shift;
my $path = shift;
-
+
$self->{parent} = $parent;
if ($parent->isa(__PACKAGE__)) {
$self->{service} = $parent->get_service;
@@ -190,14 +190,14 @@ This method disconnects the object from the bus, such that it
will no longer receive messages sent by other clients. Any
child objects will be recursively disconnected too. After an
object has been disconnected, it is possible for Perl to
-garbage collect the object instance. It will also make it
-possible to connect a newly created object to the same path.
+garbage collect the object instance. It will also make it
+possible to connect a newly created object to the same path.
=cut
sub disconnect {
my $self = shift;
-
+
return unless $self->{parent};
foreach my $child (keys %{$self->{children}}) {
@@ -224,9 +224,9 @@ will only transition if the C<disconnect> method is called.
sub is_connected {
my $self = shift;
-
+
return 0 unless $self->{parent};
-
+
if ($self->{parent}->isa(__PACKAGE__)) {
return $self->{parent}->is_connected;
}
@@ -235,7 +235,7 @@ sub is_connected {
sub DESTROY {
my $self = shift;
- # XXX there are some issues during global
+ # XXX there are some issues during global
# destruction which need to be better figured
# out before this will work
#$self->disconnect;
@@ -244,7 +244,7 @@ sub DESTROY {
sub _register_child {
my $self = shift;
my $object = shift;
-
+
$self->get_service->_register_object($object);
$self->{children}->{$object->get_object_path} = $object;
}
@@ -253,7 +253,7 @@ sub _register_child {
sub _unregister_child {
my $self = shift;
my $object = shift;
-
+
$self->get_service->_unregister_object($object);
delete $self->{children}->{$object->get_object_path};
}
@@ -288,9 +288,9 @@ Emits a signal from the object, with a name of C<$name>. If the
C<$interface> parameter is defined, the signal will be scoped
within that interface. If the C<$client> parameter is defined,
the signal will be unicast to that client on the bus. The
-signal and the data types of the arguments C<@args> must have
-been registered with L<Net::DBus::Exporter> by calling the
-C<dbus_signal> method.
+signal and the data types of the arguments C<@args> must have
+been registered with L<Net::DBus::Exporter> by calling the
+C<dbus_signal> method.
=cut
@@ -304,7 +304,7 @@ 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,
+ interface => $interface,
signal_name => $name);
if ($destination) {
$signal->set_destination($destination);
@@ -317,7 +317,7 @@ sub emit_signal_in {
$signal->append_args_list(@args);
}
$self->get_service->get_bus->get_connection->send($signal);
-
+
# Short circuit locally registered callbacks
if (exists $self->{callbacks}->{$interface} &&
exists $self->{callbacks}->{$interface}->{$name}) {
@@ -329,8 +329,8 @@ sub emit_signal_in {
=item $self->emit_signal_to($name, $client, @args);
Emits a signal from the object, with a name of C<$name>. The
-signal and the data types of the arguments C<@args> must have
-been registered with L<Net::DBus::Exporter> by calling the
+signal and the data types of the arguments C<@args> must have
+been registered with L<Net::DBus::Exporter> by calling the
C<dbus_signal> method. The signal will be sent only to the
client named by the C<$client> parameter.
@@ -344,7 +344,7 @@ sub emit_signal_to {
my $intro = $self->_introspector;
if (!$intro) {
- die "no introspection data available for '" . $self->get_object_path .
+ die "no introspection data available for '" . $self->get_object_path .
"', use the emit_signal_in method instead";
}
my @interfaces = $intro->has_signal($name);
@@ -361,8 +361,8 @@ sub emit_signal_to {
=item $self->emit_signal($name, @args);
Emits a signal from the object, with a name of C<$name>. The
-signal and the data types of the arguments C<@args> must have
-been registered with L<Net::DBus::Exporter> by calling the
+signal and the data types of the arguments C<@args> must have
+been registered with L<Net::DBus::Exporter> by calling the
C<dbus_signal> method. The signal will be broadcast to all
clients on the bus.
@@ -374,7 +374,7 @@ sub emit_signal {
my @args = @_;
$self->emit_signal_to($name, undef, @args);
-}
+}
=item $object->connect_to_signal_in($name, $interface, $coderef);
@@ -395,7 +395,7 @@ sub connect_to_signal_in {
my $code = shift;
die "object is disconnected from the bus" unless $self->is_connected;
-
+
$self->{callbacks}->{$interface} = {} unless
exists $self->{callbacks}->{$interface};
$self->{callbacks}->{$interface}->{$name} = $code;
@@ -418,11 +418,11 @@ sub connect_to_signal {
my $ins = $self->_introspector;
if (!$ins) {
- die "no introspection data available for '" . $self->get_object_path .
+ die "no introspection data available for '" . $self->get_object_path .
"', use the connect_to_signal_in method instead";
}
my @interfaces = $ins->has_signal($name);
-
+
if ($#interfaces == -1) {
die "no signal with name '$name' is exported in object '" .
$self->get_object_path . "'\n";
@@ -431,7 +431,7 @@ sub connect_to_signal {
"in multiple interfaces of '" . $self->get_object_path . "'" .
"use the connect_to_signal_in method instead";
}
-
+
$self->connect_to_signal_in($name, $interfaces[0], $code);
}
@@ -444,13 +444,13 @@ sub _dispatch {
# Experiment in handling dispatch for child objects internally
# my $path = $message->get_path;
# while ($path ne $self->get_object_path) {
-# if (exists $self->{children}->{$path}) {
-# $self->{children}->{$path}->_dispatch($connection, $message);
-# return;
-# }
-# $path =~ s,/[^/]+$,,;
+# if (exists $self->{children}->{$path}) {
+# $self->{children}->{$path}->_dispatch($connection, $message);
+# return;
+# }
+# $path =~ s,/[^/]+$,,;
# }
-
+
my $reply;
my $method_name = $message->get_member;
my $interface = $message->get_interface;
@@ -460,7 +460,7 @@ sub _dispatch {
$ENABLE_INTROSPECT) {
my $xml = $self->_introspector->format;
$reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
-
+
$self->_introspector->encode($reply, "methods", $method_name, "returns", $xml);
}
} elsif ($interface eq "org.freedesktop.DBus.Properties") {
@@ -494,14 +494,18 @@ 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);
}
-
- $self->get_service->get_bus->get_connection->send($reply);
+
+ if ($message->get_no_reply()) {
+ # Not sending reply
+ } else {
+ $self->get_service->get_bus->get_connection->send($reply);
+ }
}
@@ -511,13 +515,13 @@ sub _dispatch_prop_read {
my $method_name = shift;
my $ins = $self->_introspector;
-
+
if (!$ins) {
return Net::DBus::Binding::Message::Error->new(replyto => $message,
name => "org.freedesktop.DBus.Error.Failed",
description => "no introspection data exported for properties");
}
-
+
my ($pinterface, $pname) = $ins->decode($message, "methods", "Get", "params");
if (!$ins->has_property($pname, $pinterface)) {
@@ -525,13 +529,13 @@ sub _dispatch_prop_read {
name => "org.freedesktop.DBus.Error.Failed",
description => "no property '$pname' exported in interface '$pinterface'");
}
-
+
if (!$ins->is_property_readable($pinterface, $pname)) {
return Net::DBus::Binding::Message::Error->new(replyto => $message,
name => "org.freedesktop.DBus.Error.Failed",
description => "property '$pname' in interface '$pinterface' is not readable");
}
-
+
if ($self->can($pname)) {
my $value = eval {
$self->$pname;
@@ -542,7 +546,7 @@ sub _dispatch_prop_read {
description => "error reading '$pname' in interface '$pinterface': $@");
} else {
my $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
-
+
$self->_introspector->encode($reply, "methods", "Get", "returns", $value);
return $reply;
}
@@ -559,27 +563,27 @@ sub _dispatch_prop_write {
my $method_name = shift;
my $ins = $self->_introspector;
-
+
if (!$ins) {
return Net::DBus::Binding::Message::Error->new(replyto => $message,
name => "org.freedesktop.DBus.Error.Failed",
description => "no introspection data exported for properties");
}
-
+
my ($pinterface, $pname, $pvalue) = $ins->decode($message, "methods", "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'");
}
-
+
if (!$ins->is_property_writable($pinterface, $pname)) {
return Net::DBus::Binding::Message::Error->new(replyto => $message,
name => "org.freedesktop.DBus.Error.Failed",
description => "property '$pname' in interface '$pinterface' is not writable");
}
-
+
if ($self->can($pname)) {
eval {
$self->$pname($pvalue);
@@ -600,7 +604,7 @@ sub _dispatch_prop_write {
sub _introspector {
my $self = shift;
-
+
if (!$self->{introspected}) {
$self->{introspector} = Net::DBus::Exporter::_dbus_introspector($self);
$self->{introspected} = 1;
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index f2abf24..9f3375b 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -39,7 +39,7 @@ Net::DBus::RemoteObject - Access objects provided on the bus
This module provides the API for accessing remote objects available
on the bus. It uses the autoloader to fake the presence of methods
-based on the API of the remote object. There is also support for
+based on the API of the remote object. There is also support for
setting callbacks against signals, and accessing properties of the
object.
@@ -60,6 +60,9 @@ our $AUTOLOAD;
use Net::DBus::Binding::Message::MethodCall;
use Net::DBus::Binding::Introspector;
+use Net::DBus::ASyncReply;
+use Net::DBus::Annotation qw(:call);
+
=item my $object = Net::DBus::RemoteObject->new($service, $object_path[, $interface]);
@@ -67,7 +70,7 @@ Creates a new handle to a remote object. The C<$service> parameter is an instanc
of the L<Net::DBus::RemoteService> method, and C<$object_path> is the identifier of
an object exported by this service, for example C</org/freedesktop/DBus>. For remote
objects which implement more than one interface it is possible to specify an optional
-name of an interface as the third parameter. This is only really required, however, if
+name of an interface as the third parameter. This is only really required, however, if
two interfaces in the object provide methods with the same name, since introspection
data can be used to automatically resolve the correct interface to call cases where
method names are unique. Rather than using this constructor directly, it is preferrable
@@ -86,7 +89,7 @@ sub new {
$self->{object_path} = shift;
$self->{interface} = @_ ? shift : undef;
$self->{introspected} = 0;
-
+
bless $self, $class;
return $self;
@@ -105,7 +108,7 @@ support introspection.
sub as_interface {
my $self = shift;
my $interface = shift;
-
+
die "already cast to " . $self->{interface} . "'"
if $self->{interface};
@@ -128,7 +131,7 @@ sub get_service {
=item my $path = $object->get_object_path
-Retrieves the unique path identifier for this object within the
+Retrieves the unique path identifier for this object within the
service.
=cut
@@ -153,7 +156,7 @@ sub get_child_object {
my $path = shift;
my $interface = @_ ? shift : undef;
my $fullpath = $self->{object_path} . $path;
-
+
return $self->new($self->get_service,
$fullpath,
$interface);
@@ -161,20 +164,20 @@ 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 $xml = eval {
my $reply = $self->{service}->
get_bus()->
get_connection()->
send_with_reply_and_block($call, 60 * 1000);
-
+
my $iter = $reply->iterator;
return $iter->get(&Net::DBus::Binding::Message::TYPE_STRING);
};
@@ -184,7 +187,7 @@ sub _introspector {
die $@;
} else {
# Ignore other failures, since its probably
- # just that the object doesn't implement
+ # just that the object doesn't implement
# the introspect method. Of course without
# the introspect method we can't tell for sure
# if this is the case..
@@ -220,11 +223,11 @@ sub connect_to_signal {
my $interface = $self->{interface};
if (!$interface) {
if (!$ins) {
- die "no introspection data available for '" . $self->get_object_path .
+ die "no introspection data available for '" . $self->get_object_path .
"', and object is not cast to any interface";
}
my @interfaces = $ins->has_signal($name);
-
+
if ($#interfaces == -1) {
die "no signal with name '$name' is exported in object '" .
$self->get_object_path . "'\n";
@@ -271,10 +274,15 @@ sub AUTOLOAD {
my $self = shift;
my $sub = $AUTOLOAD;
+ my $mode = dbus_call_sync;
+ if (@_ && UNIVERSAL::isa($_[0], "Net::DBus::Annotation")) {
+ $mode = shift;
+ }
+
(my $name = $AUTOLOAD) =~ s/.*:://;
my $interface = $self->{interface};
-
+
# If introspection data is available, use that
# to resolve correct interface (if object is not
# cast to an explicit interface already)
@@ -282,7 +290,7 @@ sub AUTOLOAD {
if ($ins) {
if ($interface) {
if ($ins->has_method($name, $interface)) {
- return $self->_call_method($name, $interface, 1, @_);
+ return $self->_call_method($mode, $name, $interface, 1, @_);
}
if ($ins->has_property($name, $interface)) {
if ($ins->is_property_deprecated($name, $interface)) {
@@ -290,24 +298,24 @@ sub AUTOLOAD {
}
if (@_) {
- $self->_call_method("Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
+ $self->_call_method($mode, "Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
return ();
} else {
- return $self->_call_method("Get", "org.freedesktop.DBus.Properties", $interface, 1, $name);
+ return $self->_call_method($mode, "Get", "org.freedesktop.DBus.Properties", $interface, 1, $name);
}
}
} else {
my @interfaces = $ins->has_method($name);
-
+
if (@interfaces) {
if ($#interfaces > 0) {
die "method with name '$name' is exported " .
"in multiple interfaces of '" . $self->get_object_path . "'";
}
- return $self->_call_method($name, $interfaces[0], 1, @_);
+ return $self->_call_method($mode, $name, $interfaces[0], 1, @_);
}
@interfaces = $ins->has_property($name);
-
+
if (@interfaces) {
if ($#interfaces > 0) {
die "property with name '$name' is exported " .
@@ -318,26 +326,27 @@ sub AUTOLOAD {
warn "property $name in interface $interface on " . $self->get_object_path . " is deprecated";
}
if (@_) {
- $self->_call_method("Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
+ $self->_call_method($mode, "Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
return ();
} else {
- return $self->_call_method("Get", "org.freedesktop.DBus.Properties", $interface, 1, $name);
+ return $self->_call_method($mode, "Get", "org.freedesktop.DBus.Properties", $interface, 1, $name);
}
}
}
}
if (!$interface) {
- die "no introspection data available for method '" . $name . "' in object '" .
+ die "no introspection data available for method '" . $name . "' in object '" .
$self->get_object_path . "', and object is not cast to any interface";
}
-
- return $self->_call_method($name, $interface, 0, @_);
+
+ return $self->_call_method($mode, $name, $interface, 0, @_);
}
sub _call_method {
my $self = shift;
+ my $mode = shift;
my $name = shift;
my $interface = shift;
my $introspect = shift;
@@ -361,24 +370,39 @@ sub _call_method {
} else {
$call->append_args_list(@_);
}
-
- if (!$ins ||
- $ins->does_method_reply($name, $interface)) {
+
+ if ($mode == dbus_call_sync) {
my $reply = $self->{service}->
get_bus()->
get_connection()->
send_with_reply_and_block($call, 60 * 1000);
-
+
my @reply;
if ($ins) {
@reply = $ins->decode($reply, "methods", $name, "returns");
} else {
@reply = $reply->get_args_list;
}
-
+
return wantarray ? @reply : $reply[0];
+ } elsif ($mode == dbus_call_async) {
+ my $pending_call = $self->{service}->
+ get_bus()->
+ get_connection()->
+ send_with_reply($call, 60 * 1000);
+ my $reply = Net::DBus::ASyncReply->_new(pending_call => $pending_call,
+ ($ins ? (introspector => $ins,
+ method_name => $name)
+ : ()));
+ return $reply;
+ } elsif ($mode == dbus_call_noreply) {
+ $call->set_no_reply(1);
+ $self->{service}->
+ get_bus()->
+ get_connection()->
+ send($call, 60 * 1000);
} else {
- return wantarray ? () : undef;
+ die "unsupported annotation '$mode'";
}
}
@@ -395,7 +419,7 @@ Daniel Berrange <dan at berrange.com>
=head1 COPYRIGHT
-Copright (C) 2004-2005, Daniel Berrange.
+Copright (C) 2004-2005, Daniel Berrange.
=head1 SEE ALSO
diff --git a/t/55-method-calls.t b/t/55-method-calls.t
index 7e3e450..97ad6a9 100644
--- a/t/55-method-calls.t
+++ b/t/55-method-calls.t
@@ -1,6 +1,6 @@
# -*- perl -*-
-use Test::More tests => 67;
+use Test::More tests => 56;
use strict;
use warnings;
@@ -34,10 +34,6 @@ TEST_NO_INTROSPECT: {
&test_method_fail("raw, no introspect", $robject, "Deprecated");
&test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation");
&test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
-
- &test_method_fail("raw, no introspect", $robject, "TestNoReturn");
- &test_method_fail("myobject, no introspect",$myobject, "TestNoReturn");
- &test_method_fail("otherobject, no introspect",$otherobject, "TestNoReturn");
}
TEST_MISSING_INTROSPECT: {
@@ -63,10 +59,6 @@ TEST_MISSING_INTROSPECT: {
&test_method_fail("raw, no introspect", $robject, "Deprecated");
&test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation");
&test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
-
- &test_method_fail("raw, no introspect", $robject, "TestNoReturn");
- &test_method_fail("myobject, no introspect",$myobject, "TestNoReturn");
- &test_method_fail("otherobject, no introspect",$otherobject, "TestNoReturn");
}
TEST_FULL_INTROSPECT: {
@@ -77,7 +69,6 @@ TEST_FULL_INTROSPECT: {
$ins->add_method("PolyTest", [], ["string"], "org.example.MyObject");
$ins->add_method("PolyTest", [], ["string"], "org.example.OtherObject");
$ins->add_method("Deprecated", [], ["string"], "org.example.MyObject", { deprecated => 1 });
- $ins->add_method("TestNoReturn", [], [], "org.example.MyObject", { no_return => 1 });
$object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
reply => { return => [ $ins->format ] });
@@ -110,10 +101,6 @@ TEST_FULL_INTROSPECT: {
&test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
ok(!$warned, "deprecation warning generated");
}
-
- &test_method_noreply("raw, no introspect", $robject, "TestNoReturn");
- &test_method_noreply("myobject, no introspect",$myobject, "TestNoReturn");
- &test_method_fail("otherobject, no introspect",$otherobject, "TestNoReturn");
}
diff --git a/typemap b/typemap
index 8aba8f5..36c887f 100644
--- a/typemap
+++ b/typemap
@@ -3,6 +3,7 @@ const char * T_PV
DBusConnection* O_OBJECT_connection
DBusServer* O_OBJECT_server
DBusMessage* O_OBJECT_message
+DBusPendingCall* O_OBJECT_pendingcall
DBusWatch* O_OBJECT_watch
DBusTimeout* O_OBJECT_timeout
DBusMessageIter* O_OBJECT_messageiter
@@ -56,6 +57,19 @@ O_OBJECT_message
INPUT
+O_OBJECT_pendingcall
+ 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_pendingcall
+ sv_setref_pv( $arg, "Net::DBus::Binding::C::PendingCall", (void*)$var );
+
+INPUT
O_OBJECT_watch
if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG))
$var = ($type)SvIV((SV*)SvRV( $arg ));
--
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