[libnet-dbus-perl] 190/335: Added binding for signature & object paths and changed way (get|set)_no_reply is done
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:53 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 8b638e878b661f2394a546ab33259b49e6453316
Author: Daniel P. Berrange <berrange at redhat.com>
Date: Thu Apr 13 11:06:53 2006 -0400
Added binding for signature & object paths and changed way (get|set)_no_reply is done
---
DBus.xs | 51 ++++++++++++++---
lib/Net/DBus.pm | 51 +++++++++++++++--
lib/Net/DBus/Binding/Introspector.pm | 18 ++++--
lib/Net/DBus/Binding/Iterator.pm | 104 ++++++++++++++++++++++++++---------
lib/Net/DBus/Binding/Message.pm | 48 +++++++++++-----
lib/Net/DBus/Object.pm | 4 +-
6 files changed, 215 insertions(+), 61 deletions(-)
diff --git a/DBus.xs b/DBus.xs
index 79d31cb..053da4d 100644
--- a/DBus.xs
+++ b/DBus.xs
@@ -787,14 +787,6 @@ _create(type)
OUTPUT:
RETVAL
-void
-set_no_reply(msg, status)
- DBusMessage *msg;
- dbus_bool_t status;
- CODE:
- dbus_message_set_no_reply(msg, status);
-
-
DBusMessageIter *
_iterator_append(msg)
@@ -829,6 +821,15 @@ DESTROY(msg)
PD_DEBUG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : "");
dbus_message_unref(msg);
+dbus_bool_t
+dbus_message_get_no_reply(msg)
+ DBusMessage *msg;
+
+void
+dbus_message_set_no_reply(msg,flag)
+ DBusMessage *msg;
+ dbus_bool_t flag;
+
int
dbus_message_get_type(msg)
DBusMessage *msg;
@@ -1210,6 +1211,22 @@ get_string(iter)
OUTPUT:
RETVAL
+char *
+get_signature(iter)
+ DBusMessageIter *iter;
+ CODE:
+ dbus_message_iter_get_basic(iter, &RETVAL);
+ OUTPUT:
+ RETVAL
+
+char *
+get_object_path(iter)
+ DBusMessageIter *iter;
+ CODE:
+ dbus_message_iter_get_basic(iter, &RETVAL);
+ OUTPUT:
+ RETVAL
+
void
append_boolean(iter, val)
@@ -1301,6 +1318,24 @@ append_string(iter, val)
croak("cannot append string");
}
+void
+append_object_path(iter, val)
+ DBusMessageIter *iter;
+ char *val;
+ CODE:
+ if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_OBJECT_PATH, &val)) {
+ croak("cannot append object path");
+ }
+
+void
+append_signature(iter, val)
+ DBusMessageIter *iter;
+ char *val;
+ CODE:
+ if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_SIGNATURE, &val)) {
+ croak("cannot append signature");
+ }
+
void
diff --git a/lib/Net/DBus.pm b/lib/Net/DBus.pm
index 509a944..dd579e4 100644
--- a/lib/Net/DBus.pm
+++ b/lib/Net/DBus.pm
@@ -22,7 +22,7 @@
=head1 NAME
-DBus - Perl extension for the DBus message system
+Net::DBus - Perl extension for the DBus message system
=head1 SYNOPSIS
@@ -111,11 +111,13 @@ use vars qw(@EXPORT_OK %EXPORT_TAGS);
@EXPORT_OK = qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64
dbus_byte dbus_boolean dbus_string dbus_double
- dbus_struct dbus_array dbus_dict);
+ dbus_object_path dbus_signature
+ dbus_struct dbus_array dbus_dict dbus_variant);
%EXPORT_TAGS = (typing => [qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64
dbus_byte dbus_boolean dbus_string dbus_double
- dbus_struct dbus_array dbus_dict)]);
+ dbus_object_path dbus_signature
+ dbus_struct dbus_array dbus_dict dbus_variant)]);
=item my $bus = Net::DBus->find(%params);
@@ -633,6 +635,32 @@ sub dbus_string {
$_[0]);
}
+=item $typed_value = dbus_signature($value);
+
+Mark a value as being a UTF-8 string, whose contents is a valid
+type signature
+
+=cut
+
+
+
+sub dbus_signature {
+ return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_SIGNATURE,
+ $_[0]);
+}
+
+=item $typed_value = dbus_object_path($value);
+
+Mark a value as being a UTF-8 string, whose contents is a valid
+object path.
+
+=cut
+
+sub dbus_object_path {
+ return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
+ $_[0]);
+}
+
=item $typed_value = dbus_boolean($value);
Mark a value as being an boolean
@@ -654,7 +682,7 @@ Mark a value as being an array
sub dbus_array {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_ARRAY,
+ return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_ARRAY],
$_[0]);
}
@@ -666,7 +694,7 @@ Mark a value as being a structure
sub dbus_struct {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_STRUCT,
+ return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_STRUCT],
$_[0]);
}
@@ -677,7 +705,18 @@ Mark a value as being a dictionary
=cut
sub dbus_dict{
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_DICT_ENTRY,
+ return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_DICT_ENTRY],
+ $_[0]);
+}
+
+=item $typed_value = dbus_variant($value);
+
+Mark a value as being a variant
+
+=cut
+
+sub dbus_variant{
+ return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_VARIANT],
$_[0]);
}
diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
index d1085a8..d715d6a 100644
--- a/lib/Net/DBus/Binding/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -59,7 +59,6 @@ use Carp;
use XML::Grove::Builder;
use XML::Parser::PerlSAX;
-use Net::DBus;
use Net::DBus::Binding::Message;
our %simple_type_map = (
@@ -73,8 +72,8 @@ our %simple_type_map = (
"uint32" => &Net::DBus::Binding::Message::TYPE_UINT32,
"int64" => &Net::DBus::Binding::Message::TYPE_INT64,
"uint64" => &Net::DBus::Binding::Message::TYPE_UINT64,
- "object" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
- "variant" => &Net::DBus::Binding::Message::TYPE_VARIANT,
+ "objectpath" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
+ "signature" => &Net::DBus::Binding::Message::TYPE_SIGNATURE,
);
our %simple_type_rev_map = (
@@ -88,8 +87,8 @@ our %simple_type_rev_map = (
&Net::DBus::Binding::Message::TYPE_UINT32 => "uint32",
&Net::DBus::Binding::Message::TYPE_INT64 => "int64",
&Net::DBus::Binding::Message::TYPE_UINT64 => "uint64",
- &Net::DBus::Binding::Message::TYPE_OBJECT_PATH => "object",
- &Net::DBus::Binding::Message::TYPE_VARIANT => "variant",
+ &Net::DBus::Binding::Message::TYPE_OBJECT_PATH => "objectpath",
+ &Net::DBus::Binding::Message::TYPE_SIGNATURE => "signature",
);
our %magic_type_map = (
@@ -109,6 +108,7 @@ 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,
+ "variant" => &Net::DBus::Binding::Message::TYPE_VARIANT,
);
=item my $ins = Net::DBus::Binding::Introspector->new(object_path => $object_path,
@@ -915,6 +915,11 @@ sub to_xml_type {
$sig .= $self->to_xml_type($type->[1]);
$sig .= $self->to_xml_type($type->[2]);
$sig .= "}";
+ } elsif ($type->[0] eq "variant") {
+ if ($#{$type} != 0) {
+ die "dict spec must contain no sub-types";
+ }
+ $sig .= chr($compound_type_map{"variant"});
} else {
die "unknown/unsupported compound type " . $type->[0] . " expecting 'array', 'struct', or 'dict'";
}
@@ -978,7 +983,7 @@ sub encode {
die "expected " . int(@types) . " $direction, but got " . int(@args)
unless $#types == $#args;
-
+
my $iter = $message->iterator(1);
foreach my $t ($self->_convert(@types)) {
$iter->append(shift @args, $t);
@@ -998,6 +1003,7 @@ sub _convert {
my @subout = $self->_convert(@subtype);
die "unknown compound type " . $in->[0] unless
exists $compound_type_map{lc $in->[0]};
+
push @out, [$compound_type_map{lc $in->[0]}, \@subout];
} elsif (exists $magic_type_map{lc $in}) {
push @out, $magic_type_map{lc $in};
diff --git a/lib/Net/DBus/Binding/Iterator.pm b/lib/Net/DBus/Binding/Iterator.pm
index 9f53dcc..925e806 100644
--- a/lib/Net/DBus/Binding/Iterator.pm
+++ b/lib/Net/DBus/Binding/Iterator.pm
@@ -119,6 +119,20 @@ message iterator.
Read or write a UTF-8 string value from/to the
message iterator
+=item my $val = $iter->get_object_path()
+
+=item $iter->append_object_path($val);
+
+Read or write a UTF-8 string value, whose contents is
+a valid object path, from/to the message iterator
+
+=item my $val = $iter->get_signature()
+
+=item $iter->append_signature($val);
+
+Read or write a UTF-8 string, whose contents is a
+valid type signature, value from/to the message iterator
+
=item my $val = $iter->get_int16()
=item $iter->append_int16($val);
@@ -275,9 +289,9 @@ sub get {
} elsif ($type == &Net::DBus::Binding::Message::TYPE_INVALID) {
confess "cannot handle Net::DBus::Binding::Message::TYPE_INVALID";
} elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
- return $self->get_string();
+ return $self->get_object_path();
} elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) {
- return $self->get_string();
+ return $self->get_signature();
} else {
confess "unknown argument type '" . chr($type) . "' ($type)";
}
@@ -398,7 +412,7 @@ sub append {
my $self = shift;
my $value = shift;
my $type = shift;
-
+
if (ref($value) eq "Net::DBus::Binding::Value") {
$type = $value->type;
$value = $value->value;
@@ -411,17 +425,19 @@ sub append {
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);
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) {
+ $self->append_variant($value, $subtype);
} else {
- confess "Unsupported compound type ", $maintype;
+ confess "Unsupported compound type ", $maintype, " ('", chr($maintype), "')";
}
- } else {
+ } else {
# XXX is this good idea or not
$value = '' unless defined $value;
@@ -446,11 +462,11 @@ sub append {
} elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) {
$self->append_double($value);
} elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
- $self->append_string($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_VARIANT) {
- $self->append_variant($value);
+ $self->append_object_path($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) {
+ $self->append_signature($value);
} else {
- confess "Unsupported scalar type ", $type;
+ confess "Unsupported scalar type ", $type, " ('", chr($type), "')";
}
}
}
@@ -469,9 +485,31 @@ type is returned.
sub guess_type {
my $self = shift;
my $value = shift;
-
+
if (ref($value)) {
- if (ref($value) eq "HASH") {
+ if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) {
+ my $type = $value->type;
+ if (ref($type) && ref($type) eq "ARRAY") {
+ my $maintype = $type->[0];
+ my $subtype = $type->[1];
+
+ if (!defined $subtype) {
+ if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ $subtype = [ $self->guess_type(($value->value())[0]->[0]),
+ $self->guess_type(($value->value())[0]->[1]) ];
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) {
+ $subtype = [ $self->guess_type(($value->value())[0]->[0]) ];
+ } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) {
+ $subtype = [ map { $self->guess_type($_) } @{($value->value())[0]} ];
+ } else {
+ die "Unguessable compound type '$maintype' ('", chr($maintype), "')\n";
+ }
+ }
+ return [$maintype, $subtype];
+ } else {
+ return $type;
+ }
+ } elsif (ref($value) eq "HASH") {
my $key = (keys %{$value})[0];
my $val = $value->{$key};
# XXX Basically impossible to decide between DICT & STRUCT
@@ -491,32 +529,32 @@ sub guess_type {
}
}
-=item my $sig = $iter->get_signature($type)
+=item my $sig = $iter->format_signature($type)
Given a data type representation, construct a corresponding
signature string
=cut
-sub get_signature {
+sub format_signature {
my $self = shift;
my $type = shift;
my ($sig, $t, $i);
$sig = "";
- $i = 0;
+ $i = 0;use Data::Dumper;
if (ref($type) eq "ARRAY") {
while ($i <= $#{$type}) {
$t = $$type[$i];
if (ref($t) eq "ARRAY") {
- $sig .= $self->get_signature($t);
+ $sig .= $self->format_signature($t);
} elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
$sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY);
- $sig .= "{" . $self->get_signature($$type[++$i]) . "}";
+ $sig .= "{" . $self->format_signature($$type[++$i]) . "}";
} elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) {
- $sig .= "(" . $self->get_signature($$type[++$i]) . ")";
+ $sig .= "(" . $self->format_signature($$type[++$i]) . ")";
} else {
$sig .= chr($t);
}
@@ -542,11 +580,15 @@ sub append_array {
my $self = shift;
my $array = shift;
my $type = shift;
+
+ if (!defined($type)) {
+ $type = [$self->guess_type($array->[0])];
+ }
die "array must only have one type"
if $#{$type} > 0;
- my $sig = $self->get_signature($type);
+ my $sig = $self->format_signature($type);
my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
foreach my $value (@{$array}) {
@@ -571,13 +613,14 @@ sub append_struct {
my $struct = shift;
my $type = shift;
- if ($#{$struct} != $#{$type}) {
+ if (defined($type) &&
+ $#{$struct} != $#{$type}) {
die "number of values does not match type";
}
my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_STRUCT, "");
- my @type = @{$type};
+ my @type = defined $type ? @{$type} : ();
foreach my $value (@{$struct}) {
$iter->append($value, shift @type);
}
@@ -601,7 +644,7 @@ sub append_dict {
my $sig;
$sig = "{";
- $sig .= $self->get_signature($type);
+ $sig .= $self->format_signature($type);
$sig .= "}";
my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
@@ -629,11 +672,20 @@ the rules of the C<guess_type> method.
sub append_variant {
my $self = shift;
my $value = shift;
-
- my $type = $self->guess_type($value);
- my $sig = $self->get_signature($type);
+ my $type = shift;
+
+ if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) {
+ $type = [$self->guess_type($value)];
+ $value = $value->value;
+ } elsif (!defined $type || !defined $type->[0]) {
+ $type = [$self->guess_type($value)];
+ }
+ die "variant must only have one type"
+ if defined $type && $#{$type} > 0;
+
+ my $sig = $self->format_signature($type->[0]);
my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_VARIANT, $sig);
- $iter->append($value, $type);
+ $iter->append($value, $type->[0]);
$self->_close_container($iter);
}
diff --git a/lib/Net/DBus/Binding/Message.pm b/lib/Net/DBus/Binding/Message.pm
index c1a1355..0ecbdab 100644
--- a/lib/Net/DBus/Binding/Message.pm
+++ b/lib/Net/DBus/Binding/Message.pm
@@ -103,6 +103,11 @@ object path data type.
Constant representing the signature value associated with the
UTF-8 string data type.
+=item TYPE_SIGNATURE
+
+Constant representing the signature value associated with the
+signature data type.
+
=item TYPE_STRUCT
Constant representing the signature value associated with the
@@ -143,7 +148,6 @@ use strict;
use warnings;
use Carp;
-use Net::DBus;
use Net::DBus::Binding::Iterator;
use Net::DBus::Binding::Message::Signal;
use Net::DBus::Binding::Message::MethodCall;
@@ -344,6 +348,36 @@ sub iterator {
}
}
+=item $boolean = $msg->get_no_reply()
+
+Gets the flag indicating whether the message is expecting
+a reply to be sent.
+
+=cut
+
+sub get_no_reply {
+ my $self = shift;
+
+ return $self->{message}->dbus_message_get_no_reply;
+}
+
+=item $msg->set_no_reply($boolean)
+
+Toggles the flag indicating whether the message is expecting
+a reply to be sent. All method call messages expect a reply
+by default. By toggling this flag the communication latency
+is reduced by removing the need for the client to wait
+
+=cut
+
+
+sub set_no_reply {
+ my $self = shift;
+ my $flag = shift;
+
+ $self->{message}->dbus_message_set_no_reply($flag);
+}
+
=item my @values = $msg->get_args_list
De-marshall all the values in the body of the message, using the
@@ -385,18 +419,6 @@ sub append_args_list {
}
}
-
-# The following methods documented, are in the XS module
-
-=item $msg->set_no_reply($boolean)
-
-Toggles the flag indicating whether the message is expecting
-a reply to be sent. All method call messages expect a reply
-by default. By toggling this flag the communication latency
-is reduced by removing the need for the client to wait
-
-=cut
-
# To keep autoloader quiet
sub DESTROY {
}
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index de3a315..0af5e01 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -135,8 +135,8 @@ use Net::DBus::Binding::Message::MethodReturn;
dbus_method("Introspect", [], ["string"]);
-dbus_method("Get", ["string", "string"], ["variant"], "org.freedesktop.DBus.Properties");
-dbus_method("Set", ["string", "string", "variant"], [], "org.freedesktop.DBus.Properties");
+dbus_method("Get", ["string", "string"], [["variant"]], "org.freedesktop.DBus.Properties");
+dbus_method("Set", ["string", "string", ["variant"]], [], "org.freedesktop.DBus.Properties");
=item my $object = Net::DBus::Object->new($service, $path)
--
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