view release on metacpan or  search on metacpan

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

=cut

package Net::DBus::ProxyObject;

use 5.006;
use strict;
use warnings;
use base qw(Net::DBus::BaseObject);

=item my $object = Net::DBus::ProxyObject->new($service, $path, $impl)

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. The C<$impl> parameter is
the application object which will implement the methods being
exported to the bus.

=item my $object = Net::DBus::ProxyObject->new($parentobj, $subpath, $impl)

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> or
a subclass. The C<$impl> parameter is the application object
which will implement the methods being exported to the bus.

=cut

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    my ($serviceOrParent, $path, $impl) = @_;

    $self->{impl} = $impl;

    bless $self, $class;

    return $self;
}


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

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

    return $reply;
}


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

    if (!$self->{impl}->can($name)) {
	die "no method to for property '$name'";
    }

    return $self->{impl}->$name(@_);
}


sub _is_method_allowed {
    my $self = shift;
    my $method = shift;

    # If this object instance doesn't have it defined, trivially can't
    # allow it
    return 0 unless $self->{impl}->can($method);

    my $ins = $self->_introspector;
    if (defined $ins) {
	# Finally do check against introspection data
	return $ins->is_method_allowed($method);
    }

    # No introspector, so have to assume its allowed
    return 1;
}

1;


=pod

=back

=head1 AUTHOR

Daniel P. Berrange

=head1 COPYRIGHT