Maketext.pm revision 7c478bd95313f5f23a4c958a745db2134aa03244
# Time-stamp: "2004-01-19 15:11:14 AST"
require 5;
use strict;
use Carp ();
#--------------------------------------------------------------------------
# define the constant 'DEBUG' at compile-time
$VERSION = "1.08";
@ISA = ();
$MATCH_SUPERS = 1;
$MATCH_SUPERS_TIGHTLY = 1;
$USING_LANGUAGE_TAGS = 1;
# Turning this off is somewhat of a security risk in that little or no
# checking will be done on the legality of tokens passed to the
# eval("use $module_name") in _try_use. If you turn this off, you have
# to do your own taint checking.
# a hint for compiling bracket-notation things.
my %isa_scan = ();
###########################################################################
sub quant {
# Normal case:
# Note that the formatting of $num is preserved.
# Most human languages put the number phrase before the qualified phrase.
}
sub numerate {
# return this lexical item in a form appropriate to this number
my $s = ($num == 1);
return '' unless @forms;
} else { # sing and plural were specified
}
}
#--------------------------------------------------------------------------
sub numf {
# Specifically, don't let %G turn ten million into 1E+007
} else {
# "CORE::" is there to avoid confusion with the above sub sprintf.
}
# The initial \d+ gobbles as many digits as it can, and then we
# backtrack so it un-eats the rightmost three, and then we
# insert the comma there.
# This is just a lame hack instead of using Number::Format
return $num;
}
sub sprintf {
no integer;
# "CORE::" is there to avoid confusion with myself!
}
#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
use integer; # vroom vroom... applies to the whole rest of the module
sub language_tag {
return undef unless $it =~ m/([^':]+)(?:::)?$/s;
$it = lc($1);
$it =~ tr<_><->;
return $it;
}
sub encoding {
my $it = $_[0];
return(
|| "iso-8859-1" # Latin-1
);
}
#--------------------------------------------------------------------------
sub fallback_language_classes { return () }
#--------------------------------------------------------------------------
sub fail_with { # an actual attribute method!
return unless ref($handle);
return $handle->{'fail'};
}
#--------------------------------------------------------------------------
sub failure_handler_auto {
# Meant to be used like:
# $handle->fail_with('failure_handler_auto')
$handle->{'failure_lex'} ||= {};
my $value;
# Dumbly copied from sub maketext:
{
local $SIG{'__DIE__'};
}
# If we make it here, there was an exception thrown in the
# call to $value, and so scream:
if($@) {
my $err = $@;
# pretty up the error message
#$err =~ s/\n?$/\n/s;
Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
# Rather unexpected, but suppose that the sub tried calling
# a method that didn't exist.
} else {
return $value;
}
}
#==========================================================================
sub new {
# Nothing fancy!
return $handle;
}
sub init { return } # no-op
###########################################################################
sub maketext {
# Remember, this can fail. Failure is controllable many ways.
# Look up the value:
my $value;
foreach my $h_r (
) {
print "* Looking up \"$phrase\" in $h_r\n" if DEBUG;
print " Found \"$phrase\" in $h_r\n" if DEBUG;
# Nonref means it's not yet compiled. Compile and replace.
}
last;
# it's an auto lex, and this is an autoable key!
print " Automaking \"$phrase\" into $h_r\n" if DEBUG;
last;
}
# else keep looking
}
unless(defined($value)) {
" fails.\n" if DEBUG;
print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG;
my $fail;
# If it ever returns, it should return a good value.
} else { # It's a method name
# If it ever returns, it should return a good value.
}
} else {
# All we know how to do is this;
Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
}
}
{
local $SIG{'__DIE__'};
}
# If we make it here, there was an exception thrown in the
# call to $value, and so scream:
if($@) {
my $err = $@;
# pretty up the error message
#$err =~ s/\n?$/\n/s;
Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
# Rather unexpected, but suppose that the sub tried calling
# a method that didn't exist.
} else {
return $value;
}
}
###########################################################################
sub get_handle { # This is a constructor and, yes, it CAN FAIL.
# Its class argument has to be the base class for the current
# application's l10n files.
my($base_class, @languages) = @_;
# Complain if they use __PACKAGE__ as a project base class?
my %seen;
next unless length $module_name; # sanity
return($module_name->new); # Make it!
}
return undef; # Fail!
}
###########################################################################
sub _langtag_munging {
my($base_class, @languages) = @_;
if($USING_LANGUAGE_TAGS) {
# if it's a lg tag, fine, pass thru (untainted)
# if it's a locale ID, try converting to a lg tag (untainted),
# otherwise nix it.
@languages; # catch alternation
DEBUG and print "After adding panic languages:\n",
}
# You are free to override fallback_languages to return empty-list!
@languages = # final bit of processing:
map {
my $it = $_; # copy
$it;
} @languages
;
DEBUG and print "Nearing end of munging:\n",
} else {
DEBUG and print "Bypassing language-tags.\n",
}
DEBUG and print "Before adding fallback classes:\n",
# You are free to override that to return whatever.
DEBUG and print "Finally:\n",
return @languages;
}
###########################################################################
sub _ambient_langprefs {
my $base_class = $_[0];
return $base_class->_http_accept_langs
# it's off in its own routine because it's complicated
# Not running as a CGI: try to puzzle out from the environment
my @languages;
# LANG can be only /one/ locale as far as I know, but what the hey.
}
}
# Those are really locale IDs, but they get xlated a few lines down.
if(&_try_use('Win32::Locale')) {
# If we have that module installed...
}
return @languages;
}
###########################################################################
sub _add_supers {
my($base_class, @languages) = @_;
if(!$MATCH_SUPERS) {
# Nothing
DEBUG and print "Bypassing any super-matching.\n",
} elsif( $MATCH_SUPERS_TIGHTLY ) {
DEBUG and print "Before adding new supers tightly:\n",
my %seen_encoded;
}
my(@output_languages);
push @output_languages, $lang;
# Note that super_languages returns the longest first.
push @output_languages, $s;
}
}
DEBUG and print "After adding new supers tightly:\n",
} else {
DEBUG and print "After adding supers to end:\n",
}
return @languages;
}
###########################################################################
#
# This is where most people should stop reading.
#
###########################################################################
sub _http_accept_langs {
# Deal with HTTP "Accept-Language:" stuff. Hassle.
# This code is more lenient than RFC 3282, which you must read.
# Hm. Should I just move this into I18N::LangTags at some point?
no integer;
# (always ends up untainting)
$in =~ s/\([^\)]*\)//g; # nix just about any comment
# Very common case: just one language tag
return lc $1;
# Common case these days: just "foo, bar, baz"
}
# Else it's complicated...
$in =~ s/\s+//g; # Yes, we can just do without the WS!
my %pref;
my $q;
next unless $tag =~
(?:
;q=
(
\d* # a bit too broad of a RE, but so what.
(?:
\.\d+
)?
)
)?
$
/sx
;
$q = (defined $2 and length $2) ? $2 : 1;
#print "$1 with q=$q\n";
push @{ $pref{$q} }, lc $1;
}
return # Read off %pref, in descending key order...
map @{$pref{$_}},
sort {$b <=> $a}
keys %pref;
}
###########################################################################
my %tried = ();
# memoization of whether we've used this module, or found it unusable.
sub _try_use { # Basically a wrapper around "require Modulename"
# "Many men have tried..." "They tried and failed?" "They tried and died."
{ no strict 'refs';
# weird case: we never use'd it, but there it is!
}
print " About to use $module ...\n" if DEBUG;
{
local $SIG{'__DIE__'};
eval "require $module"; # used to be "use $module", but no point in that.
}
if($@) {
} else {
print " OK, $module is used\n" if DEBUG;
}
}
#--------------------------------------------------------------------------
sub _lex_refs { # report the lexicon references for this handle's class
# returns an arrayREF!
no strict 'refs';
my @lex_refs;
}
# Implements depth(height?)-first recursive searching of superclasses.
# In hindsight, I suppose I could have just used Class::ISA!
print " Super-class search into $superclass\n" if DEBUG;
next if $seen_r->{$superclass}++;
}
return \@lex_refs;
}
###########################################################################
1;
[end]