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