[libmoo-perl] 06/43: throw more reasonable errors for invalid sub names

[gregor herrmann]

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

gregoa pushed a commit to branch master
in repository libmoo-perl.

commit 5152d8cf9d8aefdfd510360bb4a0833cc2e5ff4c
Author: Graham Knop <ha...@haarg.org>
Date:   Fri Sep 9 16:47:15 2016 -0400

    throw more reasonable errors for invalid sub names
---
 lib/Sub/Quote.pm |  4 ++++
 t/sub-quote.t    | 20 ++++++++++++++++++++
 2 files changed, 24 insertions(+)

diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm
index 4a293fe..8ba8b06 100644
--- a/lib/Sub/Quote.pm
+++ b/lib/Sub/Quote.pm
@@ -96,8 +96,12 @@ sub quote_sub {
     $name = join '::', $package, $subname;
     croak qq{package name "$package" too long!}
       if length $package > 252;
+    croak qq{package name "$package" is not valid!}
+      unless $package =~ /^[^\d\W]\w*(?:::\w+)*$/;
     croak qq{sub name "$subname" too long!}
       if length $subname > 252;
+    croak qq{sub name "$subname" is not valid!}
+      unless $subname =~ /^[^\d\W]\w*$/;
   }
   my @caller = caller(0);
   my $attributes = $options->{attributes};
diff --git a/t/sub-quote.t b/t/sub-quote.t
index 9a07fc6..da526d5 100644
--- a/t/sub-quote.t
+++ b/t/sub-quote.t
@@ -94,6 +94,26 @@ like exception {
 }, qr/^sub name "$long$long" too long/,
   'over long sub names error';
 
+like exception {
+  quote_sub "got a space::gorp", q{ return 1; };
+}, qr/^package name "got a space" is not valid!/,
+  'packages with spaces are invalid';
+
+like exception {
+  quote_sub "Gorp::got a space", q{ return 1; };
+}, qr/^sub name "got a space" is not valid!/,
+  'sub names with spaces are invalid';
+
+like exception {
+  quote_sub "0welp::gorp", q{ return 1; };
+}, qr/^package name "0welp" is not valid!/,
+  'package names starting with numbers are not valid';
+
+like exception {
+  quote_sub "Gorp::0welp", q{ return 1; };
+}, qr/^sub name "0welp" is not valid!/,
+  'sub names starting with numbers are not valid';
+
 my $broken_quoted = quote_sub q{
   return 5<;
 };

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

_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits