Net::DBus - Perl extension for the DBus message system

Net-DBus documentation Contained in the Net-DBus distribution.

Index

Code Index:

NAME

Top

Net::DBus - Perl extension for the DBus message system

SYNOPSIS

Top



  ####### Attaching to the bus ###########

  use Net::DBus;

  # Find the most appropriate bus
  my $bus = Net::DBus->find;

  # ... 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'
  my $service = $bus->export_service("org.example.Jukebox");

DESCRIPTION

Top

Net::DBus provides a Perl API for the DBus message system. The DBus Perl interface is currently operating against the 0.32 development version of DBus, but should work with later versions too, providing the API changes have not been too drastic.

Users of this package are either typically, service providers in which case the Net::DBus::Service and Net::DBus::Object modules are of most relevance, or are client consumers, in which case Net::DBus::RemoteService and Net::DBus::RemoteObject are of most relevance.

METHODS

Top

my $bus = Net::DBus->find(%params);

Search for the most appropriate bus to connect to and return a connection to it. The heuristic used for the search is

  - If DBUS_STARTER_BUS_TYPE is set to 'session' attach
    to the session bus

  - Else If DBUS_STARTER_BUS_TYPE is set to 'system' attach
    to the system bus

  - Else If DBUS_SESSION_BUS_ADDRESS is set attach to the
    session bus

  - Else attach to the system bus

The optional params hash can contain be used to specify connection options. The only support option at this time is nomainloop which prevents the bus from being automatically attached to the main Net::DBus::Reactor event loop.

my $bus = Net::DBus->system(%params);

Return a handle for the system message bus. Note that the system message bus is locked down by default, so unless appropriate access control rules are added in /etc/dbus/system.d/, an application may access services, but won't be able to export services. The optional params hash can contain be used to specify connection options. The only support option at this time is nomainloop which prevents the bus from being automatically attached to the main Net::DBus::Reactor event loop.

my $bus = Net::DBus->session(%params);

Return a handle for the session message bus. The optional params hash can contain be used to specify connection options. The only support option at this time is nomainloop which prevents the bus from being automatically attached to the main Net::DBus::Reactor event loop.

my $bus = Net::DBus->test(%params);

Returns a handle for a virtual bus for use in unit tests. This bus does not make any network connections, but rather has an in-memory message pipeline. Consult Net::DBus::Test::MockConnection for further details of how to use this special bus.

my $bus = Net::DBus->new($address, %params);

Return a connection to a specific message bus. The $address parameter must contain the address of the message bus to connect to. An example address for a session bus might look like unix:abstract=/tmp/dbus-PBFyyuUiVb,guid=191e0a43c3efc222e0818be556d67500, while one for a system bus would look like unix:/var/run/dbus/system_bus_socket. The optional params hash can contain be used to specify connection options. The only support option at this time is nomainloop which prevents the bus from being automatically attached to the main Net::DBus::Reactor event loop.

my $connection = $bus->get_connection;

Return a handle to the underlying, low level connection object associated with this bus. The returned object will be an instance of the Net::DBus::Binding::Bus class. This method is not intended for use by (most!) application developers, so if you don't understand what this is for, then you don't need to be calling it!

my $service = $bus->get_service($name);

Retrieves a handle for the remote service identified by the service name $name. The returned object will be an instance of the Net::DBus::RemoteService class.

my $service = $bus->export_service($name);

Registers a service with the bus, returning a handle to the service. The returned object is an instance of the Net::DBus::Service class.

my $object = $bus->get_bus_object;

Retrieves a handle to the bus object, /org/freedesktop/DBus, provided by the service org.freedesktop.DBus. The returned object is an instance of Net::DBus::RemoteObject

my $name = $bus->get_unique_name;

Retrieves the unique name of this client's connection to the bus.

my $name = $bus->get_service_owner($service);

Retrieves the unique name of the client on the bus owning the service named by the $service parameter.

DATA TYPING METHODS

Top

These methods are not usually used, since most services provide introspection data to inform clients of their data typing requirements. If introspection data is incomplete, however, it may be neccessary for a client to mark values with specific data types. In such a case, the following methods can be used. They are not, however, exported by default so must be requested at import time by specifying 'use Net::DBus qw(:typing)'

$typed_value = dbus_int16($value);

Mark a value as being a signed, 16-bit integer.

$typed_value = dbus_uint16($value);

Mark a value as being an unsigned, 16-bit integer.

$typed_value = dbus_int32($value);

Mark a value as being a signed, 32-bit integer.

$typed_value = dbus_uint32($value);

Mark a value as being an unsigned, 32-bit integer.

$typed_value = dbus_int64($value);

Mark a value as being an unsigned, 64-bit integer.

$typed_value = dbus_uint64($value);

Mark a value as being an unsigned, 64-bit integer.

$typed_value = dbus_double($value);

Mark a value as being a double precision IEEE floating point.

$typed_value = dbus_byte($value);

Mark a value as being an unsigned, byte.

$typed_value = dbus_string($value);

Mark a value as being a UTF-8 string. This is not usually required since 'string' is the default data type for any Perl scalar value.

$typed_value = dbus_signature($value);

Mark a value as being a UTF-8 string, whose contents is a valid type signature

$typed_value = dbus_object_path($value);

Mark a value as being a UTF-8 string, whose contents is a valid object path.

$typed_value = dbus_boolean($value);

Mark a value as being an boolean

$typed_value = dbus_array($value);

Mark a value as being an array

$typed_value = dbus_struct($value);

Mark a value as being a structure

$typed_value = dbus_dict($value);

Mark a value as being a dictionary

$typed_value = dbus_variant($value);

Mark a value as being a variant

SEE ALSO

Top

Net::DBus, Net::DBus::RemoteService, Net::DBus::Service, Net::DBus::RemoteObject, Net::DBus::Object, Net::DBus::Exporter, Net::DBus::Dumper, Net::DBus::Reactor, dbus-monitor(1), dbus-daemon-1(1), dbus-send(1), http://dbus.freedesktop.org,

AUTHOR

Top

Daniel Berrange <dan@berrange.com>

COPYRIGHT

Top

Copyright 2004-2005 by Daniel Berrange

Net-DBus documentation Contained in the Net-DBus distribution. 
# -*- perl -*-
#
# Copyright (C) 2004-2006 Daniel P. Berrange
#
# This program is free software; You can redistribute it and/or modify
# it under the same terms as Perl itself. Either:
#
# a) the GNU General Public License as published by the Free
#   Software Foundation; either version 2, or (at your option) any
#   later version,
#
# or
#
# b) the "Artistic License"
#
# The file "COPYING" distributed along with this file provides full
# details of the terms and conditions of the two licenses.


package Net::DBus;

use 5.006;
use strict;
use warnings;

BEGIN {
    our $VERSION = '0.33.6';
    require XSLoader;
    XSLoader::load('Net::DBus', $VERSION);
}

use Net::DBus::Binding::Bus;
use Net::DBus::Service;
use Net::DBus::RemoteService;
use Net::DBus::Test::MockConnection;
use Net::DBus::Binding::Value;

use vars qw($bus_system $bus_session);

use Exporter qw(import);

use vars qw(@EXPORT_OK %EXPORT_TAGS);

@EXPORT_OK = qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64
		dbus_byte dbus_boolean dbus_string dbus_double
		dbus_object_path dbus_signature
		dbus_struct dbus_array dbus_dict dbus_variant);

%EXPORT_TAGS = (typing => [qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64
			      dbus_byte dbus_boolean dbus_string dbus_double
			      dbus_object_path dbus_signature
			      dbus_struct dbus_array dbus_dict dbus_variant)]);


sub find {
    my $class = shift;

    if ($ENV{DBUS_STARTER_BUS_TYPE} &&
	$ENV{DBUS_STARTER_BUS_TYPE} eq "session") {
	return $class->session(@_);
    } elsif ($ENV{DBUS_STARTER_BUS_TYPE} &&
	     $ENV{DBUS_STARTER_BUS_TYPE} eq "system") {
	return $class->system(@_);
    } elsif (exists $ENV{DBUS_SESSION_BUS_ADDRESS}) {
	return $class->session(@_);
    } else {
	return $class->system;
    }
}


sub system {
    my $class = shift;
    my %params = @_;
    if ($params{private}) {
	return $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM, private => 1), @_);
    }

    unless ($bus_system) {
	$bus_system = $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM), @_);
    }
    return $bus_system
}


sub session {
    my $class = shift;
    my %params = @_;
    if ($params{private}) {
	return $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SESSION, private => 1), @_);
    }

    unless ($bus_session) {
	$bus_session = $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SESSION), @_);
    }
    return $bus_session;
}



# NB. explicitly do *NOT* cache, since unit tests
# should always have pristine state
sub test {
    my $class = shift;
    return $class->_new(Net::DBus::Test::MockConnection->new());
}


sub new {
    my $class = shift;
    my $nomainloop = shift;
    return $class->_new(Net::DBus::Binding::Bus->new(address => shift), @_);
}

sub _new {
    my $class = shift;
    my $self = {};

    $self->{connection} = shift;
    $self->{signals} = [];
    $self->{services} = {};

    my %params = @_;

    bless $self, $class;

    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} = Net::DBus::RemoteService->new($self, "org.freedesktop.DBus", "org.freedesktop.DBus");

    return $self;
}


sub get_connection {
    my $self = shift;
    return $self->{connection};
}


sub get_service {
    my $self = shift;
    my $name = shift;

    if ($name eq "org.freedesktop.DBus") {
	return $self->{bus};
    }

    my $owner = $name;
    if ($owner !~ /^:/) {
	$owner = $self->get_service_owner($name);
	if (!$owner) {
	    $self->get_bus_object->StartServiceByName($name, 0);
	    $owner = $self->get_service_owner($name);
	}
    }

    unless (exists $self->{services}->{$owner}) {
	$self->{services}->{$owner} = Net::DBus::RemoteService->new($self, $owner, $name);
    }
    return $self->{services}->{$owner};
}


sub export_service {
    my $self = shift;
    my $name = shift;
    return Net::DBus::Service->new($self, $name);
}


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');
}



sub get_unique_name {
    my $self = shift;

    return $self->get_connection->get_unique_name
}


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;
}


sub _add_signal_receiver {
    my $self = shift;
    my $receiver = shift;
    my $signal_name = shift;
    my $interface = shift;
    my $service = shift;
    my $path = shift;

    my $rule = $self->_match_rule($signal_name, $interface, $service, $path);

    push @{$self->{signals}}, [$receiver, $rule, $signal_name, $interface, $service, $path];
    $self->{connection}->add_match($rule);
}

sub _remove_signal_receiver {
    my $self = shift;
    my $receiver = shift;
    my $signal_name = shift;
    my $interface = shift;
    my $service = shift;
    my $path = shift;

    my $rule = $self->_match_rule($signal_name, $interface, $service, $path);

    my @signals;
    foreach (@{$self->{signals}}) {
	if ($_->[0] eq $receiver &&
	    defined $_->[1] &&
	    $_->[1] eq $rule) {
	    $self->{connection}->remove_match($rule);
	} else {
	    push @signals, $_;
	}
    }
    $self->{signals} = \@signals;
}


sub _match_rule {
    my $self = shift;
    my $signal_name = shift;
    my $interface = shift;
    my $service = shift;
    my $path = shift;

    my $rule = "type='signal'";
    if ($interface) {
	$rule .= ",interface='$interface'";
    }
    if ($service) {
	if ($service !~ /^:/) {
	    # Resolve service name to a client id
	    $service = $self->get_service_owner($service);
	}
	if ($service) {
	    $rule .= ",sender='$service'";
	}
    }
    if ($path) {
	$rule .= ",path='$path'";
    }
    if ($signal_name) {
	$rule .= ",member='$signal_name'";
    }
    return $rule;
}


sub _rule_matches {
    my $self = shift;
    my $rule = shift;
    my $member = shift;
    my $interface = shift;
    my $sender = shift;
    my $path = shift;

    my %bits;
    map {
	if (/^(\w+)='(.*)'$/) {
	    $bits{$1} = $2;
	}
    } split /,/, $rule;


    if (exists $bits{member} &&
	$bits{member} ne $member) {
	return 0;
    }
    if (exists $bits{interface} &&
	$bits{interface} ne $interface) {
	return 0;
    }
    if (exists $bits{sender} &&
	$bits{sender} ne $sender) {
	return 0;
    }
    if (exists $bits{path} &&
	$bits{path} ne $path) {
	return 0;
    }
    return 1;
}

sub _signal_func {
    my $self = shift;
    my $connection = shift;
    my $message = shift;

    return 0 unless $message->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL;

    my $interface = $message->get_interface;
    my $sender = $message->get_sender;
    my $path = $message->get_path;
    my $member = $message->get_member;

    my $handled = 0;
    foreach my $handler (grep { defined $_->[1] &&
				$self->_rule_matches($_->[1], $member, $interface, $sender, $path) }
			 @{$self->{signals}}) {
	my $callback = $handler->[0];
	&$callback($message);
	$handled = 1;
    }

    return $handled;
}


sub dbus_int16 {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT16,
					  $_[0]);

}



sub dbus_uint16 {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT16,
					  $_[0]);
}


sub dbus_int32 {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT32,
					  $_[0]);

}



sub dbus_uint32 {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT32,
					  $_[0]);
}




sub dbus_int64 {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT64,
					  $_[0]);

}




sub dbus_uint64 {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT64,
					  $_[0]);
}




sub dbus_double {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_DOUBLE,
					  $_[0]);
}




sub dbus_byte {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BYTE,
					  $_[0]);
}




sub dbus_string {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_STRING,
					  $_[0]);
}




sub dbus_signature {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_SIGNATURE,
					  $_[0]);
}


sub dbus_object_path {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
					  $_[0]);
}




sub dbus_boolean {
    return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BOOLEAN,
					  $_[0]);
}



sub dbus_array {
    return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_ARRAY],
					  $_[0]);
}



sub dbus_struct {
    return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_STRUCT],
					  $_[0]);
}


sub dbus_dict{
    return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_DICT_ENTRY],
					  $_[0]);
}


sub dbus_variant{
    return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_VARIANT],
					  $_[0]);
}


1;