# -*- perl -*-
#
# Copyright (C) 2004-2005 Daniel P. Berrange
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# $Id: Introspector.pm,v 1.14 2006/02/03 13:30:14 dan Exp $
=pod
=head1 NAME
Net::DBus::Binding::Introspector - Handler for object introspection data
=head1 SYNOPSIS
# 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");
=head1 DESCRIPTION
This class is responsible for managing introspection data, and
answering questions about it. This is not intended for use by
application developers, whom should instead consult the higher
level API in L<Net::DBus::Exporter>.
=head1 METHODS
=over 4
=cut
package Net::DBus::Binding::Introspector;
use 5.006;
use strict;
use warnings;
use Carp;
use XML::Grove::Builder;
use XML::Parser::PerlSAX;
use Net::DBus::Binding::Message;
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,
);
=item my $ins = Net::DBus::Binding::Introspector->new(object_path => $object_path,
xml => $xml);
Creates a new introspection data manager for the object registered
at the path specified for the C<object_path> parameter. The optional
C<xml> parameter can be used to pre-load the manager with introspection
metadata from an XML document.
=cut
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} : die "object_path parameter is required";
$self->{interfaces} = $params{interfaces} if exists $params{interfaces};
$self->{children} = exists $params{children} ? $params{children} : [];
}
# XXX it is really a bug that these aren't included in the introspection
# data the bus generates
if ($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;
}
=item $ins->add_interface($name)
Register the object as providing an interface with the name C<$name>
=cut
sub add_interface {
my $self = shift;
my $name = shift;
$self->{interfaces}->{$name} = {
methods => {},
signals => {},
props => {},
} unless exists $self->{interfaces}->{$name};
}
=item my $bool = $ins->has_interface($name)
Return a true value if the object is registered as providing
an interface with the name C<$name>; returns false otherwise.
=cut
sub has_interface {
my $self = shift;
my $name = shift;
return exists $self->{interfaces}->{$name} ? 1 : 0;
}
=item my @interfaces = $ins->has_method($name)
Return a list of all interfaces provided by the object, which
contain a method called C<$name>. This may be an empty list.
=cut
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;
}
=item my @interfaces = $ins->has_signal($name)
Return a list of all interfaces provided by the object, which
contain a signal called C<$name>. This may be an empty list.
=cut
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;
}
=item my @interfaces = $ins->has_property($name)
Return a list of all interfaces provided by the object, which
contain a property called C<$name>. This may be an empty list.
=cut
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;
}
}
=item $ins->add_method($name, $params, $returns, $interface, $attributes);
Register the object as providing a method called C<$name> accepting parameters
whose types are declared by C<$params> and returning values whose type
are declared by C<$returns>. The method will be scoped to the inteface
named by C<$interface>. The C<$attributes> parameter is a hash reference
for annotating the method.
=cut
sub add_method {
my $self = shift;
my $name = shift;
my $params = shift;
my $returns = shift;
my $interface = shift;
my $attributes = shift;
$self->add_interface($interface);
$self->{interfaces}->{$interface}->{methods}->{$name} = {
params => $params,
returns => $returns,
deprecated => $attributes->{deprecated} ? 1 : 0,
no_reply => $attributes->{no_return} ? 1 : 0,
};
}
=item $ins->add_signal($name, $params, $interface, $attributes);
Register the object as providing a signal called C<$name> with parameters
whose types are declared by C<$params>. The signal will be scoped to the inteface
named by C<$interface>. The C<$attributes> parameter is a hash reference
for annotating the signal.
=cut
sub add_signal {
my $self = shift;
my $name = shift;
my $params = shift;
my $interface = shift;
my $attributes = shift;
$self->add_interface($interface);
$self->{interfaces}->{$interface}->{signals}->{$name} = {
params => $params,
deprecated => $attributes->{deprecated} ? 1 : 0,
};
}
=item $ins->add_property($name, $type, $access, $interface, $attributes);
Register the object as providing a property called C<$name> with a type
of C<$type>. The C<$access> parameter can be one of C<read>, C<write>,
or C<readwrite>. The property will be scoped to the inteface
named by C<$interface>. The C<$attributes> parameter is a hash reference
for annotating the signal.
=cut
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,
};
}
=item my $boolean = $ins->is_method_deprecated($name, $interface)
Returns a true value if the method called C<$name> in the interface
C<$interface> is marked as deprecated
=cut
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;
}
=item my $boolean = $ins->is_signal_deprecated($name, $interface)
Returns a true value if the signal called C<$name> in the interface
C<$interface> is marked as deprecated
=cut
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;
}
=item my $boolean = $ins->is_property_deprecated($name, $interface)
Returns a true value if the property called C<$name> in the interface
C<$interface> is marked as deprecated
=cut
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;
}
=item my $boolean = $ins->does_method_reply($name, $interface)
Returns a true value if the method called C<$name> in the interface
C<$interface> will generate a reply. Returns a false value otherwise.
=cut
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;
}
=item my @names = $ins->list_interfaces
Returns a list of all interfaces registered as being provided
by the object.
=cut
sub list_interfaces {
my $self = shift;
return keys %{$self->{interfaces}};
}
=item my @names = $ins->list_methods($interface)
Returns a list of all methods registered as being provided
by the object, within the interface C<$interface>.
=cut
sub list_methods {
my $self = shift;
my $interface = shift;
return keys %{$self->{interfaces}->{$interface}->{methods}};
}
=item my @names = $ins->list_signals($interface)
Returns a list of all signals registered as being provided
by the object, within the interface C<$interface>.
=cut
sub list_signals {
my $self = shift;
my $interface = shift;
return keys %{$self->{interfaces}->{$interface}->{signals}};
}
=item my @names = $ins->list_properties($interface)
Returns a list of all properties registered as being provided
by the object, within the interface C<$interface>.
=cut
sub list_properties {
my $self = shift;
my $interface = shift;
return keys %{$self->{interfaces}->{$interface}->{props}};
}
=item my @paths = $self->list_children;
Returns a list of object paths representing all the children
of this node.
=cut
sub list_children {
my $self = shift;
return @{$self->{children}};
}
=item my $path = $ins->get_object_path
Returns the path of the object associated with this introspection
data
=cut
sub get_object_path {
my $self = shift;
return $self->{object_path};
}
=item my @types = $ins->get_method_params($interface, $name)
Returns a list of declared data types for parameters of the
method called C<$name> within the interface C<$interface>.
=cut
sub get_method_params {
my $self = shift;
my $interface = shift;
my $method = shift;
return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{params}};
}
=item my @types = $ins->get_method_returns($interface, $name)
Returns a list of declared data types for return values of the
method called C<$name> within the interface C<$interface>.
=cut
sub get_method_returns {
my $self = shift;
my $interface = shift;
my $method = shift;
return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returns}};
}
=item my @types = $ins->get_signal_params($interface, $name)
Returns a list of declared data types for values associated with the
signal called C<$name> within the interface C<$interface>.
=cut
sub get_signal_params {
my $self = shift;
my $interface = shift;
my $signal = shift;
return @{$self->{interfaces}->{$interface}->{signals}->{$signal}->{params}};
}
=item my $type = $ins->get_property_type($interface, $name)
Returns the declared data type for property called C<$name> within
the interface C<$interface>.
=cut
sub get_property_type {
my $self = shift;
my $interface = shift;
my $prop = shift;
return $self->{interfaces}->{$interface}->{props}->{$prop}->{type};
}
=item my $bool = $ins->is_property_readable($interface, $name);
Returns a true value if the property called C<$name> within the
interface C<$interface> can have its value read.
=cut
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;
}
=item my $bool = $ins->is_property_writable($interface, $name);
Returns a true value if the property called C<$name> within the
interface C<$interface> can have its value written to.
=cut
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 $grove_builder = XML::Grove::Builder->new;
my $parser = XML::Parser::PerlSAX->new(Handler => $grove_builder);
my $document = $parser->parse ( Source => { String => $xml } );
my $root = $document->{Contents}->[0];
$self->_parse_node($root);
}
sub _parse_node {
my $self = shift;
my $node = shift;
$self->{object_path} = $node->{Attributes}->{name} if defined $node->{Attributes}->{name};
die "no object path provided" unless defined $self->{object_path};
$self->{children} = [];
foreach my $child (@{$node->{Contents}}) {
if (ref($child) eq "XML::Grove::Element") {
if ($child->{Name} eq "interface") {
$self->_parse_interface($child);
} elsif ($child->{Name} eq "node") {
my $subcont = $child->{Contents};
if ($#{$subcont} == -1) {
push @{$self->{children}}, $child->{Attributes}->{name};
} else {
push @{$self->{children}}, $self->new(node => $child);
}
}
}
}
}
sub _parse_interface {
my $self = shift;
my $node = shift;
my $name = $node->{Attributes}->{name};
$self->{interfaces}->{$name} = {
methods => {},
signals => {},
props => {},
};
foreach my $child (@{$node->{Contents}}) {
if (ref($child) eq "XML::Grove::Element") {
if ($child->{Name} eq "method") {
$self->_parse_method($child, $name);
} elsif ($child->{Name} eq "signal") {
$self->_parse_signal($child, $name);
} elsif ($child->{Name} eq "property") {
$self->_parse_property($child, $name);
}
}
}
}
sub _parse_method {
my $self = shift;
my $node = shift;
my $interface = shift;
my $name = $node->{Attributes}->{name};
my @params;
my @returns;
my $deprecated = 0;
my $no_reply = 0;
foreach my $child (@{$node->{Contents}}) {
if (ref($child) eq "XML::Grove::Element") {
if ($child->{Name} eq "arg") {
my $type = $child->{Attributes}->{type};
my $direction = $child->{Attributes}->{direction};
my @sig = split //, $type;
my @type = $self->_parse_type(\@sig);
if (!defined $direction || $direction eq "in") {
push @params, @type;
} elsif ($direction eq "out") {
push @returns, @type;
}
} elsif ($child->{Name} eq "annotation") {
my $name = $child->{Attributes}->{name};
my $value = $child->{Attributes}->{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,
}
}
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->{Attributes}->{name};
my @params;
my $deprecated = 0;
foreach my $child (@{$node->{Contents}}) {
if (ref($child) eq "XML::Grove::Element") {
if ($child->{Name} eq "arg") {
my $type = $child->{Attributes}->{type};
my @sig = split //, $type;
my @type = $self->_parse_type(\@sig);
push @params, @type;
} elsif ($child->{Name} eq "annotation") {
my $name = $child->{Attributes}->{name};
my $value = $child->{Attributes}->{value};
if ($name eq "org.freedesktop.DBus.Deprecated") {
$deprecated = 1 if lc($value) eq "true";
}
}
}
}
$self->{interfaces}->{$interface}->{signals}->{$name} = {
params => \@params,
deprecated => $deprecated,
};
}
sub _parse_property {
my $self = shift;
my $node = shift;
my $interface = shift;
my $name = $node->{Attributes}->{name};
my $access = $node->{Attributes}->{access};
my $deprecated = 0;
foreach my $child (@{$node->{Contents}}) {
if (ref($child) eq "XML::Grove::Element") {
if ($child->{Name} eq "annotation") {
my $name = $child->{Attributes}->{name};
my $value = $child->{Attributes}->{value};
if ($name eq "org.freedesktop.DBus.Deprecated") {
$deprecated = 1 if lc($value) eq "true";
}
}
}
}
$self->{interfaces}->{$interface}->{props}->{$name} = {
type => $self->_parse_type([$node->{Attributes}->{type}]),
access => $access,
deprecated => $deprecated,
};
}
=item my $xml = $ins->format
Return a string containing an XML document representing the
state of the introspection data.
=cut
sub format {
my $self = 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("");
}
=item my $xml_fragment = $ins->to_xml
Returns a string containing an XML fragment representing the
state of the introspection data. This is basically the same
as the C<format> method, but without the leading doctype
declaration.
=cut
sub to_xml {
my $self = shift;
my $indent = shift;
my $xml = '';
$xml .= $indent . '<node name="' . $self->{object_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";
foreach my $type (@{$method->{params}}) {
next if ! ref($type) && exists $magic_type_map{$type};
$xml .= $indent . ' <arg 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 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";
foreach my $type (@{$signal->{params}}) {
next if ! ref($type) && exists $magic_type_map{$type};
$xml .= $indent . ' <arg 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";
}
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";
}
=item $type = $ins->to_xml_type($type)
Takes a text-based representation of a data type and returns
the compact representation used in XML introspection data.
=cut
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;
}
=item $ins->encode($message, $type, $name, $direction, @args)
Append a set of values <@args> to a message object C<$message>.
The C<$type> parameter is either C<signal> or C<method> and
C<$direction> is either C<params> or C<returns>. The introspection
data will be queried to obtain the declared data types & the
argument marshalling accordingly.
=cut
sub encode {
my $self = shift;
my $message = shift;
my $type = shift;
my $name = shift;
my $direction = shift;
my @args = @_;
my $interface = $message->get_interface;
if ($interface) {
die "no interface '$interface' in introspection data for object '" . $self->get_object_path . "' encoding $type '$name'\n"
unless exists $self->{interfaces}->{$interface};
die "no introspection data when encoding $type '$name' in object " . $self->get_object_path . "\n"
unless exists $self->{interfaces}->{$interface}->{$type}->{$name};
} else {
foreach my $in (keys %{$self->{interfaces}}) {
if (exists $self->{interfaces}->{$in}->{$type}->{$name}) {
$interface = $in;
}
}
if (!$interface) {
die "no interface in introspection data for object " . $self->get_object_path . " encoding $type '$name'\n"
}
}
my @types =
@{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
# 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 = ();
}
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;
}
=item my @args = $ins->decode($message, $type, $name, $direction)
Unmarshalls the contents of a message object C<$message>.
The C<$type> parameter is either C<signal> or C<method> and
C<$direction> is either C<params> or C<returns>. The introspection
data will be queried to obtain the declared data types & the
arguments unmarshalled accordingly.
=cut
sub decode {
my $self = shift;
my $message = shift;
my $type = shift;
my $name = shift;
my $direction = shift;
my $interface = $message->get_interface;
if ($interface) {
die "no interface '$interface' in introspection data for object '" . $self->get_object_path . "' decoding $type '$name'\n"
unless exists $self->{interfaces}->{$interface};
die "no introspection data when encoding $type '$name' in object " . $self->get_object_path . "\n"
unless exists $self->{interfaces}->{$interface}->{$type}->{$name};
} else {
foreach my $in (keys %{$self->{interfaces}}) {
if (exists $self->{interfaces}->{$in}->{$type}->{$name}) {
$interface = $in;
}
}
if (!$interface) {
die "no interface in introspection data for object " . $self->get_object_path . " decoding $type '$name'\n"
}
}
my @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 @rawtypes = $self->_convert(@types);
my @ret;
do {
my $type = shift @types;
my $rawtype = shift @rawtypes;
if (exists $magic_type_map{$type}) {
push @ret, &$rawtype($message);
} else {
push @ret, $iter->get($rawtype);
}
} while ($iter->next);
return @ret;
}
1;
=pod
=back
=head1 SEE ALSO
L<Net::DBus::Exporter>, L<Net::DBus::Binding::Message>
=head1 AUTHOR
Daniel Berrange E<lt>dan@berrange.comE<gt>
=head1 COPYRIGHT
Copyright 2004 by Daniel Berrange
=cut