[libnet-dbus-perl] 123/335: Added prototype for /org/freedesktop/DBus/Exporter capability
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:36 UTC 2015
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 8922c3d5f04021e578fd76470ea5a330f7b48b9b
Author: Daniel P. Berrange <dan at berrange.com>
Date: Thu Sep 29 22:29:32 2005 +0000
Added prototype for /org/freedesktop/DBus/Exporter capability
---
lib/Net/DBus/Dumper.pm | 8 ++-
lib/Net/DBus/Object.pm | 14 +++---
lib/Net/DBus/Service.pm | 126 +++++++++++++++++++++++++++++++++++++++++++++--
t/50-object-introspect.t | 41 +--------------
t/60-object-props.t | 8 ++-
t/65-object-magic.t | 4 ++
6 files changed, 148 insertions(+), 53 deletions(-)
diff --git a/lib/Net/DBus/Dumper.pm b/lib/Net/DBus/Dumper.pm
index 6318f73..b962adf 100644
--- a/lib/Net/DBus/Dumper.pm
+++ b/lib/Net/DBus/Dumper.pm
@@ -145,8 +145,12 @@ sub _dbus_dump_service {
my @data;
push @data, "Service: ", $service->get_service_name, "\n";
- # XXX is there some way to get a list of registered object
- # paths from the bus ?!?!?!
+
+ my $exp = $service->get_object("/org/freedesktop/DBus/Exporter");
+ my $exports = $exp->ListObjects();
+ foreach (@{$exports}) {
+ push @data, " Object: $_\n";
+ }
return @data;
}
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index aadde1c..4981e34 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -156,16 +156,11 @@ sub new {
my $class = shift;
my $self = $class->_new(@_);
- $self->get_service->get_bus->get_connection->
- register_object_path($self->get_object_path,
- sub {
- $self->_dispatch(@_);
- });
+ $self->get_service->_register_object($self);
return $self;
}
-
sub _new {
my $class = shift;
my $self = {};
@@ -183,6 +178,13 @@ sub _new {
}
+sub disconnect {
+ my $self = shift;
+
+ $self->get_service->_unregister_object($self);
+}
+
+
sub get_service {
my $self = shift;
return $self->{service};
diff --git a/lib/Net/DBus/Service.pm b/lib/Net/DBus/Service.pm
index 0ab52b6..362c7a9 100644
--- a/lib/Net/DBus/Service.pm
+++ b/lib/Net/DBus/Service.pm
@@ -27,15 +27,27 @@ This module represents a service which is exported to the message
bus. Once a service has been exported, it is possible to create
and export objects to the bus.
-=head1 SEE ALSO
+=head1 METHODS
-L<Net::DBus>, L<Net::DBus::Object>, L<Net::DBus::RemoteService>
+=over 4
=cut
package Net::DBus::Service;
+=pod
+
+=item my $service = Net::DBus::Service->new($bus, $name);
+
+Create a new service, attaching to the bus provided in
+the C<$bus> parameter, which should be an instance of
+the L<Net::DBus> object. The C<$name> parameter is the
+qualified service name. It is not usually neccessary to
+use this constructor, since services can be created via
+the C<export_service> method on the L<Net::DBus> object.
+
+=cut
sub new {
my $class = shift;
@@ -43,23 +55,131 @@ sub new {
$self->{bus} = shift;
$self->{service_name} = shift;
+ $self->{objects} = {};
bless $self, $class;
$self->get_bus->get_connection->request_name($self->get_service_name);
-
+
+ my $exp = Net::DBus::Service::Exporter->new($self);
+ $self->{exporter} = $exp;
+
return $self;
}
+=pod
+
+=item my $bus = $service->get_bus;
+
+Retrieves the L<Net::DBus> object to which this service is
+attached.
+
+=cut
+
sub get_bus {
my $self = shift;
return $self->{bus};
}
+=pod
+
+=item my $name = $service-.get_service_name
+
+Retrieves the qualified name by which this service is
+known on the bus.
+
+=cut
+
sub get_service_name {
my $self = shift;
return $self->{service_name};
}
+
+sub _register_object {
+ my $self = shift;
+ my $object = shift;
+
+ $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);
+ }
+}
+
+
+sub _unregister_object {
+ my $self = shift;
+ my $object = shift;
+
+ $self->get_bus->get_connection->
+ unregister_object_path($object->get_object_path);
+
+ if ($self->{exporter}) {
+ $self->{exporter}->unregister($object->get_object_path);
+ }
+}
+
1;
+package Net::DBus::Service::Exporter;
+
+use base qw(Net::DBus::Object);
+use strict;
+use Net::DBus::Exporter qw(org.freedesktop.DBus.Exporter);
+
+dbus_method("ListObjects", [], [["array", "string"]]);
+dbus_signal("ObjectRegistered", ["string"]);
+dbus_signal("ObjectUnregistered", ["string"]);
+
+sub new {
+ my $class = shift;
+ my $service = shift;
+ my $self = $class->SUPER::new($service, "/org/freedesktop/DBus/Exporter");
+
+ $self->{objects} = {"/org/freedesktop/DBus/Exporter" => 1};
+
+ bless $self, $class;
+
+ return $self;
+}
+
+sub register {
+ my $self = shift;
+ my $path = shift;
+
+ $self->{objects}->{$path} = 1;
+
+ $self->emit_signal("ObjectRegistered", $path);
+}
+
+sub unregister {
+ my $self = shift;
+ my $path = shift;
+
+ delete $self->{objects}->{$path};
+
+ $self->emit_signal("ObjectUnregistered", $path);
+}
+
+
+sub ListObjects {
+ my $self = shift;
+
+ my @objs = sort { $a cmp $b } keys %{$self->{objects}};
+ return \@objs;
+}
+
+=pod
+
+=back
+
+=head1 SEE ALSO
+
+L<Net::DBus>, L<Net::DBus::Object>, L<Net::DBus::RemoteService>
+
+=cut
diff --git a/t/50-object-introspect.t b/t/50-object-introspect.t
index 96910c5..8d15c76 100644
--- a/t/50-object-introspect.t
+++ b/t/50-object-introspect.t
@@ -48,50 +48,11 @@ sub new {
my $class = shift;
my $self = {};
- $self->{bus} = DummyBus->new();
-
- bless $self, $class;
-
- return $self;
-}
-
-sub get_bus {
- my $self = shift;
- return $self->{bus};
-}
-
-package DummyBus;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- $self->{connection} = DummyConnection->new();
-
bless $self, $class;
return $self;
}
-sub get_connection {
- my $self = shift;
- return $self->{connection};
-}
-
-
-package DummyConnection;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- bless $self, $class;
-
- return $self;
-}
-
-
-sub register_object_path {
+sub _register_object {
my $self = shift;
- # nada
}
diff --git a/t/60-object-props.t b/t/60-object-props.t
index 9d3ff16..04a651c 100644
--- a/t/60-object-props.t
+++ b/t/60-object-props.t
@@ -247,14 +247,18 @@ package DummyService;
sub new {
my $class = shift;
my $self = {};
-
+
$self->{bus} = DummyBus->new();
-
+
bless $self, $class;
return $self;
}
+sub _register_object {
+ my $self = shift;
+}
+
sub get_bus {
my $self = shift;
return $self->{bus};
diff --git a/t/65-object-magic.t b/t/65-object-magic.t
index 48d8f04..9fdbdb3 100644
--- a/t/65-object-magic.t
+++ b/t/65-object-magic.t
@@ -121,6 +121,10 @@ sub new {
return $self;
}
+sub _register_object {
+ my $self = shift;
+}
+
sub get_bus {
my $self = shift;
return $self->{bus};
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git
More information about the Pkg-perl-cvs-commits
mailing list