diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Locale/Maketext.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Locale/Maketext.pm | 73 |
1 files changed, 63 insertions, 10 deletions
diff --git a/Master/tlpkg/tlperl/lib/Locale/Maketext.pm b/Master/tlpkg/tlperl/lib/Locale/Maketext.pm index e73c149a068..36d0c055661 100644 --- a/Master/tlpkg/tlperl/lib/Locale/Maketext.pm +++ b/Master/tlpkg/tlperl/lib/Locale/Maketext.pm @@ -1,4 +1,3 @@ - package Locale::Maketext; use strict; use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS @@ -27,7 +26,7 @@ BEGIN { } -$VERSION = '1.26_01'; +$VERSION = '1.28'; @ISA = (); $MATCH_SUPERS = 1; @@ -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; } @@ -510,7 +560,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. @@ -542,10 +592,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 { @@ -629,13 +679,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]) @@ -677,7 +729,7 @@ sub _compile { push @c, ''; } else { - $target->_die_pointing($string_to_compile, q{Unbalanced ']'}); + $handle->_die_pointing($string_to_compile, q{Unbalanced ']'}); } } @@ -762,8 +814,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"); |