[libnet-dbus-perl] 57/335: Fixed decode() method. Added more helpful warning messages. Ignore case where a method is exported with no returns, but perl returns value of last statement. Many methods for querying metadata

[Intrigeri]

This is an automated email from the git hooks/post-receive script.

intrigeri pushed a commit to branch experimental
in repository libnet-dbus-perl.

commit 141ba7a7b60289086663a60de906e55ae356e26d
Author: Daniel P. Berrange <dan at berrange.com>
Date:   Sun Aug 14 17:55:21 2005 +0000

    Fixed decode() method. Added more helpful warning messages. Ignore case where a method is exported with no returns, but perl returns value of last statement. Many methods for querying metadata
---
 lib/Net/DBus/Introspector.pm | 100 +++++++++++++++++++++++++++++++++++++------
 1 file changed, 88 insertions(+), 12 deletions(-)

diff --git a/lib/Net/DBus/Introspector.pm b/lib/Net/DBus/Introspector.pm
index 326650a..88445f6 100644
--- a/lib/Net/DBus/Introspector.pm
+++ b/lib/Net/DBus/Introspector.pm
@@ -38,6 +38,7 @@ our %simple_type_map = (
   "uint32" => &Net::DBus::Binding::Message::TYPE_UINT32,
   "int64" => &Net::DBus::Binding::Message::TYPE_INT64,
   "uint64" => &Net::DBus::Binding::Message::TYPE_UINT64,
+  "object" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
 );
 
 our %simple_type_rev_map = (
@@ -49,6 +50,7 @@ our %simple_type_rev_map = (
   &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 => "object",
 );
 
 our %compound_type_map = (
@@ -73,8 +75,10 @@ sub new {
     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";
@@ -108,21 +112,30 @@ sub add_interface {
 sub has_method {
     my $self = shift;
     my $name = shift;
-    my $interface = shift;
     
-    return 0 unless exists $self->{interfaces}->{$interface};
-    return exists $self->{interfaces}->{$interface}->{methods}->{$name};
+    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 $interface = shift;
-    
-    return 0 unless exists $self->{interfaces}->{$interface};
-    return exists $self->{interfaces}->{$interface}->{signal}->{$name};
+        
+    my @interfaces;
+    foreach my $interface (keys %{$self->{interfaces}}) {
+	if (exists $self->{interfaces}->{$interface}->{signals}->{$name}) {
+	    push @interfaces, $interface;
+	}
+    }
+    return @interfaces;
 }
 
+
 sub add_method {
     my $self = shift;
     my $name = shift;
@@ -150,6 +163,52 @@ sub add_signal {
 }
 
 
+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 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_returns {
+    my $self = shift;
+    my $interface = shift;
+    my $method = shift;
+    return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returns}};
+}
+
+sub get_signal_params {
+    my $self = shift;
+    my $interface = shift;
+    my $signal = shift;
+    return @{$self->{interfaces}->{$interface}->{signals}->{$signal}};
+}
+
+
+
 sub _parse {
     my $self = shift;
     my $xml = shift;
@@ -166,7 +225,8 @@ sub _parse_node {
     my $self = shift;
     my $node = shift;
 
-    $self->{object_path} = $node->{Attributes}->{name};
+    $self->{object_path} = $node->{Attributes}->{name} if defined $node->{Attributes}->{name};
+    die "no object path provided" unless defined $self->{object_path};
     $self->{interfaces} = {};
     $self->{children} = [];
     foreach my $child (@{$node->{Contents}}) {
@@ -394,9 +454,11 @@ sub to_xml_type {
 	    $sig .= $self->to_xml_type($type->[2]);
 	    $sig .= "}";
 	} else {
-	    die "unknown type " . $type->[0] . " expecting 'array', 'struct', or 'dict'";
+	    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;
@@ -410,13 +472,25 @@ sub encode {
     my $direction = shift;
     my @args = @_;
 
-    die "no introspection data for such $name ($type)" unless exists $self->{$type}->{$name};
+    die "no introspection data for $name (type: $type) in object " . $self->get_object_path . "\n" 
+	unless exists $self->{$type}->{$name};
 
     my @types = $type eq "signals" ? 
 	@{$self->{$type}->{$name}} :
 	@{$self->{$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) . " params, but got " . int(@args) 
+    die "expected " . int(@types) . " $direction, but got " . int(@args) 
 	unless $#types == $#args;
     
     my $iter = $message->iterator(1);
@@ -458,9 +532,11 @@ sub decode {
     
     die "no introspection data for such $name ($type)" unless exists $self->{$type}->{$name};
     
-    my @type = $type eq "signal" ? 
+    my @type = $type eq "signals" ? 
 	@{$self->{$type}->{$name}} :
 	@{$self->{$type}->{$name}->{$direction}};
 
+    # XXX validate received message against instrospection data!
     
+    return $message->get_args_list();
 }

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git