Net::DBus::Binding::Introspector - Handler for object introspection data

  # Create an object populating with info from an
  # XML doc containing introspection data.

  my $ins = Net::DBus::Binding::Introspector->new(xml => $data);

  # Create an object, defining introspection data
  # programmatically
  my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
  $ins->add_method("DoSomething", ["string"], [], "org.example.MyObject");
  $ins->add_method("TestSomething", ["int32"], [], "org.example.MyObject");

# -*- 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::Introspector;

use 5.006;
use strict;
use warnings;

use XML::Twig;

use Net::DBus::Binding::Message;

our $debug = 0;

BEGIN {
    if ($ENV{NET_DBUS_DEBUG} &&
	$ENV{NET_DBUS_DEBUG} eq "introspect") {
	$debug = 1;
    }
}

our %simple_type_map = (
  "byte" => &Net::DBus::Binding::Message::TYPE_BYTE,
  "bool" => &Net::DBus::Binding::Message::TYPE_BOOLEAN,
  "double" => &Net::DBus::Binding::Message::TYPE_DOUBLE,
  "string" => &Net::DBus::Binding::Message::TYPE_STRING,
  "int16" => &Net::DBus::Binding::Message::TYPE_INT16,
  "uint16" => &Net::DBus::Binding::Message::TYPE_UINT16,
  "int32" => &Net::DBus::Binding::Message::TYPE_INT32,
  "uint32" => &Net::DBus::Binding::Message::TYPE_UINT32,
  "int64" => &Net::DBus::Binding::Message::TYPE_INT64,
  "uint64" => &Net::DBus::Binding::Message::TYPE_UINT64,
  "objectpath" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
  "signature" => &Net::DBus::Binding::Message::TYPE_SIGNATURE,
);

our %simple_type_rev_map = (
  &Net::DBus::Binding::Message::TYPE_BYTE => "byte",
  &Net::DBus::Binding::Message::TYPE_BOOLEAN => "bool",
  &Net::DBus::Binding::Message::TYPE_DOUBLE => "double",
  &Net::DBus::Binding::Message::TYPE_STRING => "string",
  &Net::DBus::Binding::Message::TYPE_INT16 => "int16",
  &Net::DBus::Binding::Message::TYPE_UINT16 => "uint16",
  &Net::DBus::Binding::Message::TYPE_INT32 => "int32",
  &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 => "objectpath",
  &Net::DBus::Binding::Message::TYPE_SIGNATURE => "signature",
);

our %magic_type_map = (
  "caller" => sub {
    my $msg = shift;

    return $msg->get_sender;
  },
  "serial" => sub {
    my $msg = shift;

    return $msg->get_serial;
  },
);

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

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

    $self->{interfaces} = {};

    bless $self, $class;

    if (defined $params{xml}) {
	$self->{object_path} = exists $params{object_path} ? $params{object_path} : undef;
	$self->_parse($params{xml});
    } elsif (defined $params{node}) {
	$self->{object_path} = exists $params{object_path} ? $params{object_path} : undef;
	$self->_parse_node($params{node});
    } else {
	$self->{object_path} = exists $params{object_path} ? $params{object_path} : undef;
	$self->{interfaces} = $params{interfaces} if exists $params{interfaces};
	$self->{children} = exists $params{children} ? $params{children} : [];
    }

    # Some versions of dbus failed to include signals in introspection data
    # so this code adds them, letting us keep compatability with old versions
    if (defined $self->{object_path} &&
	$self->{object_path} eq "/org/freedesktop/DBus") {
	if (!$self->has_signal("NameOwnerChanged")) {
	    $self->add_signal("NameOwnerChanged", ["string","string","string"], "org.freedesktop.DBus");
	}
	if (!$self->has_signal("NameLost")) {
	    $self->add_signal("NameLost", ["string"], "org.freedesktop.DBus");
	}
	if (!$self->has_signal("NameAcquired")) {
	    $self->add_signal("NameAcquired", ["string"], "org.freedesktop.DBus");
	}
    }

    return $self;
}

sub add_interface {
    my $self = shift;
    my $name = shift;

    $self->{interfaces}->{$name} = {
	methods => {},
	signals => {},
	props => {},
    } unless exists $self->{interfaces}->{$name};
}

sub has_interface {
    my $self = shift;
    my $name = shift;

    return exists $self->{interfaces}->{$name} ? 1 : 0;
}

sub has_method {
    my $self = shift;
    my $name = shift;

    my @interfaces;
    foreach my $interface (keys %{$self->{interfaces}}) {
	if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) {
	    push @interfaces, $interface;
	}
    }

    return @interfaces;
}

sub has_signal {
    my $self = shift;
    my $name = shift;

    my @interfaces;
    foreach my $interface (keys %{$self->{interfaces}}) {
	if (exists $self->{interfaces}->{$interface}->{signals}->{$name}) {
	    push @interfaces, $interface;
	}
    }
    return @interfaces;
}

sub has_property {
    my $self = shift;
    my $name = shift;

    if (@_) {
	my $interface = shift;
	return () unless exists $self->{interfaces}->{$interface};
	return () unless exists $self->{interfaces}->{$interface}->{props}->{$name};
	return ($interface);
    } else {
	my @interfaces;
	foreach my $interface (keys %{$self->{interfaces}}) {
	    if (exists $self->{interfaces}->{$interface}->{props}->{$name}) {
		push @interfaces, $interface;
	    }
	}
	return @interfaces;
    }
}

sub add_method {
    my $self = shift;
    my $name = shift;
    my $params = shift;
    my $returns = shift;
    my $interface = shift;
    my $attributes = shift;
    my $paramnames = shift;
    my $returnnames = shift;

    $self->add_interface($interface);
    $self->{interfaces}->{$interface}->{methods}->{$name} = {
	params => $params,
	returns => $returns,
	paramnames => $paramnames,
	returnnames => $returnnames,
	deprecated => $attributes->{deprecated} ? 1 : 0,
	no_reply => $attributes->{no_return} ? 1 : 0,
    };
}

sub add_signal {
    my $self = shift;
    my $name = shift;
    my $params = shift;
    my $interface = shift;
    my $attributes = shift;
    my $paramnames = shift;

    $self->add_interface($interface);
    $self->{interfaces}->{$interface}->{signals}->{$name} = {
	params => $params,
	paramnames => $paramnames,
	deprecated => $attributes->{deprecated} ? 1 : 0,
    };
}

sub add_property {
    my $self = shift;
    my $name = shift;
    my $type = shift;
    my $access = shift;
    my $interface = shift;
    my $attributes = shift;

    $self->add_interface($interface);
    $self->{interfaces}->{$interface}->{props}->{$name} = {
	type => $type,
	access => $access,
	deprecated => $attributes->{deprecated} ? 1 : 0,
    };
}

sub is_method_deprecated {
    my $self = shift;
    my $name = shift;
    my $interface = shift;

    die "no interface $interface" unless exists $self->{interfaces}->{$interface};
    die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name};
    return 1 if $self->{interfaces}->{$interface}->{methods}->{$name}->{deprecated};
    return 0;
}

sub is_signal_deprecated {
    my $self = shift;
    my $name = shift;
    my $interface = shift;

    die "no interface $interface" unless exists $self->{interfaces}->{$interface};
    die "no signal $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{signals}->{$name};
    return 1 if $self->{interfaces}->{$interface}->{signals}->{$name}->{deprecated};
    return 0;
}

sub is_property_deprecated {
    my $self = shift;
    my $name = shift;
    my $interface = shift;

    die "no interface $interface" unless exists $self->{interfaces}->{$interface};
    die "no property $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{props}->{$name};
    return 1 if $self->{interfaces}->{$interface}->{props}->{$name}->{deprecated};
    return 0;
}

sub does_method_reply {
    my $self = shift;
    my $name = shift;
    my $interface = shift;

    die "no interface $interface" unless exists $self->{interfaces}->{$interface};
    die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name};
    return 0 if $self->{interfaces}->{$interface}->{methods}->{$name}->{no_reply};
    return 1;
}

sub list_interfaces {
    my $self = shift;

    return keys %{$self->{interfaces}};
}

sub list_methods {
    my $self = shift;
    my $interface = shift;
    return keys %{$self->{interfaces}->{$interface}->{methods}};
}

sub list_signals {
    my $self = shift;
    my $interface = shift;
    return keys %{$self->{interfaces}->{$interface}->{signals}};
}

sub list_properties {
    my $self = shift;
    my $interface = shift;
    return keys %{$self->{interfaces}->{$interface}->{props}};
}

sub list_children {
    my $self = shift;
    return @{$self->{children}};
}

sub get_object_path {
    my $self = shift;
    return $self->{object_path};
}

sub get_method_params {
    my $self = shift;
    my $interface = shift;
    my $method = shift;
    return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{params}};
}

sub get_method_param_names {
    my $self = shift;
    my $interface = shift;
    my $method = shift;
    return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{paramnames}};
}

sub get_method_returns {
    my $self = shift;
    my $interface = shift;
    my $method = shift;
    return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returns}};
}

sub get_method_return_names {
    my $self = shift;
    my $interface = shift;
    my $method = shift;
    return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returnnames}};
}

sub get_signal_params {
    my $self = shift;
    my $interface = shift;
    my $signal = shift;
    return @{$self->{interfaces}->{$interface}->{signals}->{$signal}->{params}};
}

sub get_signal_param_names {
    my $self = shift;
    my $interface = shift;
    my $signal = shift;
    return @{$self->{interfaces}->{$interface}->{signals}->{$signal}->{paramnames}};
}

sub get_property_type {
    my $self = shift;
    my $interface = shift;
    my $prop = shift;
    return $self->{interfaces}->{$interface}->{props}->{$prop}->{type};
}

sub is_property_readable {
    my $self = shift;
    my $interface = shift;
    my $prop = shift;
    my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->{access};
    return $access eq "readwrite" || $access eq "read" ? 1 : 0;
}

sub is_property_writable {
    my $self = shift;
    my $interface = shift;
    my $prop = shift;
    my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->{access};
    return $access eq "readwrite" || $access eq "write" ? 1 : 0;
}

sub _parse {
    my $self = shift;
    my $xml = shift;

    my $twig = XML::Twig->new();
    $twig->parse($xml);

    $self->_parse_node($twig->root);
}

sub _parse_node {
    my $self = shift;
    my $node = shift;

    $self->{object_path} = $node->att("name") if defined $node->att("name");
    die "no object path provided" unless defined $self->{object_path};
    $self->{children} = [];
    foreach my $child ($node->children("interface")) {
	$self->_parse_interface($child);
    }
    foreach my $child ($node->children("node")) {
	if (!$child->has_children()) {
	    push @{$self->{children}}, $child->att("name");
	} else {
	    push @{$self->{children}}, $self->new(node => $child);
	}
    }
}

sub _parse_interface {
    my $self = shift;
    my $node = shift;

    my $name = $node->att("name");
    $self->{interfaces}->{$name} = {
	methods => {},
	signals => {},
	props => {},
    };

    foreach my $child ($node->children("method")) {
	$self->_parse_method($child, $name);
    }
    foreach my $child ($node->children("signal")) {
	$self->_parse_signal($child, $name);
    }
    foreach my $child ($node->children("property")) {
	$self->_parse_property($child, $name);
    }
}

sub _parse_method {
    my $self = shift;
    my $node = shift;
    my $interface = shift;

    my $name = $node->att("name");
    my @params;
    my @returns;
    my @paramnames;
    my @returnnames;
    my $deprecated = 0;
    my $no_reply = 0;
    foreach my $child ($node->children("arg")) {
	my $type = $child->att("type");
	my $direction = $child->att("direction");
	my $name = $child->att("name");

	my @sig = split //, $type;
	my @type = $self->_parse_type(\@sig);
	if (!defined $direction || $direction eq "in") {
	    push @params, @type;
	    push @paramnames, $name;
	} elsif ($direction eq "out") {
	    push @returns, @type;
	    push @returnnames, $name;
	}
    }
    foreach my $child ($node->children("annotation")) {
	my $name = $child->att("name");
	my $value = $child->att("value");

	if ($name eq "org.freedesktop.DBus.Deprecated") {
	    $deprecated = 1 if lc($value) eq "true";
	} elsif ($name eq "org.freedesktop.DBus.Method.NoReply") {
	    $no_reply = 1 if lc($value) eq "true";
	}
    }

    $self->{interfaces}->{$interface}->{methods}->{$name} = {
	params => \@params,
	returns => \@returns,
	no_reply => $no_reply,
	deprecated => $deprecated,
	paramnames => \@paramnames,
	returnnames => \@returnnames,
    }
}

sub _parse_type {
    my $self = shift;
    my $sig = shift;

    my $root = [];
    my $current = $root;
    my @cont;
    while (my $type = shift @{$sig}) {
	if (exists $simple_type_rev_map{ord($type)}) {
	    push @{$current}, $simple_type_rev_map{ord($type)};
	    if ($current->[0] eq "array") {
		$current = pop @cont;
	    }
	} else {
	    if ($type eq "(") {
		my $new = ["struct"];
		push @{$current}, $new;
		push @cont, $current;
		$current = $new;
	    } elsif ($type eq "a") {
		my $new = ["array"];
		push @cont, $current;
		push @{$current}, $new;
		$current = $new;
	    } elsif ($type eq "{") {
		if ($current->[0] ne "array") {
		    die "dict must only occur within an array";
		}
		$current->[0] = "dict";
	    } elsif ($type eq ")") {
		die "unexpected end of struct" unless
		    $current->[0] eq "struct";
		$current = pop @cont;
		if ($current->[0] eq "array") {
		    $current = pop @cont;
		}
	    } elsif ($type eq "}") {
		die "unexpected end of dict" unless
		    $current->[0] eq "dict";
		$current = pop @cont;
		if ($current->[0] eq "array") {
		    $current = pop @cont;
		}
	    } elsif ($type eq "v") {
		push @{$current}, ["variant"];
		if ($current->[0] eq "array") {
		    $current = pop @cont;
		}
	    } else {
		die "unknown type sig '$type'";
	    }
	}
    }
    return @{$root};
}

sub _parse_signal {
    my $self = shift;
    my $node = shift;
    my $interface = shift;

    my $name = $node->att("name");
    my @params;
    my @paramnames;
    my $deprecated = 0;
    foreach my $child ($node->children("arg")) {
	my $type = $child->att("type");
	my $name = $child->att("name");
	my @sig = split //, $type;
	my @type = $self->_parse_type(\@sig);
	push @params, @type;
	push @paramnames, $name;
    }
    foreach my $child ($node->children("annotation")) {
	my $name = $child->att("name");
	my $value = $child->att("value");

	if ($name eq "org.freedesktop.DBus.Deprecated") {
	    $deprecated = 1 if lc($value) eq "true";
	}
    }

    $self->{interfaces}->{$interface}->{signals}->{$name} = {
	params => \@params,
	paramnames => \@paramnames,
	deprecated => $deprecated,
    };
}

sub _parse_property {
    my $self = shift;
    my $node = shift;
    my $interface = shift;

    my $name = $node->att("name");
    my $access = $node->att("access");
    my $deprecated = 0;

    foreach my $child ($node->children("annotation")) {
	my $name = $child->att("name");
	my $value = $child->att("value");

	if ($name eq "org.freedesktop.DBus.Deprecated") {
	    $deprecated = 1 if lc($value) eq "true";
	}
    }
    my @sig = split //, $node->att("type");
    $self->{interfaces}->{$interface}->{props}->{$name} = {
	type =>  $self->_parse_type(\@sig),
	access => $access,
	deprecated => $deprecated,
    };
}

sub format {
    my $self = shift;
    my $obj = shift;

    my $xml = '<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"' . "\n";
    $xml .= '"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">' . "\n";

    return $xml . $self->to_xml("", $obj);
}

sub to_xml {
    my $self = shift;
    my $indent = shift;
    my $obj = shift;

    my $xml = '';
    my $path = $obj ? $obj->get_object_path : $self->{object_path};
    unless (defined $path) {
	die "no object_path for introspector, and no object supplied";
    }
    $xml .= $indent . '<node name="' . $path . '">' . "\n";

    foreach my $name (sort { $a cmp $b } keys %{$self->{interfaces}}) {
	my $interface = $self->{interfaces}->{$name};
	$xml .= $indent . '  <interface name="' . $name . '">' . "\n";
	foreach my $mname (sort { $a cmp $b } keys %{$interface->{methods}}) {
	    my $method = $interface->{methods}->{$mname};
	    $xml .= $indent . '    <method name="' . $mname . '">' . "\n";

	    my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$method->{paramnames}} );
	    my @returnnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$method->{returnnames}} );

	    foreach my $type (@{$method->{params}}) {
		next if ! ref($type) && exists $magic_type_map{$type};
		$xml .= $indent . '      <arg ' . (@paramnames ? shift(@paramnames) : "")
		    . 'type="' . $self->to_xml_type($type) . '" direction="in"/>' . "\n";
	    }

	    foreach my $type (@{$method->{returns}}) {
		next if ! ref($type) && exists $magic_type_map{$type};
		$xml .= $indent . '      <arg ' . (@returnnames ? shift(@returnnames) : "")
		    . 'type="' . $self->to_xml_type($type) . '" direction="out"/>' . "\n";
	    }
	    if ($method->{deprecated}) {
		$xml .= $indent . '      <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
	    }
	    if ($method->{no_reply}) {
		$xml .= $indent . '      <annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>' . "\n";
	    }
	    $xml .= $indent . '    </method>' . "\n";
	}
	foreach my $sname (sort { $a cmp $b } keys %{$interface->{signals}}) {
	    my $signal = $interface->{signals}->{$sname};
	    $xml .= $indent . '    <signal name="' . $sname . '">' . "\n";

	    my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$signal->{paramnames}} );

	    foreach my $type (@{$signal->{params}}) {
		next if ! ref($type) && exists $magic_type_map{$type};
		$xml .= $indent . '      <arg ' . (@paramnames ? shift(@paramnames) : "")
		    . 'type="' . $self->to_xml_type($type) . '"/>' . "\n";
	    }
	    if ($signal->{deprecated}) {
		$xml .= $indent . '      <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
	    }
	    $xml .= $indent . '    </signal>' . "\n";
	}

	foreach my $pname (sort { $a cmp $b } keys %{$interface->{props}}) {
	    my $prop = $interface->{props}->{$pname};
	    my $type = $interface->{props}->{$pname}->{type};
	    my $access = $interface->{props}->{$pname}->{access};
	    if ($prop->{deprecated}) {
		$xml .= $indent . '    <property name="' . $pname . '" type="' .
		    $self->to_xml_type($type) . '" access="' . $access . '">' . "\n";
		$xml .= $indent . '      <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
		$xml .= $indent . '    </property>' . "\n";
	    } else {
		$xml .= $indent . '    <property name="' . $pname . '" type="' .
		    $self->to_xml_type($type) . '" access="' . $access . '"/>' . "\n";
	    }
	}

	$xml .= $indent . '  </interface>' . "\n";
    }

    #
    # Interfaces don't have children,  objects do
    #
    if ($obj) {
	foreach ( $obj->_get_sub_nodes ) {
	    $xml .= $indent . '  <node name="/' . $_ . '"/>' . "\n";
	}
    } else {
	foreach my $child (@{$self->{children}}) {
	    if (ref($child) eq __PACKAGE__) {
		$xml .= $child->to_xml($indent . "  ");
	    } else {
		$xml .= $indent . '  <node name="' . $child . '"/>' . "\n";
	    }
	}
    }

    $xml .= $indent . "</node>\n";
}

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

    my $sig = '';
    if (ref($type) eq "ARRAY") {
	if ($type->[0] eq "array") {
	    if ($#{$type} != 1) {
		die "array spec must contain only 1 type";
	    }
	    $sig .= chr($compound_type_map{$type->[0]});
	    $sig .= $self->to_xml_type($type->[1]);
	} elsif ($type->[0] eq "struct") {
	    $sig .= "(";
	    for (my $i = 1 ; $i <= $#{$type} ; $i++) {
		$sig .= $self->to_xml_type($type->[$i]);
	    }
	    $sig .= ")";
	} elsif ($type->[0] eq "dict") {
	    if ($#{$type} != 2) {
		die "dict spec must contain only 2 types";
	    }
	    $sig .= chr($compound_type_map{"array"});
	    $sig .= "{";
	    $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'";
	}
    } else {
	die "unknown/unsupported scalar type '$type'"
	    unless exists $simple_type_map{$type};
	$sig .= chr($simple_type_map{$type});
    }
    return $sig;
}

sub encode {
    my $self = shift;
    my $message = shift;
    my $type = shift;
    my $name = shift;
    my $direction = shift;
    my @args = @_;

    my $interface = $message->get_interface;

    my @types;
    if ($interface) {
	if (exists $self->{interfaces}->{$interface}) {
	    if (exists $self->{interfaces}->{$interface}->{$type}->{$name}) {
		@types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
	    } else {
		warn "missing introspection data when encoding $type '$name' in object " .
		    $self->get_object_path . "\n" if $debug;
	    }
	} else {
	    warn "missing interface '$interface' in introspection data for object '" .
		$self->get_object_path . "' encoding $type '$name'\n" if $debug;
	}
    } else {
	foreach my $in (keys %{$self->{interfaces}}) {
	    if (exists $self->{interfaces}->{$in}->{$type}->{$name}) {
		$interface = $in;
	    }
	}
	if ($interface) {
	    @types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
	} else {
	    warn "no interface in introspection data for object " .
		$self->get_object_path . " encoding $type '$name'\n" if $debug;
	}
    }

    # If you don't explicitly 'return ()' from methods, Perl
    # will always return a single element representing the
    # return value of the last command executed in the method.
    # To avoid this causing a PITA for methods exported with
    # no return values, we throw away returns instead of dieing
    if ($direction eq "returns" &&
	$#types == -1 &&
	$#args != -1) {
	@args = ();
    }

    # No introspection data available, then just fallback
    # to a plain (guess types) append
    unless (@types) {
	$message->append_args_list(@args);
	return;
    }


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

sub _convert {
    my $self = shift;
    my @in = @_;

    my @out;
    foreach my $in (@in) {
	if (ref($in) eq "ARRAY") {
	    my @subtype = @{$in};
	    shift @subtype;
	    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};
	} else {
	    die "unknown simple type " . $in unless
		exists $simple_type_map{lc $in};
	    push @out, $simple_type_map{lc $in};
	}
    }
    return @out;
}

sub decode {
    my $self = shift;
    my $message = shift;
    my $type = shift;
    my $name = shift;
    my $direction = shift;

    my $interface = $message->get_interface;

    my @types;
    if ($interface) {
	if (exists $self->{interfaces}->{$interface}) {
	    if (exists $self->{interfaces}->{$interface}->{$type}->{$name}) {
	        @types =
		    @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
	    } else {
		warn "missing introspection data when decoding $type '$name' in object " .
		    $self->get_object_path . "\n" if $debug;
	    }
	} else {
	    warn "missing interface '$interface' in introspection data for object '" .
		$self->get_object_path . "' when decoding $type '$name'\n" if $debug;
	}
    } else {
	foreach my $in (keys %{$self->{interfaces}}) {
	    if (exists $self->{interfaces}->{$in}->{$type}->{$name}) {
		$interface = $in;
	    }
	}
	if (!$interface) {
	    warn "no interface in introspection data for object " .
		$self->get_object_path . " decoding $type '$name'\n" if $debug;
	} else {
	    @types =
		@{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
	}
    }

    # If there are no types defined, just return the
    # actual data from the message, assuming the introspection
    # data was partial.
    return $message->get_args_list
	unless @types;

    my $iter = $message->iterator;

    my $hasnext = 1;
    my @rawtypes = $self->_convert(@types);
    my @ret;
    while (@types) {
	my $type = shift @types;
	my $rawtype = shift @rawtypes;

	if (exists $magic_type_map{$type}) {
	    push @ret, &$rawtype($message);
	} elsif ($hasnext) {
	    push @ret, $iter->get($rawtype);
	    $hasnext = $iter->next;
	}
    }
    return @ret;
}

1;