[libnet-dbus-perl] 34/335: Added dpack method for type encoding. Switched to doing looser matching on signal rules to allow matches even when the rule does not specify a sender. Added connection method for connecting to a bus based on address, rather than the two well known type names

[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 8a8c516622e2c8df1a2d55f63ee76ee0846c89a5
Author: Daniel P. Berrange <dan at berrange.com>
Date:   Mon Dec 27 16:24:49 2004 +0000

    Added dpack method for type encoding. Switched to doing looser matching on signal rules to allow matches even when the rule does not specify a sender. Added connection method for connecting to a bus based on address, rather than the two well known type names
---
 lib/Net/DBus.pm | 92 ++++++++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 85 insertions(+), 7 deletions(-)

diff --git a/lib/Net/DBus.pm b/lib/Net/DBus.pm
index 51e71fb..c4c3073 100644
--- a/lib/Net/DBus.pm
+++ b/lib/Net/DBus.pm
@@ -19,7 +19,8 @@ use base qw(Exporter);
 use vars qw(@EXPORT);
 
 @EXPORT = qw(dboolean dbyte dstring dint32
-             duint32 dint64 duint64 ddouble);
+             duint32 dint64 duint64 ddouble
+             dpack);
 
 require XSLoader;
 XSLoader::load('Net::DBus', $VERSION);
@@ -34,6 +35,22 @@ sub session {
     return $class->_new(&Net::DBus::Binding::Bus::SESSION);
 }
 
+
+sub connection {
+    my $class = shift;
+
+    my $self = {};
+    
+    $self->{connection} = Net::DBus::Binding::Bus->new(address => shift);
+    $self->{signals} = {};
+    
+    bless $self, $class;
+
+    $self->{connection}->add_filter(sub { $self->_signal_func(@_) });
+    
+    return $self;
+}
+
 sub _new {
     my $class = shift;
     my $self = {};
@@ -129,6 +146,40 @@ sub _match_rule {
 }
 
 
+sub _rule_matches {
+    my $self = shift;
+    my $rule = shift;
+    my $member = shift;
+    my $interface = shift;
+    my $sender = shift;
+    my $path = shift;
+    
+    my %bits;
+    map { 
+	if (/^(\w+)='(.*)'$/) {
+	    $bits{$1} = $2;
+	}
+    } split /,/, $rule;
+    
+    if (exists $bits{member} &&
+	$bits{member} ne $member) {
+	return 0;
+    }
+    if (exists $bits{interface} &&
+	$bits{interface} ne $interface) {
+	return 0;
+    }
+    if (exists $bits{sender} &&
+	$bits{sender} ne $sender) {
+	return 0;
+    }
+    if (exists $bits{path} &&
+	$bits{path} ne $path) {
+	return 0;
+    }
+    return 1;
+}
+
 sub _signal_func {
     my $self = shift;
     my $connection = shift;
@@ -137,16 +188,15 @@ sub _signal_func {
     return 0 unless $message->isa("Net::DBus::Binding::Message::Signal");
     
     my $interface = $message->get_interface;
-    my $service = $message->get_sender;
+    my $sender = $message->get_sender;
     my $path = $message->get_path;
     my $member = $message->get_member;
 
-    my $rule = $self->_match_rule($member, $interface, $service, $path);
-
     my $handled = 0;
-    if (exists $self->{receivers}->{$rule}) {
+    foreach my $rule (grep { $self->_rule_matches($_, $member, $interface, $sender, $path) }
+		      keys %{$self->{receivers}}) {
 	foreach my $callback (@{$self->{receivers}->{$rule}}) {
-	    &$callback($interface, $member, $service, $path, $message);
+	    &$callback($interface, $member, $sender, $path, $message);
             $handled = 1;
 	}
     }
@@ -202,7 +252,35 @@ sub ddouble {
 					  $value);
 }
 
-
+our %flags = (
+	      'o' => &Net::DBus::Binding::Message::TYPE_BOOLEAN,
+	      'b' => &Net::DBus::Binding::Message::TYPE_BYTE,
+	      's' => &Net::DBus::Binding::Message::TYPE_STRING,
+	      'i' => &Net::DBus::Binding::Message::TYPE_INT32,
+	      'I' => &Net::DBus::Binding::Message::TYPE_UINT32,
+	      'l' => &Net::DBus::Binding::Message::TYPE_INT64,
+	      'L' => &Net::DBus::Binding::Message::TYPE_UINT64,
+	      'd' => &Net::DBus::Binding::Message::TYPE_DOUBLE,
+	      );
+
+sub dpack {
+    my $format = shift;
+    my @in = @_;
+    if (length $format != ($#in+1)) {
+	confess "incorrect number of arguments for format string";
+    }
+    
+    my @out;
+    foreach my $flag (split //, $format) {
+	my $value = shift @in;
+	if (!exists $flags{$flag}) {
+	    confess "unknown format flag '$flag'";
+	}
+	push @out, Net::DBus::Binding::Value->new($flags{$flag},
+						   $value);
+    }
+    return @out;
+}
 
 
 1;

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