/lib/Net/DBus/Binding/Iterator.pm
Perl | 729 lines | 481 code | 156 blank | 92 comment | 104 complexity | f05e6901cef8ce2134609156af391ca4 MD5 | raw file
Possible License(s): AGPL-1.0
- # -*- perl -*-
- #
- # Copyright (C) 2004-2011 Daniel P. Berrange
- #
- # This program is free software; You can redistribute it and/or modify
- # it under the same terms as Perl itself. Either:
- #
- # a) the GNU General Public License as published by the Free
- # Software Foundation; either version 2, or (at your option) any
- # later version,
- #
- # or
- #
- # b) the "Artistic License"
- #
- # The file "COPYING" distributed along with this file provides full
- # details of the terms and conditions of the two licenses.
- =pod
- =head1 NAME
- Net::DBus::Binding::Iterator - Reading and writing message parameters
- =head1 SYNOPSIS
- Creating a new message
- my $msg = new Net::DBus::Binding::Message::Signal;
- my $iterator = $msg->iterator;
- $iterator->append_boolean(1);
- $iterator->append_byte(123);
- Reading from a mesage
- my $msg = ...get it from somewhere...
- my $iter = $msg->iterator();
- my $i = 0;
- while ($iter->has_next()) {
- $iter->next();
- $i++;
- if ($i == 1) {
- my $val = $iter->get_boolean();
- } elsif ($i == 2) {
- my $val = $iter->get_byte();
- }
- }
- =head1 DESCRIPTION
- Provides an iterator for reading or writing message
- fields. This module provides a Perl API to access the
- dbus_message_iter_XXX methods in the C API. The array
- and dictionary types are not yet supported, and there
- are bugs in the Quad support (ie it always returns -1!).
- =head1 METHODS
- =over 4
- =cut
- package Net::DBus::Binding::Iterator;
- use 5.006;
- use strict;
- use warnings;
- use Net::DBus;
- =item $res = $iter->has_next()
- Determines if there are any more fields in the message
- itertor to be read. Returns a positive value if there
- are more fields, zero otherwise.
- =item $success = $iter->next()
- Skips the iterator onto the next field in the message.
- Returns a positive value if the current field pointer
- was successfully advanced, zero otherwise.
- =item my $val = $iter->get_boolean()
- =item $iter->append_boolean($val);
- Read or write a boolean value from/to the
- message iterator
- =item my $val = $iter->get_byte()
- =item $iter->append_byte($val);
- Read or write a single byte value from/to the
- message iterator.
- =item my $val = $iter->get_string()
- =item $iter->append_string($val);
- 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);
- Read or write a signed 16 bit value from/to the
- message iterator
- =item my $val = $iter->get_uint16()
- =item $iter->append_uint16($val);
- Read or write an unsigned 16 bit value from/to the
- message iterator
- =item my $val = $iter->get_int32()
- =item $iter->append_int32($val);
- Read or write a signed 32 bit value from/to the
- message iterator
- =item my $val = $iter->get_uint32()
- =item $iter->append_uint32($val);
- Read or write an unsigned 32 bit value from/to the
- message iterator
- =item my $val = $iter->get_int64()
- =item $iter->append_int64($val);
- Read or write a signed 64 bit value from/to the
- message iterator. An error will be raised if this
- build of Perl does not support 64 bit integers
- =item my $val = $iter->get_uint64()
- =item $iter->append_uint64($val);
- Read or write an unsigned 64 bit value from/to the
- message iterator. An error will be raised if this
- build of Perl does not support 64 bit integers
- =item my $val = $iter->get_double()
- =item $iter->append_double($val);
- Read or write a double precision floating point value
- from/to the message iterator
- =item my $val = $iter->get_unix_fd()
- =item $iter->append_unix_fd($val);
- Read or write a unix_fd value from/to the
- message iterator
- =cut
- sub get_int64 {
- my $self = shift;
- return $self->_get_int64;
- }
- sub get_uint64 {
- my $self = shift;
- return $self->_get_uint64;
- }
- sub append_int64 {
- my $self = shift;
- $self->_append_int64(shift);
- }
- sub append_uint64 {
- my $self = shift;
- $self->_append_uint64(shift);
- }
- =item my $value = $iter->get()
- =item my $value = $iter->get($type);
- Get the current value pointed to by this iterator. If the optional
- C<$type> parameter is supplied, the wire type will be compared with
- the desired type & a warning output if their differ. The C<$type>
- value must be one of the C<Net::DBus::Binding::Message::TYPE*>
- constants.
- =cut
- sub get {
- my $self = shift;
- my $type = shift;
- if (defined $type) {
- if (ref($type)) {
- if (ref($type) eq "ARRAY") {
- # XXX we should recursively validate types
- $type = $type->[0];
- if ($type eq &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
- $type = &Net::DBus::Binding::Message::TYPE_ARRAY;
- }
- } else {
- die "unsupport type reference $type";
- }
- }
- my $actual = $self->get_arg_type;
- if ($actual != $type) {
- # "Be strict in what you send, be leniant in what you accept"
- # - ie can't rely on python to send correct types, eg int32 vs uint32
- # But, don't complain for variants because a number of apps (eg HAL)
- # claim to return variants, but in fact don't correctly encode their
- # data as variants. Technically a bug in the server, but it does
- # 'just work' normally.
- warn "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)"
- if $type != &Net::DBus::Binding::Message::TYPE_VARIANT;
- $type = $actual;
- }
- } else {
- $type = $self->get_arg_type;
- }
- if ($type == &Net::DBus::Binding::Message::TYPE_STRING) {
- return $self->get_string;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) {
- return $self->get_boolean;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) {
- return $self->get_byte;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) {
- return $self->get_int16;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) {
- return $self->get_uint16;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) {
- return $self->get_int32;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) {
- return $self->get_uint32;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) {
- return $self->get_int64;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) {
- return $self->get_uint64;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) {
- return $self->get_double;
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_ARRAY) {
- my $array_type = $self->get_element_type();
- if ($array_type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
- return $self->get_dict();
- } else {
- return $self->get_array($array_type);
- }
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRUCT) {
- return $self->get_struct();
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_VARIANT) {
- return $self->get_variant();
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
- die "dictionary can only occur as part of an array type";
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_INVALID) {
- die "cannot handle Net::DBus::Binding::Message::TYPE_INVALID";
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
- return $self->get_object_path();
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) {
- return $self->get_signature();
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_UNIX_FD) {
- return $self->get_unix_fd();
- } else {
- die "unknown argument type '" . chr($type) . "' ($type)";
- }
- }
- =item my $hashref = $iter->get_dict()
- If the iterator currently points to a dictionary value, unmarshalls
- and returns the value as a hash reference.
- =cut
- sub get_dict {
- my $self = shift;
- my $iter = $self->_recurse();
- my $type = $iter->get_arg_type();
- my $dict = {};
- while ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
- my $entry = $iter->get_struct();
- if ($#{$entry} != 1) {
- die "Dictionary entries must be structs of 2 elements. This entry has " . ($#{$entry}+1) ." elements";
- }
-
- $dict->{$entry->[0]} = $entry->[1];
- $iter->next();
- $type = $iter->get_arg_type();
- }
- return $dict;
- }
- =item my $hashref = $iter->get_array()
- If the iterator currently points to an array value, unmarshalls
- and returns the value as a array reference.
- =cut
- sub get_array {
- my $self = shift;
- my $array_type = shift;
- my $iter = $self->_recurse();
- my $type = $iter->get_arg_type();
- my $array = [];
- while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) {
- if ($type != $array_type) {
- die "Element $type not of array type $array_type";
- }
- my $value = $iter->get($type);
- push @{$array}, $value;
- $iter->next();
- $type = $iter->get_arg_type();
- }
- return $array;
- }
- =item my $hashref = $iter->get_variant()
- If the iterator currently points to a variant value, unmarshalls
- and returns the value contained in the variant.
- =cut
- sub get_variant {
- my $self = shift;
- my $iter = $self->_recurse();
- return $iter->get();
- }
- =item my $hashref = $iter->get_struct()
- If the iterator currently points to an struct value, unmarshalls
- and returns the value as a array reference. The values in the array
- correspond to members of the struct.
- =cut
- sub get_struct {
- my $self = shift;
- my $iter = $self->_recurse();
- my $type = $iter->get_arg_type();
- my $struct = [];
- while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) {
- my $value = $iter->get($type);
- push @{$struct}, $value;
- $iter->next();
- $type = $iter->get_arg_type();
- }
- return $struct;
- }
- =item $iter->append($value)
- =item $iter->append($value, $type)
- Appends a value to the message associated with this iterator. The
- value is marshalled into wire format, according to the following
- rules.
- If the C<$value> is an instance of L<Net::DBus::Binding::Value>,
- the embedded data type is used.
- If the C<$type> parameter is supplied, that is taken to represent
- the data type. The type must be one of the C<Net::DBus::Binding::Message::TYPE_*>
- constants.
- Otherwise, the data type is chosen to be a string, dict or array
- according to the perl data types SCALAR, HASH or ARRAY.
- =cut
- sub append {
- my $self = shift;
- my $value = shift;
- my $type = shift;
- if (ref($value) eq "Net::DBus::Binding::Value" &&
- ((! defined ref($type)) ||
- (ref($type) ne "ARRAY") ||
- $type->[0] != &Net::DBus::Binding::Message::TYPE_VARIANT)) {
- $type = $value->type;
- $value = $value->value;
- }
- if (!defined $type) {
- $type = $self->guess_type($value);
- }
- 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 {
- die "Unsupported compound type ", $maintype, " ('", chr($maintype), "')";
- }
- } else {
- # XXX is this good idea or not
- $value = '' unless defined $value;
- if ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) {
- $self->append_boolean($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) {
- $self->append_byte($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRING) {
- $self->append_string($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) {
- $self->append_int16($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) {
- $self->append_uint16($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) {
- $self->append_int32($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) {
- $self->append_uint32($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) {
- $self->append_int64($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) {
- $self->append_uint64($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) {
- $self->append_double($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
- $self->append_object_path($value);
- } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) {
- $self->append_signature($value);
- } else {
- die "Unsupported scalar type ", $type, " ('", chr($type), "')";
- }
- }
- }
- =item my $type = $iter->guess_type($value)
- Make a best guess at the on the wire data type to use for
- marshalling C<$value>. If the value is a hash reference,
- the dictionary type is returned; if the value is an array
- reference the array type is returned; otherwise the string
- type is returned.
- =cut
- sub guess_type {
- my $self = shift;
- my $value = shift;
- if (ref($value)) {
- 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((keys(%{ $value->value }))[0]),
- $self->guess_type((values(%{ $value->value }))[0]) ];
- } 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]} ];
- } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) {
- $subtype = $self->guess_type($value->value);
- } 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
- return [ &Net::DBus::Binding::Message::TYPE_DICT_ENTRY,
- [ &Net::DBus::Binding::Message::TYPE_STRING, $self->guess_type($val)] ];
- } elsif (ref($value) eq "ARRAY") {
- return [ &Net::DBus::Binding::Message::TYPE_ARRAY,
- [$self->guess_type($value->[0])] ];
- } else {
- die "cannot marshall reference of type " . ref($value);
- }
- } else {
- # XXX Should we bother trying to guess integer & floating point types ?
- # I say sod it, because strongly typed languages will support introspection
- # and loosely typed languages won't care about the difference
- return &Net::DBus::Binding::Message::TYPE_STRING;
- }
- }
- =item my $sig = $iter->format_signature($type)
- Given a data type representation, construct a corresponding
- signature string
- =cut
- sub format_signature {
- my $self = shift;
- my $type = shift;
- my ($sig, $t, $i);
- $sig = "";
- $i = 0;
- if (ref($type) eq "ARRAY") {
- while ($i <= $#{$type}) {
- $t = $$type[$i];
-
- if (ref($t) eq "ARRAY") {
- $sig .= $self->format_signature($t);
- } elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
- $sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY);
- $sig .= "{" . $self->format_signature($$type[++$i]) . "}";
- } elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) {
- $sig .= "(" . $self->format_signature($$type[++$i]) . ")";
- } else {
- $sig .= chr($t);
-
- if ($t == &Net::DBus::Binding::Message::TYPE_VARIANT)
- {
- last;
- }
- }
-
- $i++;
- }
- } else {
- $sig .= chr ($type);
- }
- return $sig;
- }
- =item $iter->append_array($value, $type)
- Append an array of values to the message. The C<$value> parameter
- must be an array reference, whose elements all have the same data
- type specified by the C<$type> parameter.
- =cut
- 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->format_signature($type);
- my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
- foreach my $value (@{$array}) {
- $iter->append($value, $type->[0]);
- }
- $self->_close_container($iter);
- }
- =item $iter->append_struct($value, $type)
- Append a struct to the message. The C<$value> parameter
- must be an array reference, whose elements correspond to
- members of the structure. The C<$type> parameter encodes
- the type of each member of the struct.
- =cut
- sub append_struct {
- my $self = shift;
- my $struct = shift;
- my $type = shift;
- 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 = defined $type ? @{$type} : ();
- foreach my $value (@{$struct}) {
- $iter->append($value, shift @type);
- }
- $self->_close_container($iter);
- }
- =item $iter->append_dict($value, $type)
- Append a dictionary to the message. The C<$value> parameter
- must be an hash reference.The C<$type> parameter encodes
- the type of the key and value of the hash.
- =cut
- sub append_dict {
- my $self = shift;
- my $hash = shift;
- my $type = shift;
- my $sig;
- $sig = "{";
- $sig .= $self->format_signature($type);
- $sig .= "}";
- my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
- foreach my $key (keys %{$hash}) {
- my $value = $hash->{$key};
- my $entry = $iter->_open_container(&Net::DBus::Binding::Message::TYPE_DICT_ENTRY, "");
- $entry->append($key, $type->[0]);
- $entry->append($value, $type->[1]);
- $iter->_close_container($entry);
- }
- $self->_close_container($iter);
- }
- =item $iter->append_variant($value)
- Append a value to the message, encoded as a variant type. The
- C<$value> can be of any type, however, the variant will be
- encoded as either a string, dictionary or array according to
- the rules of the C<guess_type> method.
- =cut
- sub append_variant {
- my $self = shift;
- my $value = shift;
- 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->[0]);
- $self->_close_container($iter);
- }
- =item my $type = $iter->get_arg_type
- Retrieves the type code of the value pointing to by this iterator.
- The returned code will correspond to one of the constants
- C<Net::DBus::Binding::Message::TYPE_*>
- =item my $type = $iter->get_element_type
- If the iterator points to an array, retrieves the type code of
- array elements. The returned code will correspond to one of the
- constants C<Net::DBus::Binding::Message::TYPE_*>
- =cut
- 1;
- =pod
- =back
- =head1 AUTHOR
- Daniel P. Berrange
- =head1 COPYRIGHT
- Copyright (C) 2004-2011 Daniel P. Berrange
- =head1 SEE ALSO
- L<Net::DBus::Binding::Message>
- =cut