unit JvGnugettext; (**************************************************************) (* *) (* (C) Copyright by Lars B. Dybdahl and others *) (* E-mail: Lars@dybdahl.dk, phone +45 70201241 *) (* *) (* Contributors: Peter Thornqvist, Troy Wolbrink, *) (* Frank Andreas de Groot, Igor Siticov, *) (* Jacques Garcia Vazquez *) (* Andreas Hausladen *) (* *) (* See http://dybdahl.dk/dxgettext/ for more information *) (* *) (**************************************************************) // Redistribution and use in source and binary forms, with or without // modification, are permitted provided that the following conditions are met: // // The names of any contributor may not be used to endorse or promote // products derived from this software without specific prior written permission. // // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE // ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE // LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL // DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR // SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER // CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, // OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. interface // If the conditional define DXGETTEXTDEBUG is defined, debugging log is activated. // Use DefaultInstance.DebugLogToFile() to write the log to a file. { $define DXGETTEXTDEBUG} {$ifdef VER100} // Delphi 3 {$DEFINE DELPHI5OROLDER} {$DEFINE DELPHI6OROLDER} {$DEFINE DELPHI7OROLDER} {$endif} {$ifdef VER110} // C++ Builder 3 {$DEFINE DELPHI5OROLDER} {$DEFINE DELPHI6OROLDER} {$DEFINE DELPHI7OROLDER} {$endif} {$ifdef VER120} // Delphi 4 {$DEFINE DELPHI5OROLDER} {$DEFINE DELPHI6OROLDER} {$DEFINE DELPHI7OROLDER} {$endif} {$ifdef VER125} // C++ Builder 4 {$DEFINE DELPHI5OROLDER} {$DEFINE DELPHI6OROLDER} {$DEFINE DELPHI7OROLDER} {$endif} {$ifdef VER130} // Delphi 5 {$DEFINE DELPHI5OROLDER} {$DEFINE DELPHI6OROLDER} {$DEFINE DELPHI7OROLDER} {$ifdef WIN32} {$DEFINE MSWINDOWS} {$endif} {$endif} {$ifdef VER135} // C++ Builder 5 {$DEFINE DELPHI5OROLDER} {$DEFINE DELPHI6OROLDER} {$DEFINE DELPHI7OROLDER} {$ifdef WIN32} {$DEFINE MSWINDOWS} {$endif} {$endif} {$ifdef VER140} // Delphi 6 {$DEFINE DELPHI6OROLDER} {$DEFINE DELPHI7OROLDER} {$endif} {$ifdef VER150} {$DEFINE DELPHI7OROLDER} // Delphi 7 {$endif} {$ifdef VER160} // Delphi 8 {$endif} {$IFDEF CONDITIONALEXPRESSION} {$DEFINE DELPHI6OROLDER} {$DEFINE DELPHI7OROLDER} {$ENDIF} uses {$ifdef DELPHI5OROLDER} JvGnugettextD5, {$endif} {$ifdef MSWINDOWS} Windows, {$endif} {$ifdef LINUX} Libc, {$endif} Classes, SysUtils, Contnrs, TypInfo; (*****************************************************************************) (* *) (* MAIN API *) (* *) (*****************************************************************************) // Main GNU gettext functions. See documentation for instructions on how to use them. {$ifdef DELPHI5OROLDER} function _(const szMsgId: WideString): WideString; function gettext(const szMsgId: WideString): WideString; function dgettext(const szDomain: string; const szMsgId: WideString): WideString; function dngettext(const szDomain: string; const singular, plural: WideString; Number: Longint): WideString; function ngettext(const singular, plural: WideString; Number: Longint): WideString; {$endif} {$ifndef DELPHI5OROLDER} function _(const szMsgId: AnsiString): WideString; overload; function _(const szMsgId: WideString): WideString; overload; function gettext(const szMsgId: AnsiString): WideString; overload; function gettext(const szMsgId: WideString): WideString; overload; function dgettext(const szDomain: string; const szMsgId: AnsiString): WideString; overload; function dgettext(const szDomain: string; const szMsgId: WideString): WideString; overload; function dngettext(const szDomain: string; const singular, plural: AnsiString; Number: Longint): WideString; overload; function dngettext(const szDomain: string; const singular, plural: WideString; Number: Longint): WideString; overload; function ngettext(const singular, plural: AnsiString; Number: Longint): WideString; overload; function ngettext(const singular, plural: WideString; Number: Longint): WideString; overload; {$endif} procedure textdomain(const szDomain: string); function getcurrenttextdomain: string; procedure bindtextdomain(const szDomain, szDirectory: string); // Set language to use procedure UseLanguage(const LanguageCode: string); function GetCurrentLanguage: string; // Translates a component (form, frame etc.) to the currently selected language. // Put TranslateComponent(self) in the OnCreate event of all your forms. // See the manual for documentation on these functions type TTranslator = procedure(obj: TObject) of object; procedure TP_Ignore(AnObject: TObject; const Name: AnsiString); procedure TP_IgnoreClass(IgnClass: TClass); procedure TP_IgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString); procedure TP_GlobalIgnoreClass(IgnClass: TClass); procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString); procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator); procedure TranslateComponent(AnObject: TComponent; const TextDomain: string = ''); procedure RetranslateComponent(AnObject: TComponent; const TextDomain: string = ''); // Add more domains that resourcestrings can be extracted from. If a translation // is not found in the default domain, this domain will be searched, too. // This is useful for adding mo files for certain runtime libraries and 3rd // party component libraries procedure AddDomainForResourceString(const domain: string); procedure RemoveDomainForResourceString(const domain: string); {$ifndef CLR} // Unicode-enabled way to get resourcestrings, automatically translated // Use like this: ws := LoadResStringW(@NameOfResourceString); function LoadResString(ResStringRec: PResStringRec): WideString; function LoadResStringA(ResStringRec: PResStringRec): AnsiString; function LoadResStringW(ResStringRec: PResStringRec): WideString; {$endif} // This returns an empty string if not translated or translator name is not specified. function GetTranslatorNameAndEmail: WideString; (*****************************************************************************) (* *) (* ADVANCED FUNCTIONALITY *) (* *) (*****************************************************************************) const DefaultTextDomain = 'default'; var ExecutableFilename: string; // This is set to paramstr(0) or the name of the DLL you are creating. type EGnuGettext = class(Exception); EGGProgrammingError = class(EGnuGettext); EGGComponentError = class(EGnuGettext); EGGIOError = class(EGnuGettext); EGGAnsi2WideConvError = class(EGnuGettext); {$ifndef CLR} // This function will turn resourcestring hooks on or off, eventually with BPL file support. // Please do not activate BPL file support when the package is in design mode. const AutoCreateHooks = True; procedure HookIntoResourceStrings(Enabled: Boolean = True; SupportPackages: Boolean = False); {$endif} (*****************************************************************************) (* *) (* CLASS based implementation. *) (* Use TGnuGettextInstance to have more than one language *) (* in your application at the same time *) (* *) (*****************************************************************************) {$ifdef MSWINDOWS} {$ifndef DELPHI6OROLDER} {$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CODE OFF} {$WARN UNSAFE_CAST OFF} {$endif} {$endif} {$ifndef DELPHI7OROLDER} {$WARN SYMBOL_PLATFORM OFF} {$WARN SYMBOL_DEPRECATED OFF} {$endif} type TOnDebugLine = procedure(Sender: TObject; const Line: AnsiString; var Discard: Boolean) of object; // Set Discard to False if output should still go to ordinary debug log TGetPluralForm = function(Number: Longint): Integer; TDebugLogger = procedure(Line: AnsiString) of object; TMoFile = class // Don't use this class. It's for internal use. // Threadsafe. Only constructor and destructor are writing to memory private doswap: Boolean; public Users: Integer; // Reference count. If it reaches zero, this object should be destroyed. constructor Create(const Filename: string; Offset, Size: Int64); function gettext(const msgid: AnsiString; var Found: Boolean): AnsiString; // uses mo file property isSwappedArchitecture: Boolean read doswap; private N, O, T: Cardinal; // Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html StartIndex, StartStep: Integer; moMemory: array of byte; function CardinalInMem(Offset: Cardinal): Cardinal; end; TDomain = class // Don't use this class. It's for internal use. private Enabled: Boolean; vDirectory: string; procedure SetDirectory(const Value: string); public DebugLogger: TDebugLogger; Domain: string; property Directory: string read vDirectory write SetDirectory; constructor Create; destructor Destroy; override; // Set parameters procedure SetLanguageCode(const LangCode: string); procedure SetFilename(const Filename: string); // Bind this domain to a specific file // Get information procedure GetListOfLanguages(List: TStrings); function GetTranslationProperty(PropertyName: string): WideString; function gettext(const msgid: AnsiString): AnsiString; // uses mo file private moFile: TMoFile; SpecificFilename: string; curlang: string; OpenHasFailedBefore: Boolean; procedure OpenMoFile; procedure CloseMoFile; end; TExecutable = class procedure Execute; virtual; abstract; end; TGnuGettextInstance = class private fOnDebugLine: TOnDebugLine; {$ifndef CLR} CreatorThread: Cardinal; // Only this thread can use LoadResString {$endif} public Enabled: Boolean; // Set this to False to disable translations DesignTimeCodePage: Integer; // See MultiByteToWideChar() in Win32 API for documentation constructor Create; destructor Destroy; override; procedure UseLanguage(LanguageCode: string); procedure GetListOfLanguages(const domain: string; List: TStrings); // Puts List of language codes, for which there are translations in the specified domain, into List {$ifdef DELPHI5OROLDER} function gettext(const szMsgId: WideString): WideString; function ngettext(const singular, plural: WideString; Number: Longint): WideString; {$endif} {$ifndef DELPHI5OROLDER} function gettext(const szMsgId: AnsiString): WideString; overload; function gettext(const szMsgId: WideString): WideString; overload; function ngettext(const singular, plural: AnsiString; Number: Longint): WideString; overload; function ngettext(const singular, plural: WideString; Number: Longint): WideString; overload; {$endif} function GetCurrentLanguage: string; function GetTranslationProperty(const PropertyName: AnsiString): WideString; function GetTranslatorNameAndEmail: WideString; // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites() procedure TP_Ignore(AnObject: TObject; const Name: AnsiString); procedure TP_IgnoreClass(IgnClass: TClass); procedure TP_IgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString); procedure TP_GlobalIgnoreClass(IgnClass: TClass); procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString); procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator); procedure TranslateProperties(AnObject: TObject; TextDomain: string = ''); procedure TranslateComponent(AnObject: TComponent; const TextDomain: string = ''); procedure RetranslateComponent(AnObject: TComponent; const TextDomain: string = ''); // Multi-domain functions {$ifdef DELPHI5OROLDER} function dgettext(const szDomain: string; const szMsgId: WideString): WideString; function dngettext(const szDomain: string; singular, plural: WideString; Number: Longint): WideString; {$endif} {$ifndef DELPHI5OROLDER} function dgettext(const szDomain: string; const szMsgId: AnsiString): WideString; overload; function dgettext(const szDomain: string; const szMsgId: WideString): WideString; overload; function dngettext(const szDomain: string; singular, plural: AnsiString; Number: Longint): WideString; overload; function dngettext(const szDomain: string; singular, plural: WideString; Number: Longint): WideString; overload; {$endif} procedure textdomain(const szDomain: string); function getcurrenttextdomain: string; procedure bindtextdomain(const szDomain, szDirectory: string); procedure bindtextdomainToFile(const szDomain, Filename: string); // Also works with files embedded in exe file {$ifndef CLR} // Windows API functions function LoadResString(ResStringRec: PResStringRec): WideString; {$endif} // Output all log info to this file. This may only be called once. procedure DebugLogToFile(const Filename: string; append: Boolean = False); procedure DebugLogPause(PauseEnabled: Boolean); property OnDebugLine: TOnDebugLine read fOnDebugLine write fOnDebugLine; // If set, all debug output goes here // Conversion according to design-time character set function ansi2wide(const s: AnsiString): WideString; protected procedure TranslateStrings(sl: TStrings; const TextDomain: string); // Override these three, if you want to inherited from this class // to create a new class that handles other domain and language dependent // issues procedure WhenNewLanguage(const LanguageID: AnsiString); virtual; // Override to know when language changes procedure WhenNewDomain(const TextDomain: string); virtual; // Override to know when text domain changes. Directory is purely informational procedure WhenNewDomainDirectory(const TextDomain, Directory: string); virtual; // Override to know when any text domain's directory changes. It won't be called if a domain is fixed to a specific file. private curlang: string; curGetPluralForm: TGetPluralForm; curmsgdomain: string; savefileCS: TMultiReadExclusiveWriteSynchronizer; savefile: TextFile; SaveMemory: TStringList; DefaultDomainDirectory: string; DomainList: TStringList; // List of domain names. Objects are TDomain. TP_IgnoreList: TStringList; // Temporary List, reset each time TranslateProperties is called TP_ClassHandling: TObjectList; // Items are TClassMode. If a is derived from b, a comes first TP_GlobalClassHandling: TObjectList; // Items are TClassMode. If a is derived from b, a comes first TP_Retranslator: TExecutable; // Cast this to TTP_Retranslator DebugLogCS: TMultiReadExclusiveWriteSynchronizer; DebugLog: TStream; DebugLogOutputPaused: Boolean; function TP_CreateRetranslator: TExecutable; // Must be freed by caller! procedure DebugWriteln(Line: AnsiString); function Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain; // Translates a single property of an object {$ifndef CLR} procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo; TodoList: TStrings; const TextDomain: string); {$endif} end; var DefaultInstance: TGnuGettextInstance; implementation (**************************************************************************) // Some comments on the implementation: // This unit should be independent of other units where possible. // It should have a small footprint in any way. (**************************************************************************) // TMultiReadExclusiveWriteSynchronizer is used instead of TCriticalSection // because it makes this unit independent of the SyncObjs unit (**************************************************************************) {$ifdef CLR} uses System.Globalization, System.Diagnostics, System.Windows.Forms; {$endif} type TTP_RetranslatorItem = class obj: TObject; Propname: AnsiString; OldValue: WideString; end; TTP_Retranslator = class(TExecutable) TextDomain: string; Instance: TGnuGettextInstance; constructor Create; destructor Destroy; override; procedure Remember(obj: TObject; const PropName: AnsiString; OldValue: WideString); procedure Execute; override; private List: TList; end; TEmbeddedFileInfo = class Offset, Size: Int64; end; TFileLocator = class // This class finds files even when embedded inside executable constructor Create; destructor Destroy; override; procedure Analyze; // List files embedded inside executable function FileExists(Filename: string): Boolean; function GetMoFile(Filename: string; DebugLogger: TDebugLogger): TMoFile; procedure ReleaseMoFile(var moFile: TMoFile); private BaseDirectory: string; FileList: TStringList; //Objects are TEmbeddedFileInfo. Filenames are relative to .exe file MoFilesCS: TMultiReadExclusiveWriteSynchronizer; MoFiles: TStringList; // Objects are filenames+Offset, objects are TMoFile function ReadInt64(str: TStream): Int64; end; TGnuGettextComponentMarker = class(TComponent) public LastLanguage: AnsiString; Retranslator: TExecutable; destructor Destroy; override; end; TClassMode = class HClass: TClass; SpecialHandler: TTranslator; PropertiesToIgnore: TStringList; // This is ignored if Handler is set constructor Create; destructor Destroy; override; end; TRStrinfo = record strlength, stroffset: Cardinal; end; TStrInfoArr = array[0..10000000] of TRStrinfo; PStrInfoArr = ^TStrInfoArr; TCharArray5 = array[0..4] of ansichar; {$ifndef CLR} THook = class // Replaces a runtime library procedure with a custom procedure public constructor Create(OldProcedure, NewProcedure: Pointer; FollowJump: Boolean = False); destructor Destroy; override; // Restores unhooked state procedure Reset(FollowJump: Boolean = False); // Disables and picks up patch points again procedure Disable; procedure Enable; private OldProc, NewProc: Pointer; Patch: TCharArray5; Original: TCharArray5; PatchPosition: PChar; procedure Shutdown; // Same as destroy, except that object is not destroyed end; {$endif} var // System information Win32PlatformIsUnicode: Boolean = False; // Information about files embedded inside .exe file FileLocator: TFileLocator; ResourceStringDomainListCS: TMultiReadExclusiveWriteSynchronizer; ResourceStringDomainList: TStringList; {$ifndef CLR} // Hooks into runtime library functions HookLoadResString: THook; HookLoadStr: THook; HookFmtLoadStr: THook; {$endif} function Utf8EncodeChar(wc: WideChar): AnsiString; var w: Word; begin w := Ord(wc); case w of 0..$7F: Result := AnsiChar(w); $80..$3FF: Result := AnsiChar($C0 + (w shr 6)) + AnsiChar($80 + (w and $3F)); $400..$FFFF: Result := AnsiChar($E0 +(w shr 12))+ AnsiChar($80 +((w shr 6) and $3F)) + AnsiChar($80 +(w and $3F)); else raise Exception.Create('Huh, what happened here?'); end; end; function Utf8Encode(ws: WideString): AnsiString; var i: Integer; begin Result := ''; for i := 1 to Length(ws) do Result := Result + Utf8EncodeChar(ws[i]); end; // If dummychar is #0, it will raise Exception when an error occurs function Utf8Decode(s: AnsiString; dummychar: WideChar = #0): WideString; var i: Integer; b: Byte; c: Cardinal; mode: 0..5; begin Result := ''; mode := 0; c := 0; for i := 1 to Length(s) do begin b := Ord(s[i]); if mode = 0 then begin case b of 0..$7F: Result := Result + WideChar(b); $80..$BF, $FF: begin if dummychar = #0 then raise Exception.Create ('Invalid byte sequence encountered in utf-8 string') else Result := Result + dummychar; mode := 0; end; $C0..$DF: begin c := (b and $1F); mode := 1; end; $E0..$EF: begin c := (b and $F); mode := 2; end; $F0..$F7: begin c := (b and $7); mode := 3; end; $F8..$FB: begin c := (b and $3); mode := 4; end; $FC..$FE: begin c := (b and $1); mode := 5; end; end; end else begin case b of $00..$7F, $C0..$FF: if dummychar = #0 then raise Exception.Create('Invalid byte sequence encountered in utf-8 string') else Result:=Result+dummychar; $80..$BF: begin c := c * $40 + (b and $3F); Dec(mode); if mode = 0 then begin if c <= $FFFF then Result := Result + WideChar(c) else begin if dummychar = #0 then raise Exception.Create('Utf-8 string contained unicode character larger than $FFFF. This is not supported.') else Result := Result + dummychar; end; end; end; else raise Exception.Create ('Huh? More than 256 different values in a byte?'); end; end; end; if mode <> 0 then begin if dummychar = #0 then raise Exception.Create ('Utf-8 string terminated unexpectedly in the middle of a multibyte sequence') else Result := Result + dummychar; end; end; function StripCR(s: AnsiString): AnsiString; var i: Integer; begin i := 1; while i <= Length(s) do begin if s[i] = #13 then Delete(s, i, 1) else Inc(i); end; Result := s; end; function GGGetEnvironmentVariable(const Name: string): string; {$ifdef DELPHI5OROLDER} var Len: DWORD; {$endif} begin {$ifdef DELPHI5OROLDER} SetLength(Result, 1024); Len := Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), 1024); SetLength(Result, Len); if Len > 1024 then if Windows.GetEnvironmentVariable(PChar(Name),PChar(Result), Len) <> Len then Result := 'ERROR: Windows environment changes concurrently with this application'; {$endif} {$ifndef DELPHI5OROLDER} Result := SysUtils.GetEnvironmentVariable(Name); {$endif} end; function StartsWith(const Text, StartText: string; CaseInsensitive: Boolean = False): Boolean; var Len, i: Integer; begin Result := False; Len := Length(StartText); if Len > Length(Text) then Exit; if CaseInsensitive then begin for i := 1 to Len do if UpCase(Text[i]) <> UpCase(StartText[i]) then Exit; end else begin for i := 1 to Len do if Text[i] <> StartText[i] then Exit; end; Result := True; end; function EndsWith(const Text, EndText: string; CaseInsensitive: Boolean): Boolean; var Len, i, x: Integer; begin Result := False; Len := Length(EndText); x := Length(Text); if Len > x then Exit; if CaseInsensitive then begin for i := Len downto 1 do if UpCase(Text[x]) <> UpCase(EndText[i]) then Exit else Dec(x); end else begin for i := Len downto 1 do if Text[x] <> EndText[i] then Exit else Dec(x); end; Result := True; end; function IsInDirStrOf(const Filename, Dir: string): Boolean; begin Result := StartsWith(Filename, Dir, {$ifdef MSWINDOWS}True{$else}False{$endif}); end; function EndsWithFilename(const Path, Filename: string): Boolean; begin Result := EndsWith(Path, Filename, {$ifdef MSWINDOWS}True{$else}False{$endif}); end; {$ifdef CLR} function TrimCopy(const S: string; Index, Count: Integer): string; overload; var Len, StartIndex, EndIndex: Integer; begin Result := ''; Len := Length(S); if Index <= 0 then Index := 1; if Count > Len then Count := Len; if (Count > 0) and (Len > 0) then begin StartIndex := Index; while (StartIndex <= Len) and (S[StartIndex] <= #32) do Inc(StartIndex); Dec(Count, StartIndex - Index); EndIndex := StartIndex + Count - 1; if EndIndex > Len then begin Dec(Count, EndIndex - Len); EndIndex := Len; end; while (EndIndex > 0) and (S[EndIndex] <= #32) do begin Dec(EndIndex); Dec(Count); end; if EndIndex >= StartIndex then Result := Copy(S, StartIndex, Count); end; end; {$endif} function TrimCopy(const S: AnsiString; Index, Count: Integer): AnsiString; overload; var Len, StartIndex, EndIndex: Integer; begin Result := ''; Len := Length(S); if Index <= 0 then Index := 1; if Count > Len then Count := Len; if (Count > 0) and (Len > 0) then begin StartIndex := Index; while (StartIndex <= Len) and (S[StartIndex] <= #32) do Inc(StartIndex); Dec(Count, StartIndex - Index); EndIndex := StartIndex + Count - 1; if EndIndex > Len then begin Dec(Count, EndIndex - Len); EndIndex := Len; end; while (EndIndex > 0) and (S[EndIndex] <= #32) do begin Dec(EndIndex); Dec(Count); end; if EndIndex >= StartIndex then {$ifdef CLR} Result := Copy(S, StartIndex, Count); {$else} SetString(Result, PChar(Pointer(S)) + StartIndex - 1, Count); {$endif CLR} end; end; function LF2LineBreakA(s: AnsiString): AnsiString; {$ifdef MSWINDOWS} var i: Integer; {$endif} begin {$ifdef MSWINDOWS} Assert(sLinebreak = #13#10); i := 1; while i <= Length(s) do begin if (s[i] = #10) and (i > 1) and (s[i - 1] <> #13) then begin Insert(#13, s, i); Inc(i, 2); end else Inc(i); end; {$endif} Result := s; end; function IsWriteProp(Info: PPropInfo): Boolean; begin {$ifndef CLR} Result := Assigned(Info) and (Info^.SetProc <> nil); {$else} Result := Assigned(Info) and CanWrite(Info); {$endif} end; { not used } { function string2csyntax(const s: AnsiString): AnsiString; // Converts a string to the syntax that is used in .po files var i: Integer; c: AnsiChar; begin Result := ''; for i := 1 to Length(s) do begin c := s[i]; case c of #32..#33, #35..#255: Result := Result + c; #13: Result := Result + '\r'; #10: Result := Result + '\n"'#13#10'"'; #34: Result := Result + '\"'; else Result := Result + '\0x' + IntToHex(Ord(c), 2); end; end; Result := '"' + Result + '"'; end; } {$ifdef DELPHI5OROLDER} function GetPropList(AObject: TObject; out PropList: PPropList): Integer; var Data: PTypeData; begin Result := 0; PropList := nil; if (AObject.ClassInfo <> nil) then begin Data := GetTypeData(AObject.ClassInfo); Result := Data^.PropCount; if Result > 0 then begin GetMem(PropList, Result * SizeOf(PPropInfo)); GetPropInfos(AObject.ClassInfo, PropList); end; end; end; {$endif} function ResourceStringGettext(const MsgId: WideString): WideString; var i: Integer; begin if (MsgId = '') or (ResourceStringDomainListCS = nil) then begin // This only happens during very complicated program startups that fail // or when MsgId='' Result := MsgId; Exit; end; ResourceStringDomainListCS.BeginRead; try for i := 0 to ResourceStringDomainList.Count - 1 do begin Result := dgettext(ResourceStringDomainList.Strings[i], MsgId); if Result <> MsgId then Break; end; finally ResourceStringDomainListCS.EndRead; end; end; {$ifndef DELPHI5OROLDER} function gettext(const szMsgId: AnsiString): WideString; begin Result := DefaultInstance.gettext(szMsgId); end; {$endif} function gettext(const szMsgId: WideString): WideString; begin Result := DefaultInstance.gettext(szMsgId); end; {$ifndef DELPHI5OROLDER} function _(const szMsgId: AnsiString): WideString; begin Result := DefaultInstance.gettext(szMsgId); end; {$endif} function _(const szMsgId: WideString): WideString; begin Result := DefaultInstance.gettext(szMsgId); end; {$ifndef DELPHI5OROLDER} function dgettext(const szDomain: string; const szMsgId: AnsiString): WideString; begin Result := DefaultInstance.dgettext(szDomain, szMsgId); end; {$endif} function dgettext(const szDomain: string; const szMsgId: WideString): WideString; begin Result := DefaultInstance.dgettext(szDomain, szMsgId); end; {$ifndef DELPHI5OROLDER} function dngettext(const szDomain: string; const singular, plural: AnsiString; Number: Longint): WideString; begin Result := DefaultInstance.dngettext(szDomain, singular, plural, Number); end; {$endif} function dngettext(const szDomain: string; const singular, plural: WideString; Number: Longint): WideString; begin Result := DefaultInstance.dngettext(szDomain, singular, plural, Number); end; {$ifndef DELPHI5OROLDER} function ngettext(const singular, plural: AnsiString; Number: Longint): WideString; begin Result := DefaultInstance.ngettext(singular, plural, Number); end; {$endif} function ngettext(const singular, plural: WideString; Number: Longint): WideString; begin Result := DefaultInstance.ngettext(singular, plural, Number); end; procedure textdomain(const szDomain: string); begin DefaultInstance.textdomain(szDomain); end; {not used} { procedure SetGettextEnabled(Enabled: Boolean); begin DefaultInstance.Enabled := Enabled; end; } function getcurrenttextdomain: string; begin Result := DefaultInstance.getcurrenttextdomain; end; procedure bindtextdomain(const szDomain, szDirectory: string); begin DefaultInstance.bindtextdomain(szDomain, szDirectory); end; procedure TP_Ignore(AnObject: TObject; const Name: AnsiString); begin DefaultInstance.TP_Ignore(AnObject, Name); end; procedure TP_GlobalIgnoreClass(IgnClass: TClass); begin DefaultInstance.TP_GlobalIgnoreClass(IgnClass); end; procedure TP_IgnoreClass(IgnClass: TClass); begin DefaultInstance.TP_IgnoreClass(IgnClass); end; procedure TP_IgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString); begin DefaultInstance.TP_IgnoreClassProperty(IgnClass, PropertyName); end; procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString); begin DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass, PropertyName); end; procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator); begin DefaultInstance.TP_GlobalHandleClass(HClass, Handler); end; {not used} { procedure TranslateProperties(AnObject: TObject; TextDomain: AnsiString = ''); begin DefaultInstance.TranslateProperties(AnObject, TextDomain); end; } procedure TranslateComponent(AnObject: TComponent; const TextDomain: string = ''); begin DefaultInstance.TranslateComponent(AnObject, TextDomain); end; procedure RetranslateComponent(AnObject: TComponent; const TextDomain: string = ''); begin DefaultInstance.RetranslateComponent(AnObject, TextDomain); end; {$ifdef MSWINDOWS} // These constants are only used in Windows 95 // Thanks to Frank Andreas de Groot for this table const IDAfrikaans = $0436; IDAlbanian = $041C; IDArabicAlgeria = $1401; IDArabicBahrain = $3C01; IDArabicEgypt = $0C01; IDArabicIraq = $0801; IDArabicJordan = $2C01; IDArabicKuwait = $3401; IDArabicLebanon = $3001; IDArabicLibya = $1001; IDArabicMorocco = $1801; IDArabicOman = $2001; IDArabicQatar = $4001; IDArabic = $0401; IDArabicSyria = $2801; IDArabicTunisia = $1C01; IDArabicUAE = $3801; IDArabicYemen = $2401; IDArmenian = $042B; IDAssamese = $044D; IDAzeriCyrillic = $082C; IDAzeriLatin = $042C; IDBasque = $042D; IDByelorussian = $0423; IDBengali = $0445; IDBulgarian = $0402; IDBurmese = $0455; IDCatalan = $0403; IDChineseHongKong = $0C04; IDChineseMacao = $1404; IDSimplifiedChinese = $0804; IDChineseSingapore = $1004; IDTraditionalChinese = $0404; IDCroatian = $041A; IDCzech = $0405; IDDanish = $0406; IDBelgianDutch = $0813; IDDutch = $0413; IDEnglishAUS = $0C09; IDEnglishBelize = $2809; IDEnglishCanadian = $1009; IDEnglishCaribbean = $2409; IDEnglishIreland = $1809; IDEnglishJamaica = $2009; IDEnglishNewZealand = $1409; IDEnglishPhilippines = $3409; IDEnglishSouthAfrica = $1C09; IDEnglishTrinidad = $2C09; IDEnglishUK = $0809; IDEnglishUS = $0409; IDEnglishZimbabwe = $3009; IDEstonian = $0425; IDFaeroese = $0438; IDFarsi = $0429; IDFinnish = $040B; IDBelgianFrench = $080C; IDFrenchCameroon = $2C0C; IDFrenchCanadian = $0C0C; IDFrenchCotedIvoire = $300C; IDFrench = $040C; IDFrenchLuxembourg = $140C; IDFrenchMali = $340C; IDFrenchMonaco = $180C; IDFrenchReunion = $200C; IDFrenchSenegal = $280C; IDSwissFrench = $100C; IDFrenchWestIndies = $1C0C; IDFrenchZaire = $240C; IDFrisianNetherlands = $0462; IDGaelicIreland = $083C; IDGaelicScotland = $043C; IDGalician = $0456; IDGeorgian = $0437; IDGermanAustria = $0C07; IDGerman = $0407; IDGermanLiechtenstein = $1407; IDGermanLuxembourg = $1007; IDSwissGerman = $0807; IDGreek = $0408; IDGujarati = $0447; IDHebrew = $040D; IDHindi = $0439; IDHungarian = $040E; IDIcelandic = $040F; IDIndonesian = $0421; IDItalian = $0410; IDSwissItalian = $0810; IDJapanese = $0411; IDKannada = $044B; IDKashmiri = $0460; IDKazakh = $043F; IDKhmer = $0453; IDKirghiz = $0440; IDKonkani = $0457; IDKorean = $0412; IDLao = $0454; IDLatvian = $0426; IDLithuanian = $0427; IDMacedonian = $042F; IDMalaysian = $043E; IDMalayBruneiDarussalam = $083E; IDMalayalam = $044C; IDMaltese = $043A; IDManipuri = $0458; IDMarathi = $044E; IDMongolian = $0450; IDNepali = $0461; IDNorwegianBokmol = $0414; IDNorwegianNynorsk = $0814; IDOriya = $0448; IDPolish = $0415; IDBrazilianPortuguese = $0416; IDPortuguese = $0816; IDPunjabi = $0446; IDRhaetoRomanic = $0417; IDRomanianMoldova = $0818; IDRomanian = $0418; IDRussianMoldova = $0819; IDRussian = $0419; IDSamiLappish = $043B; IDSanskrit = $044F; IDSerbianCyrillic = $0C1A; IDSerbianLatin = $081A; IDSesotho = $0430; IDSindhi = $0459; IDSlovak = $041B; IDSlovenian = $0424; IDSorbian = $042E; IDSpanishArgentina = $2C0A; IDSpanishBolivia = $400A; IDSpanishChile = $340A; IDSpanishColombia = $240A; IDSpanishCostaRica = $140A; IDSpanishDominicanRepublic = $1C0A; IDSpanishEcuador = $300A; IDSpanishElSalvador = $440A; IDSpanishGuatemala = $100A; IDSpanishHonduras = $480A; IDMexicanSpanish = $080A; IDSpanishNicaragua = $4C0A; IDSpanishPanama = $180A; IDSpanishParaguay = $3C0A; IDSpanishPeru = $280A; IDSpanishPuertoRico = $500A; IDSpanishModernSort = $0C0A; IDSpanish = $040A; IDSpanishUruguay = $380A; IDSpanishVenezuela = $200A; IDSutu = $0430; IDSwahili = $0441; IDSwedishFinland = $081D; IDSwedish = $041D; IDTajik = $0428; IDTamil = $0449; IDTatar = $0444; IDTelugu = $044A; IDThai = $041E; IDTibetan = $0451; IDTsonga = $0431; IDTswana = $0432; IDTurkish = $041F; IDTurkmen = $0442; IDUkrainian = $0422; IDUrdu = $0420; IDUzbekCyrillic = $0843; IDUzbekLatin = $0443; IDVenda = $0433; IDVietnamese = $042A; IDWelsh = $0452; IDXhosa = $0434; IDZulu = $0435; function GetOSLanguage: AnsiString; var langid: Cardinal; LangCode: AnsiString; CountryName: array[0..4] of AnsiChar; LanguageName: array[0..4] of AnsiChar; works: Boolean; begin // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero works := 3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName)); works := works and (3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName, SizeOf(CountryName))); if works then begin // Windows 98, Me, NT4, 2000, XP and newer LangCode := PChar(@LanguageName[0]) + '_' + PChar(@CountryName[0]); end else begin // This part should only happen on Windows 95. langid := GetThreadLocale; case langid of IDBelgianDutch: LangCode := 'nl_BE'; IDBelgianFrench: LangCode := 'fr_BE'; IDBrazilianPortuguese: LangCode := 'pt_BR'; IDDanish: LangCode := 'da_DK'; IDDutch: LangCode := 'nl_NL'; IDEnglishUK: LangCode := 'en_GB'; IDEnglishUS: LangCode := 'en_US'; IDFinnish: LangCode := 'fi_FI'; IDFrench: LangCode := 'fr_FR'; IDFrenchCanadian: LangCode := 'fr_CA'; IDGerman: LangCode := 'de_DE'; IDGermanLuxembourg: LangCode := 'de_LU'; IDGreek: LangCode := 'gr_GR'; IDIcelandic: LangCode := 'is_IS'; IDItalian: LangCode := 'it_IT'; IDKorean: LangCode := 'ko_KO'; IDNorwegianBokmol: LangCode := 'nb_NO'; IDNorwegianNynorsk: LangCode := 'nn_NO'; IDPolish: LangCode := 'pl_PL'; IDPortuguese: LangCode := 'pt_PT'; IDRussian: LangCode := 'ru_RU'; IDSpanish, IDSpanishModernSort: LangCode := 'es_ES'; IDSwedish: LangCode := 'sv_SE'; IDSwedishFinland: LangCode := 'sv_FI'; else LangCode := 'C'; end; end; Result := LangCode; end; {$endif} {$ifdef CLR} function GetOSLanguage: string; var p: Integer; begin Result := CultureInfo.get_CurrentCulture.ToString; p := Pos('-', Result); if p <> 0 then Result[p] := '_'; end; {$endif} {$ifdef LINUX} function GetOSLanguage: AnsiString; begin Result := ''; end; {$endif} {$ifndef CLR} function LoadResStringA(ResStringRec: PResStringRec): string; begin if DefaultInstance <> nil then Result := DefaultInstance.LoadResString(ResStringRec) else Result := PChar(ResStringRec.Identifier); end; {$endif} function GetTranslatorNameAndEmail: WideString; begin Result := DefaultInstance.GetTranslatorNameAndEmail; end; procedure UseLanguage(const LanguageCode: string); begin DefaultInstance.UseLanguage(LanguageCode); end; {$ifndef CLR} type PStrData = ^TStrData; TStrData = record Ident: Integer; Str: AnsiString; end; function SysUtilsEnumStringModules(Instance: Longint; Data: Pointer): Boolean; {$ifdef MSWINDOWS} var Buffer: array[0..1023] of AnsiChar; begin with PStrData(Data)^ do begin SetString(Str, Buffer, LoadString(Instance, Ident, Buffer, SizeOf(Buffer))); Result := Str = ''; end; end; {$endif} {$ifdef LINUX} var rs: TResStringRec; Module: HModule; begin Module := Instance; rs.Module := @Module; with PStrData(Data)^ do begin rs.Identifier := Ident; Str := System.LoadResString(@rs); Result := Str = ''; end; end; {$endif} function SysUtilsFindStringResource(Ident: Integer): AnsiString; var StrData: TStrData; begin StrData.Ident := Ident; StrData.Str := ''; EnumResourceModules(SysUtilsEnumStringModules, @StrData); Result := StrData.Str; end; function SysUtilsLoadStr(Ident: Integer): AnsiString; begin {$ifdef DXGETTEXTDEBUG} DefaultInstance.DebugWriteln('SysUtils.LoadRes(' + IntToStr(ident) + ') called'); {$endif} Result := ResourceStringGettext(SysUtilsFindStringResource(Ident)); end; function SysUtilsFmtLoadStr(Ident: Integer; const Args: array of const): AnsiString; begin {$ifdef DXGETTEXTDEBUG} DefaultInstance.DebugWriteln('SysUtils.FmtLoadRes(' + IntToStr(ident) + ', Args) called'); {$endif} FmtStr(Result, SysUtilsFindStringResource(Ident), Args); Result := ResourceStringGettext(Result); end; function LoadResString(ResStringRec: PResStringRec): WideString; begin Result := DefaultInstance.LoadResString(ResStringRec); end; function LoadResStringW(ResStringRec: PResStringRec): WideString; begin Result := DefaultInstance.LoadResString(ResStringRec); end; {$endif} function GetCurrentLanguage: string; begin Result := DefaultInstance.GetCurrentLanguage; end; { TDomain } procedure TDomain.CloseMoFile; begin if moFile <> nil then FileLocator.ReleaseMoFile(moFile); OpenHasFailedBefore := False; end; destructor TDomain.Destroy; begin CloseMoFile; inherited Destroy; end; {$ifdef MSWINDOWS} {not used} { function GetLastWinError: AnsiString; var ErrCode: Cardinal; begin SetLength(Result, 2000); ErrCode := GetLastError(); Windows.FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrCode, 0, PChar(Result), 2000, nil); Result := StrPas(PChar(Result)); end; } {$endif} procedure TDomain.OpenMoFile; const ErrorMsg = 'The translation for the language code %s (in %s) does not have ' + 'charset=utf-8 in its Content-Type. Translations are turned off.'; var Filename: string; begin // Check if it is already open if moFile <> nil then Exit; // Check if it has been attempted to open the file before if OpenHasFailedBefore then Exit; if SpecificFilename <> '' then Filename := SpecificFilename else begin Filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; if (not FileLocator.FileExists(Filename)) and (not FileExists(Filename)) then Filename := Directory + Copy(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; end; if (not FileLocator.FileExists(Filename)) and (not FileExists(Filename)) then begin OpenHasFailedBefore := True; Exit; end; moFile := FileLocator.GetMoFile(Filename, DebugLogger); {$ifdef DXGETTEXTDEBUG} if moFile.isSwappedArchitecture then DebugLogger('.mo file is swapped (comes from another CPU architecture)'); {$endif} // Check, that the contents of the file is utf-8 if Pos('CHARSET=UTF-8', UpperCase(GetTranslationProperty('Content-Type'))) = 0 then begin CloseMoFile; {$ifdef DXGETTEXTDEBUG} DebugLogger(Format(ErrorMsg, [curlang, Filename])); {$endif} {$ifdef MSWINDOWS} MessageBox(0, PChar(Format(ErrorMsg, [curlang, Filename])), 'Localization problem', MB_OK); {$endif} {$ifdef CLR} MessageBox.show(Format(ErrorMsg, [curlang, Filename])); {$endif} {$ifdef LINUX} WriteLn(stderr, Format(ErrorMsg, [curlang, Filename])); {$endif} Enabled := False; end; end; function TDomain.GetTranslationProperty(PropertyName: string): WideString; var sl: TStringList; i, PropLen: Integer; s: string; begin PropertyName := PropertyName + ': '; PropLen := Length(PropertyName) + 1; sl := TStringList.Create; try {$ifdef CLR} s := gettext(''); if Pos(sLineBreak, s) = 0 then sl.LineBreak := #10 else sl.LineBreak := sLineBreak; sl.Text := s; {$else} sl.Text := Utf8Encode(gettext('')); {$endif} for i := 0 to sl.Count - 1 do begin s := sl.Strings[i]; if StartsWith(s, PropertyName, True) then begin {$ifdef CLR} Result := TrimCopy(s, PropLen, MaxInt); {$else} Result := Utf8Decode(TrimCopy(s, PropLen, MaxInt)); {$endif} {$ifdef DXGETTEXTDEBUG} DebugLogger('GetTranslationProperty(' + PropertyName + ') returns ''' + Result + '''.'); {$endif} Exit; end; end; finally sl.Free; end; Result := ''; {$ifdef DXGETTEXTDEBUG} DebugLogger('GetTranslationProperty(' + PropertyName + ') did not find any value. An empty string is returned.'); {$endif} end; procedure TDomain.SetDirectory(const Value: string); begin vDirectory := IncludeTrailingPathDelimiter(Value); SpecificFilename := ''; CloseMoFile; end; procedure AddDomainForResourceString(const domain: string); begin {$ifdef DXGETTEXTDEBUG} DefaultInstance.DebugWriteln('Extra domain for resourcestring: ' + domain); {$endif} ResourceStringDomainListCS.BeginWrite; try if ResourceStringDomainList.IndexOf(domain) = -1 then ResourceStringDomainList.Add(domain); finally ResourceStringDomainListCS.EndWrite; end; end; procedure RemoveDomainForResourceString(const domain: string); var i: Integer; begin {$ifdef DXGETTEXTDEBUG} DefaultInstance.DebugWriteln('Remove domain for resourcestring: ' + domain); {$endif} ResourceStringDomainListCS.BeginWrite; try i := ResourceStringDomainList.IndexOf(domain); if i <> -1 then ResourceStringDomainList.Delete(i); finally ResourceStringDomainListCS.EndWrite; end; end; procedure TDomain.SetLanguageCode(const LangCode: string); begin CloseMoFile; curlang := LangCode; end; function GetPluralForm2EN(Number: Integer): Integer; begin Number := abs(Number); if Number = 1 then Result := 0 else Result := 1; end; function GetPluralForm1(Number: Integer): Integer; begin Result := 0; end; function GetPluralForm2FR(Number: Integer): Integer; begin Number := abs(Number); if (Number = 1) or (Number = 0) then Result := 0 else Result := 1; end; function GetPluralForm3LV(Number: Integer): Integer; begin Number := abs(Number); if (Number mod 10 = 1) and (Number mod 100 <> 11) then Result := 0 else if Number <> 0 then Result := 1 else Result := 2; end; function GetPluralForm3GA(Number: Integer): Integer; begin Number := abs(Number); if Number = 1 then Result := 0 else if Number = 2 then Result := 1 else Result := 2; end; function GetPluralForm3LT(Number: Integer): Integer; var n1, n2: Byte; begin Number := abs(Number); n1 := Number mod 10; n2 := Number mod 100; if (n1 = 1) and (n2 <> 11) then Result := 0 else if (n1 >= 2) and ((n2 < 10) or (n2 >= 20)) then Result := 1 else Result := 2; end; function GetPluralForm3PL(Number: Integer): Integer; var n1, n2: Byte; begin Number := abs(Number); n1 := Number mod 10; n2 := Number mod 100; if n1 = 1 then Result := 0 else if (n1 >= 2) and (n1 <= 4) and ((n2 < 10) or (n2 >= 20)) then Result := 1 else Result := 2; end; function GetPluralForm3RU(Number: Integer): Integer; var n1, n2: Byte; begin Number := abs(Number); n1 := Number mod 10; n2 := Number mod 100; if (n1 = 1) and (n2 <> 11) then Result := 0 else if (n1 >= 2) and (n1 <= 4) and ((n2 < 10) or (n2 >= 20)) then Result := 1 else Result := 2; end; function GetPluralForm4SL(Number: Integer): Integer; var n2: Byte; begin Number := abs(Number); n2 := Number mod 100; if n2 = 1 then Result := 0 else if n2 = 2 then Result := 1 else if (n2 = 3) or (n2 = 4) then Result := 2 else Result := 3; end; procedure TDomain.GetListOfLanguages(List: TStrings); var sr: TSearchRec; more: Boolean; Filename, Path, LangCode: AnsiString; i, j: Integer; begin List.Clear; // Iterate through filesystem more := FindFirst(Directory + '*', faAnyFile, sr) = 0; try while more do begin if (sr.Attr and faDirectory <> 0) and (sr.Name <> '.') and (sr.Name <> '..') then begin Filename := Directory + sr.Name + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; if FileExists(Filename) then begin LangCode := LowerCase(sr.Name); if List.IndexOf(LangCode) = -1 then List.Add(LangCode); end; end; more := FindNext(sr) = 0; end; finally FindClose(sr); end; // Iterate through embedded files for i := 0 to FileLocator.FileList.Count - 1 do begin Filename := FileLocator.BaseDirectory + FileLocator.FileList.Strings[i]; if IsInDirStrOf(Filename, Directory) then begin j := Length(Directory); Path := PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; if EndsWithFilename(Filename, Path) then begin LangCode := LowerCase(Copy(Filename, j + 1, Length(Filename) - Length(Path) - j)); if List.IndexOf(LangCode) = -1 then List.Add(LangCode); end; end; end; end; procedure TDomain.SetFilename(const Filename: string); begin CloseMoFile; vDirectory := ''; SpecificFilename := Filename; end; function TDomain.gettext(const msgid: AnsiString): AnsiString; var found: Boolean; begin if not Enabled then begin Result := msgid; Exit; end; if (moFile = nil) and (not OpenHasFailedBefore) then OpenMoFile; if moFile = nil then begin {$ifdef DXGETTEXTDEBUG} DebugLogger('.mo file is not open. Not translating "' + msgid + '"'); {$endif} Result := msgid; end else begin Result := moFile.gettext(msgid, found); {$ifdef DXGETTEXTDEBUG} if found then DebugLogger('Found in .mo (' + Domain + '): "' + Utf8Encode(msgid) + '"->"' + Utf8Encode(Result) + '"') else DebugLogger('Translation not found in .mo file (' + Domain + ') : "' + Utf8Encode(msgid) + '"'); {$endif} end; end; constructor TDomain.Create; begin inherited Create; Enabled := True; end; { TGnuGettextInstance } procedure TGnuGettextInstance.bindtextdomain(const szDomain, szDirectory: string); var dir: string; begin dir := IncludeTrailingPathDelimiter(szDirectory); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Text domain "' + szDomain + '" is now located at "' + dir + '"'); {$endif} getdomain(szDomain, DefaultDomainDirectory, CurLang).Directory := dir; WhenNewDomainDirectory(szDomain, szDirectory); end; constructor TGnuGettextInstance.Create; begin inherited Create; {$ifndef CLR} CreatorThread := GetCurrentThreadId; { TODO : Do something about Thread handling if resourcestrings are enabled } {$endif} {$ifdef MSWINDOWS} DesignTimeCodePage := CP_ACP; {$endif} {$ifdef DXGETTEXTDEBUG} DebugLogCS := TMultiReadExclusiveWriteSynchronizer.Create; DebugLog := TMemoryStream.Create; DebugWriteln('Debug log started ' + DateTimeToStr(Now)); DebugWriteln(''); {$endif} curGetPluralForm := GetPluralForm2EN; Enabled := True; curmsgdomain := DefaultTextDomain; savefileCS := TMultiReadExclusiveWriteSynchronizer.Create; DomainList := TStringList.Create; TP_IgnoreList := TStringList.Create; TP_IgnoreList.Sorted := True; TP_GlobalClassHandling := TObjectList.Create; TP_ClassHandling := TObjectList.Create; // Set some settings DefaultDomainDirectory := IncludeTrailingPathDelimiter(extractfilepath(ExecutableFilename)) + 'locale'; UseLanguage(''); bindtextdomain(DefaultTextDomain, DefaultDomainDirectory); TextDomain(DefaultTextDomain); // Add default properties to ignore TP_GlobalIgnoreClassProperty(TComponent, 'Name'); TP_GlobalIgnoreClassProperty(TCollection, 'PropName'); end; destructor TGnuGettextInstance.Destroy; var I: Integer; begin if SaveMemory <> nil then begin savefileCS.BeginWrite; try CloseFile(savefile); finally savefileCS.EndWrite; end; FreeAndNil(SaveMemory); end; FreeAndNil(savefileCS); FreeAndNil(TP_IgnoreList); FreeAndNil(TP_GlobalClassHandling); FreeAndNil(TP_ClassHandling); for I := 0 to DomainList.Count - 1 do DomainList.Objects[I].Free; FreeAndNil(DomainList); {$ifdef DXGETTEXTDEBUG} FreeAndNil(DebugLog); FreeAndNil(DebugLogCS); {$endif} inherited Destroy; end; {$ifndef DELPHI5OROLDER} function TGnuGettextInstance.dgettext(const szDomain: string; const szMsgId: AnsiString): WideString; begin Result := dgettext(szDomain, ansi2wide(szMsgId)); end; {$endif} function TGnuGettextInstance.dgettext(const szDomain: string; const szMsgId: WideString): WideString; begin if not Enabled then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('Translation has been disabled. Text is not being translated: ' + szMsgid); {$endif} Result := szMsgId; end else begin Result := Utf8Decode(LF2LineBreakA(getdomain(szDomain, DefaultDomainDirectory, CurLang).gettext(StripCR(Utf8Encode(szMsgId))))); {$ifdef DXGETTEXTDEBUG} if (szMsgId <> '') and (Result = '') then DebugWriteln(Format('Error: Translation of %s was an empty string. This may never occur.', [szMsgId])); {$endif} end; end; function TGnuGettextInstance.GetCurrentLanguage: string; begin Result := curlang; end; function TGnuGettextInstance.getcurrenttextdomain: string; begin Result := curmsgdomain; end; {$ifndef DELPHI5OROLDER} function TGnuGettextInstance.gettext(const szMsgId: AnsiString): WideString; begin Result := dgettext(curmsgdomain, szMsgId); end; {$endif} function TGnuGettextInstance.gettext(const szMsgId: WideString): WideString; begin Result := dgettext(curmsgdomain, szMsgId); end; procedure TGnuGettextInstance.textdomain(const szDomain: string); begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('Changed text domain to "' + szDomain + '"'); {$endif} curmsgdomain := szDomain; WhenNewDomain(szDomain); end; function TGnuGettextInstance.TP_CreateRetranslator: TExecutable; var ttpr: TTP_Retranslator; begin ttpr := TTP_Retranslator.Create; ttpr.Instance := self; TP_Retranslator := ttpr; Result := ttpr; {$ifdef DXGETTEXTDEBUG} DebugWriteln('A retranslator was created.'); {$endif} end; procedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator); var cm: TClassMode; i: Integer; begin for i := 0 to TP_GlobalClassHandling.Count - 1 do begin cm := TClassMode(TP_GlobalClassHandling.Items[i]); if cm.HClass = HClass then raise EGGProgrammingError.Create( 'You cannot set a handler for a class that has already been assigned otherwise.'); if HClass.InheritsFrom(cm.HClass) then begin // This is the place to insert this class cm := TClassMode.Create; cm.HClass := HClass; cm.SpecialHandler := Handler; TP_GlobalClassHandling.Insert(i, cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('A handler was set for class ' + HClass.ClassName + '.'); {$endif} Exit; end; end; cm := TClassMode.Create; cm.HClass := HClass; cm.SpecialHandler := Handler; TP_GlobalClassHandling.Add(cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('A handler was set for class ' + HClass.ClassName + '.'); {$endif} end; procedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass); var cm: TClassMode; i: Integer; begin for i := 0 to TP_GlobalClassHandling.Count - 1 do begin cm := TClassMode(TP_GlobalClassHandling.Items[i]); if cm.HClass = IgnClass then raise EGGProgrammingError.Create('You cannot add a class to the ignore List that is already on that List: ' + IgnClass.ClassName + '. You should keep all TP_Global functions in one place in your source code.'); if IgnClass.InheritsFrom(cm.HClass) then begin // This is the place to insert this class cm := TClassMode.Create; cm.HClass := IgnClass; TP_GlobalClassHandling.Insert(i, cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Globally, class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} Exit; end; end; cm := TClassMode.Create; cm.HClass := IgnClass; TP_GlobalClassHandling.Add(cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Globally, class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} end; procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString); var cm: TClassMode; i, idx: Integer; begin for i := 0 to TP_GlobalClassHandling.Count - 1 do begin cm := TClassMode(TP_GlobalClassHandling.Items[i]); if cm.HClass = IgnClass then begin if Assigned(cm.SpecialHandler) then raise EGGProgrammingError.Create( 'You cannot ignore a class property for a class that has a handler set.'); if not cm.PropertiesToIgnore.Find(PropertyName, idx) then cm.PropertiesToIgnore.Add(PropertyName); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Globally, the ' + PropertyName + ' property of class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} Exit; end; if IgnClass.InheritsFrom(cm.HClass) then begin // This is the place to insert this class cm := TClassMode.Create; cm.HClass := IgnClass; cm.PropertiesToIgnore.Add(PropertyName); TP_GlobalClassHandling.Insert(i, cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Globally, the ' + PropertyName + ' property of class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} Exit; end; end; cm := TClassMode.Create; cm.HClass := IgnClass; cm.PropertiesToIgnore.Add(PropertyName); TP_GlobalClassHandling.Add(cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Globally, the ' + PropertyName + ' property of class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} end; procedure TGnuGettextInstance.TP_Ignore(AnObject: TObject; const Name: AnsiString); begin TP_IgnoreList.Add(Name); {$ifdef DXGETTEXTDEBUG} DebugWriteln('On object with class name ' + AnObject.ClassName + ', ignore is set on ' + Name); {$endif} end; procedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent; const TextDomain: string); var Comp: TGnuGettextComponentMarker; begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('======================================================================'); DebugWriteln('TranslateComponent() was called for a component with name ' + AnObject.Name + '.'); {$endif} Comp := AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker; if Comp = nil then begin Comp := TGnuGettextComponentMarker.Create(nil); Comp.Name := 'GNUgettextMarker'; Comp.Retranslator := TP_CreateRetranslator; TranslateProperties(AnObject, TextDomain); AnObject.InsertComponent(Comp); {$ifdef DXGETTEXTDEBUG} DebugWriteln( 'This is the first time, that this component has been translated. A retranslator component has been created for this component.'); {$endif} end else begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('This is not the first time, that this component has been translated.'); {$endif} if Comp.LastLanguage <> curlang then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln( 'ERROR: TranslateComponent() was called twice with different languages. This indicates an attempt to switch language at runtime, but by using TranslateComponent every time. This API has changed - please use RetranslateComponent() instead.' ); {$endif} {$ifdef MSWINDOWS} MessageBox(0, 'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.', 'Error', MB_OK); {$endif} {$ifdef CLR} MessageBox.show('This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.'); {$endif} {$ifdef LINUX} WriteLn(stderr, 'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.'); {$endif} end else begin {$ifdef DXGETTEXTDEBUG} DebugWriteln( 'ERROR: TranslateComponent has been called twice, but with the same language chosen. This is a mistake, but in order to prevent that the application breaks, no exception is raised.' ); {$endif} end; end; Comp.LastLanguage := curlang; {$ifdef DXGETTEXTDEBUG} DebugWriteln('======================================================================'); {$endif} end; {$ifndef CLR} procedure TGnuGettextInstance.TranslateProperty(AnObject: TObject; PropInfo: PPropInfo; TodoList: TStrings; const TextDomain: AnsiString); var {$ifdef DELPHI5OROLDER} ws: AnsiString; old: AnsiString; {$endif} {$ifndef DELPHI5OROLDER} ppi: PPropInfo; ws: WideString; old: WideString; {$endif} obj: TObject; Propname: AnsiString; begin PropName := PropInfo^.Name; try // Translate certain types of properties case PropInfo^.PropType^.Kind of tkString, tkLString, tkWString: begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('Translating ' + AnObject.ClassName + '.' + PropName); {$endif} {$ifdef DELPHI5OROLDER} old := GetStrProp(AnObject, PropName); {$endif} {$ifndef DELPHI5OROLDER} if PropInfo^.PropType^.Kind <> tkWString then old := ansi2wide(GetStrProp(AnObject, PropName)) else old := GetWideStrProp(AnObject, PropName); {$endif} {$ifdef DXGETTEXTDEBUG} if old = '' then DebugWriteln('(Empty, not translated)') else DebugWriteln('Old value: "' + old + '"'); {$endif} if (old <> '') and (IsWriteProp(PropInfo)) then begin if TP_Retranslator <> nil then TTP_Retranslator(TP_Retranslator).Remember(AnObject, PropName, old); ws := dgettext(TextDomain, old); if ws <> old then begin {$ifdef DELPHI5OROLDER} SetStrProp(AnObject, PropName, ws); {$endif} {$ifndef DELPHI5OROLDER} ppi := GetPropInfo(AnObject, Propname); if ppi <> nil then begin SetWideStrProp(AnObject, ppi, ws); end else begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('ERROR: Property disappeared: ' + Propname + ' for object of type ' + AnObject.ClassName); {$endif} end; {$endif} end; end; end { case item }; tkClass: begin obj := GetObjectProp(AnObject, PropName); if obj <> nil then TodoList.AddObject('', obj); end { case item }; end { case }; except on E: Exception do raise EGGComponentError.Create('Property cannot be translated.' + sLineBreak + 'Add TP_GlobalIgnoreClassProperty(' + AnObject.ClassName + ', ''' + PropName + ''') to your source code or use' + sLineBreak + 'TP_Ignore (self, ''.' + PropName + ''') to prevent this message.' + sLineBreak + 'Reason: ' + e.Message); end; end; {$endif} procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; TextDomain: string = ''); {$ifndef CLR} var TodoList: TStringList; // List of Name/TObject's that is to be processed DoneList: TStringList; // List of hex codes representing pointers to objects that have been done i, j, Count: Integer; PropList: PPropList; UPropName: AnsiString; PropInfo: PPropInfo; Comp: TComponent; cm, currentcm: TClassMode; ObjectPropertyIgnoreList: TStringList; objid, Name: AnsiString; {$endif} begin {$ifndef CLR} {$ifdef DXGETTEXTDEBUG} DebugWriteln('----------------------------------------------------------------------'); DebugWriteln('TranslateProperties() was called for an object of class ' + AnObject.ClassName + ' with domain "' + TextDomain + '".'); {$endif} if TextDomain = '' then TextDomain := curmsgdomain; if TP_Retranslator <> nil then TTP_Retranslator(TP_Retranslator).TextDomain := TextDomain; DoneList := TStringList.Create; TodoList := TStringList.Create; ObjectPropertyIgnoreList := TStringList.Create; try TodoList.AddObject('', AnObject); DoneList.Sorted := True; ObjectPropertyIgnoreList.Sorted := True; ObjectPropertyIgnoreList.Duplicates := dupIgnore; {$ifndef DELPHI5OROLDER} ObjectPropertyIgnoreList.CaseSensitive := False; DoneList.Duplicates := dupError; DoneList.CaseSensitive := True; {$endif} while TodoList.Count <> 0 do begin AnObject := TodoList.Objects[0]; Name := TodoList.Strings[0]; TodoList.Delete(0); if (AnObject <> nil) and (AnObject is TPersistent) then begin // Make sure each object is only translated once Assert(SizeOf(Integer) = SizeOf(TObject)); objid := IntToHex(Integer(AnObject), 8); if DoneList.Find(objid, i) then begin Continue; end else begin DoneList.Add(objid); end; ObjectPropertyIgnoreList.Clear; // Find out if there is special handling of this object currentcm := nil; // First check the local handling instructions for j := 0 to TP_ClassHandling.Count - 1 do begin cm := TClassMode(TP_ClassHandling.Items[j]); if AnObject.InheritsFrom(cm.HClass) then begin if cm.PropertiesToIgnore.Count <> 0 then begin ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore); end else begin // Ignore the entire class currentcm := cm; Break; end; end; end; // Then check the global handling instructions if currentcm = nil then for j := 0 to TP_GlobalClassHandling.Count - 1 do begin cm := TClassMode(TP_GlobalClassHandling.Items[j]); if AnObject.InheritsFrom(cm.HClass) then begin if cm.PropertiesToIgnore.Count <> 0 then begin ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore); end else begin // Ignore the entire class currentcm := cm; Break; end; end; end; if currentcm <> nil then begin ObjectPropertyIgnoreList.Clear; // Ignore or use special handler if Assigned(currentcm.SpecialHandler) then begin currentcm.SpecialHandler(AnObject); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Special handler activated for ' + AnObject.ClassName); {$endif} end else begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('Ignoring object ' + AnObject.ClassName); {$endif} end; Continue; end; Count := GetPropList(AnObject, PropList); try for j := 0 to Count - 1 do begin PropInfo := PropList[j]; UPropName := PropInfo^.Name; // Ignore properties that are meant to be ignored if ((currentcm = nil) or (not currentcm.PropertiesToIgnore.Find(UPropName, i))) and (not TP_IgnoreList.Find(Name + '.' + UPropName, i)) and (not ObjectPropertyIgnoreList.Find(UPropName, i)) then begin TranslateProperty(AnObject, PropInfo, TodoList, TextDomain); end; // if end; // for finally if Count <> 0 then FreeMem(PropList); end; if AnObject is TStrings then begin if (TStrings(AnObject).Count > 0) and (TP_Retranslator <> nil) then TTP_Retranslator(TP_Retranslator).Remember(AnObject, 'Text', TStrings(AnObject).Text); TranslateStrings(TStrings(AnObject), TextDomain); end; // Check for TCollection if AnObject is TCollection then begin for i := 0 to TCollection(AnObject).Count - 1 do TodoList.AddObject('', TCollection(AnObject).Items[i]); end; if AnObject is TComponent then begin for i := 0 to TComponent(AnObject).ComponentCount - 1 do begin Comp := TComponent(AnObject).Components[i]; if (not TP_IgnoreList.Find(Comp.Name, j)) then begin TodoList.AddObject(Comp.Name, Comp); end; end; end; end { if AnObject <> nil }; end { while TodoList.count <> 0 }; finally TodoList.Free; ObjectPropertyIgnoreList.Free; DoneList.Free; end; TP_ClassHandling.Clear; // deletes the objects TP_IgnoreList.Clear; TP_Retranslator := nil; {$ifdef DXGETTEXTDEBUG} DebugWriteln('----------------------------------------------------------------------'); {$endif} {$endif} end; procedure TGnuGettextInstance.UseLanguage(LanguageCode: string); var i, p: Integer; dom: TDomain; l2: string[2]; begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('UseLanguage(''' + LanguageCode + '''); called'); {$endif} if LanguageCode = '' then begin LanguageCode := GGGetEnvironmentVariable('LANG'); {$ifdef DXGETTEXTDEBUG} DebugWriteln('LANG env variable is ''' + LanguageCode + '''.'); {$endif} if LanguageCode = '' then begin LanguageCode := GetOSLanguage; {$ifdef DXGETTEXTDEBUG} DebugWriteln('Found OS language code to be ''' + LanguageCode + '''.'); {$endif} end; p := Pos('.', LanguageCode); if p <> 0 then Delete(LanguageCode, p, MaxInt); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Language code that will be set is ''' + LanguageCode + '''.'); {$endif} end; curlang := LanguageCode; for i := 0 to DomainList.Count - 1 do begin dom := TDomain(DomainList.Objects[i]); dom.SetLanguageCode(curlang); end; l2 := LowerCase(Copy(curlang, 1, 2)); if (l2 = 'en') or (l2 = 'de') then curGetPluralForm := GetPluralForm2EN else if (l2 = 'hu') or (l2 = 'ko') or (l2 = 'zh') or (l2 = 'ja') or (l2 = 'tr') then curGetPluralForm := GetPluralForm1 else if (l2 = 'fr') or (l2 = 'fa') or (LowerCase(curlang) = 'pt_br') then curGetPluralForm := GetPluralForm2FR else if (l2 = 'lv') then curGetPluralForm := GetPluralForm3LV else if (l2 = 'ga') then curGetPluralForm := GetPluralForm3GA else if (l2 = 'lt') then curGetPluralForm := GetPluralForm3LT else if (l2 = 'ru') or (l2 = 'cs') or (l2 = 'sk') or (l2 = 'uk') or (l2 = 'hr') then curGetPluralForm := GetPluralForm3RU else if (l2 = 'pl') then curGetPluralForm := GetPluralForm3PL else if (l2 = 'sl') then curGetPluralForm := GetPluralForm4SL else begin curGetPluralForm := GetPluralForm2EN; {$ifdef DXGETTEXTDEBUG} DebugWriteln('Plural form for the language was not found. English plurality System assumed.'); {$endif} end; WhenNewLanguage(curlang); {$ifdef DXGETTEXTDEBUG} DebugWriteln(''); {$endif} end; procedure TGnuGettextInstance.TranslateStrings(sl: TStrings; const TextDomain: string); var Line: AnsiString; i: Integer; TempList: TStringList; begin if sl.Count > 0 then begin sl.BeginUpdate; try TempList := TStringList.Create; try TempList.Assign(sl); for i := 0 to TempList.Count - 1 do begin Line := TempList.Strings[i]; if Line <> '' then TempList.Strings[i] := dgettext(TextDomain, Line); end; sl.Assign(TempList); finally TempList.Free; end; { for i := 0 to sl.Count - 1 do begin Line := sl.Strings[i]; if Line <> '' then sl.Strings[i] := dgettext(TextDomain, Line); end; } finally sl.EndUpdate; end; end; end; function TGnuGettextInstance.GetTranslatorNameAndEmail: WideString; begin Result := GetTranslationProperty('LAST-TRANSLATOR'); end; function TGnuGettextInstance.GetTranslationProperty(const PropertyName: AnsiString): WideString; begin Result := getdomain(curmsgdomain, DefaultDomainDirectory, CurLang).GetTranslationProperty(PropertyName); end; function TGnuGettextInstance.dngettext(const szDomain: string; singular, plural: WideString; Number: Integer): WideString; var org, trans: WideString; idx: Integer; p: Integer; begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('dngettext translation (domain ' + szDomain + ', number is ' + IntToStr(Number) + ') of ' + singular + '/' + plural); {$endif} org := singular + #0 + plural; trans := dgettext(szDomain, org); if org = trans then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('Translation was equal to english version. English plural forms assumed.'); {$endif} idx := GetPluralForm2EN(Number) end else idx := curGetPluralForm(Number); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Index ' + IntToStr(idx) + ' will be used'); {$endif} while True do begin p := Pos(#0, string(trans)); if p = 0 then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('Last translation used: ' + Utf8Encode(trans)); {$endif} Result := trans; Exit; end; if idx = 0 then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('Translation found: ' + Utf8Encode(trans)); {$endif} Result := Copy(trans, 1, p - 1); Exit; end; Delete(trans, 1, p); Dec(idx); end; end; {$ifndef DELPHI5OROLDER} function TGnuGettextInstance.ngettext(const singular, plural: AnsiString; Number: Integer): WideString; begin Result := dngettext(curmsgdomain, singular, plural, Number); end; {$endif} function TGnuGettextInstance.ngettext(const singular, plural: WideString; Number: Integer): WideString; begin Result := dngettext(curmsgdomain, singular, plural, Number); end; procedure TGnuGettextInstance.WhenNewDomain(const TextDomain: string); begin // This is meant to be empty. end; procedure TGnuGettextInstance.WhenNewLanguage(const LanguageID: AnsiString); begin // This is meant to be empty. end; procedure TGnuGettextInstance.WhenNewDomainDirectory(const TextDomain, Directory: string); begin // This is meant to be empty. end; procedure TGnuGettextInstance.GetListOfLanguages(const domain: string; List: TStrings); begin getdomain(Domain, DefaultDomainDirectory, CurLang).GetListOfLanguages(List); end; procedure TGnuGettextInstance.bindtextdomainToFile(const szDomain, Filename: string); begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('Text domain "' + szDomain + '" is now bound to file named "' + Filename + '"'); {$endif} getdomain(szDomain, DefaultDomainDirectory, CurLang).SetFilename(Filename); end; procedure TGnuGettextInstance.DebugLogPause(PauseEnabled: Boolean); begin DebugLogOutputPaused := PauseEnabled; end; procedure TGnuGettextInstance.DebugLogToFile(const Filename: string; append: Boolean = False); var fs: TFileStream; marker: AnsiString; begin // Create the file if needed if (not FileExists(Filename)) or (not append) then FileClose(FileCreate(Filename)); // Open file fs := TFileStream.Create(Filename, fmOpenWrite or fmShareDenyWrite); if append then fs.Seek(0, soFromEnd); // Write header if appending if fs.Position <> 0 then begin marker := sLineBreak + '===========================================================================' + sLineBreak; fs.WriteBuffer(marker[1], Length(marker)); end; if DebugLog <> nil then begin // Copy the memorystream contents to the file DebugLog.Seek(0, soFromBeginning); fs.CopyFrom(DebugLog, 0); // Make DebugLog point to the filestream FreeAndNil(DebugLog); end; DebugLog := fs; end; procedure TGnuGettextInstance.DebugWriteln(Line: AnsiString); var Discard: Boolean; begin Assert(DebugLogCS <> nil); Assert(DebugLog <> nil); DebugLogCS.BeginWrite; try if DebugLogOutputPaused then Exit; if Assigned(fOnDebugLine) then begin Discard := True; fOnDebugLine(Self, Line, Discard); if Discard then Exit; end; Line := Line + sLineBreak; // Ensure that memory usage doesn't get too big. if (DebugLog is TMemoryStream) and (DebugLog.Position > 1000000) then begin Line := sLineBreak + sLineBreak + sLineBreak + sLineBreak + sLineBreak + 'Debug log halted because memory usage grew too much.' + sLineBreak + 'Specify a Filename to store the debug log in or disable debug loggin in gnugettext.pas.' + sLineBreak + sLineBreak + sLineBreak + sLineBreak + sLineBreak; DebugLogOutputPaused := True; end; DebugLog.WriteBuffer(Line[1], Length(Line)); finally DebugLogCS.EndWrite; end; end; function TGnuGettextInstance.Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain; // Retrieves the TDomain object for the specified domain. // Creates one, if none there, yet. var idx: Integer; begin idx := DomainList.IndexOf(Domain); if idx = -1 then begin Result := TDomain.Create; Result.DebugLogger := DebugWriteln; Result.Domain := Domain; Result.Directory := DefaultDomainDirectory; Result.SetLanguageCode(curlang); DomainList.AddObject(Domain, Result); end else begin Result := TDomain(DomainList.Objects[idx]); end; end; {$ifndef CLR} function TGnuGettextInstance.LoadResString(ResStringRec: PResStringRec): WideString; {$ifdef MSWINDOWS} var Len: Integer; Buffer: array[0..1023] of AnsiChar; {$endif} {$ifdef LINUX} const ResStringTableLen = 16; type ResStringTable = array[0..ResStringTableLen - 1] of Longword; var Handle: TResourceHandle; Tab: ^ResStringTable; ResMod: HMODULE; {$endif} begin if (ResStringRec = nil) or (Self = nil) then Exit; if ResStringRec.Identifier >= 64 * 1024 then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('LoadResString was given an invalid ResStringRec.Identifier'); {$endif} Result := PChar(ResStringRec.Identifier); Exit; end else begin {$ifdef LINUX} // This works with Unicode if the Linux has utf-8 character set // Result := System.LoadResString(ResStringRec); ResMod := FindResourceHInstance(ResStringRec^.Module^); Handle := FindResource(ResMod, PChar(ResStringRec^.Identifier div ResStringTableLen), PChar(6)); // RT_STRING Tab := Pointer(LoadResource(ResMod, Handle)); if Tab = nil then Result := '' else Result := PWideChar(PChar(Tab) + Tab[ResStringRec^.Identifier mod ResStringTableLen]); {$endif} {$ifdef MSWINDOWS} if not Win32PlatformIsUnicode then begin SetString(Result, Buffer, LoadString(FindResourceHInstance(ResStringRec.Module^), ResStringRec.Identifier, Buffer, SizeOf(Buffer))) end else begin Result := ''; Len := 0; while Len = Length(Result) do begin if Length(Result) = 0 then SetLength(Result, 1024) else SetLength(Result, Length(Result) * 2); Len := LoadStringW(FindResourceHInstance(ResStringRec.Module^), ResStringRec.Identifier, PWideChar(Result), Length(Result)); end; SetLength(Result, Len); end; {$endif} end; {$ifdef DXGETTEXTDEBUG} DebugWriteln('Loaded resourcestring: ' + Utf8Encode(Result)); {$endif} if CreatorThread <> GetCurrentThreadId then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('LoadResString was called from an invalid thread. Resourcestring was not translated.'); {$endif} end else Result := ResourceStringGettext(Result); end; {$endif} procedure TGnuGettextInstance.RetranslateComponent(AnObject: TComponent; const TextDomain: string); var Comp: TGnuGettextComponentMarker; begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('======================================================================'); DebugWriteln('RetranslateComponent() was called for a component with name ' + AnObject.Name + '.'); {$endif} Comp := AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker; if Comp = nil then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln( 'Retranslate was called on an object that has not been translated before. An Exception is being raised.'); {$endif} raise EGGProgrammingError.Create( 'Retranslate was called on an object that has not been translated before. Please use TranslateComponent() before RetranslateComponent().'); end else begin if Comp.LastLanguage <> curlang then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('The retranslator is being executed.'); {$endif} Comp.Retranslator.Execute; end else begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('The language has not changed. The retranslator is not executed.'); {$endif} end; end; Comp.LastLanguage := curlang; {$ifdef DXGETTEXTDEBUG} DebugWriteln('======================================================================'); {$endif} end; procedure TGnuGettextInstance.TP_IgnoreClass(IgnClass: TClass); var cm: TClassMode; i: Integer; begin for i := 0 to TP_ClassHandling.Count - 1 do begin cm := TClassMode(TP_ClassHandling.Items[i]); if cm.HClass = IgnClass then raise EGGProgrammingError.Create('You cannot add a class to the ignore List that is already on that List: ' + IgnClass.ClassName + '.'); if IgnClass.InheritsFrom(cm.HClass) then begin // This is the place to insert this class cm := TClassMode.Create; cm.HClass := IgnClass; TP_ClassHandling.Insert(i, cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Locally, class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} Exit; end; end; cm := TClassMode.Create; cm.HClass := IgnClass; TP_ClassHandling.Add(cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Locally, class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} end; procedure TGnuGettextInstance.TP_IgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString); var cm: TClassMode; i: Integer; begin for i := 0 to TP_ClassHandling.Count - 1 do begin cm := TClassMode(TP_ClassHandling.Items[i]); if cm.HClass = IgnClass then begin if Assigned(cm.SpecialHandler) then raise EGGProgrammingError.Create( 'You cannot ignore a class property for a class that has a handler set.'); cm.PropertiesToIgnore.Add(PropertyName); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Globally, the ' + PropertyName + ' property of class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} Exit; end; if IgnClass.InheritsFrom(cm.HClass) then begin // This is the place to insert this class cm := TClassMode.Create; cm.HClass := IgnClass; cm.PropertiesToIgnore.Add(PropertyName); TP_ClassHandling.Insert(i, cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Locally, the ' + PropertyName + ' property of class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} Exit; end; end; cm := TClassMode.Create; cm.HClass := IgnClass; cm.PropertiesToIgnore.Add(PropertyName); TP_GlobalClassHandling.Add(cm); {$ifdef DXGETTEXTDEBUG} DebugWriteln('Locally, the ' + PropertyName + ' property of class ' + IgnClass.ClassName + ' is being ignored.'); {$endif} end; function TGnuGettextInstance.ansi2wide(const s: AnsiString): WideString; {$ifdef MSWINDOWS} var len: Integer; {$endif} begin {$ifdef MSWINDOWS} if DesignTimeCodePage = CP_ACP then begin // No design-time codepage specified. Using runtime codepage instead. {$endif} Result := s; {$ifdef MSWINDOWS} end else begin len := Length(s); if len = 0 then Result := '' else begin SetLength(Result, len); len := MultiByteToWideChar(DesignTimeCodePage, 0, PChar(s), len, PWideChar(Result), len); if len = 0 then raise EGGAnsi2WideConvError.Create('Cannot convert AnsiString to WideString:' + sLineBreak + s); SetLength(Result, len); end; end; {$endif} end; {$ifndef DELPHI5OROLDER} function TGnuGettextInstance.dngettext(const szDomain: string; singular, plural: AnsiString; Number: Integer): WideString; begin Result := dngettext(szDomain, ansi2wide(singular), ansi2wide(plural), Number); end; {$endif} { TClassMode } constructor TClassMode.Create; begin inherited Create; PropertiesToIgnore := TStringList.Create; PropertiesToIgnore.Sorted := True; PropertiesToIgnore.Duplicates := dupError; {$ifndef DELPHI5OROLDER} PropertiesToIgnore.CaseSensitive := False; {$endif} end; destructor TClassMode.Destroy; begin PropertiesToIgnore.Free; inherited Destroy; end; { TFileLocator } procedure TFileLocator.Analyze; var s: AnsiString; i: Integer; Offset: Int64; fs: TFileStream; fi: TEmbeddedFileInfo; AnsiFilename: AnsiString; begin s := '6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0; // this string is patched in the executable s := Copy(s, Length(s) - 7, 8); Offset := 0; for i := 8 downto 1 do Offset := Offset shl 8 + Ord(s[i]); if Offset = 0 then Exit; BaseDirectory := ExtractFilePath(ExecutableFilename); try fs := TFileStream.Create(ExecutableFilename, fmOpenRead or fmShareDenyNone); try while True do begin fs.Seek(Offset, soFromBeginning); Offset := ReadInt64(fs); if Offset = 0 then Exit; fi := TEmbeddedFileInfo.Create; try fi.Offset := ReadInt64(fs); fi.Size := ReadInt64(fs); SetLength(AnsiFilename, Offset - fs.Position); fs.ReadBuffer(AnsiFilename[1], Offset - fs.Position); FileList.AddObject(Trim(AnsiFilename), fi); except fi.Free; raise; end; end; finally fs.Free; end; except {$ifdef DXGETTEXTDEBUG} raise; {$endif} end; end; constructor TFileLocator.Create; begin inherited Create; MoFilesCS := TMultiReadExclusiveWriteSynchronizer.Create; MoFiles := TStringList.Create; FileList := TStringList.Create; {$ifdef LINUX} FileList.Duplicates := dupError; FileList.CaseSensitive := True; {$endif} MoFiles.Sorted := True; {$ifndef DELPHI5OROLDER} MoFiles.Duplicates := dupError; MoFiles.CaseSensitive := False; {$ifdef MSWINDOWS} FileList.Duplicates := dupError; FileList.CaseSensitive := False; {$endif} {$endif} FileList.Sorted := True; end; destructor TFileLocator.Destroy; var I: Integer; begin for I := 0 to FileList.Count - 1 do FileList.Objects[I].Free; { while FileList.Count <> 0 do begin FileList.Objects[0].Free; FileList.Delete(0); end;} FileList.Free; MoFiles.Free; MoFilesCS.Free; inherited Destroy; end; function TFileLocator.FileExists(Filename: string): Boolean; var idx: Integer; begin if IsInDirStrOf(Filename, BaseDirectory) then Delete(Filename, 1, Length(BaseDirectory)); Result := FileList.Find(Filename, idx); end; function TFileLocator.GetMoFile(Filename: string; DebugLogger: TDebugLogger): TMoFile; var fi: TEmbeddedFileInfo; idx: Integer; idxName: string; Offset, Size: Int64; RealFilename: string; begin // Find real Filename Offset := 0; Size := 0; RealFilename := Filename; if IsInDirStrOf(Filename, BaseDirectory) then begin Delete(Filename, 1, Length(BaseDirectory)); idx := FileList.IndexOf(Filename); if idx <> -1 then begin fi := TEmbeddedFileInfo(FileList.Objects[idx]); RealFilename := ExecutableFilename; Offset := fi.Offset; Size := fi.Size; {$ifdef DXGETTEXTDEBUG} DebugLogger('Instead of ' + Filename + ', using ' + RealFilename + ' from Offset ' + IntToStr(Offset) + ', Size ' + IntToStr(Size)); {$endif} end; end; {$ifdef DXGETTEXTDEBUG} DebugLogger('Reading .mo data from file ''' + Filename + ''''); {$endif} // Find TMoFile object MoFilesCS.BeginWrite; try idxName := RealFilename + #0 + IntToStr(Offset); if MoFiles.Find(idxName, idx) then begin Result := TMoFile(MoFiles.Objects[idx]); end else begin Result := TMoFile.Create(RealFilename, Offset, Size); MoFiles.AddObject(idxName, Result); end; Inc(Result.Users); finally MoFilesCS.EndWrite; end; end; function TFileLocator.ReadInt64(str: TStream): Int64; begin Assert(SizeOf(Result) = 8); str.ReadBuffer(Result, 8); end; procedure TFileLocator.ReleaseMoFile(var moFile: TMoFile); var i: Integer; begin Assert(moFile <> nil); MoFilesCS.BeginWrite; try Dec(moFile.Users); if moFile.Users <= 0 then begin i := MoFiles.Count - 1; while i >= 0 do begin if MoFiles.Objects[i] = moFile then begin MoFiles.Delete(i); FreeAndNil(moFile); Break; end; Dec(i); end; end; finally MoFilesCS.EndWrite; end; end; { TTP_Retranslator } constructor TTP_Retranslator.Create; begin inherited Create; List := TList.Create; end; destructor TTP_Retranslator.Destroy; var i: Integer; begin for i := 0 to List.Count - 1 do TObject(List.Items[i]).Free; List.Free; inherited Destroy; end; procedure TTP_Retranslator.Execute; var i: Integer; sl: TStrings; Item: TTP_RetranslatorItem; newvalue: WideString; {$ifndef DELPHI5OROLDER} ppi: PPropInfo; {$endif} begin for i := 0 to List.Count - 1 do begin Item := TTP_RetranslatorItem(List.items[i]); if Item.obj is TStrings then begin // Since we don't know the order of items in sl, and don't have // the original .Objects[] anywhere, we cannot anticipate anything // about the current sl.Strings[] and sl.Objects[] values. We therefore // have to discard both values. We can, however, set the original .Strings[] // value into the List and retranslate that. sl := TStringList.Create; try sl.Text := Item.OldValue; Instance.TranslateStrings(sl, TextDomain); TStrings(Item.obj).BeginUpdate; try TStrings(Item.obj).Assign(sl); finally TStrings(Item.obj).EndUpdate; end; finally sl.Free; end; end else begin newValue := Instance.dgettext(TextDomain, Item.OldValue); {$ifdef DELPHI5OROLDER} SetStrProp(Item.obj, Item.PropName, newValue); {$endif} {$ifndef DELPHI5OROLDER} ppi := GetPropInfo(Item.obj, Item.Propname); if ppi <> nil then begin SetWideStrProp(Item.obj, ppi, newValue); end else begin {$ifdef DXGETTEXTDEBUG} Instance.DebugWriteln('ERROR: On retranslation, property disappeared: ' + Item.Propname + ' for object of type ' + Item.obj.ClassName); {$endif} end; {$endif} end; end; end; procedure TTP_Retranslator.Remember(obj: TObject; const PropName: AnsiString; OldValue: WideString); var Item: TTP_RetranslatorItem; begin Item := TTP_RetranslatorItem.Create; Item.obj := obj; Item.Propname := Propname; Item.OldValue := OldValue; List.Add(Item); end; { TGnuGettextComponentMarker } destructor TGnuGettextComponentMarker.Destroy; begin Retranslator.Free; inherited Destroy; end; {$ifndef CLR} { THook } constructor THook.Create(OldProcedure, NewProcedure: Pointer; FollowJump: Boolean = False); { Idea and original code from Igor Siticov } { Modified by Jacques Garcia Vazquez and Lars Dybdahl } begin inherited Create; {$ifndef CPU386} 'This procedure only works on Intel i386 compatible processors.' {$endif} OldProc := OldProcedure; NewProc := NewProcedure; Reset(FollowJump); end; destructor THook.Destroy; begin Shutdown; inherited Destroy; end; procedure THook.Disable; begin Assert(PatchPosition <> nil, 'Patch position in THook was nil when Disable was called'); PatchPosition[0] := Original[0]; PatchPosition[1] := Original[1]; PatchPosition[2] := Original[2]; PatchPosition[3] := Original[3]; PatchPosition[4] := Original[4]; end; procedure THook.Enable; begin Assert(PatchPosition <> nil, 'Patch position in THook was nil when Enable was called'); PatchPosition[0] := Patch[0]; PatchPosition[1] := Patch[1]; PatchPosition[2] := Patch[2]; PatchPosition[3] := Patch[3]; PatchPosition[4] := Patch[4]; end; procedure THook.Reset(FollowJump: Boolean); var Offset: Integer; {$ifdef LINUX} p: Pointer; pagesize: Integer; {$endif} {$ifdef MSWINDOWS} ov: Cardinal; {$endif} begin if PatchPosition <> nil then Shutdown; PatchPosition := OldProc; if FollowJump and (Word(OldProc^) = $25FF) then begin // This finds the correct procedure if a virtual jump has been inserted // at the procedure address Inc(Integer(PatchPosition), 2); // skip the jump PatchPosition := PChar(Pointer(Pointer(PatchPosition)^)^); end; Offset := Integer(NewProc) - Integer(Pointer(PatchPosition)) - 5; Patch[0] := AnsiChar($E9); Patch[1] := AnsiChar(Offset and 255); Patch[2] := AnsiChar((Offset shr 8) and 255); Patch[3] := AnsiChar((Offset shr 16) and 255); Patch[4] := AnsiChar((Offset shr 24) and 255); Original[0] := PatchPosition[0]; Original[1] := PatchPosition[1]; Original[2] := PatchPosition[2]; Original[3] := PatchPosition[3]; Original[4] := PatchPosition[4]; {$ifdef MSWINDOWS} if not VirtualProtect(Pointer(PatchPosition), 5, PAGE_EXECUTE_READWRITE, @ov) then RaiseLastOSError; {$endif} {$ifdef LINUX} pageSize := sysconf(_SC_PAGE_SIZE); p := Pointer(PatchPosition); p := Pointer((Integer(p) + PAGESIZE - 1) and not (PAGESIZE - 1) - pageSize); if mprotect(p, pageSize, PROT_READ + PROT_WRITE + PROT_EXEC) <> 0 then RaiseLastOSError; {$endif} end; procedure THook.Shutdown; begin Disable; PatchPosition := nil; end; procedure HookIntoResourceStrings(Enabled: Boolean = True; SupportPackages: Boolean = False); begin HookLoadResString.Reset(SupportPackages); HookLoadStr.Reset(SupportPackages); HookFmtLoadStr.Reset(SupportPackages); if Enabled then begin HookLoadResString.Enable; HookLoadStr.Enable; HookFmtLoadStr.Enable; end; end; {$endif} { TMoFile } constructor TMoFile.Create(const Filename: string; Offset, Size: Int64); var i: Cardinal; nn: Integer; moFile: TFileStream; begin inherited Create; if SizeOf(i) <> 4 then raise EGGProgrammingError.Create( 'TDomain in gnugettext is written for an architecture that has 32 bit integers.'); // Read the whole file into memory moFile := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone); try if Size = 0 then Size := moFile.Size; SetLength(moMemory, Size); moFile.Seek(Offset, soFromBeginning); {$ifdef CLR} mofile.ReadBuffer(moMemory, Size); {$else} mofile.ReadBuffer(moMemory[0], Size); {$endif} finally moFile.Free; end; // Check the magic number doswap := False; i := CardinalInMem(0); if (i <> $950412DE) and (i <> $DE120495) then EGGIOError.Create('This file is not a valid GNU gettext mo file: ' + Filename); doswap := (i = $DE120495); // Find the positions in the file according to the file format spec CardinalInMem(4); // Read the version number, but don't use it for anything. N := CardinalInMem(8); // Get string count O := CardinalInMem(12); // Get Offset of original strings T := CardinalInMem(16); // Get Offset of translated strings // Calculate start conditions for a binary search nn := N; StartIndex := 1; while nn <> 0 do begin nn := nn shr 1; StartIndex := StartIndex shl 1; end; StartIndex := StartIndex shr 1; StartStep := StartIndex shr 1; end; function TMoFile.CardinalInMem (Offset: Cardinal): Cardinal; begin if doswap then begin Result:= moMemory[Offset]+ (moMemory[Offset + 1] shl 8)+ (moMemory[Offset + 2] shl 16)+ (moMemory[Offset + 3] shl 24); end else begin Result:= (momemory[Offset] shl 24)+ (momemory[Offset + 1] shl 16)+ (momemory[Offset + 2] shl 8)+ momemory[Offset + 3]; end; end; function TMoFile.gettext(const msgid: AnsiString; var Found: Boolean): AnsiString; var {$ifdef CLR} j: Cardinal; {$endif} i, Step: Cardinal; Offset, Pos: Cardinal; CompareResult: Integer; msgidptr, a, b: Integer; abidx: Integer; Size, msgidsize: Integer; begin Found := False; msgidptr := 1; msgidsize := Length(msgid); // Do binary search i := StartIndex; Step := StartStep; while True do begin // Get string for index i Pos := O + 8 * (i - 1); Offset := CardinalInMem(Pos + 4); Size := CardinalInMem(Pos); a := msgidptr; b := Offset; abidx := Size; if msgidsize < abidx then abidx := msgidsize; CompareResult := 0; while abidx <> 0 do begin CompareResult := Integer(Byte(msgid[a])) - Integer(moMemory[b]); if CompareResult <> 0 then Break; Dec(abidx); Inc(a); Inc(b); end; if CompareResult = 0 then CompareResult := msgidsize - Size; if CompareResult = 0 then begin // msgid=s // Found the msgid Pos := T + 8 * (i - 1); Offset := CardinalInMem(Pos + 4); Size := CardinalInMem(Pos); {$ifdef CLR} SetLength(Result, Size); for j := 0 to Size - 1 do Result[j + 1] := AnsiChar(moMemory[Offset + j]); {$else} SetString(Result, PChar(@moMemory[0]) + Offset, Size); {$endif} Found := True; Break; end; if Step = 0 then begin // Not found Result := msgid; Break; end; if CompareResult < 0 then begin // msgids i := i + Step; if i > N then i := N; Step := Step shr 1; end; end; end; {$ifdef DXGETTEXTDEBUG} const DebuggingText = 'gnugettext.pas debugging is enabled. Turn it off before ' + 'releasing this piece of software.'; {$endif} initialization {$ifdef DXGETTEXTDEBUG} {$ifdef CLR} MessageBox.show(DebuggingText); {$else} {$ifdef MSWINDOWS} MessageBox(0, PChar(DebuggingText), 'Information', MB_OK); {$endif} {$ifdef LINUX} WriteLn(stderr, DebuggingText); {$endif} {$endif} {$endif} if IsLibrary then begin // Get DLL/shared object Filename SetLength(ExecutableFilename, 300); {$ifdef MSWINDOWS} SetLength(ExecutableFilename, GetModuleFileName(HInstance, PChar(ExecutableFilename), Length(ExecutableFilename))); {$endif} {$ifdef LINUX} // This line has not been tested on Linux, yet, but should work. SetLength(ExecutableFilename, GetModuleFileName(0, PChar(ExecutableFilename), Length(ExecutableFilename))); {$endif} {$ifdef CLR} ExecutableFilename := System.Diagnostics.Process.GetCurrentProcess.MainModule.FileName; {$endif} end else ExecutableFilename := ParamStr(0); FileLocator := TFileLocator.Create; FileLocator.Analyze; ResourceStringDomainList := TStringList.Create; ResourceStringDomainList.Add(DefaultTextDomain); ResourceStringDomainListCS := TMultiReadExclusiveWriteSynchronizer.Create; DefaultInstance := TGnuGettextInstance.Create; {$ifdef MSWINDOWS} Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT); {$endif} {$ifndef CLR} // replace Borlands LoadResString with gettext enabled version: HookLoadResString := THook.Create(@System.LoadResString, @LoadResStringA); HookLoadStr := THook.Create(@SysUtils.LoadStr, @SysUtilsLoadStr); HookFmtLoadStr := THook.Create(@SysUtils.FmtLoadStr, @SysUtilsFmtLoadStr); HookIntoResourceStrings(AutoCreateHooks, False); {$endif} finalization FreeAndNil(DefaultInstance); FreeAndNil(ResourceStringDomainListCS); FreeAndNil(ResourceStringDomainList); {$ifndef CLR} FreeAndNil(HookFmtLoadStr); FreeAndNil(HookLoadStr); FreeAndNil(HookLoadResString); {$endif} FreeAndNil(FileLocator); end.