Net::DBus::Binding::Iterator - Reading and writing message parameters

Net-DBus documentation Contained in the Net-DBus distribution.

Index

Code Index:

NAME

Top

Net::DBus::Binding::Iterator - Reading and writing message parameters

SYNOPSIS

Top

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();
    }
  }

DESCRIPTION

Top

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!).

METHODS

Top

$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.

$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.

my $val = $iter->get_boolean()
$iter->append_boolean($val);

Read or write a boolean value from/to the message iterator

my $val = $iter->get_byte()
$iter->append_byte($val);

Read or write a single byte value from/to the message iterator.

my $val = $iter->get_string()
$iter->append_string($val);

Read or write a UTF-8 string value from/to the message iterator

my $val = $iter->get_object_path()
$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

my $val = $iter->get_signature()
$iter->append_signature($val);

Read or write a UTF-8 string, whose contents is a valid type signature, value from/to the message iterator

my $val = $iter->get_int16()
$iter->append_int16($val);

Read or write a signed 16 bit value from/to the message iterator

my $val = $iter->get_uint16()
$iter->append_uint16($val);

Read or write an unsigned 16 bit value from/to the message iterator

my $val = $iter->get_int32()
$iter->append_int32($val);

Read or write a signed 32 bit value from/to the message iterator

my $val = $iter->get_uint32()
$iter->append_uint32($val);

Read or write an unsigned 32 bit value from/to the message iterator

my $val = $iter->get_int64()
$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

my $val = $iter->get_uint64()
$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

my $val = $iter->get_double()
$iter->append_double($val);

Read or write a double precision floating point value from/to the message iterator

my $value = $iter->get()
my $value = $iter->get($type);

Get the current value pointed to by this iterator. If the optional $type parameter is supplied, the wire type will be compared with the desired type & a warning output if their differ. The $type value must be one of the Net::DBus::Binding::Message::TYPE* constants.

my $hashref = $iter->get_dict()

If the iterator currently points to a dictionary value, unmarshalls and returns the value as a hash reference.

my $hashref = $iter->get_array()

If the iterator currently points to an array value, unmarshalls and returns the value as a array reference.

my $hashref = $iter->get_variant()

If the iterator currently points to a variant value, unmarshalls and returns the value contained in the variant.

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.

$iter->append($value)
$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 $value is an instance of Net::DBus::Binding::Value, the embedded data type is used.

If the $type parameter is supplied, that is taken to represent the data type. The type must be one of the 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.

my $type = $iter->guess_type($value)

Make a best guess at the on the wire data type to use for marshalling $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.

my $sig = $iter->format_signature($type)

Given a data type representation, construct a corresponding signature string

$iter->append_array($value, $type)

Append an array of values to the message. The $value parameter must be an array reference, whose elements all have the same data type specified by the $type parameter.

$iter->append_struct($value, $type)

Append a struct to the message. The $value parameter must be an array reference, whose elements correspond to members of the structure. The $type parameter encodes the type of each member of the struct.

$iter->append_dict($value, $type)

Append a dictionary to the message. The $value parameter must be an hash reference.The $type parameter encodes the type of the key and value of the hash.

$iter->append_variant($value)

Append a value to the message, encoded as a variant type. The $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 guess_type method.

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 Net::DBus::Binding::Message::TYPE_*

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 Net::DBus::Binding::Message::TYPE_*

SEE ALSO

Top

Net::DBus::Binding::Message

AUTHOR

Top

Daniel Berrange <dan@berrange.com>

COPYRIGHT

Top

Copyright 2004 by Daniel Berrange

Net-DBus documentation Contained in the Net-DBus distribution. 
# -*- perl -*-
#
# Copyright (C) 2004-2006 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.


package Net::DBus::Binding::Iterator;


use 5.006;
use strict;
use warnings;

use Net::DBus;


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);
}


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();
    } else {
	die "unknown argument type '" . chr($type) . "' ($type)";
    }
}


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;
}


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;
}


sub get_variant {
    my $self = shift;

    my $iter = $self->_recurse();
    return $iter->get();
}



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;
}


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), "')";
	}
    }
}



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(($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
	    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;
    }
}


sub format_signature {
    my $self = shift;
    my $type = shift;
    my ($sig, $t, $i);

    $sig = "";
    $i = 0;use Data::Dumper;

    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);
	    }
	    
	    $i++;
	}
    } else {
	$sig .= chr ($type);
    }
    
    return $sig;
}


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);
}



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);
}


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);
}


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);
}



1;