Add blacklist and whitelist support to Locale::Maketext.

Format string attacks against Locale::Maketext have been discovered in
several popular web applications and addresed by pre-filtering maketext
strings before they are fed into the maketext() method. It is now
possible to restrict the allowed bracked notation methods directly in
Maketext.

This commit also introduces a default blacklist that prevents using the
object and class methods in the Locale::Maketext namespace that were not
intended as bracked notation methods.

4 files changed, 322 insertions, 9 deletions

diff --git a/dist/Locale-Maketext/lib/Locale/Maketext.pm b/dist/Locale-Maketext/lib/Locale/Maketext.pm
index 24c31ea9d6..f213c7439e 100644
--- a/dist/Locale-Maketext/lib/Locale/Maketext.pm
+++ b/dist/Locale-Maketext/lib/Locale/Maketext.pm
@@ -1,4 +1,3 @@
-
 package Locale::Maketext;
 use strict;
 use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
@@ -138,6 +137,56 @@ sub fail_with { # an actual attribute method!
 
 #--------------------------------------------------------------------------
 
+sub blacklist {
+    my ( $handle, @methods ) = @_;
+
+    unless ( defined $handle->{'blacklist'} ) {
+        no strict 'refs';
+
+        # Don't let people call methods they're not supposed to from maketext.
+        # Explicitly exclude all methods in this package that start with an
+        # underscore on principle.
+        $handle->{'blacklist'} = {
+            map { $_ => 1 } (
+                qw/
+                  blacklist
+                  encoding
+                  fail_with
+                  failure_handler_auto
+                  fallback_language_classes
+                  fallback_languages
+                  get_handle
+                  init
+                  language_tag
+                  maketext
+                  new
+                  whitelist
+                  /, grep { /^_/ } keys %{ __PACKAGE__ . "::" }
+            ),
+        };
+    }
+
+    if ( scalar @methods ) {
+        $handle->{'blacklist'} = { %{ $handle->{'blacklist'} }, map { $_ => 1 } @methods };
+    }
+
+    delete $handle->{'_external_lex_cache'};
+    return;
+}
+
+sub whitelist {
+    my ( $handle, @methods ) = @_;
+    if ( scalar @methods ) {
+        $handle->{'whitelist'} = {} unless defined $handle->{'whitelist'};
+        $handle->{'whitelist'} = { %{ $handle->{'whitelist'} }, map { $_ => 1 } @methods };
+    }
+
+    delete $handle->{'_external_lex_cache'};
+    return;
+}
+
+#--------------------------------------------------------------------------
+
 sub failure_handler_auto {
     # Meant to be used like:
     #  $handle->fail_with('failure_handler_auto')
@@ -179,6 +228,7 @@ sub new {
     # Nothing fancy!
     my $class = ref($_[0]) || $_[0];
     my $handle = bless {}, $class;
+    $handle->blacklist;
     $handle->init;
     return $handle;
 }
@@ -508,7 +558,7 @@ sub _compile {
     # on strings that don't need compiling.
     return \"$string_to_compile" if($string_to_compile !~ m/[\[~\]]/ms); # return a string ref if chars [~] are not in the string
 
-    my $target = ref($_[0]) || $_[0];
+    my $handle = $_[0];
 
     my(@code);
     my(@c) = (''); # "chunks" -- scratch.
@@ -540,10 +590,10 @@ sub _compile {
                 #  preceding literal.
                 if($in_group) {
                     if($1 eq '') {
-                        $target->_die_pointing($string_to_compile, 'Unterminated bracket group');
+                        $handle->_die_pointing($string_to_compile, 'Unterminated bracket group');
                     }
                     else {
-                        $target->_die_pointing($string_to_compile, 'You can\'t nest bracket groups');
+                        $handle->_die_pointing($string_to_compile, 'You can\'t nest bracket groups');
                     }
                 }
                 else {
@@ -627,13 +677,15 @@ sub _compile {
                         push @code, ' (';
                     }
                     elsif($m =~ /^\w+$/s
-                        # exclude anything fancy, especially fully-qualified module names
+                        && !$handle->{'blacklist'}{$m}
+                        && ( !defined $handle->{'whitelist'} || $handle->{'whitelist'}{$m} )
+                        # exclude anything fancy and restrict to the whitelist/blacklist.
                     ) {
                         push @code, ' $_[0]->' . $m . '(';
                     }
                     else {
                         # TODO: implement something?  or just too icky to consider?
-                        $target->_die_pointing(
+                        $handle->_die_pointing(
                             $string_to_compile,
                             "Can't use \"$m\" as a method name in bracket group",
                             2 + length($c[-1])
@@ -675,7 +727,7 @@ sub _compile {
                     push @c, '';
                 }
                 else {
-                    $target->_die_pointing($string_to_compile, q{Unbalanced ']'});
+                    $handle->_die_pointing($string_to_compile, q{Unbalanced ']'});
                 }
 
             }
@@ -760,8 +812,9 @@ sub _compile {
 
 sub _die_pointing {
     # This is used by _compile to throw a fatal error
-    my $target = shift; # class name
-    # ...leaving $_[0] the error-causing text, and $_[1] the error message
+    my $target = shift;
+    $target = ref($target) || $target; # class name
+                                       # ...leaving $_[0] the error-causing text, and $_[1] the error message
 
     my $i = index($_[0], "\n");
 
diff --git a/dist/Locale-Maketext/lib/Locale/Maketext.pod b/dist/Locale-Maketext/lib/Locale/Maketext.pod
index a391b291b7..8c5be19f6a 100644
--- a/dist/Locale-Maketext/lib/Locale/Maketext.pod
+++ b/dist/Locale-Maketext/lib/Locale/Maketext.pod
@@ -307,6 +307,13 @@ interested in hearing about it.)
 These two methods are discussed in the section "Controlling
 Lookup Failure".
 
+=item $lh->blacklist(@list)
+
+=item $lh->whitelist(@list)
+
+These methods are discussed in the section "Bracket Notation
+Security".
+
 =back
 
 =head2 Utility Methods
@@ -861,6 +868,70 @@ I do not anticipate that you will need (or particularly want)
 to nest bracket groups, but you are welcome to email me with
 convincing (real-life) arguments to the contrary.
 
+=head1 BRACKET NOTATION SECURITY
+
+Locale::Maketext does not use any special syntax to differentiate
+bracket notation methods from normal class or object methods. This
+design makes it vulnerable to format string attacks whenever it is
+used to process strings provided by untrusted users.
+
+Locale::Maketext does support blacklist and whitelist functionality
+to limit which methods may be called as bracket notation methods.
+
+By default, Locale::Maketext blacklists all methods in the
+Locale::Maketext namespace that begin with the '_' character,
+and all methods which include Perl's namespace separator characters.
+
+The default blacklist for Locale::Maketext also prevents use of the
+following methods in bracket notation:
+
+  blacklist
+  encoding
+  fail_with
+  failure_handler_auto
+  fallback_language_classes
+  fallback_languages
+  get_handle
+  init
+  language_tag
+  maketext
+  new
+  whitelist
+
+This list can be extended by either blacklisting additional "known bad"
+methods, or whitelisting only "known good" methods.
+
+To prevent specific methods from being called in bracket notation, use
+the blacklist() method:
+
+  my $lh = MyProgram::L10N->get_handle();
+  $lh->blacklist(qw{my_internal_method my_other_method});
+  $lh->maketext('[my_internal_method]'); # dies
+
+To limit the allowed bracked notation methods to a specific list, use the
+whitelist() method:
+
+  my $lh = MyProgram::L10N->get_handle();
+  $lh->whitelist('numerate', 'numf');
+  $lh->maketext('[_1] [numerate, _1,shoe,shoes]', 12); # works
+  $lh->maketext('[my_internal_method]'); # dies
+
+The blacklist() and whitelist() methods extend their internal lists
+whenever they are called. To reset the blacklist or whitelist, create
+a new maketext object.
+
+  my $lh = MyProgram::L10N->get_handle();
+  $lh->blacklist('numerate');
+  $lh->blacklist('numf');
+  $lh->maketext('[_1] [numerate,_1,shoe,shoes]', 12); # dies
+
+For lexicons that use an internal cache, translations which have already
+been cached in their compiled form are not affected by subsequent changes
+to the whitelist or blacklist settings. Lexicons that use an external
+cache will have their cache cleared whenever the whitelist of blacklist
+setings change.  The difference between the two types of caching is explained
+in the "Readonly Lexicons" section.
+
 =head1 AUTO LEXICONS
 
 If maketext goes to look in an individual %Lexicon for an entry
diff --git a/dist/Locale-Maketext/t/92_blacklist.t b/dist/Locale-Maketext/t/92_blacklist.t
new file mode 100644
index 0000000000..6ed36d1edd
--- /dev/null
+++ b/dist/Locale-Maketext/t/92_blacklist.t
@@ -0,0 +1,93 @@
+#!/usr/bin/perl -Tw
+
+use strict;
+use warnings;
+use Test::More tests => 17;
+
+BEGIN {
+    use_ok("Locale::Maketext");
+}
+
+{
+
+    package MyTestLocale;
+    no warnings 'once';
+
+    @MyTestLocale::ISA     = qw(Locale::Maketext);
+    %MyTestLocale::Lexicon = ();
+}
+
+{
+
+    package MyTestLocale::en;
+    no warnings 'once';
+
+    @MyTestLocale::en::ISA = qw(MyTestLocale);
+
+    %MyTestLocale::en::Lexicon = ( '_AUTO' => 1 );
+
+    sub custom_handler {
+        return "custom_handler_response";
+    }
+
+    sub _internal_method {
+        return "_internal_method_response";
+    }
+
+    sub new {
+        my ( $class, @args ) = @_;
+        my $lh = $class->SUPER::new(@args);
+        $lh->{use_external_lex_cache} = 1;
+        return $lh;
+    }
+}
+
+my $lh = MyTestLocale->get_handle('en');
+my $res;
+
+# get_handle blocked by default
+$res = eval { $lh->maketext('[get_handle,en]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'get_handle blocked in bracket notation by default blacklist' );
+
+# _ambient_langprefs blocked by default
+$res = eval { $lh->maketext('[_ambient_langprefs]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, '_ambient_langprefs blocked in bracket notation by default blacklist' );
+
+# _internal_method not blocked by default
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, "_internal_method_response", '_internal_method allowed in bracket notation by default blacklist' );
+is( $@, '', 'no exception thrown by use of _internal_method under default blacklist' );
+
+# sprintf not blocked by default
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, "hello", 'sprintf allowed in bracket notation by default blacklist' );
+is( $@,   '',      'no exception thrown by use of sprintf under default blacklist' );
+
+# blacklisting sprintf and numerate
+$lh->blacklist( 'sprintf', 'numerate' );
+
+# sprintf blocked by custom blacklist
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'sprintf blocked in bracket notation by custom blacklist' );
+
+# blacklisting numf and _internal_method
+$lh->blacklist('numf');
+$lh->blacklist('_internal_method');
+
+# sprintf blocked by custom blacklist
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'sprintf blocked in bracket notation by custom blacklist after extension of blacklist' );
+
+# _internal_method blocked by custom blacklist
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'sprintf blocked in bracket notation by custom blacklist after extension of blacklist' );
+
+# custom_handler not in default or custom blacklist
+$res = eval { $lh->maketext('[custom_handler]') };
+is( $res, "custom_handler_response", 'custom_handler allowed in bracket notation by default and custom blacklists' );
+is( $@, '', 'no exception thrown by use of custom_handler under default and custom blacklists' );
diff --git a/dist/Locale-Maketext/t/93_whitelist.t b/dist/Locale-Maketext/t/93_whitelist.t
new file mode 100644
index 0000000000..21f2d8574e
--- /dev/null
+++ b/dist/Locale-Maketext/t/93_whitelist.t
@@ -0,0 +1,96 @@
+#!/usr/bin/perl -Tw
+
+use strict;
+use warnings;
+use Test::More tests => 17;
+
+BEGIN {
+    use_ok("Locale::Maketext");
+}
+
+{
+
+    package MyTestLocale;
+    no warnings 'once';
+
+    @MyTestLocale::ISA     = qw(Locale::Maketext);
+    %MyTestLocale::Lexicon = ();
+}
+
+{
+
+    package MyTestLocale::en;
+    no warnings 'once';
+
+    @MyTestLocale::en::ISA = qw(MyTestLocale);
+
+    %MyTestLocale::en::Lexicon = ( '_AUTO' => 1 );
+
+    sub custom_handler {
+        return "custom_handler_response";
+    }
+
+    sub _internal_method {
+        return "_internal_method_response";
+    }
+
+    sub new {
+        my ( $class, @args ) = @_;
+        my $lh = $class->SUPER::new(@args);
+        $lh->{use_external_lex_cache} = 1;
+        return $lh;
+    }
+}
+
+my $lh = MyTestLocale->get_handle('en');
+my $res;
+
+# _internal_method not blocked by default
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, "_internal_method_response", '_internal_method allowed when no whitelist defined' );
+is( $@, '', 'no exception thrown by use of _internal_method without whitelist setting' );
+
+# whitelisting sprintf
+$lh->whitelist('sprintf');
+
+# _internal_method blocked by whitelist
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, '_internal_method blocked in bracket notation by whitelist' );
+
+# sprintf allowed by whitelist
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, "hello", 'sprintf allowed in bracket notation by whitelist' );
+is( $@,   '',      'no exception thrown by use of sprintf with whitelist' );
+
+# custom_handler blocked by whitelist
+$res = eval { $lh->maketext('[custom_handler]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'custom_handler blocked in bracket notation by whitelist' );
+
+# adding custom_handler to whitelist
+$lh->whitelist('custom_handler');
+
+# sprintf still allowed by whitelist
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, "hello", 'sprintf allowed in bracket notation by whitelist' );
+is( $@,   '',      'no exception thrown by use of sprintf with whitelist' );
+
+# custom_handler allowed by whitelist
+$res = eval { $lh->maketext('[custom_handler]') };
+is( $res, "custom_handler_response", 'custom_handler allowed in bracket notation by whitelist' );
+is( $@, '', 'no exception thrown by use of custom_handler with whitelist' );
+
+# _internal_method blocked by whitelist
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, '_internal_method blocked in bracket notation by whitelist' );
+
+# adding fail_with to whitelist
+$lh->whitelist('fail_with');
+
+# fail_with still blocked by blacklist
+$res = eval { $lh->maketext('[fail_with,xyzzy]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'fail_with blocked in bracket notation by blacklist even when whitelisted' );
+