From 12f3ee9faa28672085733cb76aeb3d9b54df19ea Mon Sep 17 00:00:00 2001
From: Mischa POSLAWSKY <perl@shiar.org>
Date: Wed, 31 May 2006 22:12:12 +0000
Subject: [PATCH] Loc3.05: -langorder, exists

---
 Lirama/Loc3.pm | 67 ++++++++++++++++++++++++++++++--------------------
 1 file changed, 41 insertions(+), 26 deletions(-)

diff --git a/Lirama/Loc3.pm b/Lirama/Loc3.pm
index d7f4d49..781208a 100644
--- a/Lirama/Loc3.pm
+++ b/Lirama/Loc3.pm
@@ -3,7 +3,7 @@ package Lirama::Loc3;
 use strict;
 use warnings;
 
-our $VERSION = '3.01';
+our $VERSION = '3.05';
 
 sub loc($) {
 	my $this = shift;
@@ -11,7 +11,7 @@ sub loc($) {
 	# if it isn't, we're done already:
 	ref $_[0] eq "HASH" or return $_[0];
 	# localize to most preferred language
-	defined $_[0]{$_} and return $_[0]{$_} for @{$this->{-langpref}};
+	defined $_[0]{$_} and return $_[0]{$_} for @{$this->{-langorder}};
 } # loc
 
 sub TIEHASH {
@@ -20,54 +20,69 @@ sub TIEHASH {
 }
 
 sub FETCH {
-	my $this = shift;
-	local $_ = shift;
+	my ($this, $id) = @_;
 	# get setting (denoted by leading dash)
-	return wantarray ? @{$this->{$_}} : $this->{$_}->[0]
-		if $_ eq "-langpref";
-	return $this->{$_}
-		if $_ eq "-path" or $_ eq "-seperator";
+	return $this->{$id} if $id =~ /^-/;
 	# array ref used for passing arguments
-	($_, @_) = @$_ if ref $_ eq "ARRAY";
-	# add default path unless specified
-	$_ = $this->{-path} . $this->{-seperator} . $_
-		if defined $this->{-seperator} and not /\Q$this->{-seperator}/;
+	my @args;
+	($id, @args) = @$id if ref $id eq "ARRAY";
+	# add leading base path unless specified absolute
+	$id = $this->{-path} . $id
+		if defined $this->{-path} and not $id =~ s/^\Q$this->{-seperator}//;
 	# get localized string by identifier
-	if (exists $this->{$_}) {
-		$_ = $this->loc($this->{$_});
+	if (exists $this->{$id}) {
+		$id = $this->loc($this->{$id});
 		# adaptive string (code)
-		$_ = $_->(@_) if ref $_ eq "CODE";
+		$id = $id->(@args) if ref $id eq "CODE";
 	} else {
-		#todo: else remove path
-		s/.*\Q$this->{-seperator}//s if defined $this->{-seperator};
+		# not found: strip path and use literal identifier
+		$id =~ s/.*\Q$this->{-seperator}//s if defined $this->{-seperator};
 	}
 	# static output if no arguments given
-	return $_ unless @_;  # unnecessary but faster for common case
+	return $id unless @args;  # unnecessary but faster for common case
 	# dynamic output
-	return sprintf $_, @_;
+	return sprintf $id, @args;
 } # FETCH
 
+sub langorder($$) {
+	my $this = shift;
+	my %index = %{$this->{-langs}}; # overall index
+	defined $index{$_} and $index{$_} *= $this->{-langpref}{$_}
+		for keys %{$this->{-langpref}};
+	return [ sort {$index{$b} <=> $index{$a}} keys %index ];
+} # langorder
+
 sub STORE {
 	my ($this, $option, $val) = @_;
 	if ($option eq "-langpref") {
-		# set order of languages (prefered language first)
+		# set preference index of languages
 		$this->{$option} = $val;
+		$this->{-langorder} = $this->langorder;
 	} # -langpref
+	elsif ($option eq "-langorder") {
+		# set order of languages (prefered language first)
+		$this->{$option} = $val;
+	} # -langorder
 	elsif ($option eq "-seperator") {
 		$this->{-path} =~ s/\Q$this->{$option}/$val/g
 			if defined $this->{$option}; # replace old occurances
 		$this->{$option} = $val;
 	} # -seperator
 	else {
+		$val .= $this->{-seperator} if $option eq "-path" and $val ne '';
 		$this->{$option} = $val;
 #		$_[0]->{$_[1]} = $_[2];
 	}
 } # STORE
 
-# Same as found in Tie::StdHash
+sub EXISTS   {
+	my ($this, $id) = @_;
+	$id = $this->{-path} . $id
+		if defined $this->{-path} and not $id =~ s/^\Q$this->{-seperator}//;
+	return exists $this->{$id};
+} # EXISTS
 
 #todo: make path-aware
-sub EXISTS   { exists $_[0]->{$_[1]} }
 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 sub NEXTKEY  { each %{$_[0]} }
 
@@ -85,15 +100,15 @@ Lirama::Loc3 - Localize strings
 	use Lirama::Loc3;
 
 	tie my %loc, "Lirama::Loc3", {
-		-langs => {en => 100, eo => 95},
+		-langs => {eo => 100, en => 95},
 		-seperator => '_',
-		_test => {
-			en => "this is a test",
+		test => {
 			eo => "cxi tio estas testo",
+			en => "this is a test",
 		},
 	};
 
-	$loc{-langpref} = [qw/nl en eo/];  # prefer I<nl> (dutch) texts
+	$loc{-langpref} = {nl => 100, en => 50};  # prefer I<nl> (dutch) texts
 	print $loc{test};  # "this is a test", since dutch is unavailable
 
 =head1 DESCRIPTION
-- 
2.30.0