[libnet-dbus-perl] 301/335: Split Net::DBus::Object into two pieces
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:08:13 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 a71ba4ede5a2652d071ec466c927d4833290cb04
Author: Daniel P. Berrange <dan at berrange.com>
Date: Sun Nov 6 13:57:06 2011 +0000
Split Net::DBus::Object into two pieces
To allow addition of alternate object implementations, pull most
of the functionality of Net::DBus::Object out into a new super
class, Net::DBus::BaseObject
---
lib/Net/DBus/{Object.pm => BaseObject.pm} | 162 +++------
lib/Net/DBus/Object.pm | 526 +-----------------------------
2 files changed, 66 insertions(+), 622 deletions(-)
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/BaseObject.pm
similarity index 82%
copy from lib/Net/DBus/Object.pm
copy to lib/Net/DBus/BaseObject.pm
index 41a9d1b..9815f60 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/BaseObject.pm
@@ -20,35 +20,12 @@
=head1 NAME
-Net::DBus::Object - Provide objects to the bus for clients to use
+Net::DBus::BaseObject - base class for exporting objects 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);
+ use base qw(Net::DBus::BaseObject);
# Export a 'Greeting' signal taking a stringl string parameter
dbus_signal("Greeting", ["string"]);
@@ -67,26 +44,15 @@ Net::DBus::Object - Provide objects to the bus for clients to use
return $self;
}
- sub Hello {
- my $self = shift;
- my $name = shift;
+ sub _dispatch_object {
+ my $self = shift;
+ my $connection = shift;
+ my $message = 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";
+ if (....$message refers to a object's method ... ) {
+ ...dispatch this object's interfaces/methods...
+ return $reply;
+ }
}
=head1 DESCRIPTION
@@ -94,23 +60,28 @@ Net::DBus::Object - Provide objects to the bus for clients to use
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.
+this object, the C<_dispatch> object should be implemented to
+handle processing of incoming messages. The L<Net::DBus::Exporter>
+module is used to declare which methods (and signals) are being
+exported 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.
+Application developers will rarely want to use this class directly,
+instead either L<Net::DBus::Object> or C<Net::DBus::ProxyObject>
+are the common choices. This class will only be used if wanting to
+write a new approach to dispatching incoming method calls.
+
=head1 METHODS
=over 4
=cut
-package Net::DBus::Object;
+package Net::DBus::BaseObject;
use 5.006;
use strict;
@@ -134,7 +105,7 @@ dbus_method("Get", ["string", "string"], [["variant"]], "org.freedesktop.DBus.Pr
dbus_method("GetAll", ["string"], [["dict", "string", ["variant"]]], "org.freedesktop.DBus.Properties");
dbus_method("Set", ["string", "string", ["variant"]], [], "org.freedesktop.DBus.Properties");
-=item my $object = Net::DBus::Object->new($service, $path)
+=item my $object = Net::DBus::BaseObject->new($service, $path)
This creates a new DBus object with an path of C<$path>
registered within the service C<$service>. The C<$path>
@@ -144,13 +115,13 @@ parameter should be an instance 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 $object = Net::DBus::Object->new($parentobj, $subpath)
+=item my $object = Net::DBus::BaseObject->new($parentobj, $subpath)
This creates a new DBus child object with an path of C<$subpath>
relative to its parent C<$parentobj>. The C<$subpath>
parameter should be a string complying with the usual
DBus requirements for object paths, while the C<$parentobj>
-parameter should be an instance of L<Net::DBus::Object>.
+parameter should be an instance of L<Net::DBus::BaseObject>.
=cut
@@ -461,21 +432,11 @@ 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;
if ((defined $interface) &&
- ($interface eq "org.freedesktop.DBus.Introspectable")) {
+ ($interface eq "org.freedesktop.DBus.Introspectable")) {
if ($method_name eq "Introspect" &&
$self->_introspector &&
$ENABLE_INTROSPECT) {
@@ -493,32 +454,8 @@ sub _dispatch {
} elsif ($method_name eq "Set") {
$reply = $self->_dispatch_prop_write($connection, $message);
}
- } elsif ($self->_is_method_allowed($method_name)) {
- my $ins = $self->_introspector;
- my @ret = eval {
- my @args;
- if ($ins) {
- @args = $ins->decode($message, "methods", $method_name, "params");
- } else {
- @args = $message->get_args_list;
- }
-
- $self->$method_name(@args);
- };
- if ($@) {
- my $name = UNIVERSAL::isa($@, "Net::DBus::Error") ? $@->name : "org.freedesktop.DBus.Error.Failed";
- my $desc = UNIVERSAL::isa($@, "Net::DBus::Error") ? $@->message : $@;
- $reply = $connection->make_error_message($message,
- $name,
- $desc);
- } else {
- $reply = $connection->make_method_return_message($message);
- if ($ins) {
- $self->_introspector->encode($reply, "methods", $method_name, "returns", @ret);
- } else {
- $reply->append_args_list(@ret);
- }
- }
+ } else {
+ $reply = $self->_dispatch_object($connection, $message);
}
if (!$reply) {
@@ -535,6 +472,26 @@ sub _dispatch {
}
+=item $reply = $object->_dispatch_object($connection, $message);
+
+The C<_dispatch_object> method is to be used to handle dispatch of
+methods implemented by the object. The default implementation is
+a no-op and should be overridden by subclasses todo whatever
+processing is required. If the C<$message> could be handled then
+another C<Net::DBus::Binding::Message> instance should be returned
+for the reply. If C<undef> is returned, then a generic error will
+be returned to the caller.
+
+=cut
+
+sub _dispatch_object {
+ my $self = shift;
+ my $connection = shift;
+ my $message = shift;
+
+ return 0;
+}
+
sub _dispatch_prop_read {
my $self = shift;
my $connection = shift;
@@ -676,28 +633,6 @@ sub _introspector {
return $self->{introspector};
}
-sub _is_method_allowed {
- my $self = shift;
- my $method = shift;
-
- # Disallow any method defined in this specific package, since these
- # are all server-side helpers / internal methods
- return 0 if __PACKAGE__->can($method);
-
- # If this object instance doesn't have it defined, trivially can't
- # allow it
- return 0 unless $self->can($method);
-
- my $ins = $self->_introspector;
- if (defined $ins) {
- # Finally do check against introspection data
- return $ins->is_method_allowed($method);
- }
-
- # No introspector, so have to assume its allowed
- return 1;
-}
-
1;
@@ -715,7 +650,8 @@ Copyright (C) 2005-2011 Daniel P. Berrange
=head1 SEE ALSO
-L<Net::DBus>, L<Net::DBus::Service>, L<Net::DBus::RemoteObject>,
-L<Net::DBus::Exporter>.
+L<Net::DBus>, L<Net::DBus::Service>, L<Net::DBus::Object>,
+L<Net::DBus::ProxyObject>, L<Net::DBus::Exporter>,
+L<Net::DBus::RemoteObject>
=cut
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 41a9d1b..7d06db7 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -20,7 +20,7 @@
=head1 NAME
-Net::DBus::Object - Provide objects to the bus for clients to use
+Net::DBus::Object - Implement objects to export to the bus
=head1 SYNOPSIS
@@ -91,18 +91,13 @@ Net::DBus::Object - Provide objects to the bus for clients to use
=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.
+This the base for implementing objects which are directly exported
+to the bus. The methods implemented in a subclass are mapped to
+methods on the bus. By using this class, an application is directly
+tieing the RPC functionality into its object model. Applications
+may thus prefer to use the C<Net::DBus::ProxyObject> class which
+allows the RPC functionality to be maintained separately from the
+core object model, by proxying RPC method calls.
=head1 METHODS
@@ -115,24 +110,7 @@ package Net::DBus::Object;
use 5.006;
use strict;
use warnings;
-
-our $ENABLE_INTROSPECT;
-
-BEGIN {
- if ($ENV{DBUS_DISABLE_INTROSPECT}) {
- $ENABLE_INTROSPECT = 0;
- } else {
- $ENABLE_INTROSPECT = 1;
- }
-}
-
-use Net::DBus::Exporter "org.freedesktop.DBus.Introspectable";
-
-dbus_method("Introspect", [], ["string"]);
-
-dbus_method("Get", ["string", "string"], [["variant"]], "org.freedesktop.DBus.Properties");
-dbus_method("GetAll", ["string"], [["dict", "string", ["variant"]]], "org.freedesktop.DBus.Properties");
-dbus_method("Set", ["string", "string", ["variant"]], [], "org.freedesktop.DBus.Properties");
+use base qw(Net::DBus::BaseObject);
=item my $object = Net::DBus::Object->new($service, $path)
@@ -150,350 +128,30 @@ This creates a new DBus child object with an path of C<$subpath>
relative to its parent C<$parentobj>. The C<$subpath>
parameter should be a string complying with the usual
DBus requirements for object paths, while the C<$parentobj>
-parameter should be an instance of L<Net::DBus::Object>.
+parameter should be an instance of L<Net::DBus::BaseObject>
+or a subclass.
=cut
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->{interface} = shift;
- $self->{introspector} = undef;
- $self->{introspected} = 0;
- $self->{callbacks} = {};
- $self->{children} = {};
+ my $self = $class->SUPER::new(@_);
bless $self, $class;
- if ($self->{parent}->isa(__PACKAGE__)) {
- $self->{parent}->_register_child($self);
- } else {
- $self->get_service->_register_object($self);
- }
-
return $self;
}
-=item $object->disconnect();
-
-This method disconnects the object from the bus, such that it
-will no longer receive messages sent by other clients. Any
-child objects will be recursively disconnected too. After an
-object has been disconnected, it is possible for Perl to
-garbage collect the object instance. It will also make it
-possible to connect a newly created object to the same path.
-
-=cut
-
-sub disconnect {
- my $self = shift;
-
- return unless $self->{parent};
-
- foreach my $child (keys %{$self->{children}}) {
- $self->_unregister_child($self->{children}->{$child});
- }
-
- if ($self->{parent}->isa(__PACKAGE__)) {
- $self->{parent}->_unregister_child($self);
- } else {
- $self->get_service->_unregister_object($self);
- }
- $self->{parent} = undef;
-}
-
-=item my $bool = $object->is_connected
-
-Returns a true value if the object is connected to the bus,
-and thus capable of being accessed by remote clients. Returns
-false if the object is disconnected & thus ready for garbage
-collection. All objects start off in the connected state, and
-will only transition if the C<disconnect> method is called.
-
-=cut
-
-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);
- $self->{children}->{$object->get_object_path} = $object;
-}
-
-
-sub _unregister_child {
- my $self = shift;
- my $object = shift;
-
- $self->get_service->_unregister_object($object);
- delete $self->{children}->{$object->get_object_path};
-}
-
-# return a list of sub nodes for this object
-sub _get_sub_nodes {
- my $self = shift;
- my %uniq;
-
- my $base = "$self->{object_path}/";
- foreach ( keys( %{$self->{children}} ) ) {
- m/^$base([^\/]+)/;
- $uniq{$1} = 1;
- }
-
- return sort( keys( %uniq ) );
-}
-
-=item my $service = $object->get_service
-
-Retrieves the L<Net::DBus::Service> object within which this
-object is exported.
-
-=cut
-
-sub get_service {
- my $self = shift;
- return $self->{service};
-}
-
-
-=item my $path = $object->get_object_path
-
-Retrieves the path under which this object is exported
-
-=cut
-
-sub get_object_path {
- my $self = shift;
- return $self->{object_path};
-}
-
-=item $object->emit_signal_in($name, $interface, $client, @args);
-
-Emits a signal from the object, with a name of C<$name>. If the
-C<$interface> parameter is defined, the signal will be scoped
-within that interface. If the C<$client> parameter is defined,
-the signal will be unicast to that client on the bus. 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.
-
-=cut
-
-sub emit_signal_in {
- my $self = shift;
- my $name = shift;
- my $interface = shift;
- my $destination = shift;
- my @args = @_;
-
- die "object is disconnected from the bus" unless $self->is_connected;
-
- my $con = $self->get_service->get_bus->get_connection;
-
- my $signal = $con->make_signal_message($self->get_object_path,
- $interface,
- $name);
- if ($destination) {
- $signal->set_destination($destination);
- }
-
- my $ins = $self->_introspector;
- if ($ins) {
- $ins->encode($signal, "signals", $name, "params", @args);
- } else {
- $signal->append_args_list(@args);
- }
- $con->send($signal);
-
- # Short circuit locally registered callbacks
- if (exists $self->{callbacks}->{$interface} &&
- exists $self->{callbacks}->{$interface}->{$name}) {
- my $cb = $self->{callbacks}->{$interface}->{$name};
- &$cb(@args);
- }
-}
-
-=item $self->emit_signal_to($name, $client, @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. The signal will be sent only to the
-client named by the C<$client> parameter.
-
-=cut
-
-sub emit_signal_to {
- my $self = shift;
- my $name = shift;
- my $destination = shift;
- my @args = @_;
-
- my $intro = $self->_introspector;
- if (!$intro) {
- die "no introspection data available for '" . $self->get_object_path .
- "', use the emit_signal_in method instead";
- }
- my @interfaces = $intro->has_signal($name);
- if ($#interfaces == -1) {
- die "no signal with name '$name' is exported in object '" .
- $self->get_object_path . "'\n";
- } elsif ($#interfaces > 0) {
- die "signal '$name' is exported in more than one interface of '" .
- $self->get_object_path . "', use the emit_signal_in method instead.";
- }
- $self->emit_signal_in($name, $interfaces[0], $destination, @args);
-}
-
-=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. The signal will be broadcast to all
-clients on the bus.
-
-=cut
-
-sub emit_signal {
- my $self = shift;
- my $name = shift;
- my @args = @_;
-
- $self->emit_signal_to($name, undef, @args);
-}
-
-=item $object->connect_to_signal_in($name, $interface, $coderef);
-
-Connects a callback to a signal emitted by the object. The C<$name>
-parameter is the name of the signal within the object, and C<$coderef>
-is a reference to an anonymous subroutine. When the signal C<$name>
-is emitted by the remote object, the subroutine C<$coderef> will be
-invoked, and passed the parameters from the signal. The C<$interface>
-parameter is used to specify the explicit interface defining the
-signal to connect to.
-
-=cut
-
-sub connect_to_signal_in {
- my $self = shift;
- 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};
- $self->{callbacks}->{$interface}->{$name} = $code;
-}
-
-=item $object->connect_to_signal($name, $coderef);
-
-Connects a callback to a signal emitted by the object. The C<$name>
-parameter is the name of the signal within the object, and C<$coderef>
-is a reference to an anonymous subroutine. When the signal C<$name>
-is emitted by the remote object, the subroutine C<$coderef> will be
-invoked, and passed the parameters from the signal.
-
-=cut
-
-sub connect_to_signal {
- my $self = shift;
- my $name = shift;
- my $code = shift;
-
- my $ins = $self->_introspector;
- if (!$ins) {
- die "no introspection data available for '" . $self->get_object_path .
- "', use the connect_to_signal_in method instead";
- }
- my @interfaces = $ins->has_signal($name);
-
- if ($#interfaces == -1) {
- die "no signal with name '$name' is exported in object '" .
- $self->get_object_path . "'\n";
- } elsif ($#interfaces > 0) {
- die "signal with name '$name' is exported " .
- "in multiple interfaces of '" . $self->get_object_path . "'" .
- "use the connect_to_signal_in method instead";
- }
-
- $self->connect_to_signal_in($name, $interfaces[0], $code);
-}
-
-
-sub _dispatch {
+sub _dispatch_object {
my $self = shift;
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;
- if ((defined $interface) &&
- ($interface eq "org.freedesktop.DBus.Introspectable")) {
- if ($method_name eq "Introspect" &&
- $self->_introspector &&
- $ENABLE_INTROSPECT) {
- my $xml = $self->_introspector->format($self);
- $reply = $connection->make_method_return_message($message);
-
- $self->_introspector->encode($reply, "methods", $method_name, "returns", $xml);
- }
- } elsif ((defined $interface) &&
- ($interface eq "org.freedesktop.DBus.Properties")) {
- if ($method_name eq "Get") {
- $reply = $self->_dispatch_prop_read($connection, $message);
- } elsif ($method_name eq "GetAll") {
- $reply = $self->_dispatch_all_prop_read($connection, $message);
- } elsif ($method_name eq "Set") {
- $reply = $self->_dispatch_prop_write($connection, $message);
- }
- } elsif ($self->_is_method_allowed($method_name)) {
+ if ($self->_is_method_allowed($method_name)) {
my $ins = $self->_introspector;
my @ret = eval {
my @args;
@@ -521,160 +179,9 @@ sub _dispatch {
}
}
- if (!$reply) {
- $reply = $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "No such method " . ref($self) . "->" . $method_name);
- }
-
- if ($message->get_no_reply()) {
- # Not sending reply
- } else {
- $self->get_service->get_bus->get_connection->send($reply);
- }
-}
-
-
-sub _dispatch_prop_read {
- my $self = shift;
- my $connection = shift;
- my $message = shift;
-
- my $ins = $self->_introspector;
-
- if (!$ins) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "no introspection data exported for properties");
- }
-
- my ($pinterface, $pname) = $ins->decode($message, "methods", "Get", "params");
-
- if (!$ins->has_property($pname, $pinterface)) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "no property '$pname' exported in interface '$pinterface'");
- }
-
- if (!$ins->is_property_readable($pinterface, $pname)) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "property '$pname' in interface '$pinterface' is not readable");
- }
-
- if ($self->can($pname)) {
- my $value = eval {
- $self->$pname;
- };
- if ($@) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "error reading '$pname' in interface '$pinterface': $@");
- } else {
- my $reply = $connection->make_method_return_message($message);
-
- $self->_introspector->encode($reply, "methods", "Get", "returns", $value);
- return $reply;
- }
- } else {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "no method to read property '$pname' in interface '$pinterface'");
- }
-}
-
-sub _dispatch_all_prop_read {
- my $self = shift;
- my $connection = shift;
- my $message = shift;
-
- my $ins = $self->_introspector;
-
- if (!$ins) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "no introspection data exported for properties");
- }
-
- my ($pinterface) = $ins->decode($message, "methods", "Get", "params");
-
- my %values = ();
- foreach my $pname ($ins->list_properties($pinterface)) {
- unless ($ins->is_property_readable($pinterface, $pname)) {
- next; # skip write-only properties
- }
-
- $values{$pname} = eval {
- $self->$pname;
- };
- if ($@) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "error reading '$pname' in interface '$pinterface': $@");
- }
- }
-
- my $reply = $connection->make_method_return_message($message);
-
- $self->_introspector->encode($reply, "methods", "Get", "returns", \%values);
return $reply;
}
-sub _dispatch_prop_write {
- my $self = shift;
- my $connection = shift;
- my $message = shift;
-
- my $ins = $self->_introspector;
-
- if (!$ins) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "no introspection data exported for properties");
- }
-
- my ($pinterface, $pname, $pvalue) = $ins->decode($message, "methods", "Set", "params");
-
- if (!$ins->has_property($pname, $pinterface)) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "no property '$pname' exported in interface '$pinterface'");
- }
-
- if (!$ins->is_property_writable($pinterface, $pname)) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "property '$pname' in interface '$pinterface' is not writable");
- }
-
- if ($self->can($pname)) {
- eval {
- $self->$pname($pvalue);
- };
- if ($@) {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "error writing '$pname' in interface '$pinterface': $@");
- } else {
- return $connection->make_method_return_message($message);
- }
- } else {
- return $connection->make_error_message($message,
- "org.freedesktop.DBus.Error.Failed",
- "no method to write property '$pname' in interface '$pinterface'");
- }
-}
-
-
-sub _introspector {
- my $self = shift;
-
- if (!$self->{introspected}) {
- $self->{introspector} = Net::DBus::Exporter::_dbus_introspector(ref($self));
- $self->{introspected} = 1;
- }
- return $self->{introspector};
-}
sub _is_method_allowed {
my $self = shift;
@@ -715,7 +222,8 @@ Copyright (C) 2005-2011 Daniel P. Berrange
=head1 SEE ALSO
-L<Net::DBus>, L<Net::DBus::Service>, L<Net::DBus::RemoteObject>,
-L<Net::DBus::Exporter>.
+L<Net::DBus>, L<Net::DBus::Service>, L<Net::DBus::BaseObject>,
+L<Net::DBus::ProxyObject>, L<Net::DBus::Exporter>,
+L<Net::DBus::RemoteObject>
=cut
--
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