Current File : //lib/x86_64-linux-gnu/perl5/5.38/Net/DBus/Binding/Iterator.pm
# -*- 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 message
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);
} elsif ($type == &Net::DBus::Binding::Message::TYPE_UNIX_FD) {
$self->append_unix_fd($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
Mini Shell