view release on metacpan or  search on metacpan

lib/Net/DBus/BaseObject.pm  view on Meta::CPAN

#   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.

=pod

=head1 NAME

Net::DBus::BaseObject - base class for exporting objects to the bus

=head1 SYNOPSIS

  # We're going to be a DBus object
  use base qw(Net::DBus::BaseObject);

  # Export a 'Greeting' signal taking a stringl string parameter
  dbus_signal("Greeting", ["string"]);

  # Export 'Hello' as a method accepting a single string
  # parameter, and returning a single string value
  dbus_method("Hello", ["string"], ["string"]);

  sub new {
      my $class = shift;
      my $service = shift;
      my $self = $class->SUPER::new($service, "/org/demo/HelloWorld");

      bless $self, $class;

      return $self;
  }

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

      if (....$message refers to a object's method ... ) {
         ...dispatch this object's interfaces/methods...
         return $reply;
      }
  }

=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, 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::BaseObject;

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"], {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.

=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::BaseObject>.

=cut

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

    my $parent = shift;
    my $path = shift;

    $path =~ s{/$}{} unless $path eq '/';

    $self->{parent} = $parent;
    if ($parent->isa(__PACKAGE__)) {
	$path =~ s{^/}{};
	$self->{service} = $parent->get_service;
	$self->{object_path} = $parent->get_object_path;
	$self->{object_path} .= '/' unless $self->{object_path} =~ m{/$};
	$self->{object_path} .= $path;
    } else {
	$path = "/$path" unless $path =~ m{^/};
	$self->{service} = $parent;
	$self->{object_path} = $path;
    }

    $self->{interface} = shift;
    $self->{introspector} = undef;
    $self->{introspected} = 0;
    $self->{callbacks} = {};
    $self->{children} = {};

    bless $self, $class;

    if ($self->{parent}->isa(__PACKAGE__)) {
	$self->{parent}->_register_child($self);
    } else {
	$self->get_service->_register_object($self);
    }

    return $self;
}

lib/Net/DBus/BaseObject.pm  view on Meta::CPAN

=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 {
    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);
    }
}


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


=item $currvalue = $object->_dispatch_property($name);
=item $object->_dispatch_property($name, $newvalue);

The C<_dispatch_property> method is to be used to handle dispatch
of property reads and writes. The C<$name> parameter is the name
of the property being accessed. If C<$newvalue> is supplied then
the property is to be updated, otherwise the current value is to
be returned. The default implementation will simply raise an
error, so must be overridden in subclasses.

=cut

sub _dispatch_property {
    my $self = shift;
    my $name = shift;
    my $value = shift;

    die "No method for property $name";
}


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;

    if (!$self->{introspected}) {
	$self->{introspector} = Net::DBus::Exporter::_dbus_introspector(ref($self));
	$self->{introspected} = 1;
    }
    return $self->{introspector};
}

1;


=pod

=back

=head1 AUTHOR

Daniel P. Berrange

=head1 COPYRIGHT

Copyright (C) 2005-2011 Daniel P. Berrange

=head1 SEE ALSO

L<Net::DBus>, L<Net::DBus::Service>, L<Net::DBus::Object>,
L<Net::DBus::ProxyObject>, L<Net::DBus::Exporter>,
L<Net::DBus::RemoteObject>

=cut