[p5sagit/p5-mst-13.2.git] / lib / Locale / Maketext.pm


# Time-stamp: "2003-06-21 23:41:57 AHDT"

require 5;
package Locale::Maketext;
use strict;
use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
             $USE_LITERALS);
use Carp ();
use I18N::LangTags 0.21 ();

#--------------------------------------------------------------------------

BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
 # define the constant 'DEBUG' at compile-time

$VERSION = "1.06";
@ISA = ();

$MATCH_SUPERS = 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.

$USE_LITERALS = 1 unless defined $USE_LITERALS;
 # a hint for compiling bracket-notation things.

my %isa_scan = ();

###########################################################################

sub quant {
  my($handle, $num, @forms) = @_;

  return $num if @forms == 0; # what should this mean?
  return $forms[2] if @forms > 2 and $num == 0; # special zeroth case

  # Normal case:
  # Note that the formatting of $num is preserved.
  return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) );
   # 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($handle, $num, @forms) = @_;
  my $s = ($num == 1);

  return '' unless @forms;
  if(@forms == 1) { # only the headword form specified
    return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack.
  } else { # sing and plural were specified
    return $s ? $forms[0] : $forms[1];
  }
}

#--------------------------------------------------------------------------

sub numf {
  my($handle, $num) = @_[0,1];
  if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) {
    $num += 0;  # Just use normal integer stringification.
         # Specifically, don't let %G turn ten million into 1E+007
  } else {
    $num = CORE::sprintf("%G", $num);
     # "CORE::" is there to avoid confusion with the above sub sprintf.
  }
  while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1}  # right from perlfaq5
   # 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.

  $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
   # This is just a lame hack instead of using Number::Format
  return $num;
}

sub sprintf {
  no integer;
  my($handle, $format, @params) = @_;
  return CORE::sprintf($format, @params);
    # "CORE::" is there to avoid confusion with myself!
}

#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#

use integer; # vroom vroom... applies to the whole rest of the module

sub language_tag {
  my $it = ref($_[0]) || $_[0];
  return undef unless $it =~ m/([^':]+)(?:::)?$/s;
  $it = lc($1);
  $it =~ tr<_><->;
  return $it;
}

sub encoding {
  my $it = $_[0];
  return(
   (ref($it) && $it->{'encoding'})
   || "iso-8859-1"   # Latin-1
  );
} 

#--------------------------------------------------------------------------

sub fallback_languages { return('i-default', 'en', 'en-US') }

sub fallback_language_classes { return () }

#--------------------------------------------------------------------------

sub fail_with { # an actual attribute method!
  my($handle, @params) = @_;
  return unless ref($handle);
  $handle->{'fail'} = $params[0] if @params;
  return $handle->{'fail'};
}

#--------------------------------------------------------------------------

sub failure_handler_auto {
  # Meant to be used like:
  #  $handle->fail_with('failure_handler_auto')

  my($handle, $phrase, @params) = @_;
  $handle->{'failure_lex'} ||= {};
  my $lex = $handle->{'failure_lex'};

  my $value;
  $lex->{$phrase} ||= ($value = $handle->_compile($phrase));

  # Dumbly copied from sub maketext:
  {
    local $SIG{'__DIE__'};
    eval { $value = &$value($handle, @_) };
  }
  # 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<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
             <\n in bracket code [compiled line $1],>s;
    #$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!
  my $class = ref($_[0]) || $_[0];
  my $handle = bless {}, $class;
  $handle->init;
  return $handle;
}

sub init { return } # no-op

###########################################################################

sub maketext {
  # Remember, this can fail.  Failure is controllable many ways.
  Carp::croak "maketext requires at least one parameter" unless @_ > 1;

  my($handle, $phrase) = splice(@_,0,2);

  # Look up the value:

  my $value;
  foreach my $h_r (
    @{  $isa_scan{ref($handle) || $handle} || $handle->_lex_refs  }
  ) {
    print "* Looking up \"$phrase\" in $h_r\n" if DEBUG;
    if(exists $h_r->{$phrase}) {
      print "  Found \"$phrase\" in $h_r\n" if DEBUG;
      unless(ref($value = $h_r->{$phrase})) {
        # Nonref means it's not yet compiled.  Compile and replace.
        $value = $h_r->{$phrase} = $handle->_compile($value);
      }
      last;
    } elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
      # it's an auto lex, and this is an autoable key!
      print "  Automaking \"$phrase\" into $h_r\n" if DEBUG;
      
      $value = $h_r->{$phrase} = $handle->_compile($phrase);
      last;
    }
    print "  Not found in $h_r, nor automakable\n" if DEBUG > 1;
    # else keep looking
  }

  unless(defined($value)) {
    print "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle,
      " fails.\n" if DEBUG;
    if(ref($handle) and $handle->{'fail'}) {
      print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG;
      my $fail;
      if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
        return &{$fail}($handle, $phrase, @_);
         # If it ever returns, it should return a good value.
      } else { # It's a method name
        return $handle->$fail($phrase, @_);
         # 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");
    }
  }

  return $$value if ref($value) eq 'SCALAR';
  return $value unless ref($value) eq 'CODE';
  
  {
    local $SIG{'__DIE__'};
    eval { $value = &$value($handle, @_) };
  }
  # 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<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
             <\n in bracket code [compiled line $1],>s;
    #$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) = @_;
  $base_class = ref($base_class) || $base_class;
   # Complain if they use __PACKAGE__ as a project base class?

  unless(@languages) {  # Calling with no args is magical!  wooo, magic!
    if(length( $ENV{'REQUEST_METHOD'} || '' )) { # I'm a CGI
      @languages = $base_class->_http_accept_langs;
         # it's off in its own routine because it's complicated
      
    } else { # Not running as a CGI: try to puzzle out from the environment
      if(length( $ENV{'LANG'} || '' )) {
	push @languages, split m/[,:]/, $ENV{'LANG'};
         # LANG can be only /one/ locale as far as I know, but what the hey.
      }
      if(length( $ENV{'LANGUAGE'} || '' )) {
	push @languages, split m/[,:]/, $ENV{'LANGUAGE'};
      }
      print "Noting ENV LANG ", join(',', @languages),"\n" if DEBUG;
      # Those are really locale IDs, but they get xlated a few lines down.
      
      if(&_try_use('Win32::Locale')) {
        # If we have that module installed...
        push @languages, Win32::Locale::get_language()
         if defined &Win32::Locale::get_language;
      }
    }
  }

  #------------------------------------------------------------------------
  print "Lgs1: ", map("<$_>", @languages), "\n" if DEBUG;

  if($USING_LANGUAGE_TAGS) {
    @languages = map &I18N::LangTags::locale2language_tag($_), @languages;
     # 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.

    push @languages, map I18N::LangTags::super_languages($_), @languages
     if $MATCH_SUPERS;

    @languages =  map { $_, I18N::LangTags::alternate_language_tags($_) }
                      @languages;    # catch alternation

    push @languages, I18N::LangTags::panic_languages(@languages)
      if defined &I18N::LangTags::panic_languages;
    
    push @languages, $base_class->fallback_languages;
     # You are free to override fallback_languages to return empty-list!

    @languages =  # final bit of processing:
      map {
        my $it = $_;  # copy
        $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
        $it =~ tr<_a-z0-9><>cd;  # remove all but a-z0-9_
        $it;
      } @languages
    ;
  }
  print "Lgs2: ", map("<$_>", @languages), "\n" if DEBUG > 1;

  push @languages, $base_class->fallback_language_classes;
   # You are free to override that to return whatever.


  my %seen = ();
  foreach my $module_name ( map { $base_class . "::" . $_ }  @languages )
  {
    next unless length $module_name; # sanity
    next if $seen{$module_name}++        # Already been here, and it was no-go
            || !&_try_use($module_name); # Try to use() it, but can't it.
    return($module_name->new); # Make it!
  }

  return undef; # Fail!
}

###########################################################################
#
# This is where most people should stop reading.
#
###########################################################################

use Locale::Maketext::GutsLoader;

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;

  my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
  # (always ends up untainting)

  return() unless defined $in and length $in;

  $in =~ s/\([^\)]*\)//g; # nix just about any comment
  
  if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
    # Very common case: just one language tag
    return lc $1;
  } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
    # Common case these days: just "foo, bar, baz"
    return map lc($_), $in =~ m/([a-zA-Z][-a-zA-Z]+)/g;
  }

  # Else it's complicated...

  $in =~ s/\s+//g;  # Yes, we can just do without the WS!
  my @in = $in =~ m/([^,]+)/g;
  my %pref;
  
  my $q;
  foreach my $tag (@in) {
    next unless $tag =~
     m/^([a-zA-Z][-a-zA-Z]+)
        (?:
         ;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."
  return $tried{$_[0]} if exists $tried{$_[0]};  # memoization

  my $module = $_[0];   # ASSUME sane module name!
  { no strict 'refs';
    return($tried{$module} = 1)
     if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
    # 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($@) {
    print "Error using $module \: $@\n" if DEBUG > 1;
    return $tried{$module} = 0;
  } else {
    print " OK, $module is used\n" if DEBUG;
    return $tried{$module} = 1;
  }
}

#--------------------------------------------------------------------------

sub _lex_refs {  # report the lexicon references for this handle's class
  # returns an arrayREF!
  no strict 'refs';
  my $class = ref($_[0]) || $_[0];
  print "Lex refs lookup on $class\n" if DEBUG > 1;
  return $isa_scan{$class} if exists $isa_scan{$class};  # memoization!

  my @lex_refs;
  my $seen_r = ref($_[1]) ? $_[1] : {};

  if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
    push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
    print "%" . $class . "::Lexicon contains ",
         scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
  }

  # Implements depth(height?)-first recursive searching of superclasses.
  # In hindsight, I suppose I could have just used Class::ISA!
  foreach my $superclass (@{$class . "::ISA"}) {
    print " Super-class search into $superclass\n" if DEBUG;
    next if $seen_r->{$superclass}++;
    push @lex_refs, @{&_lex_refs($superclass, $seen_r)};  # call myself
  }

  $isa_scan{$class} = \@lex_refs; # save for next time
  return \@lex_refs;
}

sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!

###########################################################################
1;

__END__

HEY YOU!  You need some FOOD!


  ~~ Tangy Moroccan Carrot Salad ~~

* 6 to 8 medium carrots, peeled and then sliced in 1/4-inch rounds
* 1/4 teaspoon chile powder (cayenne, chipotle, ancho, or the like)
* 1 tablespoon ground cumin
* 1 tablespoon honey
* The juice of about a half a big lemon, or of a whole smaller one
* 1/3 cup olive oil
* 1 tablespoon of fresh dill, washed and chopped fine
* Pinch of salt, maybe a pinch of pepper

Cook the carrots in a pot of boiling water until just tender -- roughly
six minutes.  (Just don't let them get mushy!)  Drain the carrots.

In a largish bowl, combine the lemon juice, the cumin, the chile
powder, and the honey.  Mix well.
Add the olive oil and whisk it together well.  Add the dill and stir.

Add the warm carrots to the bowl and toss it all to coat the carrots
well.  Season with salt and pepper, to taste.

Serve warm or at room temperature.

The measurements here are very approximate, and you should feel free to
improvise and experiment.  It's a very forgiving recipe.  For example,
you could easily halve or double the amount of cumin, or use chopped mint
leaves instead of dill, or lime juice instead of lemon, et cetera.

[end]
Commit	Line	Data
9378c581	1
f600d105	2	# Time-stamp: "2003-06-21 23:41:57 AHDT"
9378c581	3
	4	require 5;
	5	package Locale::Maketext;
	6	use strict;
	7	use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
	8	$USE_LITERALS);
	9	use Carp ();
	10	use I18N::LangTags 0.21 ();
	11
	12	#--------------------------------------------------------------------------
	13
	14	BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
	15	# define the constant 'DEBUG' at compile-time
	16
f600d105	17	$VERSION = "1.06";
9378c581	18	@ISA = ();
	19
	20	$MATCH_SUPERS = 1;
	21	$USING_LANGUAGE_TAGS = 1;
	22	# Turning this off is somewhat of a security risk in that little or no
	23	# checking will be done on the legality of tokens passed to the
	24	# eval("use $module_name") in _try_use. If you turn this off, you have
	25	# to do your own taint checking.
	26
	27	$USE_LITERALS = 1 unless defined $USE_LITERALS;
	28	# a hint for compiling bracket-notation things.
	29
	30	my %isa_scan = ();
	31
	32	###########################################################################
	33
	34	sub quant {
	35	my($handle, $num, @forms) = @_;
	36
	37	return $num if @forms == 0; # what should this mean?
	38	return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
	39
	40	# Normal case:
	41	# Note that the formatting of $num is preserved.
	42	return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) );
	43	# Most human languages put the number phrase before the qualified phrase.
	44	}
	45
	46
	47	sub numerate {
	48	# return this lexical item in a form appropriate to this number
	49	my($handle, $num, @forms) = @_;
	50	my $s = ($num == 1);
	51
	52	return '' unless @forms;
	53	if(@forms == 1) { # only the headword form specified
	54	return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack.
	55	} else { # sing and plural were specified
	56	return $s ? $forms[0] : $forms[1];
	57	}
	58	}
	59
	60	#--------------------------------------------------------------------------
	61
	62	sub numf {
	63	my($handle, $num) = @_[0,1];
	64	if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) {
	65	$num += 0; # Just use normal integer stringification.
	66	# Specifically, don't let %G turn ten million into 1E+007
	67	} else {
	68	$num = CORE::sprintf("%G", $num);
	69	# "CORE::" is there to avoid confusion with the above sub sprintf.
	70	}
	71	while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5
	72	# The initial \d+ gobbles as many digits as it can, and then we
	73	# backtrack so it un-eats the rightmost three, and then we
	74	# insert the comma there.
	75
	76	$num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
	77	# This is just a lame hack instead of using Number::Format
	78	return $num;
	79	}
	80
	81	sub sprintf {
82	no integer;
83	my($handle, $format, @params) = @_;
84	return CORE::sprintf($format, @params);
85	# "CORE::" is there to avoid confusion with myself!
86	}
87
88	#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
89
90	use integer; # vroom vroom... applies to the whole rest of the module
91
92	sub language_tag {
93	my $it = ref($_[0]) \|\| $_[0];
94	return undef unless $it =~ m/([^':]+)(?:::)?$/s;
95	$it = lc($1);
96	$it =~ tr<_><->;
97	return $it;
98	}
99
100	sub encoding {
101	my $it = $_[0];
102	return(
103	(ref($it) && $it->{'encoding'})
104	\|\| "iso-8859-1" # Latin-1
105	);
106	}
107
108	#--------------------------------------------------------------------------
109
110	sub fallback_languages { return('i-default', 'en', 'en-US') }
111
112	sub fallback_language_classes { return () }
113
114	#--------------------------------------------------------------------------
115
116	sub fail_with { # an actual attribute method!
117	my($handle, @params) = @_;
118	return unless ref($handle);
119	$handle->{'fail'} = $params[0] if @params;
120	return $handle->{'fail'};
121	}
122
123	#--------------------------------------------------------------------------
124
125	sub failure_handler_auto {
126	# Meant to be used like:
127	# $handle->fail_with('failure_handler_auto')
128
129	my($handle, $phrase, @params) = @_;
130	$handle->{'failure_lex'} \|\|= {};
131	my $lex = $handle->{'failure_lex'};
132
133	my $value;
134	$lex->{$phrase} \|\|= ($value = $handle->_compile($phrase));
135
136	# Dumbly copied from sub maketext:
137	{
138	local $SIG{'__DIE__'};
139	eval { $value = &$value($handle, @_) };
140	}
141	# If we make it here, there was an exception thrown in the
142	# call to $value, and so scream:
143	if($@) {
144	my $err = $@;
145	# pretty up the error message
146	$err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
147	<\n in bracket code [compiled line $1],>s;
148	#$err =~ s/\n?$/\n/s;
149	Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
150	# Rather unexpected, but suppose that the sub tried calling
151	# a method that didn't exist.
152	} else {
153	return $value;
154	}
155	}
156
157	#==========================================================================
158
159	sub new {
160	# Nothing fancy!
161	my $class = ref($_[0]) \|\| $_[0];
162	my $handle = bless {}, $class;
163	$handle->init;
164	return $handle;
165	}
166
167	sub init { return } # no-op
168
169	###########################################################################
170
171	sub maketext {
172	# Remember, this can fail. Failure is controllable many ways.
173	Carp::croak "maketext requires at least one parameter" unless @_ > 1;
174
175	my($handle, $phrase) = splice(@_,0,2);
176
177	# Look up the value:
178
179	my $value;
180	foreach my $h_r (
181	@{ $isa_scan{ref($handle) \|\| $handle} \|\| $handle->_lex_refs }
182	) {
183	print "* Looking up \"$phrase\" in $h_r\n" if DEBUG;
184	if(exists $h_r->{$phrase}) {
185	print " Found \"$phrase\" in $h_r\n" if DEBUG;
186	unless(ref($value = $h_r->{$phrase})) {
187	# Nonref means it's not yet compiled. Compile and replace.
188	$value = $h_r->{$phrase} = $handle->_compile($value);
189	}
190	last;
191	} elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
192	# it's an auto lex, and this is an autoable key!
193	print " Automaking \"$phrase\" into $h_r\n" if DEBUG;
194
195	$value = $h_r->{$phrase} = $handle->_compile($phrase);
196	last;
197	}
198	print " Not found in $h_r, nor automakable\n" if DEBUG > 1;
199	# else keep looking
200	}
201
202	unless(defined($value)) {
203	print "! Lookup of \"$phrase\" in/under ", ref($handle) \|\| $handle,
204	" fails.\n" if DEBUG;
205	if(ref($handle) and $handle->{'fail'}) {
206	print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG;
207	my $fail;
208	if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
209	return &{$fail}($handle, $phrase, @_);
210	# If it ever returns, it should return a good value.
211	} else { # It's a method name
212	return $handle->$fail($phrase, @_);
213	# If it ever returns, it should return a good value.
214	}
215	} else {
216	# All we know how to do is this;
217	Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
218	}
219	}
220
221	return $$value if ref($value) eq 'SCALAR';
222	return $value unless ref($value) eq 'CODE';
223
224	{
225	local $SIG{'__DIE__'};
226	eval { $value = &$value($handle, @_) };
227	}
228	# If we make it here, there was an exception thrown in the
229	# call to $value, and so scream:
230	if($@) {
231	my $err = $@;
232	# pretty up the error message
233	$err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
234	<\n in bracket code [compiled line $1],>s;
235	#$err =~ s/\n?$/\n/s;
236	Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
237	# Rather unexpected, but suppose that the sub tried calling
238	# a method that didn't exist.
239	} else {
240	return $value;
241	}
242	}
243
244	###########################################################################
245
246	sub get_handle { # This is a constructor and, yes, it CAN FAIL.
247	# Its class argument has to be the base class for the current
248	# application's l10n files.
249	my($base_class, @languages) = @_;
250	$base_class = ref($base_class) \|\| $base_class;
251	# Complain if they use __PACKAGE__ as a project base class?
252
253	unless(@languages) { # Calling with no args is magical! wooo, magic!
254	if(length( $ENV{'REQUEST_METHOD'} \|\| '' )) { # I'm a CGI
f918d677	255	@languages = $base_class->_http_accept_langs;
f918d677	256	# it's off in its own routine because it's complicated
9378c581	257
	258	} else { # Not running as a CGI: try to puzzle out from the environment
	259	if(length( $ENV{'LANG'} \|\| '' )) {
	260	push @languages, split m/[,:]/, $ENV{'LANG'};
	261	# LANG can be only /one/ locale as far as I know, but what the hey.
	262	}
	263	if(length( $ENV{'LANGUAGE'} \|\| '' )) {
	264	push @languages, split m/[,:]/, $ENV{'LANGUAGE'};
	265	}
	266	print "Noting ENV LANG ", join(',', @languages),"\n" if DEBUG;
	267	# Those are really locale IDs, but they get xlated a few lines down.
	268
	269	if(&_try_use('Win32::Locale')) {
	270	# If we have that module installed...
	271	push @languages, Win32::Locale::get_language()
	272	if defined &Win32::Locale::get_language;
	273	}
	274	}
	275	}
	276
	277	#------------------------------------------------------------------------
	278	print "Lgs1: ", map("<$_>", @languages), "\n" if DEBUG;
	279
	280	if($USING_LANGUAGE_TAGS) {
	281	@languages = map &I18N::LangTags::locale2language_tag($_), @languages;
	282	# if it's a lg tag, fine, pass thru (untainted)
	283	# if it's a locale ID, try converting to a lg tag (untainted),
	284	# otherwise nix it.
	285
ff5ad48a	286	push @languages, map I18N::LangTags::super_languages($_), @languages
9378c581	287	if $MATCH_SUPERS;
9378c581	288
ff5ad48a	289	@languages = map { $_, I18N::LangTags::alternate_language_tags($_) }
9378c581	290	@languages; # catch alternation
9378c581	291
ff5ad48a	292	push @languages, I18N::LangTags::panic_languages(@languages)
	293	if defined &I18N::LangTags::panic_languages;
	294
9378c581	295	push @languages, $base_class->fallback_languages;
	296	# You are free to override fallback_languages to return empty-list!
	297
	298	@languages = # final bit of processing:
	299	map {
	300	my $it = $_; # copy
	301	$it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
	302	$it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_
	303	$it;
	304	} @languages
	305	;
	306	}
	307	print "Lgs2: ", map("<$_>", @languages), "\n" if DEBUG > 1;
	308
	309	push @languages, $base_class->fallback_language_classes;
	310	# You are free to override that to return whatever.
	311
	312
	313	my %seen = ();
	314	foreach my $module_name ( map { $base_class . "::" . $_ } @languages )
	315	{
	316	next unless length $module_name; # sanity
	317	next if $seen{$module_name}++ # Already been here, and it was no-go
	318	\|\| !&_try_use($module_name); # Try to use() it, but can't it.
	319	return($module_name->new); # Make it!
	320	}
	321
	322	return undef; # Fail!
	323	}
	324
	325	###########################################################################
	326	#
	327	# This is where most people should stop reading.
	328	#
	329	###########################################################################
	330
f600d105	331	use Locale::Maketext::GutsLoader;
f600d105	332
f918d677	333	sub _http_accept_langs {
	334	# Deal with HTTP "Accept-Language:" stuff. Hassle.
	335	# This code is more lenient than RFC 3282, which you must read.
	336	# Hm. Should I just move this into I18N::LangTags at some point?
	337	no integer;
	338
	339	my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
	340	# (always ends up untainting)
	341
	342	return() unless defined $in and length $in;
	343
	344	$in =~ s/\([^\)]*\)//g; # nix just about any comment
	345
	346	if( $in =~ m/^\s([a-zA-Z][-a-zA-Z]+)\s$/s ) {
	347	# Very common case: just one language tag
	348	return lc $1;
	349	} elsif( $in =~ m/^\s[a-zA-Z][-a-zA-Z]+(?:\s,\s[a-zA-Z][-a-zA-Z]+)\s*$/s ) {
	350	# Common case these days: just "foo, bar, baz"
	351	return map lc($_), $in =~ m/([a-zA-Z][-a-zA-Z]+)/g;
	352	}
	353
	354	# Else it's complicated...
	355
	356	$in =~ s/\s+//g; # Yes, we can just do without the WS!
	357	my @in = $in =~ m/([^,]+)/g;
	358	my %pref;
	359
	360	my $q;
	361	foreach my $tag (@in) {
	362	next unless $tag =~
	363	m/^([a-zA-Z][-a-zA-Z]+)
	364	(?:
	365	;q=
	366	(
	367	\d* # a bit too broad of a RE, but so what.
	368	(?:
	369	\.\d+
	370	)?
	371	)
	372	)?
	373	$
	374	/sx
	375	;
	376	$q = (defined $2 and length $2) ? $2 : 1;
	377	#print "$1 with q=$q\n";
	378	push @{ $pref{$q} }, lc $1;
	379	}
	380
	381	return # Read off %pref, in descending key order...
	382	map @{$pref{$_}},
	383	sort {$b <=> $a}
	384	keys %pref;
	385	}
	386
	387	###########################################################################
	388
9378c581	389	my %tried = ();
	390	# memoization of whether we've used this module, or found it unusable.
	391
	392	sub _try_use { # Basically a wrapper around "require Modulename"
	393	# "Many men have tried..." "They tried and failed?" "They tried and died."
	394	return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
	395
	396	my $module = $_[0]; # ASSUME sane module name!
	397	{ no strict 'refs';
	398	return($tried{$module} = 1)
	399	if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
	400	# weird case: we never use'd it, but there it is!
	401	}
	402
	403	print " About to use $module ...\n" if DEBUG;
	404	{
	405	local $SIG{'__DIE__'};
	406	eval "require $module"; # used to be "use $module", but no point in that.
	407	}
	408	if($@) {
	409	print "Error using $module \: $@\n" if DEBUG > 1;
	410	return $tried{$module} = 0;
	411	} else {
	412	print " OK, $module is used\n" if DEBUG;
	413	return $tried{$module} = 1;
	414	}
	415	}
	416
	417	#--------------------------------------------------------------------------
	418
	419	sub _lex_refs { # report the lexicon references for this handle's class
	420	# returns an arrayREF!
	421	no strict 'refs';
	422	my $class = ref($_[0]) \|\| $_[0];
	423	print "Lex refs lookup on $class\n" if DEBUG > 1;
	424	return $isa_scan{$class} if exists $isa_scan{$class}; # memoization!
	425
	426	my @lex_refs;
	427	my $seen_r = ref($_[1]) ? $_[1] : {};
	428
	429	if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
	430	push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
	431	print "%" . $class . "::Lexicon contains ",
	432	scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
	433	}
	434
ff5ad48a	435	# Implements depth(height?)-first recursive searching of superclasses.
ff5ad48a	436	# In hindsight, I suppose I could have just used Class::ISA!
9378c581	437	foreach my $superclass (@{$class . "::ISA"}) {
	438	print " Super-class search into $superclass\n" if DEBUG;
	439	next if $seen_r->{$superclass}++;
	440	push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself
	441	}
	442
	443	$isa_scan{$class} = \@lex_refs; # save for next time
	444	return \@lex_refs;
	445	}
	446
	447	sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
	448
	449	###########################################################################
	450	1;
	451
f918d677	452	__END__
	453
	454	HEY YOU! You need some FOOD!
	455
	456
	457	~~ Tangy Moroccan Carrot Salad ~~
	458
	459	* 6 to 8 medium carrots, peeled and then sliced in 1/4-inch rounds
	460	* 1/4 teaspoon chile powder (cayenne, chipotle, ancho, or the like)
	461	* 1 tablespoon ground cumin
	462	* 1 tablespoon honey
	463	* The juice of about a half a big lemon, or of a whole smaller one
	464	* 1/3 cup olive oil
	465	* 1 tablespoon of fresh dill, washed and chopped fine
	466	* Pinch of salt, maybe a pinch of pepper
	467
	468	Cook the carrots in a pot of boiling water until just tender -- roughly
	469	six minutes. (Just don't let them get mushy!) Drain the carrots.
	470
	471	In a largish bowl, combine the lemon juice, the cumin, the chile
	472	powder, and the honey. Mix well.
	473	Add the olive oil and whisk it together well. Add the dill and stir.
	474
	475	Add the warm carrots to the bowl and toss it all to coat the carrots
	476	well. Season with salt and pepper, to taste.
	477
	478	Serve warm or at room temperature.
	479
	480	The measurements here are very approximate, and you should feel free to
	481	improvise and experiment. It's a very forgiving recipe. For example,
	482	you could easily halve or double the amount of cumin, or use chopped mint
	483	leaves instead of dill, or lime juice instead of lemon, et cetera.
	484
	485	[end]