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 149d28736d4fb98f9a19848f9008fa462298181d
Author: Daniel P. Berrange <d...@berrange.com>
Date: Tue Mar 29 19:37:22 2005 +0000
Merged introspection code from INTROSPECTION branch into mainline
---
examples/example-client.pl | 3 +
examples/example-service.pl | 25 ++-
examples/example-signal-emitter.pl | 23 ++-
examples/example-signal-receiver.pl | 13 +-
lib/Net/DBus.pm | 107 +----------
lib/Net/DBus/Binding/Iterator.pm | 66 ++++---
lib/Net/DBus/Introspector.pm | 369 ++++++++++++++++++++++++++++++++++++
lib/Net/DBus/Object.pm | 38 ++--
lib/Net/DBus/RemoteObject.pm | 35 +++-
t/40-introspector.t | 63 ++++++
10 files changed, 581 insertions(+), 161 deletions(-)
diff --git a/examples/example-client.pl b/examples/example-client.pl
index 8c8fa42..5fb97ef 100644
--- a/examples/example-client.pl
+++ b/examples/example-client.pl
@@ -1,6 +1,9 @@
#/usr/bin/perl
use Net::DBus;
+use Carp qw(cluck carp);
+#$SIG{__WARN__} = sub { cluck $_[0] };
+#$SIG{__DIE__} = sub { carp $_[0] };
my $bus = Net::DBus->session();
diff --git a/examples/example-service.pl b/examples/example-service.pl
index 964b1dd..530dc74 100644
--- a/examples/example-service.pl
+++ b/examples/example-service.pl
@@ -22,7 +22,24 @@ use base qw(Net::DBus::Object);
sub new {
my $class = shift;
my $self = $class->SUPER::new("/SomeObject",
- ["HelloWorld"],
+ {
+ "SomeObject" => {
+ methods => {
+ "HelloWorld" => {
+ params => ["string"],
+ returns =>
[["array",["string"]]],
+ },
+ "GetDict" => {
+ params => [],
+ returns => [["dict",
["string", "string"]]],
+ },
+ "GetTuple" => {
+ params => [],
+ returns => [["struct",
["string", "string"]]],
+ }
+ },
+ },
+ },
@_);
bless $self, $class;
@@ -30,9 +47,11 @@ sub new {
return $self;
}
+
sub HelloWorld {
my $self = shift;
my $message = shift;
+ print "Do hello world\n";
print $message, "\n";
return ["Hello", " from example-service.pl"];
}
@@ -40,11 +59,13 @@ sub HelloWorld {
sub GetDict {
my $self = shift;
my $message = shift;
+ print "Do get dict\n";
return {"first" => "Hello Dict", "second" => " from example-service.py"};
}
sub GetTuple {
my $self = shift;
my $message = shift;
- return Net::DBus::dstruct(["Hello Tuple", " from example-service.py"]);
+ print "Do get tuple\n";
+ return ["Hello Tuple", " from example-service.py"];
}
diff --git a/examples/example-signal-emitter.pl
b/examples/example-signal-emitter.pl
index d095b2a..e4cec92 100644
--- a/examples/example-signal-emitter.pl
+++ b/examples/example-signal-emitter.pl
@@ -5,6 +5,11 @@ use Net::DBus::Reactor;
use Net::DBus::Service;
use Net::DBus::Object;
+use Carp qw(confess cluck);
+
+$SIG{__WARN__} = sub { cluck $_[0] };
+$SIG{__DIE__} = sub { confess $_[0] };
+
my $bus = Net::DBus->session();
my $service = Net::DBus::Service->new("org.designfu.TestService",
$bus);
@@ -21,7 +26,19 @@ use base qw(Net::DBus::Object);
sub new {
my $class = shift;
my $self = $class->SUPER::new("/org/designfu/TestService/object",
- ["emitHelloSignal"],
+ {
+ "org.designfu.TestService" => {
+ methods => {
+ "emitHelloSignal" => {
+ params => [],
+ returns => [],
+ },
+ },
+ signals => {
+ "hello" => [],
+ },
+ },
+ },
@_);
bless $self, $class;
@@ -31,7 +48,7 @@ sub new {
sub emitHelloSignal {
my $self = shift;
- $self->emit_signal("org.designfu.TestService",
- "hello");
+ return $self->emit_signal("org.designfu.TestService",
+ "hello");
}
diff --git a/examples/example-signal-receiver.pl
b/examples/example-signal-receiver.pl
index f870a0c..0a7e295 100644
--- a/examples/example-signal-receiver.pl
+++ b/examples/example-signal-receiver.pl
@@ -3,6 +3,11 @@
use Net::DBus;
use Net::DBus::Reactor;
+use Carp qw(confess cluck);
+
+#$SIG{__WARN__} = sub { cluck $_[0] };
+#$SIG{__DIE__} = sub { confess $_[0] };
+
my $bus = Net::DBus->session();
my $service = $bus->get_service("org.designfu.TestService");
@@ -17,9 +22,11 @@ sub hello_signal_handler {
$object->connect_to_signal("hello", \&hello_signal_handler);
-# Tell the remote object to emit the signal
-$object->emitHelloSignal();
-
my $reactor = Net::DBus::Reactor->new();
$reactor->manage($bus->{connection});
+
+$reactor->add_timeout(1000, Net::DBus::Callback->new(method => sub {
+ $object->emitHelloSignal();
+}));
+
$reactor->run();
diff --git a/lib/Net/DBus.pm b/lib/Net/DBus.pm
index 47043cd..0c30818 100644
--- a/lib/Net/DBus.pm
+++ b/lib/Net/DBus.pm
@@ -5,25 +5,20 @@ use strict;
use warnings;
use Carp;
+
+
+BEGIN {
+our $VERSION = '0.0.1';
+require XSLoader;
+XSLoader::load('Net::DBus', $VERSION);
+}
+
use Net::DBus::Binding::Bus;
use Net::DBus::Binding::Message;
use Net::DBus::Binding::Value;
use Net::DBus::RemoteService;
-our $VERSION = '0.0.1';
-
-use Exporter;
-
-use base qw(Exporter);
-use vars qw(@EXPORT);
-
-@EXPORT = qw(dboolean dbyte dstring dint32
- duint32 dint64 duint64 ddouble
- dstruct dpack);
-
-require XSLoader;
-XSLoader::load('Net::DBus', $VERSION);
sub system {
my $class = shift;
@@ -203,92 +198,6 @@ sub _signal_func {
return $handled;
}
-
-sub dboolean {
- my $value = shift;
- return
Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BOOLEAN,
- $value);
-}
-
-sub dbyte {
- my $value = shift;
- return
Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BYTE,
- $value);
-}
-
-sub dstring {
- my $value = shift;
- return
Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_STRING,
- $value);
-}
-
-sub dint32 {
- my $value = shift;
- return
Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT32,
- $value);
-}
-
-sub duint32 {
- my $value = shift;
- return
Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT32,
- $value);
-}
-
-sub dint64 {
- my $value = shift;
- return
Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT64,
- $value);
-}
-
-sub duint64 {
- my $value = shift;
- return
Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT64,
- $value);
-}
-
-sub ddouble {
- my $value = shift;
- return
Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_DOUBLE,
- $value);
-}
-
-sub dstruct {
- my $value = shift;
- return
Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_STRUCT,
- $value);
-}
-
-our %flags = (
- 'o' => &Net::DBus::Binding::Message::TYPE_BOOLEAN,
- 'b' => &Net::DBus::Binding::Message::TYPE_BYTE,
- 's' => &Net::DBus::Binding::Message::TYPE_STRING,
- 'i' => &Net::DBus::Binding::Message::TYPE_INT32,
- 'I' => &Net::DBus::Binding::Message::TYPE_UINT32,
- 'l' => &Net::DBus::Binding::Message::TYPE_INT64,
- 'L' => &Net::DBus::Binding::Message::TYPE_UINT64,
- 'd' => &Net::DBus::Binding::Message::TYPE_DOUBLE,
- );
-
-sub dpack {
- my $format = shift;
- my @in = @_;
- if (length $format != ($#in+1)) {
- confess "incorrect number of arguments for format string";
- }
-
- my @out;
- foreach my $flag (split //, $format) {
- my $value = shift @in;
- if (!exists $flags{$flag}) {
- confess "unknown format flag '$flag'";
- }
- push @out, Net::DBus::Binding::Value->new($flags{$flag},
- $value);
- }
- return @out;
-}
-
-
1;
__END__
diff --git a/lib/Net/DBus/Binding/Iterator.pm b/lib/Net/DBus/Binding/Iterator.pm
index 7543174..f83662e 100644
--- a/lib/Net/DBus/Binding/Iterator.pm
+++ b/lib/Net/DBus/Binding/Iterator.pm
@@ -276,30 +276,20 @@ sub get_struct {
sub append {
my $self = shift;
my $value = shift;
+ my $type = shift;
- my $type;
- if (@_) {
- $type = shift;
- } elsif (ref($value) eq "Net::DBus::Binding::Value") {
- $type = $value->type;
- $value = $value->value;
- } else {
- $type = &Net::DBus::Binding::Message::TYPE_STRING;
- }
-
- #warn "Type $type value $value\n";
-
- if (ref($value)) {
- if (ref($value) eq "HASH") {
- $self->append_dict($value);
- } elsif (ref($value) eq "ARRAY") {
- if ($type == &Net::DBus::Binding::Message::TYPE_STRUCT) {
- $self->append_struct($value);
- } else {
- $self->append_array($value, $type);
- }
+ if (ref($type) eq "ARRAY") {
+ my $maintype = $type->[0];
+ my $subtype = $type->[1];
+
+ if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ $self->append_dict($value, $subtype);
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) {
+ $self->append_struct($value, $subtype);
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) {
+ $self->append_array($value, $subtype);
} else {
- confess "Unsupported reference type ", ref($value);
+ confess "Unsupported compound type ", $maintype;
}
} else {
if ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) {
@@ -329,12 +319,21 @@ sub append_array {
my $self = shift;
my $array = shift;
my $type = shift;
-
- my $sig = chr($type);
+
+ die "array must only have one type"
+ if $#{$type} > 0;
+
+ my $sig;
+ if (ref($type->[0])) {
+ $sig = chr($type->[0]->[0]);
+ } else {
+ $sig = chr($type->[0]);
+ }
+
my $iter =
$self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
foreach my $value (@{$array}) {
- $iter->append($value, $type);
+ $iter->append($value, $type->[0]);
}
$self->_close_container($iter);
@@ -344,11 +343,17 @@ sub append_array {
sub append_struct {
my $self = shift;
my $struct = shift;
-
+ my $type = shift;
+
+ if ($#{$struct} != $#{$type}) {
+ die "number of values does not match type";
+ }
+
my $iter =
$self->_open_container(&Net::DBus::Binding::Message::TYPE_STRUCT, undef);
+ my @type = @{$type};
foreach my $value (@{$struct}) {
- $iter->append($value);
+ $iter->append($value, shift @type);
}
$self->_close_container($iter);
@@ -358,7 +363,8 @@ sub append_struct {
sub append_dict {
my $self = shift;
my $hash = shift;
-
+ my $type = shift;
+
# XXX don't hardcode me - cf Python bindings
my $sig = "{ss}";
my $iter =
$self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
@@ -367,8 +373,8 @@ sub append_dict {
my $value = $hash->{$key};
my $entry =
$iter->_open_container(&Net::DBus::Binding::Message::TYPE_DICT_ENTRY, $sig);
- $entry->append($key);
- $entry->append($value);
+ $entry->append($key, $type->[0]);
+ $entry->append($value, $type->[1]);
$iter->_close_container($entry);
}
$self->_close_container($iter);
diff --git a/lib/Net/DBus/Introspector.pm b/lib/Net/DBus/Introspector.pm
new file mode 100644
index 0000000..0edb420
--- /dev/null
+++ b/lib/Net/DBus/Introspector.pm
@@ -0,0 +1,369 @@
+=pod
+
+ name => "org.foo.bar.Object"
+ interfaces =>
+ "org.foo.bar.Wibble" => {
+ methods => {
+ foo => {
+ params => ["int32", "double", ["array", ["int32"]]],
+ return => ["string", "byte", ["dict", ["string", "variant"]]]
+ }
+ }
+ }
+ }
+ children => [
+ introspector...
+ ];
+
+=cut
+
+package Net::DBus::Introspector;
+
+use 5.006;
+use strict;
+use warnings;
+use Carp;
+use XML::Grove::Builder;
+use XML::Parser::PerlSAX;
+
+use Net::DBus;
+use Net::DBus::Binding::Message;
+
+our %simple_type_map = (
+ "byte" => &Net::DBus::Binding::Message::TYPE_BYTE,
+ "bool" => &Net::DBus::Binding::Message::TYPE_BOOLEAN,
+ "double" => &Net::DBus::Binding::Message::TYPE_DOUBLE,
+ "string" => &Net::DBus::Binding::Message::TYPE_STRING,
+ "int32" => &Net::DBus::Binding::Message::TYPE_INT32,
+ "uint32" => &Net::DBus::Binding::Message::TYPE_UINT32,
+ "int64" => &Net::DBus::Binding::Message::TYPE_INT64,
+ "uint64" => &Net::DBus::Binding::Message::TYPE_UINT64,
+);
+
+our %compound_type_map = (
+ "array" => &Net::DBus::Binding::Message::TYPE_ARRAY,
+ "struct" => &Net::DBus::Binding::Message::TYPE_STRUCT,
+ "dict" => &Net::DBus::Binding::Message::TYPE_DICT_ENTRY,
+);
+
+
+our $VERSION = '0.0.1';
+
+sub new {
+ my $class = shift;
+ my $self = {};
+ my %params = @_;
+
+ bless $self, $class;
+
+ if (defined $params{xml}) {
+ $self->_parse($params{xml});
+ } else {
+ $self->{name} = exists $params{name} ? $params{name} : die "name
parameter is required";
+ $self->{interfaces} = exists $params{interfaces} ? $params{interfaces}
: die "interfaces parameter is required";
+ $self->{children} = exists $params{children} ? $params{children} : [];
+ }
+
+ $self->{interfaces}->{"org.freedesktop.DBus.Introspectable"} = {
+ methods => {
+ "Introspect" => {
+ params => [],
+ returns => ["string"],
+ }
+ }
+ };
+
+ $self->{methods} = {};
+ $self->{signals} = {};
+ foreach my $name (keys %{$self->{interfaces}}) {
+ my $interface = $self->{interfaces}->{$name};
+ foreach my $method (keys %{$interface->{methods}}) {
+ $self->{methods}->{$method} = $interface->{methods}->{$method};
+ }
+ foreach my $signal (keys %{$interface->{signals}}) {
+ $self->{signals}->{$signal} = $interface->{signals}->{$signal};
+ }
+ }
+
+ return $self;
+}
+
+sub _parse {
+ my $self = shift;
+ my $xml = shift;
+
+ my $grove_builder = XML::Grove::Builder->new;
+ my $parser = XML::Parser::PerlSAX->new(Handler => $grove_builder);
+ my $document = $parser->parse ( Source => { String => $xml } );
+
+ my $root = $document->{Contents}->[0];
+
+ $self->{name} = $root->{Attributes}->{name};
+ $self->{interfaces} = {};
+ foreach my $child (@{$root->{Contents}}) {
+ if (ref($child) eq "XML::Grove::Element" &&
+ $child->{Name} eq "interface") {
+ $self->_parse_interface($child);
+ }
+ }
+}
+
+sub _parse_interface {
+ my $self = shift;
+ my $node = shift;
+
+ my $name = $node->{Attributes}->{name};
+ $self->{interfaces}->{$name} = {
+ methods => {},
+ signals => {},
+ };
+
+ foreach my $child (@{$node->{Contents}}) {
+ if (ref($child) eq "XML::Grove::Element" &&
+ $child->{Name} eq "method") {
+ $self->_parse_method($child, $name);
+ } elsif (ref($child) eq "XML::Grove::Element" &&
+ $child->{Name} eq "signal") {
+ $self->_parse_signal($child, $name);
+ }
+ }
+}
+
+sub _parse_method {
+ my $self = shift;
+ my $node = shift;
+ my $interface = shift;
+
+ my $name = $node->{Attributes}->{name};
+ my @params;
+ my @returns;
+ foreach my $child (@{$node->{Contents}}) {
+ if (ref($child) eq "XML::Grove::Element" &&
+ $child->{Name} eq "arg") {
+ my $type = $child->{Attributes}->{type};
+ my $direction = $child->{Attributes}->{direction};
+
+ if (exists $compound_type_map{lc $type}) {
+ my @subtype = $self->_parse_type($child);
+ if ($direction eq "in") {
+ push @params, [lc $type, \@subtype];
+ } elsif ($direction eq "out") {
+ push @returns, [lc $type, \@subtype];
+ }
+ } elsif (exists $simple_type_map{lc $type}) {
+ if ($direction eq "in") {
+ push @params, lc $type;
+ } elsif ($direction eq "out") {
+ push @returns, lc $type;
+ }
+ }
+ }
+ }
+
+ $self->{interfaces}->{$interface}->{methods}->{$name} = {
+ params => \@params,
+ returns => \@returns,
+ }
+}
+
+sub _parse_type {
+ my $self = shift;
+ my $node = shift;
+
+
+ my @types;
+ foreach my $child (@{$node->{Contents}}) {
+ if (ref($child) eq "XML::Grove::Element" &&
+ $child->{Name} eq "type") {
+ my $name = $child->{Attributes}->{name};
+
+ if (exists $compound_type_map{lc $name}) {
+ my @subtype = $self->_parse_type($child);
+ push @types, [lc $name, \@subtype];
+ } elsif (exists $simple_type_map{lc $name}) {
+ push @types, lc $name;
+ }
+ }
+ }
+
+ return @types;
+}
+
+sub _parse_signal {
+ my $self = shift;
+ my $node = shift;
+ my $interface = shift;
+
+ my $name = $node->{Attributes}->{name};
+ my @params;
+ foreach my $child (@{$node->{Contents}}) {
+ if (ref($child) eq "XML::Grove::Element" &&
+ $child->{Name} eq "arg") {
+ my $type = $child->{Attributes}->{type};
+
+ if (exists $compound_type_map{lc $type}) {
+ my @subtype = $self->_parse_type($child);
+ push @params, [lc $type, \@subtype];
+ } elsif (exists $simple_type_map{lc $type}) {
+ push @params, lc $type;
+ }
+ }
+ }
+
+ $self->{interfaces}->{$interface}->{signals}->{$name} =
+ \@params;
+}
+
+sub format {
+ my $self = shift;
+
+ my $xml = '<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object
Introspection 1.0//EN"' . "\n";
+ $xml .= '"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd";>'
. "\n";
+
+ return $xml . $self->to_xml("");
+}
+
+sub to_xml {
+ my $self = shift;
+ my $indent = shift;
+
+ my $xml = '';
+ $xml .= $indent . '<node name="' . $self->{name} . '">' . "\n";
+
+ foreach my $name (keys %{$self->{interfaces}}) {
+ my $interface = $self->{interfaces}->{$name};
+ $xml .= $indent . ' <interface name="' . $name . '">' . "\n";
+ foreach my $mname (keys %{$interface->{methods}}) {
+ my $method = $interface->{methods}->{$mname};
+ $xml .= $indent . ' <method name="' . $mname . '">' . "\n";
+
+ foreach my $type (@{$method->{params}}) {
+ if (ref($type) eq "ARRAY") {
+ $xml .= $indent . ' <arg type="' . $type->[0] . '"
direction="in">' . "\n";
+ $xml .= $self->to_xml_type($type->[1], $indent . ' ');
+ $xml .= $indent . ' </arg>' . "\n";
+ } else {
+ $xml .= $indent . ' <arg type="' . $type . '"
direction="in"/>' . "\n";
+ }
+ }
+
+ foreach my $type (@{$method->{returns}}) {
+ if (ref($type) eq "ARRAY") {
+ $xml .= $indent . ' <arg type="' . $type->[0] . '"
direction="out">' . "\n";
+ $xml .= $self->to_xml_type($type->[1], $indent . ' ');
+ $xml .= $indent . ' </arg>' . "\n";
+ } else {
+ $xml .= $indent . ' <arg type="' . $type . '"
direction="out"/>' . "\n";
+ }
+ }
+
+
+ $xml .= $indent . ' </method>' . "\n";
+ }
+ foreach my $sname (keys %{$interface->{signals}}) {
+ my $signal = $interface->{signals}->{$sname};
+ $xml .= $indent . ' <signal name="' . $sname . '">' . "\n";
+
+ foreach my $type (@{$signal}) {
+ if (ref($type) eq "ARRAY") {
+ $xml .= $indent . ' <arg type="' . $type->[0] . '">' .
"\n";
+ $xml .= $self->to_xml_type($type->[1], $indent . ' ');
+ $xml .= $indent . ' </arg>' . "\n";
+ } else {
+ $xml .= $indent . ' <arg type="' . $type . '"/>' .
"\n";
+ }
+ }
+ $xml .= $indent . ' </signal>' . "\n";
+ }
+
+ $xml .= $indent . ' </interface>' . "\n";
+ }
+
+ foreach my $child (@{$self->{children}}) {
+ if (ref($child) eq "Net::DBus::Introspector") {
+ $xml .= $child->to_xml($indent . " ") . "\n";
+ } else {
+ $xml .= $indent . ' <node name="' . $child . '"/>' . "\n";
+ }
+ }
+ $xml .= $indent . "</node>";
+}
+
+
+sub to_xml_type {
+ my $self = shift;
+ my $type = shift;
+ my $indent = shift;
+ my $xml = '';
+ foreach my $subtype (@{$type}) {
+ if (ref($subtype) eq "ARRAY") {
+ $xml .= $indent . ' <type name="' . $subtype->[0] . '">' .
"\n";
+ $xml .= $self->to_xml_type($subtype->[1], $indent . ' ');
+ $xml .= $indent . ' </type>' . "\n";
+ } else {
+ $xml .= $indent . ' <type name="' . $subtype . '"/>' . "\n";
+ }
+ }
+ return $xml;
+}
+
+sub encode {
+ my $self = shift;
+ my $message = shift;
+ my $type = shift;
+ my $name = shift;
+ my $direction = shift;
+ my @args = @_;
+
+ die "no introspection data for such $name ($type)" unless exists
$self->{$type}->{$name};
+
+ my @types = $type eq "signals" ?
+ @{$self->{$type}->{$name}} :
+ @{$self->{$type}->{$name}->{$direction}};
+
+ die "expected " . int(@types) . " params, but got " . int(@args)
+ unless $#types == $#args;
+
+ my $iter = $message->iterator(1);
+ foreach my $t ($self->convert(@types)) {
+ $iter->append(shift @args, $t);
+ }
+}
+
+
+sub convert {
+ my $self = shift;
+ my @in = @_;
+
+ my @out;
+ foreach my $in (@in) {
+ if (ref($in) eq "ARRAY") {
+ my @subout = $self->convert(@{$in->[1]});
+ die "unknown compound type " . $in->[0] unless
+ exists $compound_type_map{lc $in->[0]};
+ push @out, [$compound_type_map{lc $in->[0]}, \@subout];
+ } else {
+ die "unknown simple type " . $in unless
+ exists $simple_type_map{lc $in};
+ push @out, $simple_type_map{lc $in};
+ }
+ }
+ return @out;
+}
+
+sub decode {
+ my $self = shift;
+ my $message = shift;
+ my $type = shift;
+ my $name = shift;
+ my $direction = shift;
+ my @args = @_;
+
+ die "no introspection data for such $name ($type)" unless exists
$self->{$type}->{$name};
+
+ my @type = $type eq "signal" ?
+ @{$self->{$type}->{$name}} :
+ @{$self->{$type}->{$name}->{$direction}};
+
+
+}
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 1ee77dc..07340af 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -8,6 +8,7 @@ use Carp;
our $VERSION = '0.0.1';
use Net::DBus::RemoteObject;
+use Net::DBus::Introspector;
use Net::DBus::Binding::Message::Error;
use Net::DBus::Binding::Message::MethodReturn;
@@ -16,10 +17,10 @@ sub new {
my $self = {};
$self->{object_path} = shift;
-
- my $methods = shift;
- $self->{methods} = {};
- map { $self->{methods}->{$_} = 1 } @{$methods};
+
+ my $interfaces = shift;
+ $self->{introspector} = Net::DBus::Introspector->new(name =>
$self->{object_path},
+ interfaces =>
$interfaces);
$self->{service} = shift;
@@ -35,18 +36,28 @@ sub new {
}
+sub Introspect {
+ my $self = shift;
+ #warn "Asked for introspection data\n";
+ my $xml = $self->{introspector}->format;
+ #warn $xml;
+ return $xml;
+}
+
+
sub emit_signal {
my $self = shift;
my $interface = shift;
my $signal_name = shift;
+ my @args = @_;
my $signal = Net::DBus::Binding::Message::Signal->new(object_path =>
$self->{object_path},
interface =>
$interface,
signal_name =>
$signal_name);
- my $iter = $signal->iterator(1);
- foreach my $ret (@_) {
- $iter->append($ret);
- }
+
+ $self->{introspector}->encode($signal, "signals", $signal_name, "params",
@args);
$self->{service}->get_bus()->get_connection()->send($signal);
+
+ return ();
}
sub _dispatch {
@@ -68,15 +79,8 @@ sub _dispatch {
description => $@);
} else {
$reply = Net::DBus::Binding::Message::MethodReturn->new(call =>
$message);
- if (@ret == 1) {
- my $iter = $reply->iterator(1);
- $iter->append(shift @ret);
- } elsif (@ret > 1) {
- my $iter = $reply->iterator(1);
- foreach my $ret (@ret) {
- $iter->append($ret);
- }
- }
+
+ $self->{introspector}->encode($reply, "methods", $method_name,
"returns", @ret);
}
} else {
$reply = Net::DBus::Binding::Message::Error->new(replyto => $message,
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index 78ffbca..811d3d1 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -9,6 +9,7 @@ our $VERSION = '0.0.1';
our $AUTOLOAD;
use Net::DBus::Binding::Message::MethodCall;
+use Net::DBus::Introspector;
sub new {
my $class = shift;
@@ -17,12 +18,34 @@ sub new {
$self->{service} = shift;
$self->{object_path} = shift;
$self->{interface} = shift;
-
+
bless $self, $class;
+ $self->{introspector} = @_ ? shift : $self->_introspect();
+
return $self;
}
+sub _introspect {
+ my $self = shift;
+
+ 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);
+
+ return Net::DBus::Introspector->new(xml => $xml);
+}
+
sub connect_to_signal {
my $self = shift;
my $signal_name = shift;
@@ -54,17 +77,15 @@ sub AUTOLOAD {
method_name => $method,
interface => $self->{interface});
- my $iter = $call->iterator(1);
- foreach my $arg (@_) {
- $iter->append($arg);
- }
-
+ $self->{introspector}->encode($call, "methods", $method, "params", @_);
+
my $reply = $self->{service}->
get_bus()->
get_connection()->
send_with_reply_and_block($call, 5000);
- my @reply = $reply->get_args_list;
+ my @reply = $reply->get_args_list();
+ #my @reply = $self->{introspector}->decode($reply, $method, "return");
return wantarray ? @reply : $reply[0];
}
diff --git a/t/40-introspector.t b/t/40-introspector.t
new file mode 100644
index 0000000..77512de
--- /dev/null
+++ b/t/40-introspector.t
@@ -0,0 +1,63 @@
+# -*- perl -*-
+use Test::More tests => 2;
+BEGIN {
+ use_ok('Net::DBus::Introspector');
+ };
+
+
+TEST_ONE: {
+ my $other_object = Net::DBus::Introspector->new(
+ name =>
"org.example.OtherObject",
+ interfaces => {
+
"org.example.SomeInterface" => {
+ methods => {
+ "hello" => {
+ params =>
["int32", "int32", ["struct", ["int32","byte"]]],
+ returns =>
["int32"],
+ },
+ "goodbye" => {
+ params =>
[["array", [["struct", ["int32", "string"]]]]],
+ returns =>
["string", "string"],
+ },
+ },
+ signals => {
+ "meltdown" =>
["int32", "byte"],
+ }
+ }
+ });
+ my $object = Net::DBus::Introspector->new(
+ name => "org.example.Object",
+ interfaces => {
+ "org.example.SomeInterface"
=> {
+ methods => {
+ "hello" => {
+ params =>
["int32", "int32", ["struct", ["int32","byte"]]],
+ returns =>
["int32"],
+ },
+ "goodbye" => {
+ params =>
[["array", [["struct", ["int32", "string"]]]]],
+ returns =>
["string", "string"],
+ },
+ },
+ signals => {
+ "meltdown" =>
["int32", "byte"],
+ },
+ },
+ "org.example.OtherInterface"
=> {
+ methods => {
+ "hitme" => {
+ params =>
["int32", "uint32"],
+ return => [],
+ }
+ }
+ },
+ },
+ children => [
+
"org.example.AnotherObject",
+ $other_object,
+ ]);
+
+ isa_ok($object, "Net::DBus::Introspector");
+
+ warn $object->format;
+}
--
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
