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 4b5ddcf8673f166980d5baabfdf2a7d0629ccfb1
Author: Daniel P. Berrange <d...@berrange.com>
Date: Fri Jan 6 15:53:44 2006 +0000
Extend constructor for Net::DBus::Object to enable creating child objects
with a relative path, by passing in a parent object, rather than a service as
first param
---
lib/Net/DBus/Object.pm | 102 ++++++++++++++++++++++++++++++------
lib/Net/DBus/Service.pm | 21 +++++---
lib/Net/DBus/Test/MockConnection.pm | 40 +++++++++++---
3 files changed, 133 insertions(+), 30 deletions(-)
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index c93d965..103d38a 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -16,13 +16,13 @@
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
-# $Id: Object.pm,v 1.19 2005/11/21 10:53:31 dan Exp $
+# $Id: Object.pm,v 1.20 2006/01/06 15:53:44 dan Exp $
=pod
=head1 NAME
-Net::DBus::Exporter - exports methods and signals to the bus
+Net::DBus::Object - Provide objects to the bus for clients to use
=head1 SYNOPSIS
@@ -62,7 +62,7 @@ Net::DBus::Exporter - exports methods and signals to the bus
sub new {
my $class = shift;
my $service = shift;
- my $self = $class->SUPER::new("/org/demo/HelloWorld", $service);
+ my $self = $class->SUPER::new($service, "/org/demo/HelloWorld");
bless $self, $class;
@@ -110,7 +110,7 @@ this exported.
=over 4
-=item my $object = Net::DBus::Object->new($path, $service)
+=item my $object = Net::DBus::Object->new($service, $path)
This creates a new DBus object with an path of C<$path>
registered within the service C<$service>. The C<$path>
@@ -183,26 +183,34 @@ dbus_method("Set", ["string", "string", "variant"], [],
"org.freedesktop.DBus.Pr
sub new {
my $class = shift;
- my $self = $class->_new(@_);
-
- $self->get_service->_register_object($self);
-
- return $self;
-}
-
-sub _new {
- my $class = shift;
my $self = {};
+
+ my $parent = shift;
+ my $path = shift;
+
+ $self->{parent} = $parent;
+ if ($parent->isa(__PACKAGE__)) {
+ $self->{service} = $parent->get_service;
+ $self->{object_path} = $parent->get_object_path . $path;
+ } else {
+ $self->{service} = $parent;
+ $self->{object_path} = $path;
+ }
- $self->{service} = shift;
- $self->{object_path} = shift;
$self->{interface} = shift;
$self->{introspector} = undef;
$self->{introspected} = 0;
$self->{callbacks} = {};
+ $self->{children} = {};
bless $self, $class;
-
+
+ if ($self->{parent}->isa(__PACKAGE__)) {
+ $self->{parent}->_register_child($self);
+ } else {
+ $self->get_service->_register_object($self);
+ }
+
return $self;
}
@@ -210,7 +218,53 @@ sub _new {
sub disconnect {
my $self = shift;
- $self->get_service->_unregister_object($self);
+ return unless $self->{parent};
+
+ if ($self->{parent}->isa(__PACKAGE__)) {
+ $self->{parent}->_unregister_child($self);
+ } else {
+ $self->get_service->_unregister_object($self);
+ }
+ $self->{parent} = undef;
+}
+
+
+sub is_connected {
+ my $self = shift;
+
+ return 0 unless $self->{parent};
+
+ if ($self->{parent}->isa(__PACKAGE__)) {
+ return $self->{parent}->is_connected;
+ }
+ return 1;
+}
+
+sub DESTROY {
+ my $self = shift;
+ # XXX there are some issues during global
+ # destruction which need to be better figured
+ # out before this will work
+ #$self->disconnect;
+}
+
+sub _register_child {
+ my $self = shift;
+ my $object = shift;
+
+ $self->get_service->_register_object($object);
+ # Experiment in handling dispatch for child objects internally
+ #$self->{children}->{$object->get_object_path} = $object;
+}
+
+
+sub _unregister_child {
+ my $self = shift;
+ my $object = shift;
+
+ $self->get_service->_unregister_object($object);
+ # Experiment in handling dispatch for child objects internally
+ #delete $self->{children}->{$object->get_object_path};
}
@@ -232,6 +286,8 @@ sub emit_signal_in {
my $destination = shift;
my @args = @_;
+ die "object is disconnected from the bus" unless $self->is_connected;
+
my $signal = Net::DBus::Binding::Message::Signal->new(object_path =>
$self->get_object_path,
interface =>
$interface,
signal_name => $name);
@@ -291,6 +347,8 @@ sub connect_to_signal_in {
my $name = shift;
my $interface = shift;
my $code = shift;
+
+ die "object is disconnected from the bus" unless $self->is_connected;
$self->{callbacks}->{$interface} = {} unless
exists $self->{callbacks}->{$interface};
@@ -327,6 +385,16 @@ sub _dispatch {
my $connection = shift;
my $message = shift;
+ # Experiment in handling dispatch for child objects internally
+# my $path = $message->get_path;
+# while ($path ne $self->get_object_path) {
+# if (exists $self->{children}->{$path}) {
+# $self->{children}->{$path}->_dispatch($connection, $message);
+# return;
+# }
+# $path =~ s,/[^/]+$,,;
+# }
+
my $reply;
my $method_name = $message->get_member;
my $interface = $message->get_interface;
diff --git a/lib/Net/DBus/Service.pm b/lib/Net/DBus/Service.pm
index aaf8100..1d4d16a 100644
--- a/lib/Net/DBus/Service.pm
+++ b/lib/Net/DBus/Service.pm
@@ -16,7 +16,7 @@
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
-# $Id: Service.pm,v 1.10 2005/12/21 12:04:11 dan Exp $
+# $Id: Service.pm,v 1.11 2006/01/06 15:53:44 dan Exp $
=pod
@@ -119,12 +119,21 @@ sub get_service_name {
sub _register_object {
my $self = shift;
my $object = shift;
+ #my $wildcard = shift || 0;
- $self->get_bus->get_connection->
- register_object_path($object->get_object_path,
- sub {
- $object->_dispatch(@_);
- });
+# if ($wildcard) {
+# $self->get_bus->get_connection->
+# register_fallback($object->get_object_path,
+# sub {
+# $object->_dispatch(@_);
+# });
+# } else {
+ $self->get_bus->get_connection->
+ register_object_path($object->get_object_path,
+ sub {
+ $object->_dispatch(@_);
+ });
+# }
if ($self->{exporter}) {
$self->{exporter}->register($object->get_object_path);
diff --git a/lib/Net/DBus/Test/MockConnection.pm
b/lib/Net/DBus/Test/MockConnection.pm
index 7a5fa03..f79e16a 100644
--- a/lib/Net/DBus/Test/MockConnection.pm
+++ b/lib/Net/DBus/Test/MockConnection.pm
@@ -16,7 +16,7 @@
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
-# $Id: MockConnection.pm,v 1.2 2005/12/21 11:59:54 dan Exp $
+# $Id: MockConnection.pm,v 1.3 2006/01/06 15:53:44 dan Exp $
=pod
@@ -73,6 +73,7 @@ sub new {
$self->{replies} = [];
$self->{signals} = [];
$self->{objects} = {};
+ $self->{objectTrees} = {};
$self->{filters} = [];
bless $self, $class;
@@ -163,6 +164,22 @@ sub register_object_path {
$self->{objects}->{$path} = $code;
}
+sub register_fallback {
+ my $self = shift;
+ my $path = shift;
+ my $code = shift;
+
+ $self->{objects}->{$path} = $code;
+ $self->{objectTrees}->{$path} = $code;
+}
+
+sub unregister_object_path {
+ my $self = shift;
+ my $path = shift;
+
+ delete $self->{objects}->{$path};
+}
+
sub _call_method {
my $self = shift;
my $msg = shift;
@@ -170,12 +187,21 @@ sub _call_method {
if (exists $self->{objects}->{$msg->get_path}) {
my $cb = $self->{objects}->{$msg->get_path};
&$cb($self, $msg);
- } elsif ($msg->get_path eq "/org/freedesktop/DBus") {
- if ($msg->get_member eq "GetNameOwner") {
- my $reply = Net::DBus::Binding::Message::MethodReturn->new(call =>
$msg);
- my $iter = $reply->iterator(1);
- $iter->append(":1.1");
- $self->send($reply);
+ } else {
+ foreach my $path (reverse sort { $a cmp $b } keys
%{$self->{objectTrees}}) {
+ if ((index $msg->get_path, $path) == 0) {
+ my $cb = $self->{objects}->{$path};
+ &$cb($self, $msg);
+ return;
+ }
+ }
+ if ($msg->get_path eq "/org/freedesktop/DBus") {
+ if ($msg->get_member eq "GetNameOwner") {
+ my $reply = Net::DBus::Binding::Message::MethodReturn->new(call
=> $msg);
+ my $iter = $reply->iterator(1);
+ $iter->append(":1.1");
+ $self->send($reply);
+ }
}
}
}
--
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
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
