[libnet-dbus-perl] 87/335: Make introspection data optional both for client & servers
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:30 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 ae12b92166eb996e4629686f2988d9dd6ed2b0fa
Author: Daniel P. Berrange <dan at berrange.com>
Date: Mon Aug 29 12:39:17 2005 +0000
Make introspection data optional both for client & servers
---
examples/example-signal-receiver.pl | 2 +-
lib/Net/DBus/Object.pm | 102 +++++++++++++++++++++-------
lib/Net/DBus/RemoteObject.pm | 128 +++++++++++++++++++++++++-----------
3 files changed, 172 insertions(+), 60 deletions(-)
diff --git a/examples/example-signal-receiver.pl b/examples/example-signal-receiver.pl
index 4e2a5a1..d583432 100644
--- a/examples/example-signal-receiver.pl
+++ b/examples/example-signal-receiver.pl
@@ -11,7 +11,7 @@ use Carp qw(confess cluck);
my $bus = Net::DBus->session();
my $service = $bus->get_service("org.designfu.TestService");
-my $object = $service->get_object("/org/designfu/TestService/object");
+my $object = $service->get_object("/org/designfu/TestService/object", "org.designfu.TestService");
sub hello_signal_handler {
my $greeting = shift;
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 73239d9..d2dfdce 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -133,6 +133,15 @@ use warnings;
use Carp;
our $VERSION = '0.0.1';
+our $ENABLE_INTROSPECT;
+
+BEGIN {
+ if ($ENV{DBUS_DISABLE_INTROSPECT}) {
+ $ENABLE_INTROSPECT = 0;
+ } else {
+ $ENABLE_INTROSPECT = 1;
+ }
+}
use Net::DBus::RemoteObject;
use Net::DBus::Exporter "org.freedesktop.DBus.Introspectable";
@@ -143,19 +152,30 @@ dbus_method("Introspect", [], ["string"]);
sub new {
my $class = shift;
- my $self = {};
+ my $self = $class->_new(@_);
- $self->{service} = shift;
- $self->{object_path} = shift;
- $self->{callbacks} = {};
-
- bless $self, $class;
-
$self->get_service->get_bus->get_connection->
register_object_path($self->get_object_path,
sub {
$self->_dispatch(@_);
});
+
+ return $self;
+}
+
+
+sub _new {
+ my $class = shift;
+ my $self = {};
+
+ $self->{service} = shift;
+ $self->{object_path} = shift;
+ $self->{interface} = shift;
+ $self->{introspector} = undef;
+ $self->{introspected} = 0;
+ $self->{callbacks} = {};
+
+ bless $self, $class;
return $self;
}
@@ -182,7 +202,12 @@ sub emit_signal_in {
interface => $interface,
signal_name => $name);
- $self->_introspector->encode($signal, "signals", $name, "params", @args);
+ my $ins = $self->_introspector;
+ if ($ins) {
+ $ins->encode($signal, "signals", $name, "params", @args);
+ } else {
+ $signal->append_args_list(@args);
+ }
$self->get_service->get_bus->get_connection->send($signal);
# Short circuit locally registered callbacks
@@ -196,41 +221,58 @@ sub emit_signal_in {
sub emit_signal {
my $self = shift;
my $name = shift;
-
+ my @args = @_;
+
my $intro = $self->_introspector;
+ if (!$intro) {
+ die "no introspection data available for '" . $self->get_object_path .
+ "', use the emit_signal_in method instead";
+ }
my @interfaces = $intro->has_signal($name);
if ($#interfaces == -1) {
die "no signal with name '$name' is exported in object '" .
$self->get_object_path . "'\n";
} elsif ($#interfaces > 0) {
die "signal '$name' is exported in more than one interface of '" .
- $self->get_object_path . "'." .
- "use the 'emit_signal_in' method to specify the interface\n";
+ $self->get_object_path . "', use the emit_signal_in method instead.";
}
- $self->emit_signal_in($name, $interfaces[0], @_);
+ $self->emit_signal_in($name, $interfaces[0], @args);
}
+sub connect_to_signal_in {
+ my $self = shift;
+ my $name = shift;
+ my $interface = shift;
+ my $code = shift;
+
+ $self->{callbacks}->{$interface} = {} unless
+ exists $self->{callbacks}->{$interface};
+ $self->{callbacks}->{$interface}->{$name} = $code;
+}
+
sub connect_to_signal {
my $self = shift;
my $name = shift;
my $code = shift;
my $ins = $self->_introspector;
+ if (!$ins) {
+ 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";
} elsif ($#interfaces > 0) {
- warn "signal with name '$name' is exported " .
+ die "signal with name '$name' is exported " .
"in multiple interfaces of '" . $self->get_object_path . "'" .
- "connecting to first interface only\n";
+ "use the connect_to_signal_in method instead";
}
- $self->{callbacks}->{$interfaces[0]} = {} unless
- exists $self->{callbacks}->{$interfaces[0]};
- $self->{callbacks}->{$interfaces[0]}->{$name} = $code;
+ $self->connect_to_signal_in($name, $code, $interfaces[0]);
}
@@ -242,7 +284,13 @@ sub _dispatch {
my $reply;
my $method_name = $message->get_member;
if ($self->can($method_name)) {
- my @args = $self->_introspector->decode($message, "methods", $method_name, "params");
+ my $ins = $self->_introspector;
+ my @args;
+ if ($ins) {
+ @args = $ins->decode($message, "methods", $method_name, "params");
+ } else {
+ @args = $message->get_args_list;
+ }
my @ret = eval {
$self->$method_name(@args);
@@ -253,9 +301,15 @@ sub _dispatch {
description => $@);
} else {
$reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
- $self->_introspector->encode($reply, "methods", $method_name, "returns", @ret);
+ if ($ins) {
+ $self->_introspector->encode($reply, "methods", $method_name, "returns", @ret);
+ } else {
+ $reply->append_args_list(@ret);
+ }
}
- } elsif ($method_name eq "Introspect") {
+ } elsif ($method_name eq "Introspect" &&
+ $self->_introspector &&
+ $ENABLE_INTROSPECT) {
my $xml = $self->_introspector->format;
$reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
@@ -272,7 +326,11 @@ sub _dispatch {
sub _introspector {
my $self = shift;
- return Net::DBus::Exporter::dbus_introspector($self);
+ if (!$self->{introspected}) {
+ $self->{introspector} = Net::DBus::Exporter::dbus_introspector($self);
+ $self->{introspected} = 1;
+ }
+ return $self->{introspector};
}
1;
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index 0d55be8..c9b9fa5 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -17,12 +17,26 @@ sub new {
$self->{service} = shift;
$self->{object_path} = shift;
+ $self->{interface} = @_ ? shift : undef;
+ $self->{introspected} = 0;
bless $self, $class;
return $self;
}
+sub as_interface {
+ my $self = shift;
+ my $interface = shift;
+
+ die "already cast to " . $self->{interface} . "'"
+ if $self->{interface};
+
+ return $self->new($self->{service},
+ $self->{object_path},
+ $interface);
+}
+
sub get_service {
my $self = shift;
return $self->{service};
@@ -36,23 +50,31 @@ sub get_object_path {
sub _introspector {
my $self = shift;
- unless (defined $self->{introspector}) {
+ 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 $reply = $self->{service}->
- get_bus()->
- get_connection()->
- send_with_reply_and_block($call, 5000);
-
- my $iter = $reply->iterator;
- my $xml = $iter->get(&Net::DBus::Binding::Message::TYPE_STRING);
-
- $self->{introspector} = Net::DBus::Binding::Introspector->new(xml => $xml,
- object_path => $self->{object_path});
+ my $xml = eval {
+ my $reply = $self->{service}->
+ get_bus()->
+ get_connection()->
+ send_with_reply_and_block($call, 5000);
+
+ my $iter = $reply->iterator;
+ return $iter->get(&Net::DBus::Binding::Message::TYPE_STRING);
+ };
+ # Ignore failures
+ #if ($@) {
+ # warn "could not introspect object: $@";
+ #}
+ if ($xml) {
+ $self->{introspector} = Net::DBus::Binding::Introspector->new(xml => $xml,
+ object_path => $self->{object_path});
+ }
+ $self->{introspected} = 1;
}
return $self->{introspector};
}
@@ -63,16 +85,24 @@ sub connect_to_signal {
my $code = shift;
my $lazy_binding = shift;
- my $ins = $self->_introspector;
- my @interfaces = $ins->has_signal($name);
-
- if ($#interfaces == -1) {
- die "no signal with name '$name' is exported in object '" .
- $self->get_object_path . "'\n";
- } elsif ($#interfaces > 0) {
- warn "signal with name '$name' is exported " .
- "in multiple interfaces of '" . $self->get_object_path . "'" .
- "connecting to first interface only\n";
+ my $interface = $self->{interface};
+ if (!$interface) {
+ my $ins = $self->_introspector;
+ if (!$ins) {
+ 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";
+ } elsif ($#interfaces > 0) {
+ warn "signal with name '$name' is exported " .
+ "in multiple interfaces of '" . $self->get_object_path . "'" .
+ "connecting to first interface only\n";
+ }
+ $interface = $interfaces[0];
}
$self->get_service->
@@ -80,11 +110,16 @@ sub connect_to_signal {
add_signal_receiver(sub {
my $signal = shift;
my $ins = $self->_introspector;
- my @params = $ins->decode($signal, "signals", $signal->get_member, "params");
+ my @params;
+ if ($ins) {
+ @params = $ins->decode($signal, "signals", $signal->get_member, "params");
+ } else {
+ @params = $signal->get_args_list;
+ }
&$code(@params);
},
$name,
- $interfaces[0],
+ $interface,
$lazy_binding ? undef : $self->{service}->get_service_name(),
$self->{object_path});
}
@@ -99,33 +134,52 @@ sub AUTOLOAD {
my $sub = $AUTOLOAD;
(my $method = $AUTOLOAD) =~ s/.*:://;
-
- my $ins = $self->_introspector;
- my @interfaces = $ins->has_method($method);
-
- if ($#interfaces == -1) {
- die "no method with name '$method' is exported in object '" .
- $self->get_object_path . "'\n";
- } elsif ($#interfaces > 0) {
- warn "method with name '$method' is exported " .
- "in multiple interfaces of '" . $self->get_object_path . "'" .
- "calling first interface only\n";
+
+ my $interface = $self->{interface};
+ if (!$interface) {
+ my $ins = $self->_introspector;
+ if (!$ins) {
+ die "no introspection data available for '" . $self->get_object_path .
+ "', and object is not cast to any interface";
+ }
+
+ my @interfaces = $ins->has_method($method);
+
+ if ($#interfaces == -1) {
+ die "no method with name '$method' is exported in object '" .
+ $self->get_object_path . "'\n";
+ } elsif ($#interfaces > 0) {
+ warn "method with name '$method' is exported " .
+ "in multiple interfaces of '" . $self->get_object_path . "'" .
+ "calling first interface only\n";
+ }
+ $interface = $interfaces[0];
}
my $call = Net::DBus::Binding::Message::MethodCall->
new(service_name => $self->{service}->get_service_name(),
object_path => $self->{object_path},
method_name => $method,
- interface => $interfaces[0]);
+ interface => $interface);
- $ins->encode($call, "methods", $method, "params", @_);
+ my $ins = $self->_introspector;
+ if ($ins) {
+ $ins->encode($call, "methods", $method, "params", @_);
+ } else {
+ $call->append_args_list(@_);
+ }
my $reply = $self->{service}->
get_bus()->
get_connection()->
send_with_reply_and_block($call, 5000);
- my @reply = $ins->decode($reply, "methods", $method, "returns");
+ my @reply;
+ if ($ins) {
+ @reply = $ins->decode($reply, "methods", $method, "returns");
+ } else {
+ @reply = $reply->get_args_list;
+ }
return wantarray ? @reply : $reply[0];
}
--
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