dbf_lang.pas

tDBF is new ver, this is BDS 2007 insta

      Ord('U') or (Ord('K') shl 8) or (Ord('0') shl 16),
      Ord('U') or (Ord('S') shl 8) or (Ord('0') shl 16),
      Ord('C') or (Ord('F') shl 8) or (Ord('1') shl 16),
      Ord('C') or (Ord('F') shl 8) or (Ord('1') shl 16),
{1E}  0,
{1F}  Ord('C') or (Ord('Z') shl 8) or (Ord('0') shl 16),
      Ord('C') or (Ord('Z') shl 8) or (Ord('0') shl 16),
{21}  0,
{22}  Ord('H') or (Ord('D') shl 8) or (Ord('C') shl 16),
      Ord('P') or (Ord('O') shl 8) or (Ord('0') shl 16),
      Ord('P') or (Ord('T') shl 8) or (Ord('0') shl 16),
      Ord('P') or (Ord('T') shl 8) or (Ord('0') shl 16),
      Ord('R') or (Ord('U') shl 8) or (Ord('0') shl 16),
{27}  0,0,0,0,0,0,0,0,0,
{30}  0,0,0,0,0,0,0,
{37}  Ord('U') or (Ord('S') shl 8) or (Ord('0') shl 16),
{38}  0,0,0,0,0,0,0,0,
{40}  0,0,0,0,0,0,0,0,0,0,0,0,0,
{4D}  Ord('C') or (Ord('N') shl 8) or (Ord('0') shl 16),
      Ord('K') or (Ord('O') shl 8) or (Ord('0') shl 16),
      Ord('T') or (Ord('W') shl 8) or (Ord('0') shl 16),
      Ord('T') or (Ord('H') shl 8) or (Ord('0') shl 16),
{51}  0,0,0,0,0,
{56}  Ord('J') or (Ord('P') shl 8) or (Ord('1') shl 16),
      Ord('U') or (Ord('S') shl 8) or (Ord('0') shl 16),
      Ord('W') or (Ord('E') shl 8) or (Ord('0') shl 16),
      Ord('E') or (Ord('S') shl 8) or (Ord('0') shl 16),
{5A}  0,0,0,0,
// FoxPro
{5E}  Ord('D') or (Ord('E') shl 8),
      Ord('N') or (Ord('O') shl 8),
      Ord('N') or (Ord('O') shl 8),
      Ord('D') or (Ord('E') shl 8),
      Ord('N') or (Ord('O') shl 8),
{63}  0,
{64}  Ord('C') or (Ord('Z') shl 8) or (Ord('0') shl 16),
      Ord('R') or (Ord('U') shl 8) or (Ord('0') shl 16),
      Ord('N') or (Ord('O') shl 8),
      Ord('I') or (Ord('C') shl 8) or (Ord('0') shl 16),    // made this one up: iceland
      Ord('C') or (Ord('Z') shl 8) or (Ord('0') shl 16),
{69}  Ord('P') or (Ord('O') shl 8) or (Ord('1') shl 16),
      Ord('G') or (Ord('R') shl 8) or (Ord('0') shl 16),
      Ord('T') or (Ord('R') shl 8) or (Ord('0') shl 16),
{6C}  0,0,0,0,
{70}  0,0,0,0,0,0,0,0,
{78}  Ord('C') or (Ord('H') shl 8) or (Ord('0') shl 16),    // made this one up: chinese hongkong
      Ord('K') or (Ord('O') shl 8) or (Ord('0') shl 16),
      Ord('C') or (Ord('S') shl 8) or (Ord('0') shl 16),    // made this one up: chinese singapore
      Ord('J') or (Ord('P') shl 8) or (Ord('0') shl 16),
      Ord('T') or (Ord('H') shl 8) or (Ord('0') shl 16),
      Ord('R') or (Ord('E') shl 8) or (Ord('W') shl 16),
      Ord('A') or (Ord('R') shl 8) or (Ord('0') shl 16),    // made this one up: arabic (default)
{7F}  0,
{80}  0,0,0,0,0,
// dBase
{85}  Ord('R') or (Ord('E') shl 8) or (Ord('W') shl 16),
      Ord('G') or (Ord('R') shl 8) or (Ord('0') shl 16),
      Ord('S') or (Ord('L') shl 8) or (Ord('0') shl 16),
      Ord('T') or (Ord('R') shl 8) or (Ord('0') shl 16),
{89}  0,0,0,0,0,
{8E}  DbfLocale_Bul868,
{8F}  0,0,0,0,0,0,0,
{96}  Ord('R') or (Ord('U') shl 8) or (Ord('0') shl 16),
      Ord('C') or (Ord('Z') shl 8) or (Ord('0') shl 16),
      Ord('G') or (Ord('R') shl 8) or (Ord('0') shl 16),
{99}  0,0,
// FoxPro
{9B}  0, //LANG_CZECH      or (SUBLANG_DEFAULT              shl 10) or (SORT_DEFAULT shl 16),
      0, //LANG_CZECH      or (SUBLANG_DEFAULT              shl 10) or (SORT_DEFAULT shl 16),
{9D}  0,0,0,
{A0}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{B0}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{C0}  0,0,0,0,0,0,0,0,
{C8}  Ord('C') or (Ord('Z') shl 8) or (Ord('0') shl 16),
      Ord('R') or (Ord('U') shl 8) or (Ord('0') shl 16),
      Ord('T') or (Ord('R') shl 8) or (Ord('0') shl 16),
      Ord('G') or (Ord('R') shl 8) or (Ord('0') shl 16),
{CC}  0,0,0,0,
{D0}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{E0}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{F0}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
      );

{
  DbfLocaleId_DAN_865       = Ord('D') or (Ord('A') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_NLD_437       = Ord('N') or (Ord('L') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_NLD_850       = Ord('N') or (Ord('L') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_FIN_437       = Ord('F') or (Ord('I') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_FIN_850       = Ord('F') or (Ord('I') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_FRA_437       = Ord('F') or (Ord('R') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_FRA_850       = Ord('F') or (Ord('R') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_DEU_437       = Ord('D') or (Ord('E') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_DEU_850       = Ord('D') or (Ord('E') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_ITA_437       = Ord('I') or (Ord('T') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_ITA_850       = Ord('I') or (Ord('T') shl 8) or (Ord('1') shl 16);
  DbfLocaleId_JPN_932       = Ord('J') or (Ord('P') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_ESP_850       = Ord('E') or (Ord('S') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_SVE_437       = Ord('S') or (Ord('V') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_SVE_850       = Ord('S') or (Ord('V') shl 8) or (Ord('1') shl 16);
  DbfLocaleId_NOR_865       = Ord('N') or (Ord('O') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_ESP_437       = Ord('E') or (Ord('S') shl 8) or (Ord('1') shl 16);
  DbfLocaleId_ENG_437       = Ord('U') or (Ord('K') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_ENG_850       = Ord('U') or (Ord('K') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_ENU_437       = Ord('U') or (Ord('S') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_FRC_863       = Ord('C') or (Ord('F') shl 8) or (Ord('1') shl 16);
  DbfLocaleId_FRC_850       = Ord('C') or (Ord('F') shl 8) or (Ord('1') shl 16);
// ...
  DbfLocaleId_CSY_852       = Ord('C') or (Ord('Z') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_CSY_867       = Ord('C') or (Ord('Z') shl 8) or (Ord('0') shl 16);
// ...
  DbfLocaleId_HUN_852       = Ord('H') or (Ord('D') shl 8) or (Ord('C') shl 16);
  DbfLocaleId_PLK_852       = Ord('P') or (Ord('O') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_PTG_860       = Ord('P') or (Ord('T') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_PTB_850       = Ord('P') or (Ord('T') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_RUS_866       = Ord('R') or (Ord('U') shl 8) or (Ord('0') shl 16);
// ...
  DbfLocaleId_ENU_850       = Ord('U') or (Ord('S') shl 8) or (Ord('0') shl 16);
// ...
  DbfLocaleId_CHS_936       = Ord('C') or (Ord('N') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_KOR_949       = Ord('K') or (Ord('O') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_CHT_950       = Ord('T') or (Ord('W') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_THA_874       = Ord('T') or (Ord('H') shl 8) or (Ord('0') shl 16);
// ...
  DbfLocaleId_JPN_DIC_932   = Ord('J') or (Ord('P') shl 8) or (Ord('1') shl 16);
  DbfLocaleId_Ascii_Ansi    = Ord('U') or (Ord('S') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_WEurope_Ansi  = Ord('W') or (Ord('E') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_Spanish_Ansi  = Ord('E') or (Ord('S') shl 8) or (Ord('0') shl 16);
// ...
  DbfLocaleId_Hebrew        = Ord('R') or (Ord('E') shl 8) or (Ord('W') shl 16);
  DbfLocaleId_ELL_437       = Ord('G') or (Ord('R') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_SLO_852       = Ord('S') or (Ord('L') shl 8) or (Ord('0') shl 16);
  DbfLocaleId_TRK_857       = Ord('T') or (Ord('R') shl 8) or (Ord('0') shl 16);
// ...
  DbfLocaleId_BUL_868       = 'BGDB868';
}

// VdBase 7 Language strings
//  'DBWIN...' -> Charset 1252 (ansi)
//  'DB999...' -> Code page 999, 9 any digit
//  'DBHEBREW' -> Code page 1255 ??
//  'FOX..999' -> Code page 999, 9 any digit
//  'FOX..WIN' -> Charset 1252 (ansi)

//*************************************************************************//
// reverse convert routines
//*************************************************************************//

function ConstructLangName(CodePage: Integer; Locale: LCID; IsFoxPro: Boolean): string;

function ConstructLangId(CodePage: Integer; Locale: LCID; IsFoxPro: Boolean): Byte;

function GetLangId_From_LangName(LocaleStr: string): Byte;

implementation

uses
  SysUtils;

type
  PCardinal = ^Cardinal;

function ConstructLangName(CodePage: Integer; Locale: LCID; IsFoxPro: Boolean): string;
var
  SubType: Cardinal;
begin
  // ANSI?
  SubType := LangId_To_LocaleStr[ConstructLangId(CodePage, Locale, IsFoxPro)];
  // found?
  if SubType <> DbfLocale_NotFound then
  begin
    // foxpro or dbase?
    if IsFoxPro then
    begin
      Result := 'FOX' + PChar(@SubType);
      if CodePage = 1252 then
        Result := Result + 'WIN'
      else
        Result := Result + IntToStr(CodePage);
    end else begin
      if SubType = DbfLocale_Bul868 then
      begin
        // special case
        Result := 'BGDB868';
      end else begin
        // start with DB
        Result := 'DB';
        // add codepage
        if CodePage = 1252 then
          Result := Result + 'WIN'
        else
          Result := Result + IntToStr(CodePage);
        // add subtype
        Result := Result + PChar(@SubType);
      end;
    end;
  end;
end;

const
  // range of Dbase / FoxPro locale; these are INCLUSIVE

  dBase_RegionCount = 4;
  dBase_Regions: array[0..dBase_RegionCount*2-1] of Byte =
   ($00, $00,
    $05, $5D,
    $69, $69, // a lonely dbf entry :-)
    $80, $90);

function FindLangId(CodePage, Info2: Cardinal; Info2Table: PCardinal; IsFoxPro: Boolean): Byte;
var
  I, Region, FoxRes, DbfRes: Integer;
begin
  Region := 0;
  DbfRes := 0;
  FoxRes := 0;
  // scan
  for I := 0 to $FF do
  begin
    // check if need to advance to next region
    if Region + 2 < dBase_RegionCount then
      if I >= dBase_Regions[Region + 2] then
        Inc(Region, 2);
    // it seems delphi does not properly understand pointers?
    // what a mess :-(
    if ((LangId_To_CodePage[I] = CodePage) or (CodePage = 0)) and (PCardinal(PChar(Info2Table)+(I*4))^ = Info2) then
      if I <= dBase_Regions[Region+1] then
        DbfRes := Byte(I)
      else
        FoxRes := Byte(I);
  end;
  // if we can find langid in other set, use it
  if (DbfRes <> 0) and (not IsFoxPro or (FoxRes = 0)) then
    Result := DbfRes
  else  {(DbfRes = 0) or (IsFoxPro and (FoxRes <> 0)}
  if (FoxRes <> 0) {and (IsFoxPro or (DbfRes = 0)} then
    Result := FoxRes
  else
    Result := 0;
end;

{
function FindLangId(CodePage, Info2: Cardinal; Info2Table: PCardinal; IsFoxPro: Boolean): Byte;
var
  I, Region, lEnd: Integer;
  EndReached: Boolean;
begin
  Region := 0;
  Result := 0;
  repeat
    // determine region to scan
    if IsFoxPro then
    begin
      // foxpro, in between dbase regions
      I := dBase_Regions[Region+1] + 1;
      lEnd := dBase_Regions[Region+2] - 1;
      EndReached := Region = dBase_RegionCount*2-4;
    end else begin
      // dBase, select regions
      I := dBase_Regions[Region];
      lEnd := dBase_Regions[Region+1];
      EndReached := Region = dBase_RegionCount*2-2;
    end;
    // scan
    repeat
      // it seems delphi does not properly understand pointers?
      // what a mess :-(
      if (LangId_To_CodePage[I] = CodePage) and (PCardinal(PChar(Info2Table)+(I*4))^ = Info2) then
        Result := Byte(I);
      Inc(I);
      // lEnd is included in range
    until (Result <> 0) or (I > lEnd);
    // goto next region
    if (Result = 0) then
      Inc(Region, 2);
    // found or end?
  until (Result <> 0) or EndReached;
end;
}

function ConstructLangId(CodePage: Integer; Locale: LCID; IsFoxPro: Boolean): Byte;
begin
  // locale: lower 16bits only
  Locale := (Locale and $FFFF) or (SORT_DEFAULT shl 16);
  Result := FindLangId(CodePage, Locale, @LangId_To_Locale[0], IsFoxPro);
  // not found? try any codepage
  if Result = 0 then
    Result := FindLangId(0, Locale, @LangId_To_Locale[0], IsFoxPro);
end;

function GetLangId_From_LangName(LocaleStr: string): Byte;
var
  CodePage, SubType: Integer;
  IsFoxPro: Boolean;
  CodePageStr: string;
begin
  // determine foxpro/dbase
  IsFoxPro := CompareMem(PChar('FOX'), PChar(LocaleStr), 3);
  // get codepage/locale subtype
  if IsFoxPro then
  begin
    CodePageStr := Copy(LocaleStr, 6, 3);
    SubType := Integer(LocaleStr[4]) or (Integer(LocaleStr[5]) shl 8);
  end else begin
    CodePageStr := Copy(LocaleStr, 3, 3);
    SubType := Integer(LocaleStr[6]) or (Integer(LocaleStr[7]) shl 8) or (Integer(LocaleStr[8]) shl 16);
  end;
  // convert codepage string to codepage id
  if CodePageStr = 'WIN' then
    CodePage := 1252
  else if CodePageStr = 'REW' then    // hebrew
    CodePage := 1255
  else
    CodePage := StrToInt(CodePageStr);
  // find lang id
  Result := FindLangId(CodePage, SubType, @LangId_To_LocaleStr[0], IsFoxPro);
end;

end.