[libnet-dbus-perl] 326/335: Add 'strict_exceptions' annotation

[Intrigeri]

This is an automated email from the git hooks/post-receive script.

intrigeri pushed a commit to branch experimental
in repository libnet-dbus-perl.

commit 4aac8944286919f60a11046f070ec4e0709d7245
Author: Daniel Collins <daniel.collins at smoothwall.net>
Date:   Mon Mar 16 19:58:36 2015 +0000

    Add 'strict_exceptions' annotation
    
    Add a new annotation which allows an exported service to be
    setup such that only Net::DBus::Error subclass exceptions
    are propogated to the caller. All others are rethrown causing
    the service to terminate.
---
 lib/Net/DBus/Binding/Introspector.pm | 21 +++++++++++++++++++++
 lib/Net/DBus/Exporter.pm             |  6 ++++++
 lib/Net/DBus/Object.pm               |  6 ++++++
 3 files changed, 33 insertions(+)

diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
index b5bc305..f45f06b 100644
--- a/lib/Net/DBus/Binding/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -331,6 +331,7 @@ sub add_method {
 	returnnames => $returnnames,
 	deprecated => $attributes->{deprecated} ? 1 : 0,
 	no_reply => $attributes->{no_return} ? 1 : 0,
+	strict_exceptions => $attributes->{strict_exceptions} ? 1 : 0,
     };
 }
 
@@ -457,6 +458,26 @@ sub does_method_reply {
     return 1;
 }
 
+=item my $boolean = $ins->method_has_strict_exceptions($name, $interface)
+
+Returns true if the method called C<$name> in the interface C<$interface> has
+the strict_exceptions attribute; that is any exceptions which aren't
+L<Net::DBus::Error> objects should not be caught and allowed to travel up the
+stack.
+
+=cut
+
+sub method_has_strict_exceptions {
+    my $self = shift;
+    my $name = shift;
+    my $interface = shift;
+
+    die "no interface $interface" unless exists $self->{interfaces}->{$interface};
+    die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name};
+    return 1 if $self->{interfaces}->{$interface}->{methods}->{$name}->{strict_exceptions};
+    return 0;
+}
+
 =item my @names = $ins->list_interfaces
 
 Returns a list of all interfaces registered as being provided
diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
index 3ca829c..dcbb266 100644
--- a/lib/Net/DBus/Exporter.pm
+++ b/lib/Net/DBus/Exporter.pm
@@ -233,6 +233,12 @@ method or signal. If omitted, no names will be assigned.
 An array of strings specifying names for the return parameters of the
 method. If omitted, no names will be assigned.
 
+=item strict_exceptions
+
+Exceptions thrown by this method which are not of type L<Net::DBus::Error> will
+not be caught and converted to D-Bus errors. They will be rethrown and continue
+up the stack until something else catches them (or the process dies).
+
 =back
 
 =head1 METHODS
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 2e97260..52e99bd 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -164,6 +164,12 @@ sub _dispatch_object {
 	    $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,

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git