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 <[email protected]> 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 _______________________________________________ Pkg-perl-cvs-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
