File Coverage

blib/lib/Win32/Locale.pm

Criterion	Covered	Total	%
statement	12	23	52.1
branch	1	8	12.5
condition	0	8	0.0
subroutine	4	6	66.6
pod	3	3	100.0
total	20	48	41.6

package Win32::Locale;
# Time-stamp: "2004-01-11 18:56:06 AST"
use strict;
use vars qw($VERSION %MSLocale2LangTag);
$VERSION = '0.04';
%MSLocale2LangTag = (

  0x0436 => 'af'   ,  #
  0x041c => 'sq'   ,  #

  0x0401 => 'ar-sa',  #
  0x0801 => 'ar-iq',  #
  0x0C01 => 'ar-eg',  #
  0x1001 => 'ar-ly',  #
  0x1401 => 'ar-dz',  #
  0x1801 => 'ar-ma',  #
  0x1C01 => 'ar-tn',  #
  0x2001 => 'ar-om',  #
  0x2401 => 'ar-ye',  #
  0x2801 => 'ar-sy',  #
  0x2C01 => 'ar-jo',  #
  0x3001 => 'ar-lb',  #
  0x3401 => 'ar-kw',  #
  0x3801 => 'ar-ae',  #
  0x3C01 => 'ar-bh',  #
  0x4001 => 'ar-qa',  #

  0x042b => 'hy'   ,  #
  0x044d => 'as'   ,  #
  0x042c => 'az-latn',  #
  0x082c => 'az-cyrl',  #
  0x042D => 'eu'   ,  #
  0x0423 => 'be'   ,  #
  0x0445 => 'bn'   ,  #
  0x0402 => 'bg'   ,  #
  0x0403 => 'ca'   ,  #

  # Chinese is zh, not cn!
  0x0404 => 'zh-tw',  #
  0x0804 => 'zh-cn',  #
  0x0C04 => 'zh-hk',  #
  0x1004 => 'zh-sg',  #
  0x1404 => 'zh-mo',  #

  0x041a => 'hr'   ,  #
  0x0405 => 'cs'   ,  #
  0x0406 => 'da'   ,  #
  0x0413 => 'nl-nl',  #
  0x0813 => 'nl-be',  #

  0x0409 => 'en-us',  #
  0x0809 => 'en-gb',  #
  0x0c09 => 'en-au',  #
  0x1009 => 'en-ca',  #
  0x1409 => 'en-nz',  #
  0x1809 => 'en-ie',  #
  0x1c09 => 'en-za',  #
  0x2009 => 'en-jm',  #
  0x2409 => 'en-jm',  #     # a hack
  0x2809 => 'en-bz',  #
  0x2c09 => 'en-tt',  #
  0x3009 => 'en-zw',  #
  0x3409 => 'en-ph',  #

  0x0425 => 'et'   ,  #
  0x0438 => 'fo'   ,  #
  0x0429 => 'pa'   ,  #      # =Persian
  0x040b => 'fi'   ,  #

  0x040c => 'fr-fr',  #
  0x080c => 'fr-be',  #
  0x0c0c => 'fr-ca',  #
  0x100c => 'fr-ch',  #
  0x140c => 'fr-lu',  #
  0x180c => 'fr-mc',  #

  0x0437 => 'ka'   ,  #

  0x0407 => 'de-de',  #
  0x0807 => 'de-ch',  #
  0x0c07 => 'de-at',  #
  0x1007 => 'de-lu',  #
  0x1407 => 'de-li',  #

  0x0408 => 'el'   ,  #
  0x0447 => 'gu'   ,  #
  0x040D => 'he'   ,  #     # formerly 'iw'
  0x0439 => 'hi'   ,  #
  0x040e => 'hu'   ,  #
  0x040F => 'is'   ,  #
  0x0421 => 'id'   ,  #     # formerly 'in'
  0x0410 => 'it-it',  #
  0x0810 => 'it-ch',  #
  0x0411 => 'ja'   ,  #     # not "jp"!
  0x044b => 'kn'   ,  #
  0x0860 => 'ks'   ,  #
  0x043f => 'kk'   ,  #
  0x0457 => 'kok'  ,  #       3-letters!
  0x0412 => 'ko'   ,  #
  0x0812 => 'ko'   ,  #     ?
  0x0426 => 'lv'   ,  #     # = lettish
  0x0427 => 'lt'   ,  #
  0x0827 => 'lt'   ,  #     ?
  0x042f => 'mk'   ,  #
  0x043e => 'ms'   ,  #
  0x083e => 'ms-bn',  #
  0x044c => 'ml'   ,  #
  0x044e => 'mr'   ,  #
  0x0461 => 'ne-np',  #
  0x0861 => 'ne-in',  #
  0x0414 => 'nb'   ,  #      #was no-bok
  0x0814 => 'nn'   ,  #     #was no-nyn
                        # note that this leaves nothing using "no" ("Norwegian")
  0x0448 => 'or'   ,  #
  0x0415 => 'pl'   ,  #
  0x0416 => 'pt-br',  #
  0x0816 => 'pt-pt',  #
  0x0446 => 'pa'   ,  #
  0x0417 => 'rm'   ,  #
  0x0418 => 'ro'   ,  #
  0x0818 => 'ro-md',  #
  0x0419 => 'ru'   ,  #
  0x0819 => 'ru-md',  #
  0x043b => 'se'   ,  #     assuming == "Northern Sami"
  0x044f => 'sa'   ,  #
  0x0c1a => 'sr-cyrl', #
  0x081a => 'sr-latn', #
  0x0459 => 'sd'   ,  #
  0x041b => 'sk'   ,  #
  0x0424 => 'sl'   ,  #
  0x042e => 'wen'  ,  #     # !!! 3 letters

  0x040a => 'es-es',  #
  0x080a => 'es-mx',  #
  0x0c0a => 'es-es',  #
  0x100a => 'es-gt',  #
  0x140a => 'es-cr',  #
  0x180a => 'es-pa',  #
  0x1c0a => 'es-do',  #
  0x200a => 'es-ve',  #
  0x240a => 'es-co',  #
  0x280a => 'es-pe',  #
  0x2c0a => 'es-ar',  #
  0x300a => 'es-ec',  #
  0x340a => 'es-cl',  #
  0x380a => 'es-uy',  #
  0x3c0a => 'es-py',  #
  0x400a => 'es-bo',  #
  0x440a => 'es-sv',  #
  0x480a => 'es-hn',  #
  0x4c0a => 'es-ni',  #
  0x500a => 'es-pr',  #

  0x0430 => 'st'   ,  #     == soto, sesotho
  0x0441 => 'sw-ke',  #
  0x041D => 'sv'   ,  #
  0x081d => 'sv-fi',  #
  0x0449 => 'ta'   ,  #
  0x0444 => 'tt'   ,  #
  0x044a => 'te'   ,  #
  0x041E => 'th'   ,  #
  0x0431 => 'ts'   ,  #       (not Tonga!)
  0x0432 => 'tn'   ,  #       == Setswana
  0x041f => 'tr'   ,  #
  0x0422 => 'uk'   ,  #
  0x0420 => 'ur-pk',  #
  0x0820 => 'ur-in',  #
  0x0443 => 'uz-latn',  #
  0x0843 => 'uz-cyrl',  #
  0x0433 => 'ven'  ,  #
  0x042a => 'vi'   ,  #
  0x0434 => 'xh'   ,  #
  0x043d => 'yi'   ,  #     # formetly ji
  0x0435 => 'zu'   ,  #
);
#-----------------------------------------------------------------------------

sub get_ms_locale {
  my $locale;
  return unless defined do {
    # see if there's a W32 registry on this machine, and if so, look in it
    local $SIG{"__DIE__"} = "";
    eval '
      use Win32::TieRegistry ();
      my $i18n = Win32::TieRegistry->new(
         "HKEY_CURRENT_USER/Control Panel/International",
         { Delimiter => "/" }
      );
      #print "no key!" unless $i18n;
      $locale = $i18n->GetValue("Locale") if $i18n;
      undef $i18n;
    ';
    #print "<$@>\n" if $@;
    $locale;
  };
  return unless $locale =~ m/^[0-9a-fA-F]+$/s;
  return hex($locale);
}

sub get_language {
  my $lang = $MSLocale2LangTag{ $_[0] || get_ms_locale() || '' };
  return unless $lang;
  return $lang;
}

sub get_locale {
  # I guess this is right.
  my $lang = get_language(@_);
  return unless $lang and $lang =~ m/^[a-z]{2}(?:-[a-z]{2})?$/s;

  # should we try to turn "fi" into "fi_FI"?

  $lang =~ tr/-/_/;
  return $lang;
}
#-----------------------------------------------------------------------------

# If we're just executed...
unless(caller) {
  my $locale = get_ms_locale();
  if($locale) {
    printf "Locale 0x%08x (%s => %s) => Lang %s\n",
      $locale, $locale,
      get_locale($locale)   || '?',
      get_language($locale) || '?',
  } else {
    print "Can't get ms-locale\n";
  }
}

#-----------------------------------------------------------------------------
1;

__END__