| Commit | Line | Data |
|---|
| a0d0e21e |
1 | package I18N::Collate; |
| 2 | |
| 3 | # Collate.pm |
| 4 | # |
| 5 | # Author: Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi> |
| 6 | # Helsinki University of Technology, Finland |
| 7 | # |
| 8 | # Acks: Guy Decoux <decoux@moulon.inra.fr> understood |
| 9 | # overloading magic much deeper than I and told |
| 10 | # how to cut the size of this code by more than half. |
| 11 | # (my first version did overload all of lt gt eq le ge cmp) |
| 12 | # |
| 13 | # Purpose: compare 8-bit scalar data according to the current locale |
| 14 | # |
| 15 | # Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm() |
| 16 | # |
| 17 | # Exports: setlocale 1) |
| 18 | # collate_xfrm 2) |
| 19 | # |
| 20 | # Overloads: cmp # 3) |
| 21 | # |
| 22 | # Usage: use Collate; |
| 23 | # setlocale(&LC_COLLATE, 'locale-of-your-choice'); # 4) |
| 24 | # $s1 = new Collate "scalar_data_1"; |
| 25 | # $s2 = new Collate "scalar_data_2"; |
| 26 | # |
| 27 | # now you can compare $s1 and $s2: $s1 le $s2 |
| 28 | # to extract the data itself, you need to deref: $$s1 |
| 29 | # |
| 30 | # Notes: |
| 31 | # 1) this uses POSIX::setlocale |
| 32 | # 2) the basic collation conversion is done by strxfrm() which |
| 33 | # terminates at NUL characters being a decent C routine. |
| 34 | # collate_xfrm handles embedded NUL characters gracefully. |
| 35 | # 3) due to cmp and overload magic, lt le eq ge gt work also |
| 36 | # 4) the available locales depend on your operating system; |
| 37 | # try whether "locale -a" shows them or the more direct |
| 38 | # approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls". |
| 39 | # The locale names are probably something like |
| 40 | # 'xx_XX.(ISO)?8859-N'. |
| 41 | # |
| 42 | # Updated: 19940913 1341 GMT |
| 43 | # |
| 44 | # --- |
| 45 | |
| 46 | use POSIX qw(strxfrm LC_COLLATE); |
| 47 | |
| 48 | require Exporter; |
| 49 | |
| 50 | @ISA = qw(Exporter); |
| 51 | @EXPORT = qw(collate_xfrm setlocale LC_COLLATE); |
| 52 | @EXPORT_OK = qw(); |
| 53 | |
| 54 | %OVERLOAD = qw( |
| 55 | fallback 1 |
| 56 | cmp collate_cmp |
| 57 | ); |
| 58 | |
| 59 | sub new { my $new = $_[1]; bless \$new } |
| 60 | |
| 61 | sub setlocale { |
| 62 | my ($category, $locale) = @_[0,1]; |
| 63 | |
| 64 | POSIX::setlocale($category, $locale) if (defined $category); |
| 65 | # the current $LOCALE |
| 66 | $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || ''; |
| 67 | } |
| 68 | |
| 69 | sub C { |
| 70 | my $s = ${$_[0]}; |
| 71 | |
| 72 | $C->{$LOCALE}->{$s} = collate_xfrm($s) |
| 73 | unless (defined $C->{$LOCALE}->{$s}); # cache when met |
| 74 | |
| 75 | $C->{$LOCALE}->{$s}; |
| 76 | } |
| 77 | |
| 78 | sub collate_xfrm { |
| 79 | my $s = $_[0]; |
| 80 | my $x = ''; |
| 81 | |
| 82 | for (split(/(\000+)/, $s)) { |
| 83 | $x .= (/^\000/) ? $_ : strxfrm("$_\000"); |
| 84 | } |
| 85 | |
| 86 | $x; |
| 87 | } |
| 88 | |
| 89 | sub collate_cmp { |
| 90 | &C($_[0]) cmp &C($_[1]); |
| 91 | } |
| 92 | |
| 93 | # init $LOCALE |
| 94 | |
| 95 | &I18N::Collate::setlocale(); |
| 96 | |
| 97 | 1; # keep require happy |
projects / p5sagit/p5-mst-13.2.git / blame