From: Abhijit Menon-Sen <ams@wiw.org>
Date: Tue, 13 Jan 2004 07:16:33 +0000 (+0000)
Subject: Upgrade to Locale::Maketext 1.07.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=14be35aaf1e66d9ee3b0b434256386e605d6024d;p=p5sagit%2Fp5-mst-13.2.git

Upgrade to Locale::Maketext 1.07.

p4raw-id: //depot/perl@22126
---

diff --git a/MANIFEST b/MANIFEST
index c40708c..b55bb7a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1124,7 +1124,7 @@ lib/ExtUtils/MakeMaker/Tutorial.pod	Writing a module with MakeMaker
 lib/ExtUtils/MakeMaker/vmsish.pm	Platform agnostic vmsish.pm
 lib/ExtUtils/Manifest.pm	Utilities to write MANIFEST files
 lib/ExtUtils/MANIFEST.SKIP	The default MANIFEST.SKIP
-lib/ExtUtils/META.yml	ExtUtils::MakeMaker metadata
+lib/ExtUtils/META.yml		ExtUtils::MakeMaker metadata
 lib/ExtUtils/Mkbootstrap.pm	Writes a bootstrap file (see MakeMaker)
 lib/ExtUtils/Mksymlists.pm	Writes a linker options file for extensions
 lib/ExtUtils/MM_Any.pm		MakeMaker methods for Any OS
@@ -1148,7 +1148,7 @@ lib/ExtUtils/README		MakeMaker README
 lib/ExtUtils/t/00compile.t	See if MakeMaker modules compile
 lib/ExtUtils/t/backwards.t	Check MakeMaker's backwards compatibility
 lib/ExtUtils/t/basic.t		See if MakeMaker can build a module
-lib/ExtUtils/t/bytes.t	Test ExtUtils::MakeMaker::bytes
+lib/ExtUtils/t/bytes.t		Test ExtUtils::MakeMaker::bytes
 lib/ExtUtils/t/Command.t	See if ExtUtils::Command works (Win32 only)
 lib/ExtUtils/t/Constant.t	See if ExtUtils::Constant works
 lib/ExtUtils/t/Embed.t		See if ExtUtils::Embed and embedding works
@@ -1313,10 +1313,13 @@ lib/Locale/Maketext/Guts.pm	Locale::Maketext
 lib/Locale/Maketext.pm		Locale::Maketext
 lib/Locale/Maketext.pod		Locale::Maketext documentation
 lib/Locale/Maketext/README	Locale::Maketext
+lib/Locale/Maketext/META.yml	Locale::Maketext
 lib/Locale/Maketext/t/00about.t	See if Locale::Maketext works
 lib/Locale/Maketext/t/01make.t	See if Locale::Maketext works
 lib/Locale/Maketext/t/02get.t	See if Locale::Maketext works
 lib/Locale/Maketext/t/03http.t	See if Locale::Maketext works
+lib/Locale/Maketext/t/04super.t	See if Locale::Maketext works
+lib/Locale/Maketext/t/05super.t	See if Locale::Maketext works
 lib/Locale/Maketext/t/90utf8.t	Locale::Maketext
 lib/Locale/Maketext/TPJ13.pod	Locale::Maketext documentation article
 lib/locale.pm			For "use locale"
@@ -2488,7 +2491,7 @@ pp_sys.c			Push/Pop code for system interaction
 proto.h				Prototypes
 qnx/ar				QNX implementation of "ar" utility
 qnx/cpp				QNX implementation of preprocessor filter
-README			The Instructions
+README				The Instructions
 README.aix			Perl notes for AIX
 README.amiga			Perl notes for AmigaOS
 README.apollo			Perl notes for Apollo DomainOS
@@ -2509,7 +2512,7 @@ README.ko			Perl for Korean (in EUC-KR)
 README.machten			Perl notes for Power MachTen
 README.macos			Perl notes for Mac OS (Classic)
 README.macosx			Perl notes for Mac OS X
-README.micro		Notes about microperl
+README.micro			Notes about microperl
 README.mint			Perl notes for MiNT
 README.mpeix			Perl notes for MPE/iX
 README.netware			Perl notes for NetWare
@@ -2526,7 +2529,7 @@ README.vmesa			Perl notes for VM/ESA
 README.vms			Perl notes for VMS
 README.vos			Perl notes for Stratus VOS
 README.win32			Perl notes for Windows
-README.Y2K		Notes about Year 2000 concerns
+README.Y2K			Notes about Year 2000 concerns
 reentr.c			Reentrant interfaces
 reentr.h			Reentrant interfaces
 reentr.pl			Reentrant interfaces
diff --git a/lib/Locale/Maketext.pm b/lib/Locale/Maketext.pm
index b978312..757b817 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 781e4bb..2851894 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 a801c2f..f19ffc8 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 5fdcae4..3174ad1 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 0000000..39df0be
--- /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 0000000..a581416
--- /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;
+