Upgrade to Locale::Maketext 1.07.

p4raw-id: //depot/perl@22126

6 files changed, 309 insertions, 48 deletions

diff --git a/lib/Locale/Maketext.pm b/lib/Locale/Maketext.pm
index b978312d8f..757b817e08 100644
--- a/lib/Locale/Maketext.pm
+++ b/lib/Locale/Maketext.pm
@@ -1,11 +1,11 @@
 
-# Time-stamp: "2003-06-21 23:41:57 AHDT"
+# Time-stamp: "2004-01-11 19:02:37 AST"
 
 require 5;
 package Locale::Maketext;
 use strict;
 use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
-             $USE_LITERALS);
+             $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
 use Carp ();
 use I18N::LangTags 0.21 ();
 
@@ -14,11 +14,12 @@ use I18N::LangTags 0.21 ();
 BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
  # define the constant 'DEBUG' at compile-time
 
-$VERSION = "1.06";
+$VERSION = "1.07";
 @ISA = ();
 
 $MATCH_SUPERS = 1;
-$USING_LANGUAGE_TAGS = 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
@@ -246,36 +247,31 @@ sub maketext {
 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;
-      }
-    }
+  @languages = $base_class->_ambient_langprefs() unless @languages;
+  @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!
   }
 
-  #------------------------------------------------------------------------
-  print "Lgs1: ", map("<$_>", @languages), "\n" if DEBUG;
+  return undef; # Fail!
+}
+
+###########################################################################
+
+sub _langtag_munging {
+  my($base_class, @languages) = @_;
+
+  DEBUG and print "Lgs1: ", map("<$_>", @languages), "\n";
 
   if($USING_LANGUAGE_TAGS) {
     @languages = map &I18N::LangTags::locale2language_tag($_), @languages;
@@ -283,17 +279,21 @@ sub get_handle {  # This is a constructor and, yes, it CAN FAIL.
      # 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 = map {; $_, I18N::LangTags::alternate_language_tags($_) }
                       @languages;    # catch alternation
+    DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
+
+    if( defined &I18N::LangTags::panic_languages ) {
+      push @languages, I18N::LangTags::panic_languages(@languages);
+      DEBUG and print "After adding panic languages:\n", 
+        " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
+    }
 
-    push @languages, I18N::LangTags::panic_languages(@languages)
-      if defined &I18N::LangTags::panic_languages;
+    @languages     = $base_class->_add_supers( @languages );
     
     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:
       map {
@@ -303,23 +303,99 @@ sub get_handle {  # This is a constructor and, yes, it CAN FAIL.
         $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";
   }
-  print "Lgs2: ", map("<$_>", @languages), "\n" if DEBUG > 1;
+
+  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";
 
-  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 @languages;
+}
+
+###########################################################################
+
+sub _ambient_langprefs {
+  my $base_class = $_[0];
+  
+  return $base_class->_http_accept_langs
+   if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI
+       # 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;
+
+  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.
   }
 
-  return undef; # Fail!
+  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;
+  }
+
+  return @languages;
+}
+
+###########################################################################
+
+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";
+
+    my %seen_encoded;
+    foreach my $lang (@languages) {
+      $seen_encoded{ I18N::LangTags::encode_language_tag($lang) } = 1
+    }
+
+    my(@output_languages);
+    foreach my $lang (@languages) {
+      push @output_languages, $lang;
+      foreach my $s ( I18N::LangTags::super_languages($lang) ) {
+        # Note that super_languages returns the longest first.
+        last if $seen_encoded{ I18N::LangTags::encode_language_tag($s) };
+        push @output_languages, $s;
+      }
+    }
+    @languages = @output_languages;
+
+    DEBUG and print "After adding new supers tightly:\n", 
+      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
+
+  } else {
+
+    push @languages,  map I18N::LangTags::super_languages($_), @languages;
+    DEBUG and print "After adding supers to end:\n", 
+      " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
+  }
+  
+  return @languages;
 }
 
 ###########################################################################
diff --git a/lib/Locale/Maketext.pod b/lib/Locale/Maketext.pod
index 781e4bb2bd..285189408f 100644
--- a/lib/Locale/Maketext.pod
+++ b/lib/Locale/Maketext.pod
@@ -1,5 +1,5 @@
 
-# Time-stamp: "2003-04-02 11:10:32 AHST"
+# Time-stamp: "2004-01-11 18:35:34 AST"
 
 =head1 NAME
 
@@ -1304,7 +1304,7 @@ shorter than its documentation!
 
 =head1 COPYRIGHT AND DISCLAIMER
 
-Copyright (c) 1999-2003 Sean M. Burke.  All rights reserved.
+Copyright (c) 1999-2004 Sean M. Burke.  All rights reserved.
 
 This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself.
diff --git a/lib/Locale/Maketext/ChangeLog b/lib/Locale/Maketext/ChangeLog
index a801c2f4a8..f19ffc8a05 100644
--- a/lib/Locale/Maketext/ChangeLog
+++ b/lib/Locale/Maketext/ChangeLog
@@ -1,6 +1,26 @@
 Revision history for Perl suite Locale::Maketext
-                                        Time-stamp: "2003-06-21 23:38:38 AHDT"
+                                        Time-stamp: "2004-01-11 18:30:43 AST"
 
+2004-01-11  Sean M. Burke  sburke@cpan.org
+	
+	* Release 1.07:  Now uses a new and different rule for implicating
+	superordinate language tags in accept-language lists.  Previously,
+	superordinates were just tacked onto the, so "en-US, ja", turned
+	into "en-US, ja, en".  However, this turned out to be suboptimal
+	for many users of RT, a popular system using Maketext.  The new
+	rule is that a tag implicates superordinate forms right after it,
+	unless those tags are explicitly stated elsewhere in the
+	accept-languages list.  So "en-US ja" becomes "en-US en ja".  If
+	you want "en" to be really lower, you have to actually state it
+	there: "en-US ja en" is left as-is.
+
+	The 04super.t and 05super.t tests in t/ have many many examples of
+	this, including some strange corner cases.
+
+	(In implementing this change, I also refactored some code in
+	Maketext.pm, for hopefully improved readability.  However,
+	the above is the only actual change in behavior.)
+	
 2003-06-21  Sean M. Burke  sburke@cpan.org
 	* Release 1.06:  Now has "use utf8" to make the things work
 	happily.  Some fancy footwork is required to make this work under
diff --git a/lib/Locale/Maketext/README b/lib/Locale/Maketext/README
index 5fdcae40c7..3174ad1334 100644
--- a/lib/Locale/Maketext/README
+++ b/lib/Locale/Maketext/README
@@ -1,5 +1,5 @@
 README for Locale::Maketext
-                                        Time-stamp: "2003-04-02 11:06:17 AHST"
+                                        Time-stamp: "2004-01-11 18:36:09 AST"
 
 			   Locale::Maketext
 
@@ -61,7 +61,7 @@ Comprehensive Perl Archive Network (CPAN).  Visit
 
 COPYRIGHT
 
-Copyright 1999-2003, Sean M. Burke <sburke@cpan.org>, all rights
+Copyright 1999-2004, Sean M. Burke <sburke@cpan.org>, all rights
 reserved.  This program is free software; you can redistribute it
 and/or modify it under the same terms as Perl itself.
 
diff --git a/lib/Locale/Maketext/t/04super.t b/lib/Locale/Maketext/t/04super.t
new file mode 100644
index 0000000000..39df0bedbb
--- /dev/null
+++ b/lib/Locale/Maketext/t/04super.t
@@ -0,0 +1,78 @@
+
+#sub Locale::Maketext::DEBUG () {10}
+use Locale::Maketext;
+
+use Test;
+BEGIN { plan tests => 19 };
+
+print "#\n# Testing non-tight insertion of super-ordinate language tags...\n#\n";
+
+my @in = grep m/\S/, split /[\n\r]/, q{
+ NIX => NIX
+  sv => sv
+  en => en
+ hai => hai
+
+          pt-br => pt-br pt
+       pt-br fr => pt-br fr pt
+    pt-br fr pt => pt-br fr pt pt
+ pt-br fr pt de => pt-br fr pt de pt
+ de pt-br fr pt => de pt-br fr pt pt
+    de pt-br fr => de pt-br fr pt
+   hai pt-br fr => hai pt-br fr  pt
+
+# Now test multi-part complicateds:
+   pt-br-janeiro fr => pt-br-janeiro fr pt-br pt 
+pt-br-janeiro de fr => pt-br-janeiro de fr pt-br pt
+pt-br-janeiro de pt fr => pt-br-janeiro de pt fr pt-br pt
+
+ja    pt-br-janeiro fr => ja pt-br-janeiro fr pt-br pt 
+ja pt-br-janeiro de fr => ja pt-br-janeiro de fr pt-br pt
+ja pt-br-janeiro de pt fr => ja pt-br-janeiro de pt fr pt-br pt 
+
+pt-br-janeiro de pt-br fr => pt-br-janeiro de pt-br fr pt-br pt pt
+ # an odd case, since we don't filter for uniqueness in this sub
+ 
+};
+
+$Locale::Maketext::MATCH_SUPERS_TIGHTLY = 0;
+
+foreach my $in (@in) {
+  $in =~ s/^\s+//s;
+  $in =~ s/\s+$//s;
+  $in =~ s/#.+//s;
+  next unless $in =~ m/\S/;
+  
+  my(@in, @should);
+  {
+    die "What kind of line is <$in>?!"
+     unless $in =~ m/^(.+)=>(.+)$/s;
+  
+    my($i,$s) = ($1, $2);
+    @in     = ($i =~ m/(\S+)/g);
+    @should = ($s =~ m/(\S+)/g);
+    #print "{@in}{@should}\n";
+  }
+  my @out = Locale::Maketext->_add_supers(
+    ("@in" eq 'NIX') ? () : @in
+  );
+  #print "O: ", join(' ', map "<$_>", @out), "\n";
+  @out = 'NIX' unless @out;
+
+  
+  if( @out == @should
+      and lc( join "\e", @out ) eq lc( join "\e", @should )
+  ) {
+    print "#     Happily got [@out] from [$in]\n";
+    ok 1;
+  } else {
+    ok 0;
+    print "#!!Got:         [@out]\n",
+          "#!! but wanted: [@should]\n",
+          "#!! from \"$in\"\n#\n";
+  }
+}
+
+print "#\n#\n# Bye-bye!\n";
+ok 1;
+
diff --git a/lib/Locale/Maketext/t/05super.t b/lib/Locale/Maketext/t/05super.t
new file mode 100644
index 0000000000..a5814165ce
--- /dev/null
+++ b/lib/Locale/Maketext/t/05super.t
@@ -0,0 +1,87 @@
+
+#sub Locale::Maketext::DEBUG () {10}
+use Locale::Maketext;
+
+use Test;
+BEGIN { plan tests => 26 };
+print "#\n# Testing tight insertion of super-ordinate language tags...\n#\n";
+
+my @in = grep m/\S/, split /[\n\r]/, q{
+ NIX => NIX
+  sv => sv
+  en => en
+ hai => hai
+
+          pt-br => pt-br pt
+       pt-br fr => pt-br pt fr
+    pt-br fr pt => pt-br fr pt
+
+ pt-br fr pt de => pt-br fr pt de
+ de pt-br fr pt => de pt-br fr pt
+    de pt-br fr => de pt-br pt fr
+   hai pt-br fr => hai pt-br pt fr
+
+ # Now test multi-part complicateds:
+          pt-br-janeiro => pt-br-janeiro pt-br pt
+       pt-br-janeiro fr => pt-br-janeiro pt-br pt fr
+    pt-br-janeiro de fr => pt-br-janeiro pt-br pt de fr
+ pt-br-janeiro de pt fr => pt-br-janeiro pt-br de pt fr
+
+          pt-br-janeiro pt-br-saopaolo => pt-br-janeiro pt-br pt pt-br-saopaolo
+       pt-br-janeiro fr pt-br-saopaolo => pt-br-janeiro pt-br pt fr pt-br-saopaolo
+    pt-br-janeiro de pt-br-saopaolo fr => pt-br-janeiro pt-br pt de pt-br-saopaolo fr
+    pt-br-janeiro de pt-br fr pt-br-saopaolo => pt-br-janeiro de pt-br pt fr pt-br-saopaolo
+
+ pt-br de en fr pt-br-janeiro => pt-br pt de en fr pt-br-janeiro
+ pt-br de en fr               => pt-br pt de en fr
+
+    ja    pt-br-janeiro fr => ja pt-br-janeiro pt-br pt fr
+    ja pt-br-janeiro de fr => ja pt-br-janeiro pt-br pt de fr
+ ja pt-br-janeiro de pt fr => ja pt-br-janeiro pt-br de pt fr
+
+ pt-br-janeiro de pt-br fr => pt-br-janeiro de pt-br pt fr
+# an odd case, since we don't filter for uniqueness in this sub
+ 
+};
+
+sub uniq { my %seen; return grep(!($seen{$_}++), @_); }
+
+foreach my $in (@in) {
+  $in =~ s/^\s+//s;
+  $in =~ s/\s+$//s;
+  $in =~ s/#.+//s;
+  next unless $in =~ m/\S/;
+  
+  my(@in, @should);
+  {
+    die "What kind of line is <$in>?!"
+     unless $in =~ m/^(.+)=>(.+)$/s;
+  
+    my($i,$s) = ($1, $2);
+    @in     = ($i =~ m/(\S+)/g);
+    @should = ($s =~ m/(\S+)/g);
+    #print "{@in}{@should}\n";
+  }
+  my @out = uniq( Locale::Maketext->_add_supers(
+    ("@in" eq 'NIX') ? () : @in
+  ) );
+  #print "O: ", join(' ', map "<$_>", @out), "\n";
+  @out = 'NIX' unless @out;
+
+  
+  if( @out == @should
+      and lc( join "\e", @out ) eq lc( join "\e", @should )
+  ) {
+    print "#     Happily got [@out] from [$in]\n";
+    ok 1;
+  } else {
+    ok 0;
+    print "#!!Got:         [@out]\n",
+          "#!! but wanted: [@should]\n",
+          "#!! from \"$in\"\n#\n";
+  }
+}
+
+print "#\n#\n# Bye-bye!\n";
+ok 1;
+