[libnet-dbus-perl] 274/335: Allow leading _ in interface names. Clarify error message (rt #44837)

[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 8a238c8ef7d293984dc8e4b6834049fa33686799
Author: Daniel P. Berrange <berrange at redhat.com>
Date:   Mon May 4 17:51:22 2009 +0100

    Allow leading _ in interface names. Clarify error message (rt #44837)
---
 lib/Net/DBus/Exporter.pm | 19 +++++++++++++++----
 t/45-exporter.t          | 12 +++++++++++-
 2 files changed, 26 insertions(+), 5 deletions(-)

diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
index 6373fe1..b551229 100644
--- a/lib/Net/DBus/Exporter.pm
+++ b/lib/Net/DBus/Exporter.pm
@@ -270,10 +270,7 @@ sub import {
     die "usage: use Net::DBus::Exporter 'interface-name';" unless @_;
 
     my $interface = shift;
-    die "interface name '$interface' is not valid." .
-	"Names must consist of tokens using the characters a-z, A-Z, 0-9, _, " .
-	"with at least two tokens, separated by '.'\n"
-	unless $interface =~ /^[a-zA-Z]\w*(\.[a-zA-Z]\w*)+$/;
+    &_validate_interface($interface);
     $dbus_exports{$caller}->{interface} = $interface;
 
     $class->export_to_level(1, "", @EXPORT);
@@ -377,6 +374,7 @@ sub dbus_method {
     }
     if (@_ && !ref($_[0])) {
 	$interface = shift;
+	&_validate_interface($interface);
     }
     if (@_ && ref($_[0]) eq "HASH") {
 	%attributes = %{$_[0]};
@@ -428,6 +426,7 @@ sub dbus_property {
     }
     if (@_ && !ref($_[0])) {
 	$interface = shift;
+	&_validate_interface($interface);
     }
     if ($_ && ref($_[0]) eq "HASH") {
 	%attributes = %{$_[0]};
@@ -468,6 +467,7 @@ sub dbus_signal {
     }
     if (@_ && !ref($_[0])) {
 	$interface = shift;
+	&_validate_interface($interface);
     }
     if (@_ && ref($_[0]) eq "HASH") {
 	%attributes = %{$_[0]};
@@ -486,6 +486,17 @@ sub dbus_signal {
     $dbus_exports{$caller}->{signals}->{$name} = [$params, $interface, \%attributes, $param_names];
 }
 
+
+sub _validate_interface {
+    my $interface = shift;
+
+    die "interface name '$interface' is not valid. " .
+	"Names must consist of at least two tokens, separated by '.'. " .
+	"Each token can use the characters a-z, A-Z, 0-9, _. " .
+	"Tokens must not start with a leading digit."
+	unless $interface =~ /^[a-zA-Z_]\w*(\.[a-zA-Z_]\w*)+$/;
+}
+
 1;
 
 =back
diff --git a/t/45-exporter.t b/t/45-exporter.t
index ce70ac1..0792047 100644
--- a/t/45-exporter.t
+++ b/t/45-exporter.t
@@ -1,6 +1,6 @@
 # -*- perl -*-
 
-use Test::More tests => 93;
+use Test::More tests => 94;
 
 use strict;
 use warnings;
@@ -49,7 +49,12 @@ dbus_method("NoArgsReturnsInterfaceAnnotate", "org.example.OtherObject", { depre
 dbus_method("NoReturnsInterfaceAnnotate", ["string"], "org.example.OtherObject", { deprecated => 1, param_names => ["one"] });
 dbus_method("NoArgsInterfaceAnnotate", [],["int32"], "org.example.OtherObject", { deprecated => 1, return_names => ["two"] });
 
+dbus_method("DemoInterfaceName1", [], ["string"], "_org.example._some_9object");
 
+eval {
+    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));
 
@@ -60,6 +65,11 @@ 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"/>

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