You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
RnQ/for.RnQ/RnQLangs.pas

941 lines
22 KiB
Plaintext

{
This file is part of RnQ.
Under same license
}
unit RnQLangs;
{$I ForRnQConfig.inc}
interface
uses
{$IFDEF LANGDEBUG}
System.IniFiles,
{$ENDIF}
Generics.Collections,
RDFileUtil;
{$I NoRTTI.inc}
type
ToLangInfo = Class(TObject)
public
fn, subFile, desc: string;
end;
aLangInfo = array of ToLangInfo;
TLangList = TDictionary;
type
TRnQLang = class
private
// LangPath : TThemePath;
LangsStr: TLangList;
{$IFDEF LANGDEBUG}
hLangsStr: THashedStringList;
{$ENDIF}
LangFN0, LangFN1: String;
// langIsUTF : Boolean;
function TranslateString(const Str: AnsiString): String; overload; inline;
{$IFDEF UNICODE}
function TranslateString(const Str: UnicodeString): String; overload; inline;
{$ENDIF UNICODE}
procedure LangAddStr(const k: String; const v: String; var Mas: TLangList);
{$IFDEF LANGDEBUG}
procedure DebugAddStr(const k: String; const v: String);
{$ENDIF}
function FileIsUTF(const fn: String): Boolean;
public
// constructor LoadLang(p_fn : String; p_isUTFLang : Boolean);
constructor Create;
destructor Destroy; override;
// function Trans(const key: AnsiString; const args:array of const):string; overload;
// function Trans(const key: AnsiString):string; overload;
{$IFDEF UNICODE}
// function Trans(const key: UnicodeString; const args:array of const):string; overload;
// function Trans(const key: UnicodeString):string; overload;
{$ENDIF UNICODE}
// Procedure loadLanguageFile(fn : String; isUTFLang : Boolean);
function LoadLanguageFile2(fn: String; ts: TThemeSourcePath; IsUTFLang: Boolean): Boolean;
procedure ClearLanguage;
procedure ResetLanguage;
// procedure loadLanguage;
procedure LoadLanguage2(f: ToLangInfo);
procedure LoadLastLanguage;
procedure ClearLang;
procedure ResetLang;
end;
function GetTranslation(const key: AnsiString; const args: array of const): string; overload;
function GetTranslation(const key: AnsiString): string; overload;
{$IFDEF UNICODE}
function GetTranslation(const key: UnicodeString; const args: array of const): string; overload;
function GetTranslation(const key: UnicodeString): string; overload;
{$ENDIF UNICODE}
procedure RefreshLangList(pOnlyFileNames: Boolean);
procedure ClearLanglist;
procedure LoadSomeLanguage;
procedure ClearLanguage;
function IsRuLang: Boolean;
function GetYearsWord(Years: Integer): String;
function GetDaysWord(Days: Integer): String;
function GetHoursWord(Hours: Integer): String;
function GetMinutesWord(Minutes: Integer; Accusative: Boolean = False): String;
var
UseLang: Boolean = false;
gLangFile, gLangSubFile: String;
const
c_Int_Lang_FN = 'internal';
implementation
uses
System.SysUtils, System.StrUtils, System.Masks,
{$IFDEF UNICODE}
System.AnsiStrings,
{$ENDIF UNICODE}
{$IFDEF RNQ}
RQlog,
{$ENDIF RNQ}
{$IFDEF USE_ZIP}
RnQZip,
{$ENDIF USE_ZIP}
RDGlobal, RnQStrings, RDUtils, RnQLangFrm, RnQGlobal;
var
langList: aLangInfo;
LangVar: TRnQLang;
{ lang:array of record
key,text:string;
end;
alreadyLoaded:array of string; // keep track of loaded modules
}
// PrefStr : THashedStringList;
{
Procedure LangAddStr(const k, v : AnsiString; Mas : THashedStringList);
var
so : TPUStrObj;
i : Integer;
begin
i := Mas.IndexOf(k);
if i>=0 then
begin
so := TPUStrObj(Mas.Objects[i]);
FreeMemory(so.Str);
so.Str := NIL;
end
else
so := TPUStrObj.Create;
so.Str := GetMemory(Length(v)+1);
StrCopy(so.Str, PChar(v));
if i<0 then
Mas.AddObject(k, so);
// Mas.Names
end;
constructor TRnQLang.LoadLang(p_fn : String; p_isUTFLang : Boolean);
begin
LangsStr := THashedStringList.Create;
loadLanguageFile(p_fn, p_isUTFLang);
end;
}
constructor TRnQLang.Create;
begin
// LangsStr := THashedStringList.Create;
LangsStr := TLangList.Create;
end;
destructor TRnQLang.Destroy;
begin
FreeAndNil(LangsStr);
inherited;
end;
procedure TRnQLang.resetLanguage;
begin
if Assigned(LangsStr) then
LangsStr.Clear;
end; // resetLanguage
procedure TRnQLang.ClearLanguage;
// var
// sr:TsearchRec;
// ls : String;
// i : Integer;
// so : TPUStrObj;
begin
// useLang := False;
{$IFDEF LANGDEBUG}
if lang_debug then
if Assigned(hLangsStr) then
begin
hLangsStr.SaveToFile('RnQ.Translate.txt');
for I := 0 to hLangsStr.Count - 1 do
begin
so := TPUStrObj(hLangsStr.Objects[I]);
hLangsStr.Objects[I] := NIL;
FreeMemory(so.Str);
so.Free;
end;
hLangsStr.Clear;
FreeAndNil(hLangsStr);
end;
{$ENDIF}
if Assigned(LangsStr) then
begin
{
for I := 0 to LangsStr.Count - 1 do
begin
so := TPUStrObj(LangsStr.Objects[i]);
LangsStr.Objects[i] := NIL;
FreeMemory(so.Str);
so.Free;
end;
}
LangsStr.Clear;
FreeAndNil(LangsStr);
end;
end;
function TRnQLang.loadLanguageFile2(fn: string; ts: TThemeSourcePath; isUTFLang: Boolean): Boolean;
function fullpath(const fn: string): string;
var
s1: String;
begin
if RnQMainPath > '' then
s1 := RnQMainPath + fn
else
s1 := fn;
if ansipos(':', fn) = 0 then
result := myPath + s1
else
result := s1
end;
var
k, v: RawByteString;
kU, vU: String;
I, j: Integer;
txt: RawByteString;
begin
Result := False;
ts.path := ts.path + ExtractFilePath(fn);
ts.path := includeTrailingPathDelimiter(ts.path);
if IsPathDelimiter(ts.path, 1) then
Delete(ts.path, 1, 1);
fn := ExtractFileName(fn);
if fn = '' then
Exit;
Result := ExistsFile(ts, fn);
if not Result then
Exit;
txt := loadfile(ts, fn);
while txt > '' do
begin
k := chopline(txt);
// par := trim(line);
if k = '' then
continue;
if k[1] <> '[' then
begin
{$IFDEF UNICODE}
v := Trim(chop(RawByteString('='), k));
k := Trim(k);
{$ELSE nonUNICODE}
v := trim(chop('=', k));
k := trim(k);
{$ENDIF UNICODE}
if v = 'include' then
begin
kU := UnUTF(k);
loadLanguageFile2(kU, ts, isUTFLang);
end;
continue;
end;
Delete(k, 1, 1);
I := 1;
repeat
{$IFDEF UNICODE}
j := PosEx(']', k, I + 1);
{$ELSE nonUNICODE}
j := PosEx(']', k, I + 1);
{$ENDIF UNICODE}
if j > 0 then
I := j;
until j <= 0;
// i := AnsiPos(']', k);
if I > 1 then
Delete(k, I, length(k));
{$IFDEF UNICODE}
k := Trim(k);
kU := UnUTF(k);
{$ELSE nonUNICODE}
k := trim(k);
kU := trim(k);
{$ENDIF UNICODE}
v := chopline(txt);
if isUTFLang then
begin
// vv := UnUTF(v);
// vv := UnUTF(UTF8String(Pointer(v)));
vU := UnUTF(v);
vU := TrimRight(vU);
end
else
begin
vU := UnUTF(TrimRight(v));
end;
if vU <> '' then
LangAddStr(kU, vU, LangsStr);
end;
end;
procedure TRnQLang.loadLastLanguage;
var
f: ToLangInfo;
begin
f := ToLangInfo.Create;
f.fn := langFN0;
f.subFile := langFN1;
// f.isUTF := langIsUTF;
try
loadLanguage2(f);
finally
f.Free;
end;
end;
procedure TRnQLang.loadLanguage2(f: ToLangInfo);
var
I { ,k } : Integer;
pt: TThemeSourcePath;
fn: String;
isUTF: Boolean;
begin
{$IFDEF RNQ}
LogEvent('loading language: ');
{$ENDIF RNQ}
langFN0 := f.fn;
langFN1 := f.subFile;
// langIsUTF := f.isUTF;
useLang := false;
FreeAndNil(LangsStr);
{$IFDEF LANGDEBUG}
if lang_debug then
hLangsStr := THashedStringList.Create;
{$ENDIF}
if FileExists(f.fn) then
begin
if f.subFile = '' then
begin
pt.pathType := pt_path;
pt.path := ExtractFilePath(f.fn);
fn := f.fn;
end
else
begin
pt.pathType := pt_zip;
pt.ArcFile := f.fn;
fn := f.subFile;
pt.zp := TZipFile.Create;
pt.zp.LoadFromFile(pt.ArcFile);
end;
isUTF := fileIsUTF(fn);
LangsStr := TLangList.Create;
{
LangsStr.Sorted := false;
// LangsStr.Sorted := True;
// LangStr.CaseSensitive := False;
LangsStr.CaseSensitive := True;
}
useLang := loadLanguageFile2(fn, pt, isUTF);
if (pt.pathType = pt_zip) and Assigned(pt.zp) then
FreeAndNil(pt.zp);
// LangsStr.Sorted := True;
// useLang := True;
end;
{$IFDEF LANGDEBUG}
lang_debug := lang_debug and useLang;
{$ENDIF LANGDEBUG}
if useLang and Assigned(LangsStr) then
for I := low(not2Translate) to High(not2Translate) do
begin
LangsStr.Remove(not2Translate[I]);
{ k := LangsStr.IndexOf(not2Translate[i]);
if k >=0 then
begin
FreeMemory(TPUStrObj(LangsStr.Objects[k]).Str);
TPUStrObj(LangsStr.Objects[k]).Free;
LangsStr.Objects[k] := NIL;
LangsStr.Delete(k);
end;
}
{$IFDEF LANGDEBUG}
if lang_debug then
begin
k := hLangsStr.IndexOf(not2Translate[I]);
if k >= 0 then
begin
FreeMemory(TPUStrObj(hLangsStr.Objects[k]).Str);
TPUStrObj(hLangsStr.Objects[k]).Free;
hLangsStr.Objects[k] := NIL;
hLangsStr.Delete(k);
end;
end;
{$ENDIF LANGDEBUG}
end;
{$IFDEF LANGDEBUG}
if lang_debug then
hLangsStr.Sorted := True;
{$ENDIF}
{$IFDEF RNQ}
LogEvent('language loaded');
{$ENDIF RNQ}
end;
Function TRnQLang.TranslateString(const Str: AnsiString): String;
var
// Res : String;
// i : Integer;
s: String;
begin
if LangsStr.TryGetValue(Str, s) then
result := s
else
result := Str;
(*
// if not useLang then
// Result := Str
// else
begin
Result := '';
i := LangsStr.IndexOf(Str);
if i >= 0 then
begin
Result := StrPas(TPUStrObj(LangsStr.Objects[i]).Str);
// if LangIsUnicode then
// Result := unUTF(Result);
end
else
begin
// LangAddStr(Str, Str, LangStr);
{$IFDEF LANGDEBUG}
if lang_debug then
begin
i := hLangStr.IndexOf(Str);
if i < 0 then
PrefAddStr(Str, '', hLangStr);
end;
{$ENDIF}
Result := Str;
end;
end;
*)
end;
{$IFDEF UNICODE}
Function TRnQLang.TranslateString(const Str: UnicodeString): String;
var
// Res : String;
// i : Integer;
s: String;
begin
if LangsStr.TryGetValue(Str, s) then
Result := s
else
begin
Result := Str;
{$IFDEF LANGDEBUG}
if lang_debug then
if hLangsStr.IndexOf(Str) < 0 then
DebugAddStr(Str, '');
{$ENDIF}
end;
(*
// if not useLang then
// Result := Str
// else
begin
Result := '';
i := LangsStr.IndexOf(Str);
if i >= 0 then
begin
Result := StrPas(TPUStrObj(LangsStr.Objects[i]).Str);
// if LangIsUnicode then
// Result := unUTF(Result);
end
else
begin
// LangAddStr(Str, Str, LangStr);
{$IFDEF LANGDEBUG}
if lang_debug then
begin
i := hLangsStr.IndexOf(Str);
if i < 0 then
PrefAddStr(Str, '', hLangStr);
end;
{$ENDIF}
Result := Str;
end;
end;
*)
end;
{$ENDIF UNICODE}
Procedure TRnQLang.LangAddStr(const k: String; const v: String; var Mas: TLangList);
// var
// so : TPUStrObj;
// i : Integer;
begin
Mas.AddOrSetValue(k, v);
(*
i := Mas.IndexOf(k);
if i>=0 then
begin
so := TPUStrObj(Mas.Objects[i]);
FreeMemory(so.Str);
// FreeMem(so.Str);
so.Str := NIL;
end
else
so := TPUStrObj.Create;
// so.Str := GetMemory(Length(v)+1);
so.Str := AllocMem((Length(v)+1)*SizeOf(Char));
{$IFNDEF UNICODE}
StrCopy(so.Str, PChar(v));
{$ELSE UNICODE}
StrCopy(PWideChar(so.Str), PWideChar(v));
{$ENDIF UNICODE}
if i<0 then
Mas.AddObject(k, so);
*)
end;
{$IFDEF LANGDEBUG}
procedure TRnQLang.DebugAddStr(const k: String; const v: String);
var
so: TPUStrObj;
i: Integer;
begin
i := hLangsStr.IndexOf(k);
if i>=0 then
begin
so := TPUStrObj(hLangsStr.Objects[i]);
FreeMemory(so.Str);
// FreeMem(so.Str);
so.Str := NIL;
end
else
so := TPUStrObj.Create;
// so.Str := GetMemory(Length(v)+1);
so.Str := AllocMem((Length(v)+1)*SizeOf(Char));
{$IFNDEF UNICODE}
StrCopy(so.Str, PChar(v));
{$ELSE UNICODE}
StrCopy(PWideChar(so.Str), PWideChar(v));
{$ENDIF UNICODE}
if i<0 then
hLangsStr.AddObject(k, so);
end;
{$ENDIF LANGDEBUG}
function TRnQLang.fileIsUTF(const fn: String): Boolean;
begin
result := ExtractFileExt(fn) = '.utflng';
end;
procedure TRnQLang.resetLang;
// var
// i : Integer;
// so : TPUStrObj;
begin
if Assigned(LangsStr) then
begin
(*
for I := 0 to LangsStr.Count - 1 do
begin
so := TPUStrObj(LangsStr.Objects[i]);
LangsStr.Objects[i] := NIL;
FreeMemory(so.Str);
so.Free;
end;
*)
LangsStr.Clear;
end;
end; // resetLanguage
procedure TRnQLang.ClearLang;
begin
if Assigned(LangsStr) then
begin
resetLang;
FreeAndNil(LangsStr);
end;
end;
/// ///////////////////////////////////////////////////////////////////////
function getTranslation(const key: AnsiString): string;
begin
if useLang and Assigned(LangVar) then
result := LangVar.TranslateString(key)
else
result := key;
result := ReplaceStr(result, '\n', CRLF);
end; // getTranslation
function getTranslation(const key: AnsiString; const args: array of const): string;
// var
// s : extended;
begin
if useLang and Assigned(LangVar) then
begin
result := LangVar.TranslateString(key);
end
else
result := key;
if length(args) > 0 then
try
result := format(result, args);
except
end;
result := ReplaceStr(result, '\n', CRLF);
// result := ReplaceStr(result,'\s',' ');
end; // getTranslation
{$IFDEF UNICODE}
function GetTranslation(const key: String): string;
begin
if useLang and Assigned(LangVar) then
result := LangVar.TranslateString(key)
else
result := key;
result := ReplaceStr(result, '\n', CRLF);
end; // getTranslation
function getTranslation(const key: string; const args: array of const): string;
begin
if useLang and Assigned(LangVar) then
begin
if (Length(key) > 0) and (key[1] = ' ') then
result := ' ' + LangVar.TranslateString(copy(key, 2, length(key)))
else
result := LangVar.TranslateString(key)
end
else
result := key;
if length(args) > 0 then
try
result := format(result, args);
except end;
result := ReplaceStr(result, '\n', CRLF);
// result := ReplaceStr(result, '\s', ' ');
end; // getTranslation
{$ENDIF UNICODE}
procedure RefreshLangList(pOnlyFileNames: Boolean);
procedure ProcessFile(Const fn, subFile: String; s: RawByteString; isUTF: Boolean);
var
line, k, v, section: RawByteString;
procedure InternalprocessTheme(var ati: aLangInfo);
var
n: Integer;
begin
n := length(ati);
setlength(ati, n + 1);
ati[n] := ToLangInfo.Create;
ati[n].fn := fn;
ati[n].subFile := subFile;
// ati[n].isUTF := isUTF;
section := '';
while s > '' do
begin
line := chopline(s);
if (line > '') and (line[1] = '[') then
begin
line := trim(line);
if line[length(line)] = ']' then
section := copy(line, 2, length(line) - 2);
continue;
end;
v := trim(line);
k := AnsiLowerCase(trim(chop('=', v)));
v := trim(v);
if section = '' then
begin
// if k = 'logo' then ati[n].logo := v;
// if k = 'title' then ati[n].title:= UnUTF(v);
if k = 'desc' then
ati[n].desc := ReplaceStr(UnUTF(v), '\n', CRLF);
end;
v := '';
if section = 'desc' then
with ati[n] do
desc := desc + UnUTF(line) + CRLF;
end;
with ati[n] do
desc := TrimRight(desc);
end;
begin
// line := trim(chopline(s));
// if (line='&RQ theme file version 1')
// or (line='R&Q theme file version 1') then
begin
InternalprocessTheme(langList);
end
end;
const
langsFiles: array [0 .. 1] of string = ('RnQ*.utflng', 'RnQ*.lng');
ZipLangs: array [0 .. 0] of string = ('.zlng');
var
sr: TSearchRec;
I, e: Integer;
// str: TStringStream;
// str2: TMemoryStream;
ts: TThemeSourcePath;
fn, FullFN: String;
// subFile,
sA: RawByteString;
w: string;
// lang_paths : array[0..1] of string;
lang_paths: array of string;
lang_subpaths: array of string;
ti: Integer;
begin
setlength(lang_paths, 2);
setlength(lang_subpaths, 2);
lang_paths[0] := myPath;
lang_paths[1] := myPath + 'Langs' + PathDelim;
lang_subpaths[0] := '';
lang_subpaths[1] := 'Langs' + PathDelim;
if RnQMainPath > '' then
begin
setlength(lang_paths, 3);
lang_paths[2] := RnQMainPath;
setlength(lang_subpaths, 3);
lang_subpaths[2] := ExtractRelativePath(myPath, RnQMainPath);
end;
// theme_paths[1] := myPath; // For *.rtz
// n:=0;
ClearLanglist;
for ti := Low(lang_paths) to High(lang_paths) do
for e := 0 to length(langsFiles) - 1 do
begin
if findFirst(lang_paths[ti] + langsFiles[e], faAnyFile, sr) = 0 then
repeat
if sr.name[1] <> '.' then
begin
fn := sr.name;
if pOnlyFileNames then
sA := ''
else
sA := loadFileA(lang_paths[ti] + fn);
ProcessFile(lang_subpaths[ti] + fn, '', sA, e = 0);
end;
until findNext(sr) <> 0;
findClose(sr);
end;
{$IFDEF USE_ZIP}
// for ti := Low(lang_paths) to High(lang_paths) do
for e := 0 to length(ZipLangs) - 1 do
begin
if findFirst(lang_paths[0] + '*' + ZipLangs[e], faAnyFile, sr) = 0 then
repeat
if sr.name[1] <> '.' then
begin
fn := sr.name;
FullFN := lang_paths[0] + fn;
ts.zp := TZipFile.Create;
ts.zp.LoadFromFile(FullFN, pOnlyFileNames);
if ts.zp.Count > 0 then
begin
for I := 0 to ts.zp.Count - 1 do
begin
w := ts.zp.name[I];
if (LastDelimiter('\/:', w) <= 0) and (MatchesMask(w, langsFiles[0]) or MatchesMask(w, langsFiles[1])) then
begin
if pOnlyFileNames then
sA := ''
else
sA := ts.zp.Data[I];
ProcessFile(fn, w, sA, MatchesMask(w, langsFiles[0]));
sA := '';
end;
end;
ts.zp.Free;
end;
end;
until findNext(sr) <> 0;
findClose(sr);
end;
{$ENDIF USE_ZIP}
end; // refreshLangList
procedure ClearLanglist;
procedure Clear1LangList(var tl: aLangInfo);
var
t: ToLangInfo;
// i : Integer;
begin
for t in tl do
begin
setlength(t.fn, 0);
setlength(t.subFile, 0);
setlength(t.desc, 0);
t.Free;
end;
setlength(tl, 0);
end;
begin
Clear1LangList(langList);
end;
procedure LoadSomeLanguage;
var
I: Integer;
lv: ToLangInfo;
begin
if gLangFile = c_Int_Lang_FN then
Exit;
if gLangFile > '' then
begin
lv := ToLangInfo.Create;
lv.fn := gLangFile;
lv.subFile := gLangSubFile;
LangVar := TRnQLang.Create;
LangVar.loadLanguage2(lv);
lv.Free;
if UseLang then
Exit
else
FreeAndNil(LangVar);
end;
RefreshLangList(True);
if Length(langList) = 0 then
begin
UseLang := False;
// Exit;
end else if Length(langList) = 1 then
begin
LangVar := TRnQLang.Create;
LangVar.loadLanguage2(langList[0]);
// langList[0]
end
else
begin
RefreshLangList(False);
I := ShowLangsFrm(langList);
if I < 0 then
begin
UseLang := False;
if I = -5 then
gLangFile := c_Int_Lang_FN;
// Exit;
end
else
begin
gLangFile := langList[I].fn;
gLangSubFile := langList[I].subFile;
LangVar := TRnQLang.Create;
// LangVar.loadLanguage;
LangVar.loadLanguage2(langList[I]);
end;
end;
ClearLanglist;
end;
procedure ClearLanguage;
begin
useLang := False;
if Assigned(LangVar) then
LangVar.ClearLanguage;
FreeAndNil(LangVar);
end;
function IsRuLang: Boolean;
begin
Result := ContainsText(LangVar.langFN0, '_ru') or ContainsText(LangVar.langFN1, '_ru');
end;
function GetENCase(Num: Integer; const Nom, GenX: String): String;
begin
Result := IfThen(Num = 1, Nom, GenX);
end;
function GetRUCase(Num: Integer; const Nom, Gen1, GenX: String): String;
var
Last1, Last2: Integer;
begin
Last1 := Num mod 10;
Last2 := Num mod 100;
if (Last1 = 1) and (Last2 <> 11) then
Result := Nom
else if ((Last1 = 2) and (Last2 <> 12)) or ((Last1 = 3) and (Last2 <> 13)) or ((Last1 = 4) and (Last2 <> 14)) then
Result := Gen1
else
Result := GenX;
end;
function GetDaysWord(Days: Integer): String;
begin
if IsRuLang then
Result := GetRUCase(Days, 'день', 'дня', 'дней')
else
Result := GetTranslation(GetENCase(Days, 'day', 'days'))
end;
function GetHoursWord(Hours: Integer): String;
begin
if IsRuLang then
Result := GetRUCase(Hours, 'час', 'часа', 'часов')
else
Result := GetTranslation(GetENCase(Hours, 'hour', 'hours'))
end;
function GetMinutesWord(Minutes: Integer; Accusative: Boolean = False): String;
begin
if IsRuLang then
Result := GetRUCase(Minutes, IfThen(Accusative, 'минуту', 'минута'), 'минуты', 'минут')
else
Result := GetTranslation(GetENCase(Minutes, 'minute', 'minutes'))
end;
function GetYearsWord(Years: Integer): String;
begin
if IsRuLang then
Result := ' ' + GetRUCase(Years, 'год', 'года', 'лет')
else
Result := ' ' + GetTranslation('y.o.');
end;
end.