SWAMPy

✎ CARVE FLESH

EDITING: MockIterator.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::Test::MockIterator - Iterator over a mock message

=head1 SYNOPSIS

Creating a new message

my $msg = new Net::DBus::Test::MockMessage
  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

This module provides a "mock" counterpart to the L<Net::DBus::Binding::Iterator>
object which is capable of iterating over mock message objects. Instances of this
module are not created directly, instead they are obtained via the C<iterator>
method on the L<Net::DBus::Test::MockMessage> module.

=head1 METHODS

=over 4

=cut

package Net::DBus::Test::MockIterator;

use 5.006;
use strict;
use warnings;

sub _new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    my %params = @_;

$self->{data} = exists $params{data} ? $params{data} : die "data parameter is required";
    $self->{append} = exists $params{append} ? $params{append} : 0;
    $self->{position} = 0;

bless $self, $class;

return $self;
}

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

=cut

sub has_next {
    my $self = shift;

if ($self->{position} < $#{$self->{data}}) {
	return 1;
    }
    return 0;
}

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

=cut

sub next {
    my $self = shift;

$self->{position}++;
    if ($self->{position} <= $#{$self->{data}}) {
	return 1;
    }
    return 0;
}

=item my $val = $iter->get_boolean()

=item $iter->append_boolean($val);

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

=cut

sub get_boolean {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_BOOLEAN);
}

sub append_boolean {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_BOOLEAN, $_[0] ? 1 : "");
}

=item my $val = $iter->get_byte()

=item $iter->append_byte($val);

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

=cut

sub get_byte {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_BYTE);
}

sub append_byte {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_BYTE, $_[0]);
}

=item my $val = $iter->get_string()

=item $iter->append_string($val);

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

=cut

sub get_string {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_STRING);
}

sub append_string {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_STRING, $_[0]);
}

=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

=cut

sub get_object_path {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH);
}

sub append_object_path {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH, $_[0]);
}

=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

=cut

sub get_signature {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_SIGNATURE);
}

sub append_signature {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_SIGNATURE, $_[0]);
}

=item my $val = $iter->get_int16()

=item $iter->append_int16($val);

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

=cut

sub get_int16 {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_INT16);
}

sub append_int16 {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_INT16, int($_[0]));
}

=item my $val = $iter->get_uint16()

=item $iter->append_uint16($val);

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

=cut

sub get_uint16 {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT16);
}

sub append_uint16 {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_UINT16, int($_[0]));
}

=item my $val = $iter->get_int32()

=item $iter->append_int32($val);

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

=cut

sub get_int32 {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_INT32);
}

sub append_int32 {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_INT32, int($_[0]));
}

=item my $val = $iter->get_uint32()

=item $iter->append_uint32($val);

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

=cut

sub get_uint32 {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT32);
}

sub append_uint32 {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_UINT32, int($_[0]));
}

=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

=cut

sub get_int64 {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_INT64);
}

sub append_int64 {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_INT64, int($_[0]));
}

=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

=cut

sub get_uint64 {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT64);
}

sub append_uint64 {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_UINT64, int($_[0]));
}

=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

=cut

sub get_double {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_DOUBLE);
}

sub append_double {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_DOUBLE, $_[0]);
}

=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_unix_fd {
    my $self = shift;
    return $self->_get(&Net::DBus::Binding::Message::TYPE_UNIX_FD);
}

sub append_unix_fd {
    my $self = shift;
    $self->_append(&Net::DBus::Binding::Message::TYPE_UNIX_FD, $_[0] ? 1 : "");
}

=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
	    #die "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)";
	    warn "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)";
	    $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(($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]} ];
		    } 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);
	    }
	
	    $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]);
    }
}

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

=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, $sig);

$entry->append($key, $type->[0]);
	$entry->append($value, $type->[1]);
    }
}

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

=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_*>

=cut

sub get_arg_type {
    my $self = shift;

return &Net::DBus::Binding::Message::TYPE_INVALID
	if $self->{position} > $#{$self->{data}};

my $data = $self->{data}->[$self->{position}];
    return $data->[0];
}

=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

sub get_element_type {
    my $self = shift;

die "current element is not valid" if $self->{position} > $#{$self->{data}};

my $data = $self->{data}->[$self->{position}];
    if ($data->[0] != &Net::DBus::Binding::Message::TYPE_ARRAY) {
	die "current element is not an array";
    }
    return $data->[1]->[0]->[0];
}

sub _recurse {
    my $self = shift;

die "_recurse call is not valid for writable iterator" if $self->{append};

die "current element is not valid" if $self->{position} > $#{$self->{data}};

my $data = $self->{data}->[$self->{position}];

my $type = $data->[0];
    if ($type != &Net::DBus::Binding::Message::TYPE_STRUCT &&
	$type != &Net::DBus::Binding::Message::TYPE_ARRAY &&
	$type != &Net::DBus::Binding::Message::TYPE_DICT_ENTRY &&
	$type != &Net::DBus::Binding::Message::TYPE_VARIANT) {
	die "current data element '$type' is not a container";
    }

return $self->_new(data => $data->[1],
		       append => 0);
}

sub _append {
    my $self = shift;
    my $type = shift;
    my $data = shift;

die "iterator is not open for append" unless $self->{append};

push @{$self->{data}}, [$type, $data];
}

sub _open_container {
    my $self = shift;
    my $type = shift;
    my $sig = shift;

my $data = [];

push @{$self->{data}}, [$type, $data, $sig];

return $self->_new(data => $data,
		       append => 1);
}

sub _get {
    my $self = shift;
    my $type = shift;

die "iterator is not open for reading" if $self->{append};

die "current element is not valid" if $self->{position} > $#{$self->{data}};

my $data = $self->{data}->[$self->{position}];

die "data type does not match" unless $data->[0] == $type;

return $data->[1];
}

=pod

=back

=head1 BUGS

It doesn't completely replicate the API of L<Net::DBus::Binding::Iterator>,
merely enough to make the high level bindings work in a test scenario.

=head1 AUTHOR

Daniel P. Berrange

=head1 COPYRIGHT

=head1 SEE ALSO

L<Net::DBus::Test::MockMessage>, L<Net::DBus::Binding::Iterator>,
L<http://www.mockobjects.com/Faq.html>

=cut

CANCEL

Name	Type	Size	Modified	Actions
↩ ..	DIR	—	—
📄 MockConnection.pm	PM	11.9 KB	2019-02-12 20:30	EDIT
📄 MockIterator.pm	PM	24.1 KB	2019-12-16 21:15	EDIT
📄 MockMessage.pm	PM	10 KB	2019-02-12 20:30	EDIT
📄 MockObject.pm	PM	7.9 KB	2019-02-12 20:30	EDIT