Net-DBus
view release on metacpan or search on metacpan
- Remove obsolete XML::Grove dep from spec
- Fix GIT repo location
- Fix misc typos in POD
- Make reactor robust to time going backwards
- Add GIT repo & bug tracker to Makefile.PL
- Fix basepath when enumerating subnodes
- Fix child paths in introspection XML to be relative
- Support passing UNIX file descriptors
- Fix encoding of properties via GetAll method
- Add return & param names for standard interface introspection
- Use org.freedesktop.DBus.Error.UnknownMethod error code
- Fix reactor add_exception method
- Enable exporting objects on the root node
- Fix introspection decode with zero parameters
- Validate parameters for standard methods
- Validate object interface against declared method
- Don't include MYMETA.* files in dist
- Fix passing nomainloop parameter to constructor
- Fix variant type in mock iterator
1.1.0 2015-03-16
- Make introspection much more tolerant of missing information
about methods/properties/signals.
- Fix use of magic values & added tests
- Export the Net::DBus::Dumper methods correctly.
0.33.4 2006-11-04
- Fixed service owner used for org.freedesktop.DBus object
to make signal handling on the bus work again
- Pass return value for signal handling callbacks all the
way back to DBus
- Fix multiple problems with marshalling of variant data
types
- Replace use of dbus_connection_disconnect with _close
when compiling against dbus >= 0.90
- Call dbus_connection_unref in the DESTROY method of
connection object
- Fix reference counting in connection & pending call
objects
- Added example of galago desktop notifications
- Fix test suite errors
- Added missing import statement
- Throw Net::DBus::Error if an async call fails
0.33.3 2006-07-05
- Fixed parsing of introspection data if there are processing
- Made all Perl scripts / modules / tests use 'strict' and
'warnings' pragmas
- Turn Net::DBus::Error into fully fledged object which services
can sub-class to allow explicit error handling by clients.
- In _dispatch method of Net::DBus::Object ensure that any
instances of Net::DBus::Error thrown by the method call
are explicitly serialized into DBus errors, rather than
a generic 'org.freedesktop.DBus.Failed'.
- Change re-distribution license from GPL, to GPL / Perl Artistic,
matching the terms of Perl itself.
- Add support for registering a callback on Net::DBus::ASyncReply
objects to allow notification of completion for asynchronous
method calls
0.33.2 2006-06-03
- Re-add dbus_XXX convenience methods to Net::DBus to allow
clients to do explicit type casting. Must be requested at
export time, using 'Net::DBus qw(:typing)'.
- Update all example programs to run against session bus,
since there are no security rules to enable them to work
on system bus.
- Print out warning upon use, if a method, signal, or property
is annotated with the 'org.freedesktop.DBus.Deprecated' flag.
- Do not wait for a method reply if the method is annotated
with the 'org.freedesktop.DBus.Method.NoReply' flag.
- Extend Net::DBus::Exporter to enable methods, signals, and
properties to be annotated.
- Add support for 'org.freedesktop.DBus.Method.NoReply' and
'org.freedesktop.DBus.Deprecated' annotations when exporting
objects
- Add a pure in-memory bus implementation for facilitating
creation of unit tests which would otherwise require making
a connection to a 'live' message bus. Can be accessed via:
Net::DBus->test
- Add an *EXPERIMENTAL* mock object to faciltate creation of
unit tests which need to communicate with other objects on
the bus. See Net::DBus::Test::MockObject for further info.
0.32.2 2005-10-23
- Fix unit tests broken in previous build
- Added patch to avoid leaking memory when throwing dbus
errors from the XS layer
- Added support for org.freedesktop.DBus.Properties
in exported & remote objects.
- Added support for getting the unique name of the client's
connection to the bus
- Added support for getting the unique name of the client
owning a service on the bus
- RemoteService object constructor gains an extra parameter
for the owner of the service at the time it was aquired to
requires:
Time::HiRes: 0
XML::Twig: 0
build_requires:
Test::More: 0
Test::Pod: 0
Test::Pod::Coverage: 0
resources:
license: http://dev.perl.org/licenses/
homepage: http://www.freedesktop.org/wiki/Software/dbus
repository: https://gitlab.com/berrange/perl-net-dbus
MailingList: http://lists.freedesktop.org/mailman/listinfo/dbus/
distribution_type: module
meta-spec:
version: 1.3
url: http://module-build.sourceforge.net/META-spec-v1.3.html
META.yml.PL view on Meta::CPAN
requires:
Time::HiRes: 0
XML::Twig: 0
build_requires:
Test::More: 0
Test::Pod: 0
Test::Pod::Coverage: 0
resources:
license: http://dev.perl.org/licenses/
homepage: http://www.freedesktop.org/wiki/Software/dbus
repository: https://gitlab.com/berrange/perl-net-dbus
MailingList: http://lists.freedesktop.org/mailman/listinfo/dbus/
distribution_type: module
meta-spec:
version: 1.3
url: http://module-build.sourceforge.net/META-spec-v1.3.html
Net::DBus
=========
Net::DBus provides a Perl XS API to the dbus inter-application
messaging system. The Perl API covers the core base level
of the dbus APIs, not concerning itself yet with the GLib
or QT wrappers. For more information on dbus visit the
project website at:
http://www.freedesktop.org/software/dbus/
The homepage for Net::DBus is
https://metacpan.org/pod/Net::DBus
Please report bugs at
https://gitlab.com/berrange/perl-net-dbus/issues
The primary GIT repository for Net::DBus is
examples/lshal.pl view on Meta::CPAN
#!/usr/bin/perl -w
use strict;
use Net::DBus;
my $bus = Net::DBus->system;
# Get a handle to the HAL service
my $hal = $bus->get_service("org.freedesktop.Hal");
# Get the device manager
my $manager = $hal->get_object("/org/freedesktop/Hal/Manager", "org.freedesktop.Hal.Manager");
print "Warning. There may be a slight pause while this next\n";
print "method times out, if your version of HAL still just\n";
print "silently ignores unsupported method calls, rather than\n";
print "returning an error. The timeout is ~60 seconds\n";
# List devices
foreach my $dev (sort { $a cmp $b } @{$manager->GetAllDevices}) {
print $dev, "\n";
}
examples/notification.pl view on Meta::CPAN
#!/usr/bin/perl
use Net::DBus qw(:typing);
my $bus = Net::DBus->session;
my $svc = $bus->get_service("org.freedesktop.Notifications");
my $obj = $svc->get_object("/org/freedesktop/Notifications");
$obj->Notify("notification.pl",
0,
'',
"Demo notification",
"Demonstrating using of desktop\n" .
"notifications from Net::DBus\n",
["done", "Done"],
{"desktop-entry" => "virt-manager", x => dbus_variant(dbus_int32(200)), y => dbus_variant(dbus_int32(200))},
2_000);
lib/Net/DBus.pm view on Meta::CPAN
# ... or explicitly go for the session bus
my $bus = Net::DBus->session;
# .... or explicitly go for the system bus
my $bus = Net::DBus->system
######## Accessing remote services #########
# Get a handle to the HAL service
my $hal = $bus->get_service("org.freedesktop.Hal");
# Get the device manager
my $manager = $hal->get_object("/org/freedesktop/Hal/Manager",
"org.freedesktop.Hal.Manager");
# List devices
foreach my $dev (@{$manager->GetAllDevices}) {
print $dev, "\n";
}
######### Providing services ##############
# Register a service known as 'org.example.Jukebox'
lib/Net/DBus.pm view on Meta::CPAN
unless ($params{nomainloop}) {
if (exists $INC{'Net/DBus/Reactor.pm'}) {
my $reactor = $params{reactor} ? $params{reactor} : Net::DBus::Reactor->main;
$reactor->manage($self->get_connection);
}
# ... Add support for GLib and POE
}
$self->get_connection->add_filter(sub { return $self->_signal_func(@_); });
$self->{bus} = $self->{services}->{"org.freedesktop.DBus"} =
Net::DBus::RemoteService->new($self, "org.freedesktop.DBus", "org.freedesktop.DBus");
$self->get_bus_object()->connect_to_signal('NameOwnerChanged', sub {
my ($svc, $old, $new) = @_;
# Slightly evil poking into the private 'owner_name' field here
if (exists $self->{services}->{$svc}) {
$self->{services}->{$svc}->{owner_name} = $new;
}
});
return $self;
}
lib/Net/DBus.pm view on Meta::CPAN
Retrieves a handle for the remote service identified by the
service name C<$name>. The returned object will be an instance
of the L<Net::DBus::RemoteService> class.
=cut
sub get_service {
my $self = shift;
my $name = shift;
if ($name eq "org.freedesktop.DBus") {
return $self->{bus};
}
if (!exists $self->{services}->{$name}) {
my $owner = $name;
if ($owner !~ /^:/) {
$owner = $self->get_service_owner($name);
if (!defined $owner) {
$self->get_bus_object->StartServiceByName($name, 0);
$owner = $self->get_service_owner($name);
lib/Net/DBus.pm view on Meta::CPAN
=cut
sub export_service {
my $self = shift;
my $name = shift;
return Net::DBus::Service->new($self, $name);
}
=item my $object = $bus->get_bus_object;
Retrieves a handle to the bus object, C</org/freedesktop/DBus>,
provided by the service C<org.freedesktop.DBus>. The returned
object is an instance of L<Net::DBus::RemoteObject>
=cut
sub get_bus_object {
my $self = shift;
my $service = $self->get_service("org.freedesktop.DBus");
return $service->get_object('/org/freedesktop/DBus',
'org.freedesktop.DBus');
}
=item my $name = $bus->get_unique_name;
Retrieves the unique name of this client's connection to
the bus.
=cut
lib/Net/DBus.pm view on Meta::CPAN
sub get_service_owner {
my $self = shift;
my $service = shift;
my $bus = $self->get_bus_object;
my $owner = eval {
$bus->GetNameOwner($service);
};
if ($@) {
if (UNIVERSAL::isa($@, "Net::DBus::Error") &&
$@->{name} eq "org.freedesktop.DBus.Error.NameHasNoOwner") {
$owner = undef;
} else {
die $@;
}
}
return $owner;
}
=item my $timeout = $bus->timeout(60 * 1000);
lib/Net/DBus.pm view on Meta::CPAN
=pod
=back
=head1 SEE ALSO
L<Net::DBus>, L<Net::DBus::RemoteService>, L<Net::DBus::Service>,
L<Net::DBus::RemoteObject>, L<Net::DBus::Object>,
L<Net::DBus::Exporter>, L<Net::DBus::Dumper>, L<Net::DBus::Reactor>,
C<dbus-monitor(1)>, C<dbus-daemon-1(1)>, C<dbus-send(1)>, L<http://dbus.freedesktop.org>,
=head1 AUTHOR
Daniel Berrange <dan@berrange.com>
=head1 COPYRIGHT
Copyright 2004-2011 by Daniel Berrange
=cut
lib/Net/DBus/BaseObject.pm view on Meta::CPAN
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, 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
lib/Net/DBus/BaseObject.pm view on Meta::CPAN
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"], {return_names => ["xml_data"]});
dbus_method("Get", ["string", "string"], [["variant"]], "org.freedesktop.DBus.Properties", {return_names => ["value"], param_names => ["interface_name", "property_name"]});
dbus_method("GetAll", ["string"], [["dict", "string", ["variant"]]], "org.freedesktop.DBus.Properties", {return_names => ["properties"], param_names => ["interface_name"]});
dbus_method("Set", ["string", "string", ["variant"]], [], "org.freedesktop.DBus.Properties", {param_names => ["interface_name", "property_name", "value"]});
=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>
parameter should be a string complying with the usual
DBus requirements for object paths, while the C<$service>
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.
lib/Net/DBus/BaseObject.pm view on Meta::CPAN
sub _dispatch {
my $self = shift;
my $connection = shift;
my $message = shift;
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) {
if ($message->get_args_list) {
$reply = $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"too many parameters for method 'Introspect'");
} else {
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);
}
} else {
$reply = $self->_dispatch_object($connection, $message);
}
if (!$reply) {
$reply = $connection->make_error_message($message,
"org.freedesktop.DBus.Error.UnknownMethod",
"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);
}
}
lib/Net/DBus/BaseObject.pm view on Meta::CPAN
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, @pargs) = eval { $ins->decode($message, "methods", "Get", "params") };
if ($@) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"$@");
}
if (@pargs) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"too many parameters for method 'Get'");
}
if (not defined $pinterface) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"no interface was specified");
}
if (not defined $pname) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"no property was specified for interface '$pinterface'");
}
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");
}
my $value = eval {
$self->_dispatch_property($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;
}
}
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, @pargs) = eval { $ins->decode($message, "methods", "GetAll", "params") };
if ($@) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"$@");
}
if (@pargs) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"too many parameters for method 'GetAll'");
}
if (not defined $pinterface) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"no interface was specified");
}
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->_dispatch_property($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", "GetAll", "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, @pargs) = eval { $ins->decode($message, "methods", "Set", "params") };
if ($@) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"$@");
}
if (@pargs) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"too many parameters for method 'Set'");
}
if (not defined $pinterface) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"no interface was specified");
}
if (not defined $pname) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"no property was specified for interface '$pinterface'");
}
if (not defined $pvalue) {
return $connection->make_error_message($message,
"org.freedesktop.DBus.Error.Failed",
"no value was specified for property '$pname' in interface '$pinterface'");
}
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");
}
eval {
$self->_dispatch_property($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);
}
}
sub _introspector {
my $self = shift;
lib/Net/DBus/Binding/Introspector.pm view on Meta::CPAN
$self->{object_path} = exists $params{object_path} ? $params{object_path} : undef;
$self->{interfaces} = $params{interfaces} if exists $params{interfaces};
$self->{children} = exists $params{children} ? $params{children} : [];
}
$self->{strict} = exists $params{strict} ? $params{strict} : 0;
# Some versions of dbus failed to include signals in introspection data
# so this code adds them, letting us keep compatability with old versions
if (defined $self->{object_path} &&
$self->{object_path} eq "/org/freedesktop/DBus") {
if (!$self->has_signal("NameOwnerChanged")) {
$self->add_signal("NameOwnerChanged", ["string","string","string"], "org.freedesktop.DBus");
}
if (!$self->has_signal("NameLost")) {
$self->add_signal("NameLost", ["string"], "org.freedesktop.DBus");
}
if (!$self->has_signal("NameAcquired")) {
$self->add_signal("NameAcquired", ["string"], "org.freedesktop.DBus");
}
}
return $self;
}
=item $ins->add_interface($name)
Register the object as providing an interface with the name C<$name>
lib/Net/DBus/Binding/Introspector.pm view on Meta::CPAN
push @paramnames, $name;
} elsif ($direction eq "out") {
push @returns, @type;
push @returnnames, $name;
}
}
foreach my $child ($node->children("annotation")) {
my $name = $child->att("name");
my $value = $child->att("value");
if ($name eq "org.freedesktop.DBus.Deprecated") {
$deprecated = 1 if lc($value) eq "true";
} elsif ($name eq "org.freedesktop.DBus.Method.NoReply") {
$no_reply = 1 if lc($value) eq "true";
}
}
$self->{interfaces}->{$interface}->{methods}->{$name} = {
params => \@params,
returns => \@returns,
no_reply => $no_reply,
deprecated => $deprecated,
paramnames => \@paramnames,
lib/Net/DBus/Binding/Introspector.pm view on Meta::CPAN
my $name = $child->att("name");
my @sig = split //, $type;
my @type = $self->_parse_type(\@sig);
push @params, @type;
push @paramnames, $name;
}
foreach my $child ($node->children("annotation")) {
my $name = $child->att("name");
my $value = $child->att("value");
if ($name eq "org.freedesktop.DBus.Deprecated") {
$deprecated = 1 if lc($value) eq "true";
}
}
$self->{interfaces}->{$interface}->{signals}->{$name} = {
params => \@params,
paramnames => \@paramnames,
deprecated => $deprecated,
};
}
lib/Net/DBus/Binding/Introspector.pm view on Meta::CPAN
my $interface = shift;
my $name = $node->att("name");
my $access = $node->att("access");
my $deprecated = 0;
foreach my $child ($node->children("annotation")) {
my $name = $child->att("name");
my $value = $child->att("value");
if ($name eq "org.freedesktop.DBus.Deprecated") {
$deprecated = 1 if lc($value) eq "true";
}
}
my @sig = split //, $node->att("type");
$self->{interfaces}->{$interface}->{props}->{$name} = {
type => $self->_parse_type(\@sig),
access => $access,
deprecated => $deprecated,
};
}
lib/Net/DBus/Binding/Introspector.pm view on Meta::CPAN
state of the introspection data. The optional C<$obj> parameter
can be an instance of L<Net::DBus::Object> to include object
specific information in the XML (eg child nodes).
=cut
sub format {
my $self = shift;
my $obj = shift;
my $xml = '<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"' . "\n";
$xml .= '"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">' . "\n";
return $xml . $self->to_xml("", $obj);
}
=item my $xml_fragment = $ins->to_xml
Returns a string containing an XML fragment representing the
state of the introspection data. This is basically the same
as the C<format> method, but without the leading doctype
declaration.
lib/Net/DBus/Binding/Introspector.pm view on Meta::CPAN
$xml .= $indent . ' <arg ' . (@paramnames ? shift(@paramnames) : "")
. 'type="' . $self->to_xml_type($type) . '" direction="in"/>' . "\n";
}
foreach my $type (@{$method->{returns}}) {
next if ! ref($type) && exists $magic_type_map{$type};
$xml .= $indent . ' <arg ' . (@returnnames ? shift(@returnnames) : "")
. 'type="' . $self->to_xml_type($type) . '" direction="out"/>' . "\n";
}
if ($method->{deprecated}) {
$xml .= $indent . ' <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
}
if ($method->{no_reply}) {
$xml .= $indent . ' <annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>' . "\n";
}
$xml .= $indent . ' </method>' . "\n";
}
foreach my $sname (sort { $a cmp $b } keys %{$interface->{signals}}) {
my $signal = $interface->{signals}->{$sname};
$xml .= $indent . ' <signal name="' . $sname . '">' . "\n";
my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$signal->{paramnames}} );
foreach my $type (@{$signal->{params}}) {
next if ! ref($type) && exists $magic_type_map{$type};
$xml .= $indent . ' <arg ' . (@paramnames ? shift(@paramnames) : "")
. 'type="' . $self->to_xml_type($type) . '"/>' . "\n";
}
if ($signal->{deprecated}) {
$xml .= $indent . ' <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
}
$xml .= $indent . ' </signal>' . "\n";
}
foreach my $pname (sort { $a cmp $b } keys %{$interface->{props}}) {
my $prop = $interface->{props}->{$pname};
my $type = $interface->{props}->{$pname}->{type};
my $access = $interface->{props}->{$pname}->{access};
if ($prop->{deprecated}) {
$xml .= $indent . ' <property name="' . $pname . '" type="' .
$self->to_xml_type($type) . '" access="' . $access . '">' . "\n";
$xml .= $indent . ' <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
$xml .= $indent . ' </property>' . "\n";
} else {
$xml .= $indent . ' <property name="' . $pname . '" type="' .
$self->to_xml_type($type) . '" access="' . $access . '"/>' . "\n";
}
}
$xml .= $indent . ' </interface>' . "\n";
}
lib/Net/DBus/Dumper.pm view on Meta::CPAN
use Net::DBus::Dumper;
use Net::DBus;
# Dump out info about the bus
my $bus = Net::DBus->find;
print dbus_dump($bus);
# Dump out info about a service
my $service = $bus->get_service("org.freedesktop.DBus");
print dbus_dump($service);
# Dump out info about an object
my $object = $service->get_object("/org/freedesktop/DBus");
print dbus_dump($object);
=head1 DESCRIPTION
This module serves as a debugging aid, providing a means to stringify
a DBus related object in a form suitable for printing out. It can
stringify any of the Net::DBus:* objects, generating the following
information for each
=over 4
lib/Net/DBus/Dumper.pm view on Meta::CPAN
return @objects;
}
sub _dbus_dump_bus {
my $bus = shift;
my @data;
push @data, "Bus: \n";
my $dbus = $bus->get_service("org.freedesktop.DBus");
my $obj = $dbus->get_object("/org/freedesktop/DBus");
my $names = $obj->ListNames();
foreach (sort { $a cmp $b } @{$names}) {
push @data, " Service: ", $_, "\n";
}
return @data;
}
1;
lib/Net/DBus/Error.pm view on Meta::CPAN
=head1 DESCRIPTION
This objects provides for strongly typed error handling. Normally
a service would simply call
die "some message text"
When returning the error condition to the calling DBus client, the
message is associated with a generic error code or "org.freedesktop.DBus.Failed".
While this suffices for many applications, occasionally it is desirable
to be able to catch and handle specific error conditions. For such
scenarios the service should create subclasses of the C<Net::DBus::Error>
object providing in a custom error name. This error name is then sent back
to the client instead of the genreic "org.freedesktop.DBus.Failed" code.
=head1 METHODS
=over 4
=cut
package Net::DBus::Error;
use strict;
lib/Net/DBus/Object.pm view on Meta::CPAN
my $reply;
my $method_name = $message->get_member;
my $interface = $message->get_interface;
if ($self->_is_method_allowed($method_name)) {
my $ins = $self->_introspector;
my @ret = eval {
my @args;
if ($ins) {
if (defined $interface and not $ins->has_interface($interface)) {
die Net::DBus::Error->new(name => 'org.freedesktop.DBus.Error.UnknownMethod',
message => "object does not provide interface '$interface'");
}
@args = $ins->decode($message, "methods", $method_name, "params");
($interface) = $ins->has_method($method_name) unless defined $interface;
if (defined $interface && scalar @args != scalar $ins->get_method_params($interface, $method_name)) {
die Net::DBus::Error->new(name => 'org.freedesktop.DBus.Error.Failed',
message => "incorrect number of parameters for method '$method_name' in interface '$interface'");
}
} else {
@args = $message->get_args_list;
}
$self->$method_name(@args);
};
if ($@) {
if (defined($interface) &&
$ins && $ins->method_has_strict_exceptions($method_name, $interface) &&
!UNIVERSAL::isa($@, "Net::DBus::Error")) {
die($@);
}
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);
lib/Net/DBus/ProxyObject.pm view on Meta::CPAN
my $reply;
my $method_name = $message->get_member;
my $interface = $message->get_interface;
if ($self->_is_method_allowed($method_name)) {
my $ins = $self->_introspector;
my @ret = eval {
my @args;
if ($ins) {
if (defined $interface and not $ins->has_interface($interface)) {
die Net::DBus::Error->new(name => 'org.freedesktop.DBus.Error.UnknownMethod',
message => "object does not provide interface '$interface'");
}
@args = $ins->decode($message, "methods", $method_name, "params");
($interface) = $ins->has_method($method_name) unless defined $interface;
if (defined $interface && scalar @args != scalar $ins->get_method_params($interface, $method_name)) {
die Net::DBus::Error->new(name => 'org.freedesktop.DBus.Error.Failed',
message => "incorrect number of parameters for method '$method_name' in interface '$interface'");
}
} else {
@args = $message->get_args_list;
}
$self->{impl}->$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);
lib/Net/DBus/RemoteObject.pm view on Meta::CPAN
# details of the terms and conditions of the two licenses.
=pod
=head1 NAME
Net::DBus::RemoteObject - Access objects provided on the bus
=head1 SYNOPSIS
my $service = $bus->get_service("org.freedesktop.DBus");
my $object = $service->get_object("/org/freedesktop/DBus");
print "Names on the bus {\n";
foreach my $name (sort @{$object->ListNames}) {
print " ", $name, "\n";
}
print "}\n";
=head1 DESCRIPTION
This module provides the API for accessing remote objects available
lib/Net/DBus/RemoteObject.pm view on Meta::CPAN
# them too.
#
# END WARNING
#
=item my $object = Net::DBus::RemoteObject->new($service, $object_path[, $interface], \%params);
Creates a new handle to a remote object. The C<$service> parameter is an instance
of the L<Net::DBus::RemoteService> method, and C<$object_path> is the identifier of
an object exported by this service, for example C</org/freedesktop/DBus>. For remote
objects which implement more than one interface it is possible to specify an optional
name of an interface as the third parameter. This is only really required, however, if
two interfaces in the object provide methods with the same name, since introspection
data can be used to automatically resolve the correct interface to call cases where
method names are unique. Rather than using this constructor directly, it is preferable
to use the C<get_object> method on L<Net::DBus::RemoteService>, since this caches handles
to remote objects, eliminating unnecessary introspection data lookups.
The C<%params> parameter contains extra configuration parameters for the object. Currently
a single parameter is supported, C<timeout> which takes a value in milliseconds to use as
lib/Net/DBus/RemoteObject.pm view on Meta::CPAN
sub _net_dbus_introspector {
my $self = shift;
unless ($self->{introspected}) {
my $con = $self->{service}->get_bus()->get_connection();
my $call = $con->make_method_call_message($self->{service}->get_service_name(),
$self->{object_path},
"org.freedesktop.DBus.Introspectable",
"Introspect");
my $xml = eval {
my $reply = $con->send_with_reply_and_block($call, 60 * 1000);
my $iter = $reply->iterator;
return $iter->get(&Net::DBus::Binding::Message::TYPE_STRING);
};
if ($@) {
if (UNIVERSAL::isa($@, "Net::DBus::Error") &&
($@->{name} eq "org.freedesktop.DBus.Error.ServiceUnknown" ||
$@->{name} eq "org.freedesktop.DBus.Error.NoReply")) {
die $@;
} else {
# Ignore other failures, since its probably
# just that the object doesn't implement
# the introspect method. Of course without
# the introspect method we can't tell for sure
# if this is the case..
#warn "could not introspect object: $@";
}
}
lib/Net/DBus/RemoteObject.pm view on Meta::CPAN
$name, $interface, 1,
@_);
}
if ($ins->has_property($name, $interface)) {
if ($ins->is_property_deprecated($name, $interface)) {
warn "property $name in interface $interface on " . $self->get_object_path . " is deprecated";
}
if (@_) {
$self->_net_dbus_call_method($mode, $timeout,
"Set", "org.freedesktop.DBus.Properties", 1,
$interface, $name, $_[0]);
return ();
} else {
return $self->_net_dbus_call_method($mode, $timeout,
"Get", "org.freedesktop.DBus.Properties", 1,
$interface, $name);
}
}
} else {
my @interfaces = $ins->has_method($name);
if (@interfaces) {
if ($#interfaces > 0) {
die "method with name '$name' is exported " .
"in multiple interfaces of '" . $self->get_object_path . "'";
lib/Net/DBus/RemoteObject.pm view on Meta::CPAN
if ($#interfaces > 0) {
die "property with name '$name' is exported " .
"in multiple interfaces of '" . $self->get_object_path . "'";
}
$interface = $interfaces[0];
if ($ins->is_property_deprecated($name, $interface)) {
warn "property $name in interface $interface on " . $self->get_object_path . " is deprecated";
}
if (@_) {
$self->_net_dbus_call_method($mode, $timeout,
"Set", "org.freedesktop.DBus.Properties", 1,
$interface, $name, $_[0]);
return ();
} else {
return $self->_net_dbus_call_method($mode, $timeout,
"Get", "org.freedesktop.DBus.Properties", 1,
$interface, $name);
}
}
}
}
if (!$interface) {
die "no introspection data available for method '" . $name . "' in object '" .
$self->get_object_path . "', and object is not cast to any interface";
}
lib/Net/DBus/RemoteService.pm view on Meta::CPAN
=pod
=head1 NAME
Net::DBus::RemoteService - Access services provided on the bus
=head1 SYNOPSIS
my $bus = Net::DBus->find;
my $service = $bus->get_service("org.freedesktop.DBus");
my $object = $service->get_object("/org/freedesktop/DBus");
foreach (@{$object->ListNames}) {
print "$_\n";
}
=head1 DESCRIPTION
This object provides a handle to a remote service on the
bus. From this handle it is possible to access objects
associated with the service. If a service is not running,
an attempt will be made to activate it the first time a
lib/Net/DBus/RemoteService.pm view on Meta::CPAN
use Net::DBus::RemoteObject;
=item my $service = Net::DBus::RemoteService->new($bus, $owner, $service_name);
Creates a new handle for a remote service. The C<$bus> parameter is an
instance of L<Net::DBus>, C<$owner> is the name of the client providing the
service, while C<$service_name> is the well known name of the service on
the bus. Service names consist of two or more tokens, separated
by periods, while the tokens comprise the letters a-z, A-Z, 0-9 and _,
for example C<org.freedesktop.DBus>. There is generally no need to call
this constructor, instead the C<get_service> method on L<Net::DBus> should
be used. This caches handles to remote services, eliminating repeated
retrieval of introspection data.
=cut
sub new {
my $class = shift;
my $self = {};
lib/Net/DBus/Test/MockConnection.pm view on Meta::CPAN
my $cb = $self->{objects}->{$msg->get_path};
&$cb($self, $msg);
} 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 = $self->make_method_return_message($msg);
my $iter = $reply->iterator(1);
$iter->append(":1.1");
$self->send($reply);
}
}
}
}
lib/Net/DBus/Test/MockObject.pm view on Meta::CPAN
=head1 SYNOPSIS
use Net::DBus;
use Net::DBus::Test::MockObject;
my $bus = Net::DBus->test
# Lets fake presence of HAL...
# First we need to define the service
my $service = $bus->export_service("org.freedesktop.Hal");
# Then create a mock object
my $object = Net::DBus::Test::MockObject->new($service,
"/org/freedesktop/Hal/Manager");
# Fake the 'GetAllDevices' method
$object->seed_action("org.freedesktop.Hal.Manager",
"GetAllDevices",
reply => {
return => [ "/org/freedesktop/Hal/devices/computer_i8042_Aux_Port",
"/org/freedesktop/Hal/devices/computer_i8042_Aux_Port_logicaldev_input",
"/org/freedesktop/Hal/devices/computer_i8042_Kbd_Port",
"/org/freedesktop/Hal/devices/computer_i8042_Kbd_Port_logicaldev_input"
],
});
# Now can test any class which calls out to 'GetAllDevices' in HAL
....test stuff....
=head1 DESCRIPTION
This provides an alternate for L<Net::DBus::Object> to enable bus
lib/Net/DBus/Test/MockObject.pm view on Meta::CPAN
my $connection = shift;
my $message = shift;
my $interface = $message->get_interface;
my $method = $message->get_member;
my $con = $self->get_service->get_bus->get_connection;
if (!exists $self->{actions}->{$method}) {
my $error = $con->make_error_message($message,
"org.freedesktop.DBus.Failed",
"no action seeded for method " . $message->get_member);
$con->send($error);
return;
}
my $action;
if ($interface) {
if (!exists $self->{actions}->{$method}->{$interface}) {
my $error = $con->make_error_message($message,
"org.freedesktop.DBus.Failed",
"no action with correct interface seeded for method " . $message->get_member);
$con->send($error);
return;
}
$action = $self->{actions}->{$method}->{$interface};
} else {
my @interfaces = keys %{$self->{actions}->{$method}};
if ($#interfaces > 0) {
my $error = $con->make_error_message($message,
"org.freedesktop.DBus.Failed",
"too many actions seeded for method " . $message->get_member);
$con->send($error);
return;
}
$action = $self->{actions}->{$method}->{$interfaces[0]};
}
if (exists $action->{signals}) {
my $sigs = $action->{signals};
if (ref($sigs) ne "ARRAY") {
lib/Net/DBus/Tutorial.pod view on Meta::CPAN
of calling methods on remote objects, explicitly calling methods
in particular interfaces, listening for signals.
NB This tutorial is yet to be written.
=back
=head1 SEE ALSO
L<Net::DBus>, L<Net::DBus::Object>, L<Net::DBus::RemoteObject>,
L<http://freedesktop.org/>
=head1 AUTHORS
Daniel P. Berrange L<mailto:dan@berrange.com>
=head1 COPYRIGHT
Copyright 2005 Daniel P. Berrange
=cut
lib/Net/DBus/Tutorial/ExportingObjects.pod view on Meta::CPAN
my $self = $class->SUPER::new($bus, "org.cpan.music.player");
bless $self, $class;
$self->{manager} = Music::Player::Manager->new($self);
return $self;
}
The L<Net::DBus::Service> automatically provides one special
object to all services, under the path C</org/freedesktop/DBus/Exporter>.
This object implements the C<org.freedesktop.DBus.Exporter> interface
which has a method C<ListObject>. This enables clients to determine
a list of all objects exported within a service. While not functionally
necessary for most applications, it is none-the-less a useful tool for
developers debugging applications, or wondering what a service provides.
=head1 CONNECTING TO THE BUS
The final step in getting our service up and running is to connect it
to the bus. This brings up an interesting conundrum, does one export
the service on the system bus (shared by all users & processes on the
t/40-introspector.t view on Meta::CPAN
"parents" => { type => ["array", "string"], access => "readwrite" },
},
}
});
isa_ok($other_object, "Net::DBus::Binding::Introspector");
my $other_xml_got = $other_object->format();
my $other_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.example.SomeInterface">
<method name="goodbye">
<arg name="ooh" type="a(is)" direction="in"/>
<arg name="ahh" type="s" direction="out"/>
<arg name="eek" type="s" direction="out"/>
</method>
<method name="hello">
<arg name="wibble" type="i" direction="in"/>
<arg name="eek" type="i" direction="in"/>
t/40-introspector.t view on Meta::CPAN
children => [
"org.example.Object.SubObject",
$other_object,
]);
isa_ok($object, "Net::DBus::Binding::Introspector");
my $object_xml_got = $object->format();
my $object_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">
<interface name="org.example.OtherInterface">
<method name="hitme">
<arg type="i" direction="in"/>
<arg type="u" direction="in"/>
</method>
<property name="salary" type="i" access="read"/>
<property name="title" type="s" access="readwrite"/>
</interface>
<interface name="org.example.SomeInterface">
t/42-object-introspect-avahi.t view on Meta::CPAN
use strict;
use warnings;
BEGIN {
use_ok('Net::DBus::Binding::Introspector');
};
local $/ = undef;
my $xml = <DATA>;
my $introspector = Net::DBus::Binding::Introspector->new(object_path => "/org/freedesktop/Avahi/ServiceBrowser",
xml => $xml);
isa_ok($introspector, "Net::DBus::Binding::Introspector");
ok($introspector->has_interface("org.freedesktop.DBus.Introspectable"),
"org.freedesktop.DBus.Introspectable interface present");
ok($introspector->has_interface("org.freedesktop.Avahi.ServiceBrowser"),
"org.freedesktop.Avahi.ServiceBrowser interface present");
ok($introspector->has_method("Free"), "Free method present");
ok($introspector->has_signal("ItemNew"), "ItemNew signal present");
ok($introspector->has_signal("ItemRemove"), "ItemRemove signal present");
ok($introspector->has_signal("Failure"), "Failure signal present");
ok($introspector->has_signal("AllForNow"), "AllForNow signal present");
ok($introspector->has_signal("CacheExhausted"), "CacheExhausted signal present");
__DATA__
t/42-object-introspect-avahi.t view on Meta::CPAN
General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with avahi; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
02111-1307 USA.
-->
<node>
<interface name="org.freedesktop.DBus.Introspectable">
<method name="Introspect">
<arg name="data" type="s" direction="out" />
</method>
</interface>
<interface name="org.freedesktop.Avahi.ServiceBrowser">
<method name="Free"/>
<signal name="ItemNew">
<arg name="interface" type="i"/>
<arg name="protocol" type="i"/>
<arg name="name" type="s"/>
<arg name="type" type="s"/>
<arg name="domain" type="s"/>
<arg name="flags" type="u"/>
t/45-exporter.t view on Meta::CPAN
dbus_method("DemoInterfaceName2", [], ["string"], "9org.example.SomeObject");
};
ok($@ ne "", "raised error for leading digit in interface");
my $ins = Net::DBus::Exporter::_dbus_introspector(ref($obj));
ok($ins->has_interface("org.example.MyObject"), "interface registration");
ok(!$ins->has_interface("org.example.BogusObject"), "-ve interface registration");
my $wantxml = <<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/MyObject">
<interface name="_org.example._some_9object">
<method name="DemoInterfaceName1">
<arg type="s" direction="out"/>
</method>
</interface>
<interface name="org.example.MyObject">
<method name="Everything">
<arg type="s" direction="in"/>
<arg type="i" direction="out"/>
</method>
<method name="EverythingAnnotate">
<arg type="s" direction="in"/>
<arg type="i" direction="out"/>
<annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
<annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>
</method>
<method name="EverythingNegativeAnnotate">
<arg type="s" direction="in"/>
<arg type="i" direction="out"/>
</method>
<method name="NoArgs">
<arg type="i" direction="out"/>
</method>
<method name="NoArgsAnnotate">
<arg type="i" direction="out"/>
<annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
</method>
<method name="NoArgsReturns">
</method>
<method name="NoArgsReturnsAnnotate">
<annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
</method>
<method name="NoReturns">
<arg name="wizz" type="s" direction="in"/>
</method>
<method name="NoReturnsAnnotate">
<arg type="s" direction="in"/>
<annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
</method>
</interface>
<interface name="org.example.OtherObject">
<method name="EverythingInterface">
<arg type="s" direction="in"/>
<arg type="i" direction="out"/>
</method>
<method name="EverythingInterfaceAnnotate">
<arg type="s" direction="in"/>
<arg type="i" direction="out"/>
<annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
<annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>
</method>
<method name="EverythingInterfaceNegativeAnnotate">
<arg type="s" direction="in"/>
<arg type="i" direction="out"/>
</method>
<method name="NoArgsInterface">
<arg type="i" direction="out"/>
</method>
<method name="NoArgsInterfaceAnnotate">
<arg name="two" type="i" direction="out"/>
<annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
</method>
<method name="NoArgsReturnsInterface">
</method>
<method name="NoArgsReturnsInterfaceAnnotate">
<annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
</method>
<method name="NoReturnsInterface">
<arg type="s" direction="in"/>
</method>
<method name="NoReturnsInterfaceAnnotate">
<arg name="one" type="s" direction="in"/>
<annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Introspectable">
<method name="Introspect">
<arg name="xml_data" type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Properties">
<method name="Get">
<arg name="interface_name" type="s" direction="in"/>
<arg name="property_name" type="s" direction="in"/>
<arg name="value" type="v" direction="out"/>
</method>
<method name="GetAll">
<arg name="interface_name" type="s" direction="in"/>
<arg name="properties" type="a{sv}" direction="out"/>
</method>
<method name="Set">
t/50-object-introspect.t view on Meta::CPAN
my $bus = Net::DBus->test;
my $service = $bus->export_service("/org/cpan/Net/DBus/Test/introspect");
my $object = Net::DBus::Object->new($service, "/org/example/Object/OtherObject");
my $introspector = $object->_introspector;
my $xml_got = $introspector->format($object);
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 name="xml_data" type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Properties">
<method name="Get">
<arg name="interface_name" type="s" direction="in"/>
<arg name="property_name" type="s" direction="in"/>
<arg name="value" type="v" direction="out"/>
</method>
<method name="GetAll">
<arg name="interface_name" type="s" direction="in"/>
<arg name="properties" type="a{sv}" direction="out"/>
</method>
<method name="Set">
t/55-method-calls.t view on Meta::CPAN
BEGIN {
use_ok('Net::DBus::Binding::Introspector') or die;
use_ok('Net::DBus::Object') or die;
use_ok('Net::DBus::Test::MockObject') or die;
};
TEST_NO_INTROSPECT: {
my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
$object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
error => { name => "org.freedesktop.DBus.Error.UnknownMethod",
description => "No such method" });
&test_method_fail("raw, no introspect", $robject, "Test");
&test_method_reply("myobject, no introspect",$myobject, "Test", "TestedMyObject");
&test_method_fail("otherobject, no introspect",$otherobject, "Test");
&test_method_fail("raw, no introspect",$robject, "Bogus");
&test_method_fail("myobject, no introspect",$myobject, "Bogus");
&test_method_fail("otherobject, no introspect",$otherobject, "Bogus");
t/55-method-calls.t view on Meta::CPAN
&test_method_fail("raw, no introspect", $robject, "Deprecated");
&test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation");
&test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
}
TEST_MISSING_INTROSPECT: {
my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
$object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
reply => { return => [ $ins->format ] });
&test_method_fail("raw, missing introspect",$robject, "Test");
&test_method_reply("myobject, missing introspect",$myobject, "Test", "TestedMyObject");
&test_method_fail("otherobject, missing introspect",$otherobject, "Test");
&test_method_fail("raw, missing introspect",$robject, "Bogus");
&test_method_fail("myobject, missing introspect",$myobject, "Bogus");
&test_method_fail("otherobject, missing introspect",$otherobject, "Bogus");
t/55-method-calls.t view on Meta::CPAN
}
TEST_FULL_INTROSPECT: {
my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
$ins->add_method("Test", [], ["string"], "org.example.MyObject", {}, []);
$ins->add_method("PolyTest", [], ["string"], "org.example.MyObject", {}, []);
$ins->add_method("PolyTest", [], ["string"], "org.example.OtherObject", {}, []);
$ins->add_method("Deprecated", [], ["string"], "org.example.MyObject", { deprecated => 1 }, []);
$object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
reply => { return => [ $ins->format ] });
&test_method_reply("raw, full introspect",$robject, "Test", "TestedMyObject");
&test_method_reply("myobject, full introspect",$myobject, "Test", "TestedMyObject");
&test_method_fail("otherobject, full introspect",$otherobject, "Test");
&test_method_fail("raw, full introspect",$robject, "Bogus");
&test_method_fail("myobject, full introspect",$myobject, "Bogus");
&test_method_fail("otherobject, full introspect",$otherobject, "Bogus");
t/56-scalar-param-typing.t view on Meta::CPAN
my $ins = Net::DBus::Binding::Introspector->new();
$ins->add_method("ScalarString", ["string"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarInt16", ["int16"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarUInt16", ["uint16"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarInt32", ["int32"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarUInt32", ["uint32"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarDouble", ["double"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarByte", ["byte"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarBoolean", ["bool"], [], "org.example.MyObject", {}, []);
$object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
reply => { return => [ $ins->format($object) ] });
##### String tests
$myobject->ScalarString("Foo");
is($object->get_last_message_signature, "s", "string as string");
is($object->get_last_message_param, "Foo", "string as string");
$myobject->ScalarString(2);
is($object->get_last_message->get_signature, "s", "int as string");
t/60-object-props.t view on Meta::CPAN
use Net::DBus qw(:typing);
my $bus = Net::DBus->test;
my $service = $bus->export_service("org.cpan.Net.Bus.test");
my $object = MyObject->new($service, "/org/example/MyObject");
my $introspector = $object->_introspector;
my $xml_got = $introspector->format($object);
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/MyObject">
<interface name="org.example.MyObject">
<property name="age" type="i" access="write"/>
<property name="email" type="s" access="read"/>
<property name="height" type="d" access="write"/>
<property name="name" type="s" access="readwrite"/>
<property name="parents" type="as" access="readwrite"/>
</interface>
<interface name="org.freedesktop.DBus.Introspectable">
<method name="Introspect">
<arg name="xml_data" type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Properties">
<method name="Get">
<arg name="interface_name" type="s" direction="in"/>
<arg name="property_name" type="s" direction="in"/>
<arg name="value" type="v" direction="out"/>
</method>
<method name="GetAll">
<arg name="interface_name" type="s" direction="in"/>
<arg name="properties" type="a{sv}" direction="out"/>
</method>
<method name="Set">
t/60-object-props.t view on Meta::CPAN
</method>
</interface>
</node>
EOF
is($xml_got, $xml_expect, "xml data matches");
GET_NAME: {
my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.freedesktop.DBus.Properties",
method_name => "Get");
my $iter = $msg->iterator(1);
$iter->append_string("org.example.MyObject");
$iter->append_string("name");
$object->name("John Doe");
my $reply = $bus->get_connection->send_with_reply_and_block($msg);
is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
my ($value) = $reply->get_args_list;
is($value, "John Doe", "name is John Doe");
}
GET_BOGUS: {
my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.freedesktop.DBus.Properties",
method_name => "Get");
my $iter = $msg->iterator(1);
$iter->append_string("org.example.MyObject");
$iter->append_string("bogus");
$object->name("John Doe");
my $reply = eval {
$bus->get_connection->send_with_reply_and_block($msg);
};
ok($@, "error is set");
}
sub GET_SET_NAME: {
my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.freedesktop.DBus.Properties",
method_name => "Get");
my $iter1 = $msg1->iterator(1);
$iter1->append_string("org.example.MyObject");
$iter1->append_string("name");
$object->name("John Doe");
my $reply1 = $bus->get_connection->send_with_reply_and_block($msg1);
is($reply1->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
my ($value1) = $reply1->get_args_list;
is($value1, "John Doe", "name is John Doe");
my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.freedesktop.DBus.Properties",
method_name => "Set");
my $iter2 = $msg2->iterator(1);
$iter2->append_string("org.example.MyObject");
$iter2->append_string("name");
$iter2->append_variant("Jane Doe");
my $reply2 = $bus->get_connection->send_with_reply_and_block($msg2);
is($reply2->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
t/60-object-props.t view on Meta::CPAN
is($reply3->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
my ($value2) = $reply3->get_args_list;
is($value2, "Jane Doe", "name is Jane Doe");
}
SET_AGE: {
my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.freedesktop.DBus.Properties",
method_name => "Get");
my $iter1 = $msg1->iterator(1);
$iter1->append_string("org.example.MyObject");
$iter1->append_string("age");
my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.freedesktop.DBus.Properties",
method_name => "Set");
my $iter2 = $msg2->iterator(1);
$iter2->append_string("org.example.MyObject");
$iter2->append_string("age");
$iter2->append_variant(21);
my $reply1 = $bus->get_connection->send_with_reply_and_block($msg2);
is($reply1->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
t/60-object-props.t view on Meta::CPAN
};
ok($@, "error is set");
is($object->age, 21, "age is 21");
}
GET_EMAIL: {
my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.freedesktop.DBus.Properties",
method_name => "Get");
my $iter1 = $msg1->iterator(1);
$iter1->append_string("org.example.MyObject");
$iter1->append_string("email");
$object->email('john@example.com');
my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.freedesktop.DBus.Properties",
method_name => "Set");
my $iter2 = $msg2->iterator(1);
$iter2->append_string("org.example.MyObject");
$iter2->append_string("email");
$iter2->append_variant('jane@example.com');
my $reply1 = eval {
$bus->get_connection->send_with_reply_and_block($msg2);
};
t/60-object-props.t view on Meta::CPAN
is($object->age, 21, "age is 21");
my ($value) = $reply2->get_args_list;
is($value, 'john@example.com', 'email is john@example.com');
}
SET_HEIGHT: {
my $msg = $bus->get_connection()->make_method_call_message("org.example.MyService",
"/org/example/MyObject",
"org.freedesktop.DBus.Properties",
"Set");
$introspector->encode($msg, "methods", "Set", "params", "org.example.MyObject", "height", dbus_double(1.414));
is($msg->get_signature, "ssv", "signature is ssvd");
my $reply = $bus->get_connection->send_with_reply_and_block($msg);
is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
ok($object->height > 1.410 &&
$object->height < 1.420, "height is 1.414");
}
GET_ALL: {
my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.freedesktop.DBus.Properties",
method_name => "GetAll");
my $iter = $msg->iterator(1);
$iter->append_string("org.example.MyObject");
my $reply = $bus->get_connection->send_with_reply_and_block($msg);
is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN);
my ($value) = $reply->get_args_list;
t/65-object-magic.t view on Meta::CPAN
my $bus = Net::DBus->test;
my $service = $bus->export_service("/org/cpan/Net/Bus/test");
my $object = MyObject->new($service, "/org/example/MyObject");
my $introspector = $object->_introspector;
my $xml_got = $introspector->format($object);
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/MyObject">
<interface name="org.example.MyObject">
<method name="test_set_caller">
</method>
<method name="test_set_multi_args1">
<arg type="s" direction="in"/>
</method>
<method name="test_set_multi_args2">
<arg type="s" direction="in"/>
</method>
<method name="test_set_multi_args3">
<arg type="s" direction="in"/>
<arg type="s" direction="in"/>
</method>
<method name="test_set_serial">
</method>
</interface>
<interface name="org.freedesktop.DBus.Introspectable">
<method name="Introspect">
<arg name="xml_data" type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Properties">
<method name="Get">
<arg name="interface_name" type="s" direction="in"/>
<arg name="property_name" type="s" direction="in"/>
<arg name="value" type="v" direction="out"/>
</method>
<method name="GetAll">
<arg name="interface_name" type="s" direction="in"/>
<arg name="properties" type="a{sv}" direction="out"/>
</method>
<method name="Set">
t/66-child-objects.t view on Meta::CPAN
# skip some nodes
my $c7 = ObjectType1->new($c2,"/skip/one", "C7");
my $c8 = ObjectType2->new($c7,"/skip/skip/two", "C8");
my $c9 = ObjectType3->new($c8,"/skip/skip/skip/three", "C9");
my $introspector = $root->_introspector;
my $xml_got = $introspector->format($root);
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="/base">
<interface name="com.dbelser.test.type1">
<method name="version">
<arg type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Introspectable">
<method name="Introspect">
<arg name="xml_data" type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Properties">
<method name="Get">
<arg name="interface_name" type="s" direction="in"/>
<arg name="property_name" type="s" direction="in"/>
<arg name="value" type="v" direction="out"/>
</method>
<method name="GetAll">
<arg name="interface_name" type="s" direction="in"/>
<arg name="properties" type="a{sv}" direction="out"/>
</method>
<method name="Set">
t/66-child-objects.t view on Meta::CPAN
my $ins2 = Net::DBus::Binding::Introspector->new(xml => $xml_got);
my @children = $ins2->list_children();
is_deeply(\@children, ["branch_1", "branch_2", "branch_3"], "children match");
$introspector = $c2->_introspector;
$xml_got = $introspector->format($c2);
$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="/base/branch_2">
<interface name="com.dbelser.test.type2">
<method name="version">
<arg type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Introspectable">
<method name="Introspect">
<arg name="xml_data" type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Properties">
<method name="Get">
<arg name="interface_name" type="s" direction="in"/>
<arg name="property_name" type="s" direction="in"/>
<arg name="value" type="v" direction="out"/>
</method>
<method name="GetAll">
<arg name="interface_name" type="s" direction="in"/>
<arg name="properties" type="a{sv}" direction="out"/>
</method>
<method name="Set">
t/67-child-objects.t view on Meta::CPAN
# skip some nodes
my $c7 = ObjectType1->new($c2,"/skip/one", "C7");
my $c8 = ObjectType2->new($c7,"/skip/skip/two", "C8");
my $c9 = ObjectType3->new($c8,"/skip/skip/skip/three", "C9");
my $introspector = $root->_introspector;
my $xml_got = $introspector->format($root);
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="/">
<interface name="com.dbelser.test.type1">
<method name="version">
<arg type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Introspectable">
<method name="Introspect">
<arg name="xml_data" type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Properties">
<method name="Get">
<arg name="interface_name" type="s" direction="in"/>
<arg name="property_name" type="s" direction="in"/>
<arg name="value" type="v" direction="out"/>
</method>
<method name="GetAll">
<arg name="interface_name" type="s" direction="in"/>
<arg name="properties" type="a{sv}" direction="out"/>
</method>
<method name="Set">
t/67-child-objects.t view on Meta::CPAN
my $ins2 = Net::DBus::Binding::Introspector->new(xml => $xml_got);
my @children = $ins2->list_children();
is_deeply(\@children, ["branch_1", "branch_2", "branch_3"], "children match");
$introspector = $c2->_introspector;
$xml_got = $introspector->format($c2);
$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="/branch_2">
<interface name="com.dbelser.test.type2">
<method name="version">
<arg type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Introspectable">
<method name="Introspect">
<arg name="xml_data" type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Properties">
<method name="Get">
<arg name="interface_name" type="s" direction="in"/>
<arg name="property_name" type="s" direction="in"/>
<arg name="value" type="v" direction="out"/>
</method>
<method name="GetAll">
<arg name="interface_name" type="s" direction="in"/>
<arg name="properties" type="a{sv}" direction="out"/>
</method>
<method name="Set">
t/75-notifications.t view on Meta::CPAN
# -*- perl -*-
use Test::More tests => 10;
# This test case is primarily about variants - but
# in particular the signature of org.freedesktop.Notifications.Notify
use strict;
use warnings;
BEGIN {
use_ok('Net::DBus') or die;
use_ok('Net::DBus::Object') or die;
};
( run in 0.804 second using v1.01-cache-2.11-cpan-299005ec8e3 )