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


# Time-stamp: "2004-03-30 16:33:31 AST"

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

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

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

$VERSION = "1.10_01";
@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.

$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);

  # Don't interefere with $@ in case that's being interpolated into the msg.
  local $@;

  # 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?
  
  if( @languages ) {
    DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
    if($USING_LANGUAGE_TAGS) {   # An explicit language-list was given!
      @languages =
       map {; $_, I18N::LangTags::alternate_language_tags($_) }
        # Catch alternation
       map I18N::LangTags::locale2language_tag($_),
        # 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;
      DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
    }
  } else {
    @languages = $base_class->_ambient_langprefs;
  }
 
  @languages = $base_class->_langtag_munging(@languages);

  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!
}

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

sub _langtag_munging {
  my($base_class, @languages) = @_;

  # We have all these DEBUG statements because otherwise it's hard as hell
  # to diagnose ifwhen something goes wrong.

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

  if($USING_LANGUAGE_TAGS) {
    DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
    @languages     = $base_class->_add_supers( @languages );

    push @languages, I18N::LangTags::panic_languages(@languages);
    DEBUG and print "After adding panic languages:\n", 
      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";

    push @languages, $base_class->fallback_languages;
     # You are free to override fallback_languages to return empty-list!
    DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";

    @languages =  # final bit of processing to turn them into classname things
      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
    ;
    DEBUG and print "Nearing end of munging:\n", 
      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
  } else {
    DEBUG and print "Bypassing language-tags.\n", 
      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
  }

  DEBUG and print "Before adding fallback classes:\n", 
    " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";

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

  DEBUG and print "Finally:\n", 
    " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";

  return @languages;
}

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

sub _ambient_langprefs {
  require I18N::LangTags::Detect;
  return  I18N::LangTags::Detect::detect();
}

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

sub _add_supers {
  my($base_class, @languages) = @_;

  if(!$MATCH_SUPERS) {
    # Nothing
    DEBUG and print "Bypassing any super-matching.\n", 
      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";

  } elsif( $MATCH_SUPERS_TIGHTLY ) {
    DEBUG and print "Before adding new supers tightly:\n", 
      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
    @languages = I18N::LangTags::implicate_supers( @languages );
    DEBUG and print "After adding new supers tightly:\n", 
      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";

  } else {
    DEBUG and print "Before adding supers to end:\n", 
      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
    @languages = I18N::LangTags::implicate_supers_strictly( @languages );
    DEBUG and print "After adding supers to end:\n", 
      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
  }
  
  return @languages;
}

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

use Locale::Maketext::GutsLoader;

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

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