[libnet-dbus-perl] 55/335: Added concept of Net::DBus::Exporter for defining metadata, rather than passing raw introspection data into object constructor. Added much documentation. Updated tests & examples
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:23 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 8c51f7c8da196ea86ab3f2ef7baa41fa94b20d60
Author: Daniel P. Berrange <dan at berrange.com>
Date: Wed Aug 10 19:27:23 2005 +0000
Added concept of Net::DBus::Exporter for defining metadata, rather than passing raw introspection data into object constructor. Added much documentation. Updated tests & examples
---
examples/example-client.pl | 2 +-
examples/example-service.pl | 47 ++---
examples/example-signal-emitter.pl | 35 ++--
lib/Net/DBus/Exporter.pm | 363 +++++++++++++++++++++++++++++++++++++
lib/Net/DBus/Introspector.pm | 78 ++++++--
lib/Net/DBus/Object.pm | 170 +++++++++++++++--
lib/Net/DBus/Service.pm | 38 +++-
t/40-introspector.t | 19 +-
t/50-object-introspect.t | 85 +++++++++
9 files changed, 737 insertions(+), 100 deletions(-)
diff --git a/examples/example-client.pl b/examples/example-client.pl
index 5fb97ef..9568f79 100644
--- a/examples/example-client.pl
+++ b/examples/example-client.pl
@@ -5,7 +5,7 @@ use Carp qw(cluck carp);
#$SIG{__WARN__} = sub { cluck $_[0] };
#$SIG{__DIE__} = sub { carp $_[0] };
-my $bus = Net::DBus->session();
+my $bus = Net::DBus->find();
my $service = $bus->get_service("org.designfu.SampleService");
my $object = $service->get_object("/SomeObject",
diff --git a/examples/example-service.pl b/examples/example-service.pl
index f10d262..7291c5b 100644
--- a/examples/example-service.pl
+++ b/examples/example-service.pl
@@ -4,50 +4,29 @@ use Carp qw(confess cluck);
use Net::DBus;
use Net::DBus::Service;
use Net::DBus::Reactor;
-
-my $bus = Net::DBus->session();
+use Net::DBus::Exporter foo => "bar";
+my $bus = Net::DBus->find();
my $service = Net::DBus::Service->new("org.designfu.SampleService",
$bus);
-my $object = SomeObject->new($service);
+#... continued at botom
-my $reactor = Net::DBus::Reactor->new();
-$reactor->manage($bus->{connection});
-$reactor->run();
package SomeObject;
use base qw(Net::DBus::Object);
+use Net::DBus::Exporter qw(SomeObject);
sub new {
my $class = shift;
- my $self = $class->SUPER::new("/SomeObject",
- {
- "SomeObject" => {
- methods => {
- "HelloWorld" => {
- params => ["string"],
- returns => [["array","string"]],
- },
- "GetDict" => {
- params => [],
- returns => [["dict", "string", "string"]],
- },
- "GetTuple" => {
- params => [],
- returns => [["struct", "string", "string"]],
- }
- },
- },
- },
- @_);
-
+ my $service = shift;
+ my $self = $class->SUPER::new("/SomeObject", $service);
bless $self, $class;
return $self;
}
-
+dbus_method("HelloWorld", ["string"], [["array", "string"]]);
sub HelloWorld {
my $self = shift;
my $message = shift;
@@ -56,16 +35,24 @@ sub HelloWorld {
return ["Hello", " from example-service.pl"];
}
+dbus_method("GetDict", [], [["dict", "string", "string"]]);
sub GetDict {
my $self = shift;
- my $message = shift;
print "Do get dict\n";
return {"first" => "Hello Dict", "second" => " from example-service.py"};
}
+dbus_method("GetTuple", [], [["struct", "string", "string"]]);
sub GetTuple {
my $self = shift;
- my $message = shift;
print "Do get tuple\n";
return ["Hello Tuple", " from example-service.py"];
}
+
+package main;
+
+my $object = SomeObject->new($service);
+
+my $reactor = Net::DBus::Reactor->new();
+$reactor->manage($bus->{connection});
+$reactor->run();
diff --git a/examples/example-signal-emitter.pl b/examples/example-signal-emitter.pl
index e4cec92..02af77f 100644
--- a/examples/example-signal-emitter.pl
+++ b/examples/example-signal-emitter.pl
@@ -13,42 +13,37 @@ $SIG{__DIE__} = sub { confess $_[0] };
my $bus = Net::DBus->session();
my $service = Net::DBus::Service->new("org.designfu.TestService",
$bus);
-my $object = TestObject->new($service);
-
-my $reactor = Net::DBus::Reactor->new();
-$reactor->manage($bus->{connection});
-$reactor->run();
-
package TestObject;
use base qw(Net::DBus::Object);
+use Net::DBus::Exporter qw(org.designfu.TestService);
sub new {
my $class = shift;
+ my $service = shift;
my $self = $class->SUPER::new("/org/designfu/TestService/object",
- {
- "org.designfu.TestService" => {
- methods => {
- "emitHelloSignal" => {
- params => [],
- returns => [],
- },
- },
- signals => {
- "hello" => [],
- },
- },
- },
- @_);
+ $service);
bless $self, $class;
return $self;
}
+dbus_signal("hello", []);
+dbus_method("emitHelloSignal", [], []);
sub emitHelloSignal {
my $self = shift;
return $self->emit_signal("org.designfu.TestService",
"hello");
}
+
+package main;
+
+my $object = TestObject->new($service);
+
+my $reactor = Net::DBus::Reactor->new();
+$reactor->manage($bus->{connection});
+$reactor->run();
+
+
diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
new file mode 100644
index 0000000..578940c
--- /dev/null
+++ b/lib/Net/DBus/Exporter.pm
@@ -0,0 +1,363 @@
+=pod
+
+=head1 NAME
+
+Net::DBus::Exporter - exports methods and signals to the bus
+
+=head1 SYNOPSIS
+
+ # Define a new package for the object we're going
+ # to export
+ package Demo::HelloWorld;
+
+ # Specify the main interface provided by our object
+ use Net::DBus::Exporter qw(org.example.demo.Greeter);
+
+ # We're going to be a DBus object
+ use base qw(Net::DBus::Object);
+
+ # Export a 'Greeting' signal taking a stringl string parameter
+ dbus_signal("Greeting", ["string"]);
+
+ # Export 'Hello' as a method accepting a single string
+ # parameter, and returning a single string value
+ dbus_method("Hello", ["string"], ["string"]);
+
+ # Export 'Goodbye' as a method accepting a single string
+ # parameter, and returning a single string, but put it
+ # in the 'org.exaple.demo.Farewell' interface
+ dbus_method("Goodbye", ["string"], ["string"], "org.example.demo.Farewell");
+
+=head1 DESCRIPTION
+
+The C<Net::DBus::Exporter> module is used to export methods
+and signals defined in an object to the message bus. Since
+Perl is a loosely typed language it is not possible to automatically
+determine correct type information for methods to be exported.
+Thus when sub-classing L<Net::DBus::Object>, this package will
+provide the type information for methods and signals.
+
+When importing this package, an optional argument can be supplied
+to specify the default interface name to associate with methods
+and signals, for which an explicit interface is not specified.
+Thus in the common case of objects only providing a single interface,
+this removes the need to repeat the interface name against each
+method exported.
+
+=head1 SCALAR TYPES
+
+When specifying scalar data types for parameters and return values,
+the following string constants must be used to denote the data
+type. When values corresponding to these types are (un)marshalled
+they are represented as the Perl SCALAR data type (see L<perldata>).
+
+=over 4
+
+=item "string"
+
+A UTF-8 string of characters
+
+=item "int32"
+
+A 32-bit signed integer
+
+=item "uint32"
+
+A 32-bit unsigned integer
+
+=item "int64"
+
+A 64-bit signed integer. NB, this type is not supported by
+many builds of Perl on 32-bit platforms, so if used, your
+data is liable to be truncated at 32-bits.
+
+=item "uint64"
+
+A 64-bit unsigned integer. NB, this type is not supported by
+many builds of Perl on 32-bit platforms, so if used, your
+data is liable to be truncated at 32-bits.
+
+=item "byte"
+
+A single 8-bit byte
+
+=item "bool"
+
+A boolean value
+
+=item "double"
+
+An IEEE double-precision floating point
+
+=back
+
+=head1 COMPOUND TYPES
+
+When specifying compound data types for parameters and return
+values, an array reference must be used, with the first element
+being the name of the compound type.
+
+=over 4
+
+=item ["array", ARRAY-TYPE]
+
+An array of values, whose type os C<ARRAY-TYPE>. The C<ARRAY-TYPE>
+can be either a scalar type name, or a nested compound type. When
+values corresponding to the array type are (un)marshalled, they
+are represented as the Perl ARRAY data type (see L<perldata>). If,
+for example, a method was declared to have a single parameter with
+the type, ["array", "string"], then when calling the method one
+would provide a array reference of strings:
+
+ $object->hello(["John", "Doe"])
+
+=item ["dict", KEY-TYPE, VALUE-TYPE]
+
+A dictionary of values, more commonly known as a hash table. The
+C<KEY-TYPE> is the name of the scalar data type used for the dictionary
+keys. The C<VALUE-TYPE> is the name of the scalar, or compound
+data type used for the dictionary values. When values corresponding
+to the dict type are (un)marshalled, they are represented as the
+Perl HASH data type (see L<perldata>). If, for example, a method was
+declared to have a single parameter with the type ["dict", "string", "string"],
+then when calling the method one would provide a hash reference
+of strings,
+
+ $object->hello({forename => "John", surname => "Doe"});
+
+=item ["struct", VALUE-TYPE-1, VALUE-TYPE-2]
+
+A structure of values, best thought of as a variation on the array
+type where the elements can vary. Many languages have an explicit
+name associated with each value, but since Perl does not have a
+native representation of structures, they are represented by the
+LIST data type. If, for exaple, a method was declared to have a single
+parameter with the type ["struct", "string", "string"], corresponding
+to the C structure
+
+ struct {
+ char *forename;
+ char *surname;
+ } name;
+
+then, when calling the method one would provide an array refernce
+with the values orded to match the structure
+
+ $object->hello(["John", "Doe"]);
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item dbus_method($name, $params, $returns);
+
+=item dbus_method($name, $params, $returns, $interface);
+
+
+Exports a method called C<$name>, having parameters whose types
+are defined by C<$params>, and returning values whose types are
+defined by C<$returns>. If the C<$interface> parameter is
+provided, then the method is associated with that interface, otherwise
+the default interface for the calling package is used. The
+value for the C<$params> parameter should be an array reference
+with each element defining the data type of a parameter to the
+method. Likewise, the C<$returns> parameter should be an array
+reference with each element defining the data type of a return
+value. If it not possible to export a method which accepts a
+variable number of parameters, or returns a variable number of
+values.
+
+=item dbus_signal($name, $params);
+
+=item dbus_signal($name, $params, $interface);
+
+Exports a signal called C<$name>, having parameters whose types
+are defined by C<$params>, and returning values whose types are
+defined by C<$returns>. If the C<$interface> parameter is
+provided, then the signal is associated with that interface, otherwise
+the default interface for the calling package is used. The
+value for the C<$params> parameter should be an array reference
+with each element defining the data type of a parameter to the
+signal. Signals do not have return values. It not possible to
+export a signal which has a variable number of parameters.
+
+=back
+
+=head1 EXAMPLES
+
+=over 4
+
+=item No paramters, no return values
+
+A method which simply prints "Hello World" each time its called
+
+ sub Hello {
+ my $self = shift;
+ print "Hello World\n";
+ }
+
+ dbus_method("Hello", [], []);
+
+=item One string parameter, returning an boolean value
+
+A method which accepts a process name, issues the killall
+command on it, and returns a boolean value to indicate whether
+it was successful.
+
+ sub KillAll {
+ my $self = shift;
+ my $processname = shift;
+ my $ret = system("killall $processname");
+ return $ret == 0 ? 1 : 0;
+ }
+
+ dbus_method("KillAll", ["string"], ["bool"]);
+
+=item One list of strings parameter, returning a dictionary
+
+A method which accepts a list of files names, stats them, and
+returns a dictionary containing the last modification times.
+
+ sub LastModified {
+ my $self = shift;
+ my $files = shift;
+
+ my %mods;
+ foreach my $file (@{$files}) {
+ $mods{$file} = (stat $file)[9];
+ }
+ return \%mods;
+ }
+
+ dbus_method("LastModified", ["array", "string"], ["dict", "string", "int32"]);
+
+=back
+
+=head1 SEE ALSO
+
+L<Net::DBus::Object>
+
+=head1 AUTHORS
+
+Daniel P, Berrange L<dan at berrange.com>
+
+=cut
+
+package Net::DBus::Exporter;
+
+use vars qw(@ISA @EXPORT %dbus_exports %dbus_introspectors);
+
+use warnings;
+#use strict;
+
+require Exporter;
+ at ISA = qw(Exporter);
+
+ at EXPORT = qw(dbus_method dbus_signal);
+
+
+sub import {
+ my $class = shift;
+
+ my $caller = caller;
+ if (exists $dbus_exports{$caller}) {
+ warn "$caller is already registered with Net::DBus::Exporter";
+ return;
+ }
+
+ $dbus_exports{$caller} = {
+ methods => {},
+ signals => {},
+ };
+ die "usage: use Net::DBus::Exporter 'interface-name';" unless @_;
+
+ my $interface = shift;
+ $dbus_exports{$caller}->{interface} = $interface;
+
+ $class->export_to_level(1, "", @EXPORT);
+}
+
+sub dbus_introspector {
+ my $object = shift;
+
+ my $class = ref($object);
+ die "$object must be a blessed reference" unless $class;
+
+ unless (exists $dbus_introspectors{$class}) {
+ my $is = Net::DBus::Introspector->new(object_path => $object->get_object_path);
+
+ &_dbus_introspector_add(ref($object), $is);
+ $dbus_introspectors{$class} = $is;
+ }
+
+ return $dbus_introspectors{$class};
+}
+
+sub _dbus_introspector_add {
+ my $class = shift;
+ my $introspector = shift;
+
+ my $exports = $dbus_exports{$class};
+ if ($exports) {
+ foreach my $method (keys %{$exports->{methods}}) {
+ my ($params, $returns, $interface) = @{$exports->{methods}->{$method}};
+ $introspector->add_method($method, $params, $returns, $interface);
+ }
+ foreach my $signal (keys %{$exports->{signals}}) {
+ my ($params, $interface) = @{$exports->{signals}->{$signal}};
+ $introspector->add_signal($signal, $params, $interface);
+ }
+ }
+
+
+ if (defined (*{"${class}::ISA"})) {
+ my @isa = @{"${class}::ISA"};
+ foreach my $parent (@isa) {
+ &_dbus_introspector_add($parent, $introspector);
+ }
+ }
+}
+
+sub dbus_method {
+ my $name = shift;
+ my $params = shift;
+ my $returns = shift;
+
+ my $caller = caller;
+ my $is = $dbus_exports{$caller};
+
+ my $interface;
+ if (@_) {
+ $interface = shift;
+ } elsif (!exists $is->{interface}) {
+ die "interface not specified & not default interface defined";
+ } else {
+ $interface = $is->{interface};
+ }
+
+ $is->{methods}->{$name} = [$params, $returns, $interface];
+}
+
+
+sub dbus_signal {
+ my $name = shift;
+ my $params = shift;
+
+ my $caller = caller;
+ my $is = $dbus_exports{$caller};
+
+ my $interface;
+ if (@_) {
+ $interface = shift;
+ } elsif (!exists $is->{interface}) {
+ die "interface not specified & not default interface defined";
+ } else {
+ $interface = $is->{interface};
+ }
+
+ $is->{signals}->{$name} = [$params, $interface];
+}
+
+1;
diff --git a/lib/Net/DBus/Introspector.pm b/lib/Net/DBus/Introspector.pm
index 0428c8b..326650a 100644
--- a/lib/Net/DBus/Introspector.pm
+++ b/lib/Net/DBus/Introspector.pm
@@ -66,6 +66,10 @@ sub new {
my $self = {};
my %params = @_;
+ $self->{methods} = {};
+ $self->{signals} = {};
+ $self->{interfaces} = {};
+
bless $self, $class;
if (defined $params{xml}) {
@@ -73,22 +77,11 @@ sub new {
} elsif (defined $params{node}) {
$self->_parse_node($params{node});
} else {
- $self->{name} = exists $params{name} ? $params{name} : die "name parameter is required";
- $self->{interfaces} = exists $params{interfaces} ? $params{interfaces} : die "interfaces parameter is required";
+ $self->{object_path} = exists $params{object_path} ? $params{object_path} : die "object_path parameter is required";
+ $self->{interfaces} = exists $params{interfaces} ? $params{interfaces} : {};
$self->{children} = exists $params{children} ? $params{children} : [];
}
- $self->{interfaces}->{"org.freedesktop.DBus.Introspectable"} = {
- methods => {
- "Introspect" => {
- params => [],
- returns => ["string"],
- }
- }
- };
-
- $self->{methods} = {};
- $self->{signals} = {};
foreach my $name (keys %{$self->{interfaces}}) {
my $interface = $self->{interfaces}->{$name};
foreach my $method (keys %{$interface->{methods}}) {
@@ -102,6 +95,61 @@ sub new {
return $self;
}
+sub add_interface {
+ my $self = shift;
+ my $name = shift;
+
+ $self->{interfaces}->{$name} = {
+ methods => {},
+ signals => {},
+ } unless exists $self->{interfaces}->{$name};
+}
+
+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};
+}
+
+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};
+}
+
+sub add_method {
+ my $self = shift;
+ my $name = shift;
+ my $params = shift;
+ my $returns = shift;
+ my $interface = shift;
+
+ $self->add_interface($interface);
+
+ $self->{methods}->{$name} = { params => $params,
+ returns => $returns };
+ $self->{interfaces}->{$interface}->{methods}->{$name} = $self->{methods}->{$name};
+}
+
+sub add_signal {
+ my $self = shift;
+ my $name = shift;
+ my $params = shift;
+ my $interface = shift;
+
+ $self->add_interface($interface);
+
+ $self->{signals}->{$name} = $params;
+ $self->{interfaces}->{$interface}->{signals}->{$name} = $self->{signals}->{$name};
+}
+
+
sub _parse {
my $self = shift;
my $xml = shift;
@@ -118,7 +166,7 @@ sub _parse_node {
my $self = shift;
my $node = shift;
- $self->{name} = $node->{Attributes}->{name};
+ $self->{object_path} = $node->{Attributes}->{name};
$self->{interfaces} = {};
$self->{children} = [];
foreach my $child (@{$node->{Contents}}) {
@@ -275,7 +323,7 @@ sub to_xml {
my $indent = shift;
my $xml = '';
- $xml .= $indent . '<node name="' . $self->{name} . '">' . "\n";
+ $xml .= $indent . '<node name="' . $self->{object_path} . '">' . "\n";
foreach my $name (sort { $a cmp $b } keys %{$self->{interfaces}}) {
my $interface = $self->{interfaces}->{$name};
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 07340af..07477ec 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -1,3 +1,130 @@
+=pod
+
+=head1 NAME
+
+Net::DBus::Exporter - exports methods and signals to the bus
+
+=head1 SYNOPSIS
+
+ # Connecting an object to the bus, under a service
+ package main;
+
+ use Net::DBus;
+
+ # Attach to the bus
+ my $bus = Net::DBus->find;
+
+ # Acquire a service 'org.demo.Hello'
+ my $service = $bus->export_service("org.demo.Hello");
+
+ # Export our object within the service
+ my $object = Demo::HelloWorld->new($service);
+
+ ....rest of program...
+
+ # Define a new package for the object we're going
+ # to export
+ package Demo::HelloWorld;
+
+ # Specify the main interface provided by our object
+ use Net::DBus::Exporter qw(org.example.demo.Greeter);
+
+ # We're going to be a DBus object
+ use base qw(Net::DBus::Object);
+
+ # Export a 'Greeting' signal taking a stringl string parameter
+ dbus_signal("Greeting", ["string"]);
+
+ # Export 'Hello' as a method accepting a single string
+ # parameter, and returning a single string value
+ dbus_method("Hello", ["string"], ["string"]);
+
+ sub new {
+ my $class = shift;
+ my $service = shift;
+ my $self = $class->SUPER::new("/org/demo/HelloWorld", $service);
+
+ bless $self, $class;
+
+ return $self;
+ }
+
+ sub Hello {
+ my $self = shift;
+ my $name = shift;
+
+ $self->emit_signal("Greeting", "Hello $name");
+ return "Said hello to $name";
+ }
+
+ # Export 'Goodbye' as a method accepting a single string
+ # parameter, and returning a single string, but put it
+ # in the 'org.exaple.demo.Farewell' interface
+
+ dbus_method("Goodbye", ["string"], ["string"], "org.example.demo.Farewell");
+
+ sub Goodbye {
+ my $self = shift;
+ my $name = shift;
+
+ $self->emit_signal("Greeting", "Goodbye $name");
+ return "Said goodbye to $name";
+ }
+
+=head1 DESCRIPTION
+
+This the base of all objects which are exported to the
+message bus. It provides the core support for type introspection
+required for objects exported to the message. When sub-classing
+this object, methods can be created & tested as per normal Perl
+modules. Then just as the L<Exporter> module is used to export
+methods within a script, the L<Net::DBus::Exporter> module is
+used to export methods (and signals) to the message bus.
+
+All packages inheriting from this, will automatically have the
+interface C<org.freedesktop.DBus.Introspectable> registered
+with L<Net::DBus::Exporter>, and the C<Introspect> method within
+this exported.
+
+=head1 METHODS
+
+=over 4
+
+=item my $object = Net::DBus::Object->new($path, $service)
+
+This creates a new DBus object with an path of C<$path>
+registered within the service C<$service>. The C<$path>
+parameter should be a string complying with the usual
+DBus requirements for object paths, while the C<$service>
+parameter should be an instrance of L<Net::DBus::Service>.
+The latter is typically obtained by calling the C<export_service>
+method on the L<Net::DBus> object.
+
+=item my $service = $self->get_service
+
+Retrieves the L<Net::DBus::Service> object within which this
+object is exported.
+
+=item my $path = $self->get_object_path
+
+Retrieves the path under which this object is exported
+
+=item $self->emit_signal($name, @args);
+
+Emits a signal from the object, with a name of C<$name>. The
+signal and the data types of the arguments C<@args> must have
+been registered with L<Net::DBus::Exporter> by calling the
+C<dbus_signal> method.
+
+=back
+
+=head1 SEE ALSO
+
+L<Net::DBus>, L<Net::DBus::Service>, L<Net::DBus::RemoteObject>,
+L<Net::DBus::Exporter>.
+
+=cut
+
package Net::DBus::Object;
use 5.006;
@@ -8,26 +135,24 @@ use Carp;
our $VERSION = '0.0.1';
use Net::DBus::RemoteObject;
+use Net::DBus::Exporter "org.freedesktop.DBus.Introspectable";
use Net::DBus::Introspector;
use Net::DBus::Binding::Message::Error;
use Net::DBus::Binding::Message::MethodReturn;
+dbus_method("Introspect", [], ["string"]);
+
sub new {
my $class = shift;
my $self = {};
$self->{object_path} = shift;
-
- my $interfaces = shift;
- $self->{introspector} = Net::DBus::Introspector->new(name => $self->{object_path},
- interfaces => $interfaces);
-
$self->{service} = shift;
bless $self, $class;
- $self->{service}->{bus}->{connection}->
- register_object_path($self->{object_path},
+ $self->get_service->get_bus->get_connection->
+ register_object_path($self->get_object_path,
sub {
$self->_dispatch(@_);
});
@@ -36,12 +161,14 @@ sub new {
}
-sub Introspect {
+sub get_service {
+ my $self = shift;
+ return $self->{service};
+}
+
+sub get_object_path {
my $self = shift;
- #warn "Asked for introspection data\n";
- my $xml = $self->{introspector}->format;
- #warn $xml;
- return $xml;
+ return $self->{object_path};
}
@@ -54,8 +181,8 @@ sub emit_signal {
interface => $interface,
signal_name => $signal_name);
- $self->{introspector}->encode($signal, "signals", $signal_name, "params", @args);
- $self->{service}->get_bus()->get_connection()->send($signal);
+ $self->_introspector->encode($signal, "signals", $signal_name, "params", @args);
+ $self->get_service->get_bus->get_connection->send($signal);
return ();
}
@@ -80,15 +207,26 @@ sub _dispatch {
} else {
$reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
- $self->{introspector}->encode($reply, "methods", $method_name, "returns", @ret);
+ $self->_introspector->encode($reply, "methods", $method_name, "returns", @ret);
}
+ } elsif ($method_name eq "Introspect") {
+ my $xml = $self->_introspector->format;
+ $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
+
+ $self->_introspector->encode($reply, "methods", $method_name, "returns", $xml);
} else {
$reply = Net::DBus::Binding::Message::Error->new(replyto => $message,
name => "org.freedesktop.DBus.Error.Failed",
description => "No such method " . ref($self) . "->" . $method_name);
}
- $self->{service}->{bus}->{connection}->send($reply);
+ $self->get_service->get_bus->get_connection->send($reply);
+}
+
+sub _introspector {
+ my $self = shift;
+
+ return Net::DBus::Exporter::dbus_introspector($self);
}
1;
diff --git a/lib/Net/DBus/Service.pm b/lib/Net/DBus/Service.pm
index 6ddd253..05e9f30 100644
--- a/lib/Net/DBus/Service.pm
+++ b/lib/Net/DBus/Service.pm
@@ -1,3 +1,39 @@
+=pod
+
+=head1 NAME
+
+Net::DBus::Service - represents a service exported to the message bus
+
+=head1 SYNOPSIS
+
+ package main;
+
+ use Net::DBus;
+
+ # Attach to the bus
+ my $bus = Net::DBus->find;
+
+ # Acquire a service 'org.demo.Hello'
+ my $service = $bus->export_service("org.demo.Hello");
+
+ # Export our object within the service
+ my $object = Demo::HelloWorld->new($service);
+
+ ....rest of program...
+
+=head1 DESCRIPTION
+
+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
+
+L<Net::DBus>, L<Net::DBus::Object>, L<Net::DBus::RemoteService>
+
+=cut
+
+
package Net::DBus::Service;
@@ -10,7 +46,7 @@ sub new {
bless $self, $class;
- $self->{bus}->get_connection()->request_name($self->{service_name});
+ $self->get_bus->get_connection->request_name($self->service_name);
return $self;
}
diff --git a/t/40-introspector.t b/t/40-introspector.t
index 1c2bcab..a397da0 100644
--- a/t/40-introspector.t
+++ b/t/40-introspector.t
@@ -11,7 +11,7 @@ BEGIN {
TEST_ONE: {
my $other_object = Net::DBus::Introspector->new(
- name => "org.example.Object.OtherObject",
+ object_path => "org.example.Object.OtherObject",
interfaces => {
"org.example.SomeInterface" => {
methods => {
@@ -55,17 +55,12 @@ TEST_ONE: {
<arg type="y"/>
</signal>
</interface>
- <interface name="org.freedesktop.DBus.Introspectable">
- <method name="Introspect">
- <arg type="s" direction="out"/>
- </method>
- </interface>
</node>
EOF
is($other_xml_got, $other_xml_expect, "xml data matches");
my $object = Net::DBus::Introspector->new(
- name => "org.example.Object",
+ object_path => "org.example.Object",
interfaces => {
"org.example.SomeInterface" => {
methods => {
@@ -127,11 +122,6 @@ EOF
<arg type="y"/>
</signal>
</interface>
- <interface name="org.freedesktop.DBus.Introspectable">
- <method name="Introspect">
- <arg type="s" direction="out"/>
- </method>
- </interface>
<node name="org.example.Object.SubObject"/>
<node name="org.example.Object.OtherObject">
<interface name="org.example.SomeInterface">
@@ -151,11 +141,6 @@ EOF
<arg type="y"/>
</signal>
</interface>
- <interface name="org.freedesktop.DBus.Introspectable">
- <method name="Introspect">
- <arg type="s" direction="out"/>
- </method>
- </interface>
</node>
</node>
EOF
diff --git a/t/50-object-introspect.t b/t/50-object-introspect.t
new file mode 100644
index 0000000..394b304
--- /dev/null
+++ b/t/50-object-introspect.t
@@ -0,0 +1,85 @@
+# -*- perl -*-
+use Test::More tests => 3;
+
+use strict;
+use warnings;
+
+BEGIN {
+ use_ok('Net::DBus::Introspector');
+ use_ok('Net::DBus::Object');
+};
+
+my $object = Net::DBus::Object->new("/org/example/Object/OtherObject", new DummyService());
+
+my $introspector = $object->_introspector;
+
+my $xml_got = $introspector->format();
+
+my $xml_expect = <<EOF;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/org/example/Object/OtherObject">
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+</node>
+EOF
+
+ is($xml_got, $xml_expect, "xml data matches");
+
+
+package DummyService;
+
+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 {
+ my $self = shift;
+ # nada
+}
--
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