perl 5.8.2 from CPAN

7 files changed, 615 insertions, 0 deletions

diff --git a/gnu/usr.bin/perl/lib/Locale/Maketext/Guts.pm b/gnu/usr.bin/perl/lib/Locale/Maketext/Guts.pm
new file mode 100644
index 00000000000..72f0c9b3a19
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Locale/Maketext/Guts.pm
@@ -0,0 +1,295 @@
+
+package Locale::Maketext::Guts;
+BEGIN { *zorp = sub { return scalar @_ } unless defined &zorp; }
+ # Just so we're nice and define SOMETHING in "our" package.
+
+package Locale::Maketext;
+use strict;
+use vars qw($USE_LITERALS $GUTSPATH);
+
+BEGIN {
+  $GUTSPATH = __FILE__;
+  *DEBUG = sub () {0} unless defined &DEBUG;
+}
+
+use utf8;
+
+sub _compile {
+  # This big scary routine compiles an entry.
+  # It returns either a coderef if there's brackety bits in this, or
+  #  otherwise a ref to a scalar.
+  
+  my $target = ref($_[0]) || $_[0];
+  
+  my(@code);
+  my(@c) = (''); # "chunks" -- scratch.
+  my $call_count = 0;
+  my $big_pile = '';
+  {
+    my $in_group = 0; # start out outside a group
+    my($m, @params); # scratch
+    
+    while($_[1] =~  # Iterate over chunks.
+     m<\G(
+       [^\~\[\]]+  # non-~[] stuff
+       |
+       ~.       # ~[, ~], ~~, ~other
+       |
+       \[          # [ presumably opening a group
+       |
+       \]          # ] presumably closing a group
+       |
+       ~           # terminal ~ ?
+       |
+       $
+     )>xgs
+    ) {
+      print "  \"$1\"\n" if DEBUG > 2;
+
+      if($1 eq '[' or $1 eq '') {       # "[" or end
+        # Whether this is "[" or end, force processing of any
+        #  preceding literal.
+        if($in_group) {
+          if($1 eq '') {
+            $target->_die_pointing($_[1], "Unterminated bracket group");
+          } else {
+            $target->_die_pointing($_[1], "You can't nest bracket groups");
+          }
+        } else {
+          if($1 eq '') {
+            print "   [end-string]\n" if DEBUG > 2;
+          } else {
+            $in_group = 1;
+          }
+          die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
+          if(length $c[-1]) {
+            # Now actually processing the preceding literal
+            $big_pile .= $c[-1];
+            if($USE_LITERALS and (
+              (ord('A') == 65)
+               ? $c[-1] !~ m<[^\x20-\x7E]>s
+                  # ASCII very safe chars
+               : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
+                  # EBCDIC very safe chars
+            )) {
+              # normal case -- all very safe chars
+              $c[-1] =~ s/'/\\'/g;
+              push @code, q{ '} . $c[-1] . "',\n";
+              $c[-1] = ''; # reuse this slot
+            } else {
+              push @code, ' $c[' . $#c . "],\n";
+              push @c, ''; # new chunk
+            }
+          }
+           # else just ignore the empty string.
+        }
+
+      } elsif($1 eq ']') {  # "]"
+        # close group -- go back in-band
+        if($in_group) {
+          $in_group = 0;
+          
+          print "   --Closing group [$c[-1]]\n" if DEBUG > 2;
+          
+          # And now process the group...
+          
+          if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
+            DEBUG > 2 and print "   -- (Ignoring)\n";
+            $c[-1] = ''; # reset out chink
+            next;
+          }
+          
+           #$c[-1] =~ s/^\s+//s;
+           #$c[-1] =~ s/\s+$//s;
+          ($m,@params) = split(",", $c[-1], -1);  # was /\s*,\s*/
+          
+          # A bit of a hack -- we've turned "~,"'s into DELs, so turn
+          #  'em into real commas here.
+          if (ord('A') == 65) { # ASCII, etc
+            foreach($m, @params) { tr/\x7F/,/ } 
+          } else {              # EBCDIC (1047, 0037, POSIX-BC)
+            # Thanks to Peter Prymmer for the EBCDIC handling
+            foreach($m, @params) { tr/\x07/,/ } 
+          }
+          
+          # Special-case handling of some method names:
+          if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) {
+            # Treat [_1,...] as [,_1,...], etc.
+            unshift @params, $m;
+            $m = '';
+          } elsif($m eq '*') {
+            $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
+          } elsif($m eq '#') {
+            $m = 'numf';  # "#" for "number": [#,_1] for "the number _1"
+          }
+
+          # Most common case: a simple, legal-looking method name
+          if($m eq '') {
+            # 0-length method name means to just interpolate:
+            push @code, ' (';
+          } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s
+            and $m !~ m<(?:^|\:)\d>s
+             # exclude starting a (sub)package or symbol with a digit 
+          ) {
+            # Yes, it even supports the demented (and undocumented?)
+            #  $obj->Foo::bar(...) syntax.
+            $target->_die_pointing(
+              $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method",
+              2 + length($c[-1])
+            )
+             if $m =~ m/^SUPER::/s;
+              # Because for SUPER:: to work, we'd have to compile this into
+              #  the right package, and that seems just not worth the bother,
+              #  unless someone convinces me otherwise.
+            
+            push @code, ' $_[0]->' . $m . '(';
+          } else {
+            # TODO: implement something?  or just too icky to consider?
+            $target->_die_pointing(
+             $_[1],
+             "Can't use \"$m\" as a method name in bracket group",
+             2 + length($c[-1])
+            );
+          }
+          
+          pop @c; # we don't need that chunk anymore
+          ++$call_count;
+          
+          foreach my $p (@params) {
+            if($p eq '_*') {
+              # Meaning: all parameters except $_[0]
+              $code[-1] .= ' @_[1 .. $#_], ';
+               # and yes, that does the right thing for all @_ < 3
+            } elsif($p =~ m<^_(-?\d+)$>s) {
+              # _3 meaning $_[3]
+              $code[-1] .= '$_[' . (0 + $1) . '], ';
+            } elsif($USE_LITERALS and (
+              (ord('A') == 65)
+               ? $p !~ m<[^\x20-\x7E]>s
+                  # ASCII very safe chars
+               : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
+                  # EBCDIC very safe chars            
+            )) {
+              # Normal case: a literal containing only safe characters
+              $p =~ s/'/\\'/g;
+              $code[-1] .= q{'} . $p . q{', };
+            } else {
+              # Stow it on the chunk-stack, and just refer to that.
+              push @c, $p;
+              push @code, ' $c[' . $#c . "], ";
+            }
+          }
+          $code[-1] .= "),\n";
+
+          push @c, '';
+        } else {
+          $target->_die_pointing($_[1], "Unbalanced ']'");
+        }
+        
+      } elsif(substr($1,0,1) ne '~') {
+        # it's stuff not containing "~" or "[" or "]"
+        # i.e., a literal blob
+        $c[-1] .= $1;
+        
+      } elsif($1 eq '~~') { # "~~"
+        $c[-1] .= '~';
+        
+      } elsif($1 eq '~[') { # "~["
+        $c[-1] .= '[';
+        
+      } elsif($1 eq '~]') { # "~]"
+        $c[-1] .= ']';
+
+      } elsif($1 eq '~,') { # "~,"
+        if($in_group) {
+          # This is a hack, based on the assumption that no-one will actually
+          # want a DEL inside a bracket group.  Let's hope that's it's true.
+          if (ord('A') == 65) { # ASCII etc
+            $c[-1] .= "\x7F";
+          } else {              # EBCDIC (cp 1047, 0037, POSIX-BC)
+            $c[-1] .= "\x07";
+          }
+        } else {
+          $c[-1] .= '~,';
+        }
+        
+      } elsif($1 eq '~') { # possible only at string-end, it seems.
+        $c[-1] .= '~';
+        
+      } else {
+        # It's a "~X" where X is not a special character.
+        # Consider it a literal ~ and X.
+        $c[-1] .= $1;
+      }
+    }
+  }
+
+  if($call_count) {
+    undef $big_pile; # Well, nevermind that.
+  } else {
+    # It's all literals!  Ahwell, that can happen.
+    # So don't bother with the eval.  Return a SCALAR reference.
+    return \$big_pile;
+  }
+
+  die "Last chunk isn't null??" if @c and length $c[-1]; # sanity
+  print scalar(@c), " chunks under closure\n" if DEBUG;
+  if(@code == 0) { # not possible?
+    print "Empty code\n" if DEBUG;
+    return \'';
+  } elsif(@code > 1) { # most cases, presumably!
+    unshift @code, "join '',\n";
+  }
+  unshift @code, "use strict; sub {\n";
+  push @code, "}\n";
+
+  print @code if DEBUG;
+  my $sub = eval(join '', @code);
+  die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
+  return $sub;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _die_pointing {
+  # This is used by _compile to throw a fatal error
+  my $target = shift; # class name
+  # ...leaving $_[0] the error-causing text, and $_[1] the error message
+  
+  my $i = index($_[0], "\n");
+
+  my $pointy;
+  my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
+  if($pos < 1) {
+    $pointy = "^=== near there\n";
+  } else { # we need to space over
+    my $first_tab = index($_[0], "\t");
+    if($pos > 2 and ( -1 == $first_tab  or  $first_tab > pos($_[0]))) {
+      # No tabs, or the first tab is harmlessly after where we will point to,
+      # AND we're far enough from the margin that we can draw a proper arrow.
+      $pointy = ('=' x $pos) . "^ near there\n";
+    } else {
+      # tabs screw everything up!
+      $pointy = substr($_[0],0,$pos);
+      $pointy =~ tr/\t //cd;
+       # make everything into whitespace, but preseving tabs
+      $pointy .= "^=== near there\n";
+    }
+  }
+  
+  my $errmsg = "$_[1], in\:\n$_[0]";
+  
+  if($i == -1) {
+    # No newline.
+    $errmsg .= "\n" . $pointy;
+  } elsif($i == (length($_[0]) - 1)  ) {
+    # Already has a newline at end.
+    $errmsg .= $pointy;
+  } else {
+    # don't bother with the pointy bit, I guess.
+  }
+  Carp::croak( "$errmsg via $target, as used" );
+}
+
+1;
+
diff --git a/gnu/usr.bin/perl/lib/Locale/Maketext/GutsLoader.pm b/gnu/usr.bin/perl/lib/Locale/Maketext/GutsLoader.pm
new file mode 100644
index 00000000000..5cce12e37b5
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Locale/Maketext/GutsLoader.pm
@@ -0,0 +1,47 @@
+
+package Locale::Maketext::GutsLoader;
+use strict;
+sub zorp { return scalar @_ }
+
+BEGIN {
+  $Locale::Maketext::GutsLoader::GUTSPATH = __FILE__;
+  *Locale::Maketext::DEBUG = sub () {0}
+   unless defined &Locale::Maketext::DEBUG;
+}
+
+#
+# This whole drama is so that we can load the utf8'd code
+# in Locale::Maketext::Guts, but if that fails, snip the
+# utf8 and then try THAT.
+#
+
+$Locale::Maketext::GUTSPATH = '';
+Locale::Maketext::DEBUG and print "Requiring Locale::Maketext::Guts...\n";
+eval 'require Locale::Maketext::Guts';
+
+if($@) {
+  my $path = $Locale::Maketext::GUTSPATH;
+
+  die "Can't load Locale::Maketext::Guts\nAborting" unless $path;
+  
+  die "No readable file $Locale::Maketext::GutsLoader::GUTSPATH\nAborting"
+   unless -e $path and -f _ and -r _;
+
+  open(IN, $path) or die "Can't read-open $path\nAborting";
+  
+  my $source;
+  { local $/;  $source = <IN>; }
+  close(IN);
+  unless( $source =~ s/\b(use utf8)/# $1/ ) {
+    Locale::Maketext::DEBUG and
+     print "I didn't see 'use utf8' in $path\n";
+  }
+  eval $source;
+  die "Can't compile $path\n...The error I got was:\n$@\nAborting" if $@;
+  Locale::Maketext::DEBUG and print "Non-utf8'd Locale::Maketext::Guts fine\n";
+} else {
+  Locale::Maketext::DEBUG and print "Loaded Locale::Maketext::Guts fine\n";
+}
+
+1;
+
diff --git a/gnu/usr.bin/perl/lib/Locale/Maketext/t/00about.t b/gnu/usr.bin/perl/lib/Locale/Maketext/t/00about.t
new file mode 100644
index 00000000000..9b2fc859994
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Locale/Maketext/t/00about.t
@@ -0,0 +1,29 @@
+
+require 5;
+use Test;
+BEGIN { plan tests => 1; }
+use Locale::Maketext 1.01;
+
+print "#\n#\n",
+ "# Locale::Maketext v$Locale::Maketext::VERSION\n",
+ "# I18N::LangTags v", $I18N::LangTags::VERSION || "?", "\n",
+ "#\n#\n",
+;
+
+print "# Running under perl version $] for $^O",
+      (chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n";
+
+print "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n"
+ if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber();
+
+print "# MacPerl verison $MacPerl::Version\n"
+ if defined $MacPerl::Version;
+
+printf
+ "# Current time local: %s\n# Current time GMT:   %s\n",
+ scalar(   gmtime($^T)), scalar(localtime($^T));
+      
+print "# Using Test.pm v", $Test::VERSION || "?", "\n";
+
+ok 1;
+
diff --git a/gnu/usr.bin/perl/lib/Locale/Maketext/t/01make.t b/gnu/usr.bin/perl/lib/Locale/Maketext/t/01make.t
new file mode 100644
index 00000000000..d9352d03407
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Locale/Maketext/t/01make.t
@@ -0,0 +1,34 @@
+
+require 5;
+use Test;
+BEGIN { plan tests => 6; }
+use Locale::Maketext 1.01;
+print "# Hi there...\n";
+ok 1;
+
+# declare some classes...
+{
+  package Woozle;
+  @ISA = ('Locale::Maketext');
+  sub dubbil   { return $_[1] * 2 }
+  sub numerate { return $_[2] . 'en' }
+}
+{
+  package Woozle::elx;
+  @ISA = ('Woozle');
+  %Lexicon = (
+   'd2' => 'hum [dubbil,_1]',
+   'd3' => 'hoo [quant,_1,zaz]',
+   'd4' => 'hoo [*,_1,zaz]',
+  );
+  keys %Lexicon; # dodges the 'used only once' warning
+}
+
+ok defined( $lh = Woozle->get_handle('elx') ) && ref($lh);
+ok $lh && $lh->maketext('d2', 7), "hum 14"      ;
+ok $lh && $lh->maketext('d3', 7), "hoo 7 zazen" ;
+ok $lh && $lh->maketext('d4', 7), "hoo 7 zazen" ;
+
+print "# Byebye!\n";
+ok 1;
+
diff --git a/gnu/usr.bin/perl/lib/Locale/Maketext/t/02get.t b/gnu/usr.bin/perl/lib/Locale/Maketext/t/02get.t
new file mode 100644
index 00000000000..86fd4b20af5
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Locale/Maketext/t/02get.t
@@ -0,0 +1,69 @@
+
+require 5;
+use Test;
+BEGIN { plan tests => 11; }
+use Locale::Maketext 1.01;
+print "# Hi there...\n";
+ok 1;
+
+print "# --- Making sure that get_handle works ---\n";
+
+# declare some classes...
+{
+  package Woozle;
+  @ISA = ('Locale::Maketext');
+  sub dubbil   { return $_[1] * 2 }
+  sub numerate { return $_[2] . 'en' }
+}
+{
+  package Woozle::eu_mt;
+  @ISA = ('Woozle');
+  %Lexicon = (
+   'd2' => 'hum [dubbil,_1]',
+   'd3' => 'hoo [quant,_1,zaz]',
+   'd4' => 'hoo [*,_1,zaz]',
+  );
+  keys %Lexicon; # dodges the 'used only once' warning
+}
+
+my $lh;
+print "# Basic sanity:\n";
+ok defined( $lh = Woozle->get_handle('eu-mt') ) && ref($lh);
+ok $lh && $lh->maketext('d2', 7), "hum 14"      ;
+
+
+
+print "# Make sure we can assign to ENV entries\n",
+      "# (Otherwise we can't run the subsequent tests)...\n";
+$ENV{'MYORP'}   = 'Zing';
+ok $ENV{'MYORP'}, 'Zing';
+$ENV{'SWUZ'}   = 'KLORTHO HOOBOY';
+ok $ENV{'SWUZ'}, 'KLORTHO HOOBOY';
+
+delete $ENV{'MYORP'};
+delete $ENV{'SWUZ'};
+
+print "# Test LANG...\n";
+$ENV{'REQUEST_METHOD'} = '';
+$ENV{'LANG'}     = 'Eu_MT';
+$ENV{'LANGUAGE'} = '';
+ok defined( $lh = Woozle->get_handle() ) && ref($lh);
+
+print "# Test LANGUAGE...\n";
+$ENV{'LANG'}     = '';
+$ENV{'LANGUAGE'} = 'Eu-MT';
+ok defined( $lh = Woozle->get_handle() ) && ref($lh);
+
+print "# Test HTTP_ACCEPT_LANGUAGE...\n";
+$ENV{'REQUEST_METHOD'}       = 'GET';
+$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'eu-MT';
+ok defined( $lh = Woozle->get_handle() ) && ref($lh);
+$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'x-plorp, zaz, eu-MT, i-klung';
+ok defined( $lh = Woozle->get_handle() ) && ref($lh);
+$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'x-plorp, zaz, eU-Mt, i-klung';
+ok defined( $lh = Woozle->get_handle() ) && ref($lh);
+
+
+print "# Byebye!\n";
+ok 1;
+
diff --git a/gnu/usr.bin/perl/lib/Locale/Maketext/t/03http.t b/gnu/usr.bin/perl/lib/Locale/Maketext/t/03http.t
new file mode 100644
index 00000000000..98e7207a602
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Locale/Maketext/t/03http.t
@@ -0,0 +1,102 @@
+
+use Locale::Maketext;
+
+use Test;
+BEGIN { plan tests => 87 };
+
+my @in = grep m/\S/, split /\n/, q{
+
+[ sv      ]  sv
+[ en      ]  en
+[ en fi   ]  en, fi
+[ en-us   ]  en-us
+[ en-us   ]  en-US
+[ en-us   ]  EN-US
+
+[ en-au en i-klingon en-gb en-us mt-mt mt ja ]  EN-au, JA;q=0.14, i-klingon;q=0.83, en-gb;q=0.71, en-us;q=0.57, mt-mt;q=0.43, mt;q=0.29, en;q=0.86
+[ en-au en i-klingon en-gb en-us mt-mt mt tli ja ]  EN-au, tli;q=0.201, JA;q=0.14, i-klingon;q=0.83, en-gb;q=0.71, en-us;q=0.57, mt-mt;q=0.43, mt;q=0.29, en;q=0.86
+[ en-au en en-gb en-us ja  ]  en-au, ja;q=0.20, en-gb;q=0.60, en-us;q=0.40, en;q=0.80
+
+[ en-au en en-gb en-us mt-mt mt ja ]  EN-au, JA;q=0.14, en-gb;q=0.71, en-us;q=0.57, mt-mt;q=0.43, mt;q=0.29, en;q=0.86
+[ en-au en en-gb en-us ja  ]  en-au, ja;q=0.20, en-gb;q=0.60, en-us;q=0.40, en;q=0.80
+[ en fr           ]  en;q=1,fr;q=.5
+[ en fr           ]  en;q=1,fr;q=.99
+[ en ru ko        ]  en, ru;q=0.7, ko;q=0.3
+[ en ru ko        ]  en, ru;q=0.7, KO;q=0.3
+[ en-us en        ]  en-us, en;q=0.50
+[ en fr           ]  fr ; q = 0.9, en
+[ en fr           ]  en,fr;q=.90
+[ ru en-uk en fr  ]  ru, en-UK;q=0.5, en;q=0.3, fr;q=0.1
+[ en-us fr es-mx  ]  en-us,fr;q=0.7,es-mx;q=0.3 
+[ en-us en        ]  en-us, en;q=0.50 
+
+[ da en-gb en       ]  da, en-gb;q=0.8, en;q=0.7
+[ da en-gb en       ]  da, en;q=0.7, en-gb;q=0.8
+[ da en-gb en       ]  da, en-gb;q=0.8, en;q=0.7
+[ da en-gb en       ]  da,en;q=0.7,en-gb;q=0.8
+[ da en-gb en       ]  da, en-gb ; q=0.8, en ; q=0.7
+[ da en-gb en       ]  da , en-gb ; q = 0.8 , en ; q  =0.7
+[ da en-gb en       ]  da (yup, Danish) , en-gb ; q = 0.8 , en ; q  =0.7
+
+[ no dk en-uk en-us ]  en-UK;q=0.7, en-US;q=0.6, no;q=1.0, dk;q=0.8
+[ no dk en-uk en-us ]  en-US;q=0.6, en-UK;q=0.7, no;q=1.0, dk;q=0.8
+[ no dk en-uk en-us ]  en-UK;q=0.7, no;q=1.0, en-US;q=0.6, dk;q=0.8
+[ no dk en-uk en-us ]  en-UK;q=0.7, no;q=1.0, dk;q=0.8, en-US;q=0.6
+
+[ fi en ]  fi;q=1, en;q=0.2
+[ de-de de en en-us en-gb ]  de-DE, de;q=0.80, en;q=0.60, en-US;q=0.40, en-GB;q=0.20
+[ ru          ]  ru; q=1, *; q=0.1
+[ ru en       ]  ru, en; q=0.1
+[ ja en       ]  ja,en;q=0.5
+[ en          ]  en; q=1.0
+[ ja          ]  ja; q=1.0
+[ ja          ]  ja; q=1.0
+[ en ja       ]  en; q=0.5, ja; q=0.5
+[ fr-ca fr en ]  fr-ca, fr;q=0.8, en;q=0.7
+[ NIX ] NIX
+};
+
+foreach my $in (@in) {
+  $in =~ s/^\s*\[([^\]]+)\]\s*//s or die "Bad input: $in";
+  my @should = do { my $x = $1; $x =~ m/(\S+)/g };
+
+  if($in eq 'NIX') { $in = ''; @should = (); }
+
+  local $ENV{'HTTP_ACCEPT_LANGUAGE'};
+  
+  foreach my $modus (
+    sub {
+      print "# Testing with arg...\n";
+      $ENV{'HTTP_ACCEPT_LANGUAGE'} = 'PLORK';
+      return $_[0];
+    },
+    sub {
+      print "# Testing wath HTTP_ACCEPT_LANGUAGE...\n";
+      $ENV{'HTTP_ACCEPT_LANGUAGE'} = $_[0];
+     return();
+    },
+  ) {
+    my @args = &$modus($in);
+
+    # ////////////////////////////////////////////////////
+    my @out = Locale::Maketext->_http_accept_langs(@args);
+    # \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+
+    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",
+            "# < \"$in\"\n#\n";
+    }
+  }
+}
+
+print "#\n#\n# Bye-bye!\n";
+ok 1;
+
diff --git a/gnu/usr.bin/perl/lib/Locale/Maketext/t/90utf8.t b/gnu/usr.bin/perl/lib/Locale/Maketext/t/90utf8.t
new file mode 100644
index 00000000000..96731e2b192
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Locale/Maketext/t/90utf8.t
@@ -0,0 +1,39 @@
+
+require 5;
+use Test;
+BEGIN { plan tests => 4; }
+use Locale::Maketext 1.01;
+print "# Hi there...\n";
+ok 1;
+
+
+print "# --- Making sure that get_handle works with utf8 ---\n";
+use utf8;
+
+# declare some classes...
+{
+  package Woozle;
+  @ISA = ('Locale::Maketext');
+  sub dubbil   { return $_[1] * 2  .chr(2000)}
+  sub numerate { return $_[2] . 'en'  }
+}
+{
+  package Woozle::eu_mt;
+  @ISA = ('Woozle');
+  %Lexicon = (
+   'd2' => chr(1000) . 'hum [dubbil,_1]',
+   'd3' => chr(1000) . 'hoo [quant,_1,zaz]',
+   'd4' => chr(1000) . 'hoo [*,_1,zaz]',
+  );
+  keys %Lexicon; # dodges the 'used only once' warning
+}
+
+my $lh;
+print "# Basic sanity:\n";
+ok defined( $lh = Woozle->get_handle('eu-mt') ) && ref($lh);
+ok $lh && $lh->maketext('d2', 7), chr(1000)."hum 14".chr(2000)   ;
+
+
+print "# Byebye!\n";
+ok 1;
+