view release on metacpan or  search on metacpan

lib/Net/DBus/Binding/Introspector.pm  view on Meta::CPAN

  &Net::DBus::Binding::Message::TYPE_UNIX_FD => "unixfd",
);

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} : undef;
	$self->{interfaces} = $params{interfaces} if exists $params{interfaces};
	$self->{children} = exists $params{children} ? $params{children} : [];
    }

    $self->{strict} = exists $params{strict} ? $params{strict} : 0;

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

=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, [$interface])

Return a list of all interfaces provided by the object, which
contain a method called C<$name>. This may be an empty list.
The optional C<$interface> parameter can restrict the check to
just that one interface.

=cut

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

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

lib/Net/DBus/Binding/Introspector.pm  view on Meta::CPAN

	    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)};
	    while ($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;
		while ($current->[0] eq "array") {
		    $current = pop @cont;
		}
	    } elsif ($type eq "}") {
		die "unexpected end of dict" unless
		    $current->[0] eq "dict";
		$current = pop @cont;
		while ($current->[0] eq "array") {
		    $current = pop @cont;
		}
	    } elsif ($type eq "v") {
		push @{$current}, ["variant"];
		while ($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,
    };
}

=item my $xml = $ins->format([$obj])

Return a string containing an XML document representing the
state of the introspection data. The optional C<$obj> parameter
can be an instance of L<Net::DBus::Object> to include object
specific information in the XML (eg child nodes).

=cut

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

=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 $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";
}

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