// // This unit is part of the GLScene Engine, http://glscene.org // {*------------------------------------------------------------------------------ GNU gettext translation system for Delphi, Kylix, C++ Builder and others. All parts of the translation system are kept in this unit. @author Lars B. Dybdahl and others @version $LastChangedRevision$ @see http://dybdahl.dk/dxgettext/ -------------------------------------------------------------------------------} unit GnuGettext; (**************************************************************) (* *) (* (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, Igor Gitman *) (* Arvid Winkelsdorf, Andreas Hausladen, *) (* Olivier Sannier *) (* *) (* See http://dybdahl.dk/dxgettext/ for more information *) (* *) (**************************************************************) // Information about this file: // $--LastChangedDate: 2010-08-25 15:40:17 +0200 (mer., 25 avg 2010) $ // $--LastChangedRevision: 220 $ // $--HeadURL: http://svn.berlios.de/svnroot/repos/dxgettext/trunk/dxgettext/sample/gnugettext.pas $ // 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 VER140} // Delphi 6 {$DEFINE DELPHI2007OROLDER} {$ifdef MSWINDOWS} {$DEFINE DELPHI6OROLDER} {$endif} {$endif} {$ifdef VER150} // Delphi 7 {$DEFINE DELPHI2007OROLDER} {$endif} {$ifdef VER160} // Delphi 8 {$DEFINE DELPHI2007OROLDER} {$endif} {$ifdef VER170} // Delphi 2005 {$DEFINE DELPHI2007OROLDER} {$endif} {$ifdef VER180} // Delphi 2006 {$DEFINE DELPHI2007OROLDER} {$endif} {$ifdef VER190} // Delphi 2007 {$DEFINE DELPHI2007OROLDER} {$endif} {$ifdef VER200} // Delphi 2009 with Unicode {$endif} {$ifdef VER220} // Delphi XE with Unicode {$endif} {$ifdef VER230} // Delphi XE2 with Unicode {$endif} {$ifdef VER240} // Delphi XE3 with Unicode {$DEFINE DELPHIXE3OROLDER} {$endif} uses {$ifdef MSWINDOWS} Winapi.Windows, {$else} Libc, {$ifdef FPC} CWString, {$endif} {$endif} Classes, StrUtils, SysUtils, TypInfo; (*****************************************************************************) (* *) (* MAIN API *) (* *) (*****************************************************************************) type {$IFNDEF UNICODE} UnicodeString=WideString; RawUtf8String=AnsiString; RawByteString=AnsiString; {$ELSE} RawUtf8String=RawByteString; {$ENDIF} DomainString = string; LanguageString = string; ComponentNameString = string; FilenameString = string; MsgIdString = UnicodeString; TranslatedUnicodeString = UnicodeString; // Main GNU gettext functions. See documentation for instructions on how to use them. function _(const szMsgId: MsgIdString): TranslatedUnicodeString; function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString; function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; function dngettext(const szDomain: DomainString; const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString; function ngettext(const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString; procedure textdomain(const szDomain: DomainString); function getcurrenttextdomain: DomainString; procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString); // Set language to use procedure UseLanguage(LanguageCode: LanguageString); function GetCurrentLanguage: LanguageString; // 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: ComponentNameString); procedure TP_IgnoreClass(IgnClass: TClass); procedure TP_IgnoreClassProperty(IgnClass: TClass; const propertyname: ComponentNameString); procedure TP_GlobalIgnoreClass(IgnClass: TClass); procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const propertyname: ComponentNameString); procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator); procedure TranslateComponent(AnObject: TComponent; const TextDomain: DomainString = ''); procedure RetranslateComponent(AnObject: TComponent; const TextDomain: DomainString = ''); // 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: DomainString); procedure RemoveDomainForResourceString(const domain: DomainString); // Add more domains that component strings can be extracted from. If a translation // is not found in the default domain, this domain will be searched, too. // This is useful when an application inherits components from a 3rd // party component libraries procedure AddDomainForComponent (const domain:DomainString); procedure RemoveDomainForComponent (const domain:DomainString); // Unicode-enabled way to get resourcestrings, automatically translated // Use like this: ws:=LoadResStringW(@NameOfResourceString); function LoadResString(ResStringRec: PResStringRec): WideString; function LoadResStringW(ResStringRec: PResStringRec): UnicodeString; // This returns an empty string if not translated or translator name is not specified. function GetTranslatorNameAndEmail: TranslatedUnicodeString; (*****************************************************************************) (* *) (* ADVANCED FUNCTIONALITY *) (* *) (*****************************************************************************) const DefaultTextDomain = 'default'; var ExecutableFilename: FilenameString; // This is set to paramstr(0) or the name of the DLL you are creating. const PreferExternal = False; // Set to true, to prefer external *.mo over embedded translation UseMemoryMappedFiles = True; // Set to False, to use the mo-file as independent copy in memory (you can update the file while it is in use) ReReadMoFileOnSameLanguage = True; // Set to True, to reread mo-file if the current language is selected again const // Subversion source code version control version information VCSVersion = '$LastChangedRevision$'; type EGnuGettext = class(Exception); EGGProgrammingError = class(EGnuGettext); EGGComponentError = class(EGnuGettext); EGGIOError = class(EGnuGettext); EGGAnsi2WideConvError = class(EGnuGettext); // 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); (*****************************************************************************) (* *) (* CLASS based implementation. *) (* Use TGnuGettextInstance to have more than one language *) (* in your application at the same time *) (* *) (*****************************************************************************) {$ifdef MSWINDOWS} {$ifndef DELPHIXE3OROLDER} {$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CODE OFF} {$WARN UNSAFE_CAST OFF} {$endif} {$endif} type TOnDebugLine = procedure(Sender: TObject; const Line: string; 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; {*------------------------------------------------------------------------------ Handles .mo files, in separate files or inside the exe file. Don't use this class. It's for internal use. -------------------------------------------------------------------------------} TMoFile= class /// 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: FilenameString; const Offset: int64; Size: int64; const xUseMemoryMappedFiles: Boolean); destructor Destroy; override; function gettext(const msgid: RawUtf8String;var found:boolean): RawUtf8String; // uses mo file and utf-8 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; FUseMemoryMappedFiles: Boolean; mo: THandle; momapping: THandle; momemoryHandle: PAnsiChar; momemory: PAnsiChar; function autoswap32(i: cardinal): cardinal; function CardinalInMem(baseptr: PAnsiChar; Offset: cardinal): cardinal; end; {*------------------------------------------------------------------------------ Handles all issues regarding a specific domain. Don't use this class. It's for internal use. -------------------------------------------------------------------------------} TDomain = class private Enabled: boolean; vDirectory: FilenameString; procedure setDirectory(const dir: FilenameString); public DebugLogger: TDebugLogger; Domain: DomainString; property Directory: FilenameString Read vDirectory Write setDirectory; constructor Create; destructor Destroy; override; // Set parameters procedure SetLanguageCode(const langcode: LanguageString); procedure SetFilename(const filename: FilenameString); // Bind this domain to a specific file // Get information procedure GetListOfLanguages(list: TStrings); function GetTranslationProperty(Propertyname: ComponentNameString): TranslatedUnicodeString; function gettext(const msgid: RawUtf8String): RawUtf8String; // uses mo file and utf-8 private mofile: TMoFile; SpecificFilename: FilenameString; curlang: LanguageString; OpenHasFailedBefore: boolean; procedure OpenMoFile; procedure CloseMoFile; end; {*------------------------------------------------------------------------------ Helper class for invoking events. -------------------------------------------------------------------------------} TExecutable = class procedure Execute; virtual; abstract; end; {*------------------------------------------------------------------------------ The main translation engine. -------------------------------------------------------------------------------} TGnuGettextInstance = class private fOnDebugLine: TOnDebugLine; CreatorThread: cardinal; /// Only this thread can use LoadResString 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: LanguageString); procedure GetListOfLanguages(const domain: DomainString; list: TStrings); // Puts list of language codes, for which there are translations in the specified domain, into list {$ifndef UNICODE} function gettext(const szMsgId: ansistring): TranslatedUnicodeString; overload; virtual; function ngettext(const singular,plural:ansistring;Number:longint):TranslatedUnicodeString; overload; virtual; {$endif} function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString; overload; virtual; function gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString; function gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString; function ngettext(const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString; overload; virtual; function ngettext_NoExtract(const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString; function GetCurrentLanguage:LanguageString; function GetTranslationProperty (const Propertyname:ComponentNameString):TranslatedUnicodeString; function GetTranslatorNameAndEmail:TranslatedUnicodeString; // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites() procedure TP_Ignore(AnObject: TObject; const Name: ComponentNameString); procedure TP_IgnoreClass(IgnClass: TClass); procedure TP_IgnoreClassProperty(IgnClass: TClass; propertyname: ComponentNameString); procedure TP_GlobalIgnoreClass(IgnClass: TClass); procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; propertyname: ComponentNameString); procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator); procedure TranslateProperties(AnObject: TObject; textdomain: DomainString = ''); procedure TranslateComponent(AnObject: TComponent; const TextDomain: DomainString = ''); procedure RetranslateComponent(AnObject: TComponent; const TextDomain: DomainString = ''); // Multi-domain functions {$ifndef UNICODE} function dgettext(const szDomain: DomainString; const szMsgId: ansistring): TranslatedUnicodeString; overload; virtual; function dngettext(const szDomain: DomainString; const singular,plural:ansistring;Number:longint):TranslatedUnicodeString; overload; virtual; {$endif} function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; overload; virtual; function dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; function dngettext(const szDomain: DomainString; const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString; overload; virtual; function dngettext_NoExtract(const szDomain: DomainString; const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString; procedure textdomain(const szDomain: DomainString); function getcurrenttextdomain: DomainString; procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString); procedure bindtextdomainToFile(const szDomain: DomainString; const filename: FilenameString); // Also works with files embedded in exe file // Windows API functions function LoadResString(ResStringRec: PResStringRec): UnicodeString; // Output all log info to this file. This may only be called once. procedure DebugLogToFile(const filename: FilenameString; append: boolean = False); procedure DebugLogPause(PauseEnabled: boolean); property OnDebugLine: TOnDebugLine Read fOnDebugLine Write fOnDebugLine; // If set, all debug output goes here {$ifndef UNICODE} // Conversion according to design-time character set function ansi2wideDTCP(const s: ansistring): MsgIdString; // Convert using Design Time Code Page {$endif} protected procedure TranslateStrings(sl: TStrings; const TextDomain: DomainString); // 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: LanguageString); virtual; // Override to know when language changes procedure WhenNewDomain(const TextDomain: DomainString); virtual; // Override to know when text domain changes. Directory is purely informational procedure WhenNewDomainDirectory(const TextDomain: DomainString; const Directory: FilenameString); 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: LanguageString; curGetPluralForm: TGetPluralForm; curmsgdomain: DomainString; savefileCS: TMultiReadExclusiveWriteSynchronizer; savefile: TextFile; savememory: TStringList; DefaultDomainDirectory: FilenameString; domainlist: TStringList; /// List of domain names. Objects are TDomain. TP_IgnoreList: TStringList; /// Temporary list, reset each time TranslateProperties is called TP_ClassHandling: TList; /// Items are TClassMode. If a is derived from b, a comes first TP_GlobalClassHandling: TList; /// Items are TClassMode. If a is derived from b, a comes first TP_Retranslator: TExecutable; /// Cast this to TTP_Retranslator FWhenNewLanguageListeners: TInterfaceList; /// List of all registered WhenNewLanguage listeners {$ifdef DXGETTEXTDEBUG} DebugLogCS:TMultiReadExclusiveWriteSynchronizer; DebugLog:TStream; DebugLogOutputPaused:Boolean; {$endif} function TP_CreateRetranslator: TExecutable; // Must be freed by caller! procedure FreeTP_ClassHandlingItems; {$ifdef DXGETTEXTDEBUG} procedure DebugWriteln(line: ansistring); {$endif} procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo; TodoList: TStrings; const TextDomain: DomainString); function Getdomain(const domain: DomainString; const DefaultDomainDirectory: FilenameString; const CurLang: LanguageString): TDomain; // Translates a single property of an object end; const LOCALE_SISO639LANGNAME = $59; // Used by Lazarus software development tool {$NODEFINE LOCALE_SISO639LANGNAME} LOCALE_SISO3166CTRYNAME = $5A; // Used by Lazarus software development tool {$NODEFINE LOCALE_SISO3166CTRYNAME } var DefaultInstance: TGnuGettextInstance; /// Default instance of the main API for singlethreaded applications. implementation {$ifndef MSWINDOWS} {$ifndef LINUX} 'This version of gnugettext.pas is only meant to be compiled with Kylix 3,' 'Delphi 6, Delphi 7 and later versions. If you use other versions, please' 'get the gnugettext.pas version from the Delphi 5 directory.' {$endif} {$endif} (**************************************************************************) // 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 (**************************************************************************) {$B-,R+,I+,Q+} type TTP_RetranslatorItem = class obj: TObject; Propname: ComponentNameString; OldValue: TranslatedUnicodeString; end; TTP_Retranslator = class(TExecutable) TextDomain: DomainString; Instance: TGnuGettextInstance; constructor Create; destructor Destroy; override; procedure Remember(obj: TObject; PropName: ComponentNameString; OldValue: TranslatedUnicodeString); 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; function FindSignaturePos(const signature: RawByteString; str: TFileStream): Int64; procedure Analyze; // List files embedded inside executable function FileExists(filename: FilenameString): boolean; function GetMoFile(filename: FilenameString; DebugLogger: TDebugLogger): TMoFile; procedure ReleaseMoFile(mofile: TMoFile); private basedirectory: FilenameString; 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: LanguageString; 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; THook = // Replaces a runtime library procedure with a custom procedure class 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: PAnsiChar; procedure Shutdown; // Same as destroy, except that object is not destroyed end; var // System information Win32PlatformIsUnicode: boolean = False; // Information about files embedded inside .exe file FileLocator: TFileLocator; // Hooks into runtime library functions ResourceStringDomainListCS: TMultiReadExclusiveWriteSynchronizer; ResourceStringDomainList: TStringList; ComponentDomainListCS:TMultiReadExclusiveWriteSynchronizer; ComponentDomainList:TStringList; HookLoadResString: THook; HookLoadStr: THook; HookFmtLoadStr: THook; function GGGetEnvironmentVariable(const Name: WideString): WideString; var Len: integer; W: WideString; begin Result := ''; SetLength(W, 1); Len := GetEnvironmentVariableW(PWideChar(Name), PWideChar(W), 1); if Len > 0 then begin SetLength(Result, Len - 1); GetEnvironmentVariableW(PWideChar(Name), PWideChar(Result), Len); end; end; function StripCRRawMsgId(s: RawUtf8String): RawUtf8String; 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 EnsureLineBreakInTranslatedString(s: RawUtf8String): RawUtf8String; {$ifdef MSWINDOWS} var i: integer; {$endif} begin {$ifdef MSWINDOWS} Assert(sLinebreak = AnsiString(#13#10)); i := 1; while i <= length(s) do begin if (s[i] = #10) and (MidStr(s, i - 1, 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 Result := Assigned(Info) and (Info^.SetProc <> nil); end; function ResourceStringGettext(MsgId: MsgIdString): TranslatedUnicodeString; 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; function ComponentGettext(MsgId: MsgIdString; Instance: TGnuGettextInstance = nil): TranslatedUnicodeString; var i:integer; begin if (MsgID='') or (ComponentDomainListCS=nil) then begin // This only happens during very complicated program startups that fail, // or when Msgid='' Result:=MsgId; exit; end; ComponentDomainListCS.BeginRead; try for i:=0 to ComponentDomainList.Count-1 do begin if Assigned(Instance) then Result:=Instance.dgettext(ComponentDomainList.Strings[i], MsgId) else Result:=dgettext(ComponentDomainList.Strings[i], MsgId); if Result<>MsgId then break; end; finally ComponentDomainListCS.EndRead; end; end; function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString; begin Result := DefaultInstance.gettext(szMsgId); end; function gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString; begin // This one is very useful for translating text in variables. // This can sometimes be necessary, and by using this function, // the source code scanner will not trigger warnings. Result := gettext(szMsgId); end; function gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString; begin //*** With this function Strings can be added to the po-file without beeing // ResourceStrings (dxgettext will add the string and this function will // return it without a change) // see gettext manual // 4.7 - Special Cases of Translatable Strings // http://www.gnu.org/software/hello/manual/gettext/Special-cases.html#Special-cases Result := DefaultInstance.gettext_NoOp(szMsgId); end; {*------------------------------------------------------------------------------ This is the main translation procedure used in programs. It takes a parameter, looks it up in the translation dictionary, and returns the translation. If no translation is found, the parameter is returned. @param szMsgId The text, that should be displayed if no translation is found. -------------------------------------------------------------------------------} function _(const szMsgId: MsgIdString): TranslatedUnicodeString; begin Result := DefaultInstance.gettext(szMsgId); end; {*------------------------------------------------------------------------------ Translates a text, using a specified translation domain. If no translation is found, the parameter is returned. @param szDomain Which translation domain that should be searched for a translation. @param szMsgId The text, that should be displayed if no translation is found. -------------------------------------------------------------------------------} function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; begin Result := DefaultInstance.dgettext(szDomain, szMsgId); end; function dngettext(const szDomain: DomainString; const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString; begin Result := DefaultInstance.dngettext(szDomain, singular, plural, Number); end; function ngettext(const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString; begin Result := DefaultInstance.ngettext(singular, plural, Number); end; procedure textdomain(const szDomain: Domainstring); begin DefaultInstance.textdomain(szDomain); end; procedure SetGettextEnabled(Enabled: boolean); begin DefaultInstance.Enabled := Enabled; end; function getcurrenttextdomain: DomainString; begin Result := DefaultInstance.getcurrenttextdomain; end; procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString); begin DefaultInstance.bindtextdomain(szDomain, szDirectory); end; procedure TP_Ignore(AnObject: TObject; const Name: FilenameString); 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: ComponentNameString); begin DefaultInstance.TP_IgnoreClassProperty(IgnClass, propertyname); end; procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const propertyname: ComponentNameString); begin DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass, propertyname); end; procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator); begin DefaultInstance.TP_GlobalHandleClass(HClass, Handler); end; procedure TranslateComponent(AnObject: TComponent; const TextDomain: DomainString = ''); begin DefaultInstance.TranslateComponent(AnObject, TextDomain); end; procedure RetranslateComponent(AnObject: TComponent; const TextDomain: DomainString = ''); 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 GetWindowsLanguage: WideString; var langid: cardinal; langcode: WideString; CountryName: array[0..4] of widechar; LanguageName: array[0..4] of widechar; works: boolean; begin // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero works := 3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName)); works := works and (3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName, SizeOf(CountryName))); if works then begin // Windows 98, Me, NT4, 2000, XP and newer LangCode := PWideChar(@(LanguageName[0])); if lowercase(LangCode) = 'no' then LangCode := 'nb'; LangCode := LangCode + '_' + PWideChar(@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 := 'el_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} {$ifndef UNICODE} function LoadResStringA(ResStringRec: PResStringRec): ansistring; begin Result := DefaultInstance.LoadResString(ResStringRec); end; {$endif} function GetTranslatorNameAndEmail: TranslatedUnicodeString; begin Result := DefaultInstance.GetTranslatorNameAndEmail; end; procedure UseLanguage(LanguageCode: LanguageString); begin DefaultInstance.UseLanguage(LanguageCode); end; type PStrData = ^TStrData; TStrData = record Ident: integer; Str: string; end; function SysUtilsEnumStringModules(Instance: NativeInt; Data: Pointer): boolean; {$IFDEF MSWINDOWS} var Buffer: array [0..1023] of char; // WideChar in Delphi 2008, AnsiChar before that begin with PStrData(Data)^ do begin SetString(Str, Buffer, LoadString(Instance, Ident, @Buffer[0], 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): string; var StrData: TStrData; tmp :TEnumModuleFunc; begin StrData.Ident := Ident; StrData.Str := ''; tmp := SysUtilsEnumStringModules; EnumResourceModules(tmp, Pointer(@StrData)); Result := StrData.Str; end; function SysUtilsLoadStr(Ident: integer): string; 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): string; begin {$ifdef DXGETTEXTDEBUG} DefaultInstance.DebugWriteln ('Sysutils.FmtLoadRes('+IntToStr(ident)+',Args) called'); {$endif} FmtStr(Result, ResourceStringGettext(SysUtilsFindStringResource(Ident)), Args); end; function LoadResString(ResStringRec: PResStringRec): WideString; begin Result := DefaultInstance.LoadResString(ResStringRec); end; function LoadResStringW(ResStringRec: PResStringRec): UnicodeString; begin Result := DefaultInstance.LoadResString(ResStringRec); end; function GetCurrentLanguage: LanguageString; begin Result := DefaultInstance.GetCurrentLanguage; end; { TDomain } procedure TDomain.CloseMoFile; begin if mofile <> nil then begin FileLocator.ReleaseMoFile(mofile); mofile := nil; end; OpenHasFailedBefore := False; end; destructor TDomain.Destroy; begin CloseMoFile; inherited; end; {$ifdef mswindows} function GetLastWinError: WideString; var errcode: cardinal; begin SetLength(Result, 2000); errcode := GetLastError(); FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM, nil, errcode, 0, PWideChar(Result), 2000, nil); Result := PWideChar(Result); end; {$endif} procedure TDomain.OpenMoFile; var filename: FilenameString; 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 begin filename := SpecificFilename; {$ifdef DXGETTEXTDEBUG} DebugLogger ('Domain '+domain+' is bound to specific file '+filename); {$endif} end else begin filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin {$ifdef DXGETTEXTDEBUG} DebugLogger ('Domain '+domain+': File does not exist, neither embedded or in file system: '+filename); {$endif} filename := Directory + MidStr(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; {$ifdef DXGETTEXTDEBUG} DebugLogger ('Domain '+domain+' will attempt to use this file: '+filename); {$endif} end else begin {$ifdef DXGETTEXTDEBUG} if FileLocator.FileExists(filename) then DebugLogger ('Domain '+domain+' will attempt to use this embedded file: '+filename) else DebugLogger ('Domain '+domain+' will attempt to use this file that was found on the file system: '+filename); {$endif} end; end; if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin {$ifdef DXGETTEXTDEBUG} DebugLogger ('Domain '+domain+' failed to locate the file: '+filename); {$endif} OpenHasFailedBefore := True; exit; end; {$ifdef DXGETTEXTDEBUG} DebugLogger ('Domain '+domain+' now accesses the file.'); {$endif} 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 ('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.'); {$endif} {$ifdef MSWINDOWS} MessageBoxW(0, PWideChar(WideString('The translation for the language code ' + curlang + ' (in ' + filename + ') does not have charset=utf-8 in its Content-Type. Translations are turned off.')), 'Localization problem', MB_OK); {$else} writeln (stderr,'The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.'); {$endif} Enabled := False; end; end; {$IFDEF UNICODE} function utf8decode (s:RawByteString):UnicodeString; inline; begin Result:=UTF8ToWideString(s); end; {$endif} function TDomain.GetTranslationProperty( Propertyname: ComponentNameString): TranslatedUnicodeString; var sl: TStringList; i: integer; s: string; begin Propertyname := uppercase(Propertyname) + ': '; sl := TStringList.Create; try sl.Text := utf8decode(gettext('')); for i := 0 to sl.Count - 1 do begin s := sl.Strings[i]; if uppercase(MidStr(s, 1, length(Propertyname))) = Propertyname then begin Result := trim(MidStr(s, length(PropertyName) + 1, maxint)); {$ifdef DXGETTEXTDEBUG} DebugLogger ('GetTranslationProperty('+PropertyName+') returns '''+Result+'''.'); {$endif} exit; end; end; finally FreeAndNil(sl); end; Result := ''; {$ifdef DXGETTEXTDEBUG} DebugLogger ('GetTranslationProperty('+PropertyName+') did not find any value. An empty string is returned.'); {$endif} end; procedure TDomain.setDirectory(const dir: FilenameString); begin vDirectory := IncludeTrailingPathDelimiter(dir); SpecificFilename := ''; CloseMoFile; end; procedure AddDomainForResourceString(const domain: DomainString); 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: DomainString); 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 AddDomainForComponent (const domain:DomainString); begin {$ifdef DXGETTEXTDEBUG} DefaultInstance.DebugWriteln ('Extra domain for component: '+domain); {$endif} ComponentDomainListCS.BeginWrite; try if ComponentDomainList.IndexOf(domain)=-1 then ComponentDomainList.Add (domain); finally ComponentDomainListCS.EndWrite; end; end; procedure RemoveDomainForComponent (const domain:DomainString); var i:integer; begin {$ifdef DXGETTEXTDEBUG} DefaultInstance.DebugWriteln ('Remove domain for component: '+domain); {$endif} ComponentDomainListCS.BeginWrite; try i:=ComponentDomainList.IndexOf(domain); if i<>-1 then ComponentDomainList.Delete (i); finally ComponentDomainListCS.EndWrite; end; end; procedure TDomain.SetLanguageCode(const langcode: LanguageString); 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 Number = 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 GetPluralForm3SK(Number: integer): integer; begin Number := abs(Number); if number = 1 then Result := 0 else if (number < 5) and (number <> 0) 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: FilenameString; langcode: LanguageString; 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]; path := Directory; {$ifdef MSWINDOWS} path := uppercase(path); filename := uppercase(filename); {$endif} j := length(path); if MidStr(filename, 1, j) = path then begin path := PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; {$ifdef MSWINDOWS} path := uppercase(path); {$endif} if MidStr(filename, length(filename) - length(path) + 1, length(path)) = path then begin langcode := lowercase(MidStr(filename, j + 1, length(filename) - length(path) - j)); langcode := LeftStr(langcode, 3) + uppercase(MidStr(langcode, 4, maxint)); if list.IndexOf(langcode) = -1 then list.Add(langcode); end; end; end; end; procedure TDomain.SetFilename(const filename: FilenameString); begin CloseMoFile; vDirectory := ''; SpecificFilename := filename; end; function TDomain.gettext(const msgid: RawUtf8String): RawUtf8String; 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: DomainString; const szDirectory: FilenameString); var dir: FilenameString; 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 CreatorThread := GetCurrentThreadId; {$ifdef MSWindows} DesignTimeCodePage := CP_ACP; {$endif} {$ifdef DXGETTEXTDEBUG} DebugLogCS:=TMultiReadExclusiveWriteSynchronizer.Create; DebugLog:=TMemoryStream.Create; DebugWriteln('Debug log started '+DateTimeToStr(Now)); DebugWriteln('GNU gettext module version: '+VCSVersion); DebugWriteln(''); {$endif} curGetPluralForm := GetPluralForm2EN; Enabled := True; curmsgdomain := DefaultTextDomain; savefileCS := TMultiReadExclusiveWriteSynchronizer.Create; domainlist := TStringList.Create; TP_IgnoreList := TStringList.Create; TP_IgnoreList.Sorted := True; TP_GlobalClassHandling := TList.Create; TP_ClassHandling := TList.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; begin if savememory <> nil then begin savefileCS.BeginWrite; try CloseFile(savefile); finally savefileCS.EndWrite; end; FreeAndNil(savememory); end; FreeAndNil(savefileCS); FreeAndNil(TP_IgnoreList); while TP_GlobalClassHandling.Count <> 0 do begin TObject(TP_GlobalClassHandling.Items[0]).Free; TP_GlobalClassHandling.Delete(0); end; FreeAndNil(TP_GlobalClassHandling); FreeTP_ClassHandlingItems; FreeAndNil(TP_ClassHandling); while domainlist.Count <> 0 do begin domainlist.Objects[0].Free; domainlist.Delete(0); end; FreeAndNil(domainlist); {$ifdef DXGETTEXTDEBUG} FreeAndNil (DebugLog); FreeAndNil (DebugLogCS); {$endif} inherited; end; {$ifndef UNICODE} function TGnuGettextInstance.dgettext(const szDomain: DomainString; const szMsgId: ansistring): TranslatedUnicodeString; begin Result := dgettext(szDomain, ansi2wideDTCP(szMsgId)); end; {$endif} function TGnuGettextInstance.dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; 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(EnsureLineBreakInTranslatedString( getdomain(szDomain, DefaultDomainDirectory, CurLang).gettext( StripCRRawMsgId(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.dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; begin // This one is very useful for translating text in variables. // This can sometimes be necessary, and by using this function, // the source code scanner will not trigger warnings. Result := dgettext(szDomain, szMsgId); end; function TGnuGettextInstance.GetCurrentLanguage: LanguageString; begin Result := curlang; end; function TGnuGettextInstance.getcurrenttextdomain: DomainString; begin Result := curmsgdomain; end; {$ifndef UNICODE} function TGnuGettextInstance.gettext( const szMsgId: ansistring): TranslatedUnicodeString; begin Result := dgettext(curmsgdomain, szMsgId); end; {$endif} function TGnuGettextInstance.gettext( const szMsgId: MsgIdString): TranslatedUnicodeString; begin Result := dgettext(curmsgdomain, szMsgId); end; function TGnuGettextInstance.gettext_NoExtract( const szMsgId: MsgIdString): TranslatedUnicodeString; begin // This one is very useful for translating text in variables. // This can sometimes be necessary, and by using this function, // the source code scanner will not trigger warnings. Result:=gettext (szMsgId); end; function TGnuGettextInstance.gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString; begin //*** With this function Strings can be added to the po-file without beeing // ResourceStrings (dxgettext will add the string and this function will // return it without a change) // see gettext manual // 4.7 - Special Cases of Translatable Strings // http://www.gnu.org/software/hello/manual/gettext/Special-cases.html#Special-cases Result := TranslatedUnicodeString(szMsgId); end; procedure TGnuGettextInstance.textdomain(const szDomain: DomainString); 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 := TObject(TP_GlobalClassHandling.Items[i]) as TClassMode; 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 := TObject(TP_GlobalClassHandling.Items[i]) as TClassMode; 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; propertyname: ComponentNameString); var cm: TClassMode; i, idx: integer; begin propertyname := uppercase(propertyname); for i := 0 to TP_GlobalClassHandling.Count - 1 do begin cm := TObject(TP_GlobalClassHandling.Items[i]) as TClassMode; 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: ComponentNameString); begin TP_IgnoreList.Add(uppercase(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: DomainString); 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); {$else} 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; procedure TGnuGettextInstance.TranslateProperty(AnObject: TObject; PropInfo: PPropInfo; TodoList: TStrings; const TextDomain: DomainString); var ppi: PPropInfo; ws: TranslatedUnicodeString; old: TranslatedUnicodeString; compmarker: TComponent; obj: TObject; Propname: ComponentNameString; begin PropName := string(PropInfo^.Name); try // Translate certain types of properties case PropInfo^.PropType^.Kind of {$IFDEF UNICODE} // All dfm files returning tkUString tkString, tkLString, tkWString, tkUString: {$ELSE} tkString, tkLString, tkWString: {$ENDIF} begin {$ifdef DXGETTEXTDEBUG} DebugWriteln ('Translating '+AnObject.ClassName+'.'+PropName); {$endif} case PropInfo^.PropType^.Kind of tkString, tkLString: old := GetStrProp(AnObject, PropName); tkWString: old := GetStrProp(AnObject, PropName); tkUString : old := GetStrProp(AnObject, PropName); else raise Exception.Create( 'Internal error: Illegal property type. This problem needs to be solved by a programmer, try to find a workaround.'); end; {$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 (TP_Retranslator as TTP_Retranslator).Remember(AnObject, PropName, old); if textdomain = '' then ws := ComponentGettext(old) else ws := dgettext(textdomain, old); if ws <> old then begin 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; end; end; end { case item }; tkClass: begin obj := GetObjectProp(AnObject, PropName); if obj <> nil then begin if obj is TComponent then begin compmarker := TComponent(obj).FindComponent('GNUgettextMarker'); if Assigned(compmarker) then exit; end; TodoList.AddObject('', obj); end; 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; procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; textdomain: DomainString = ''); 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: ComponentNameString; PropInfo: PPropInfo; compmarker, comp: TComponent; cm, currentcm: TClassMode; // currentcm is nil or contains special information about how to handle the current object ObjectPropertyIgnoreList: TStringList; objid: string; Name: ComponentNameString; begin {$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 (TP_Retranslator as TTP_Retranslator).TextDomain := textdomain; {$ifdef FPC} DoneList:=TCSStringList.Create; TodoList:=TCSStringList.Create; ObjectPropertyIgnoreList:=TCSStringList.Create; {$else} DoneList := TStringList.Create; TodoList := TStringList.Create; ObjectPropertyIgnoreList := TStringList.Create; {$endif} try TodoList.AddObject('', AnObject); DoneList.Sorted := True; ObjectPropertyIgnoreList.Sorted := True; ObjectPropertyIgnoreList.Duplicates := dupIgnore; ObjectPropertyIgnoreList.CaseSensitive := False; DoneList.Duplicates := dupError; DoneList.CaseSensitive := True; 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 := TObject(TP_ClassHandling.Items[j]) as TClassMode; 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 := TObject(TP_GlobalClassHandling.Items[j]) as TClassMode; 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]; {$IFDEF UNICODE} if not (PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString, tkClass, tkUString]) then {$ELSE} if not (PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString, tkClass]) then {$ENDIF} continue; UPropName := uppercase(string(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 ((AnObject as TStrings).Text <> '') and (TP_Retranslator <> nil) then (TP_Retranslator as TTP_Retranslator).Remember(AnObject, 'Text', (AnObject as TStrings).Text); TranslateStrings(AnObject as TStrings, TextDomain); end; // Check for TCollection if AnObject is TCollection then begin for i := 0 to (AnObject as TCollection).Count - 1 do begin // Only add the object if it's not totally ignored already if not Assigned(currentcm) or not AnObject.InheritsFrom( currentcm.HClass) then TodoList.AddObject('', (AnObject as TCollection).Items[i]); end; 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(uppercase(comp.Name), j)) then begin // Only add the object if it's not totally ignored or translated already if not Assigned(currentcm) or not AnObject.InheritsFrom(currentcm.HClass) then begin compmarker := comp.FindComponent('GNUgettextMarker'); if not Assigned(compmarker) then TodoList.AddObject(uppercase(comp.Name), comp); end; end; end; end; end { if AnObject<>nil }; end { while todolist.count<>0 }; finally FreeAndNil(todolist); FreeAndNil(ObjectPropertyIgnoreList); FreeAndNil(DoneList); end; FreeTP_ClassHandlingItems; TP_IgnoreList.Clear; TP_Retranslator := nil; {$ifdef DXGETTEXTDEBUG} DebugWriteln ('----------------------------------------------------------------------'); {$endif} end; procedure TGnuGettextInstance.UseLanguage(LanguageCode: LanguageString); var i, p: integer; dom: TDomain; l2: string; begin {$ifdef DXGETTEXTDEBUG} DebugWriteln('UseLanguage('''+LanguageCode+'''); called'); {$endif} if LanguageCode = '' then begin LanguageCode := GGGetEnvironmentVariable('LANG'); {$ifdef DXGETTEXTDEBUG} DebugWriteln ('LANG env variable is '''+LanguageCode+'''.'); {$endif} {$ifdef MSWINDOWS} if LanguageCode = '' then begin LanguageCode := GetWindowsLanguage; {$ifdef DXGETTEXTDEBUG} DebugWriteln ('Found Windows language code to be '''+LanguageCode+'''.'); {$endif} end; {$endif} p := pos('.', LanguageCode); if p <> 0 then LanguageCode := LeftStr(LanguageCode, p - 1); {$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 := domainlist.Objects[i] as TDomain; dom.SetLanguageCode(curlang); end; l2 := lowercase(LeftStr(curlang, 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 = 'uk') or (l2 = 'hr') then curGetPluralForm := GetPluralForm3RU else if (l2 = 'cs') or (l2 = 'sk') then curGetPluralForm := GetPluralForm3SK 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: DomainString); var line: string; i: integer; s:TStringList; slAsTStringList:TStringList; begin if sl.Count > 0 then begin sl.BeginUpdate; try s := TStringList.Create; try s.Assign(sl); for i := 0 to s.Count - 1 do begin line := s.Strings[i]; if line <> '' then s.Strings[i] := dgettext(TextDomain, line); end; sl.Assign(s); finally FreeAndNil(s); end; finally sl.EndUpdate; end; end; end; function TGnuGettextInstance.GetTranslatorNameAndEmail: TranslatedUnicodeString; begin Result := GetTranslationProperty('LAST-TRANSLATOR'); end; function TGnuGettextInstance.GetTranslationProperty( const Propertyname: ComponentNameString): TranslatedUnicodeString; begin Result := getdomain(curmsgdomain, DefaultDomainDirectory, CurLang).GetTranslationProperty(Propertyname); end; function TGnuGettextInstance.dngettext(const szDomain: DomainString; const singular, plural: MsgIdString; Number: integer): TranslatedUnicodeString; var org: MsgIdString; trans: TranslatedUnicodeString; 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, 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 := LeftStr(trans, p - 1); exit; end; Delete(trans, 1, p); Dec(idx); end; end; function TGnuGettextInstance.dngettext_NoExtract(const szDomain: DomainString; const singular, plural: MsgIdString; Number: integer): TranslatedUnicodeString; begin // This one is very useful for translating text in variables. // This can sometimes be necessary, and by using this function, // the source code scanner will not trigger warnings. Result := dngettext(szDomain, singular, plural, Number); end; {$ifndef UNICODE} function TGnuGettextInstance.ngettext(const singular, plural: ansistring; Number: integer): TranslatedUnicodeString; begin Result := dngettext(curmsgdomain, singular, plural, Number); end; {$endif} function TGnuGettextInstance.ngettext(const singular, plural: MsgIdString; Number: integer): TranslatedUnicodeString; begin Result := dngettext(curmsgdomain, singular, plural, Number); end; function TGnuGettextInstance.ngettext_NoExtract(const singular, plural: MsgIdString; Number: integer): TranslatedUnicodeString; begin // This one is very useful for translating text in variables. // This can sometimes be necessary, and by using this function, // the source code scanner will not trigger warnings. Result := ngettext(singular, plural, Number); end; procedure TGnuGettextInstance.WhenNewDomain(const TextDomain: DomainString); begin // This is meant to be empty. end; procedure TGnuGettextInstance.WhenNewLanguage(const LanguageID: LanguageString); begin // This is meant to be empty. end; procedure TGnuGettextInstance.WhenNewDomainDirectory(const TextDomain: DomainString; const Directory: FilenameString); begin // This is meant to be empty. end; procedure TGnuGettextInstance.GetListOfLanguages(const domain: DomainString; list: TStrings); begin getdomain(Domain, DefaultDomainDirectory, CurLang).GetListOfLanguages(list); end; procedure TGnuGettextInstance.bindtextdomainToFile(const szDomain: DomainString; const filename: FilenameString); 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 {$ifdef DXGETTEXTDEBUG} DebugLogOutputPaused:=PauseEnabled; {$endif} end; procedure TGnuGettextInstance.DebugLogToFile(const filename: FilenameString; append: boolean = False); {$ifdef DXGETTEXTDEBUG} var fs:TFileStream; marker:ansistring; {$endif} begin {$ifdef DXGETTEXTDEBUG} // Creates 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; // Copy the memorystream contents to the file DebugLog.Seek(0,soFromBeginning); fs.CopyFrom(DebugLog,0); // Make DebugLog point to the filestream FreeAndNil (DebugLog); DebugLog:=fs; {$endif} end; {$ifdef DXGETTEXTDEBUG} 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; {$endif} function TGnuGettextInstance.Getdomain(const domain: DomainString; const DefaultDomainDirectory: FilenameString; const CurLang: LanguageString): 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; {$ifdef DXGETTEXTDEBUG} Result.DebugLogger:=DebugWriteln; {$endif} Result.Domain := Domain; Result.Directory := DefaultDomainDirectory; Result.SetLanguageCode(curlang); domainlist.AddObject(Domain, Result); end else begin Result := domainlist.Objects[idx] as TDomain; end; end; function TGnuGettextInstance.LoadResString(ResStringRec: PResStringRec): UnicodeString; {$ifdef MSWINDOWS} var Len: integer; {$IFDEF UNICODE} Buffer: array [0..1023] of widechar; {$else} Buffer: array [0..1023] of ansichar; {$endif} {$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 then exit; if ResStringRec.Identifier >= 64 * 1024 then begin {$ifdef DXGETTEXTDEBUG} DebugWriteln ('LoadResString was given an invalid ResStringRec.Identifier'); {$endif} Result := 'ERROR'; 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, PAnsiChar(ResStringRec^.Identifier div ResStringTableLen), PAnsiChar(6)); // RT_STRING Tab:=Pointer(LoadResource(ResMod, Handle)); if Tab=nil then Result:='' else Result:=PWideChar(PAnsiChar(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 Length(Result) <= Len + 1 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; procedure TGnuGettextInstance.RetranslateComponent(AnObject: TComponent; const TextDomain: DomainString); 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 := TObject(TP_ClassHandling.Items[i]) as TClassMode; 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; propertyname: ComponentNameString); var cm: TClassMode; i: integer; begin propertyname := uppercase(propertyname); for i := 0 to TP_ClassHandling.Count - 1 do begin cm := TObject(TP_ClassHandling.Items[i]) as TClassMode; 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; procedure TGnuGettextInstance.FreeTP_ClassHandlingItems; begin while TP_ClassHandling.Count <> 0 do begin TObject(TP_ClassHandling.Items[0]).Free; TP_ClassHandling.Delete(0); end; end; {$ifndef UNICODE} function TGnuGettextInstance.ansi2wideDTCP(const s: ansistring): MsgIdString; {$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, pansichar(s), len, pwidechar(Result), len); if len = 0 then raise EGGAnsi2WideConvError.Create( 'Cannot convert string to widestring:' + sLineBreak + s); SetLength(Result, len); end; end; {$endif} end; {$endif} {$ifndef UNICODE} function TGnuGettextInstance.dngettext(const szDomain: DomainString; const singular, plural: ansistring; Number: integer): TranslatedUnicodeString; begin Result := dngettext(szDomain, ansi2wideDTCP(singular), ansi2wideDTCP(plural), Number); end; {$endif} { TClassMode } constructor TClassMode.Create; begin PropertiesToIgnore := TStringList.Create; PropertiesToIgnore.Sorted := True; PropertiesToIgnore.Duplicates := dupError; PropertiesToIgnore.CaseSensitive := False; end; destructor TClassMode.Destroy; begin FreeAndNil(PropertiesToIgnore); inherited; end; { TFileLocator } function TFileLocator.FindSignaturePos(const signature: RawByteString; str: TFileStream): Int64; // Finds the position of signature in the file. const bufsize=100000; var a:RawByteString; b:RawByteString; offset:integer; rd,p:Integer; begin if signature='' then begin Result := 0; Exit; end; offset:=0; str.Seek(0, soFromBeginning); SetLength (a, bufsize); SetLength (b, bufsize); str.Read(a[1],bufsize); while true do begin rd:=str.Read(b[1],bufsize); p:=pos(signature,a+b); if (p<>0) then begin // do not check p < bufsize+100 here! Result:=offset+p-1; exit; end; if rd<>bufsize then begin // Prematurely ended without finding anything Result:=0; exit; end; a:=b; offset:=offset+bufsize; end; Result:=0; end; procedure TFileLocator.Analyze; var s: ansistring; i: integer; offset: int64; fs: TFileStream; fi: TEmbeddedFileInfo; filename: FilenameString; filename8bit: ansistring; begin s := '6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0; s := MidStr(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(filename8bit, offset - fs.position); fs.ReadBuffer(filename8bit[1], offset - fs.position); filename := trim(string(filename8bit)); if PreferExternal and SysUtils.fileexists(basedirectory + filename) then begin // Disregard the internal version and use the external version instead FreeAndNil(fi); end else filelist.AddObject(filename, fi); except FreeAndNil(fi); raise; end; end; finally FreeAndNil(fs); end; except {$ifdef DXGETTEXTDEBUG} raise; {$endif} end; end; constructor TFileLocator.Create; begin MoFilesCS := TMultiReadExclusiveWriteSynchronizer.Create; MoFiles := TStringList.Create; filelist := TStringList.Create; {$ifdef LINUX} filelist.Duplicates:=dupError; filelist.CaseSensitive:=True; {$endif} MoFiles.Sorted := True; MoFiles.Duplicates := dupError; MoFiles.CaseSensitive := False; {$ifdef MSWINDOWS} filelist.Duplicates := dupError; filelist.CaseSensitive := False; {$endif} filelist.Sorted := True; end; destructor TFileLocator.Destroy; begin while filelist.Count <> 0 do begin filelist.Objects[0].Free; filelist.Delete(0); end; FreeAndNil(filelist); FreeAndNil(MoFiles); FreeAndNil(MoFilesCS); inherited; end; function TFileLocator.FileExists(filename: FilenameString): boolean; var idx: integer; begin if LeftStr(filename, length(basedirectory)) = basedirectory then begin // Cut off basedirectory if the file is located beneath that base directory filename := MidStr(filename, length(basedirectory) + 1, maxint); end; Result := filelist.Find(filename, idx); end; function TFileLocator.GetMoFile(filename: FilenameString; DebugLogger: TDebugLogger): TMoFile; var fi: TEmbeddedFileInfo; idx: integer; idxname: FilenameString; Offset, Size: int64; realfilename: FilenameString; begin // Find real filename offset := 0; size := 0; realfilename := filename; if LeftStr(filename, length(basedirectory)) = basedirectory then begin filename := MidStr(filename, length(basedirectory) + 1, maxint); idx := filelist.IndexOf(filename); if idx <> -1 then begin fi := filelist.Objects[idx] as TEmbeddedFileInfo; 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 + ' //\\ ' + IntToStr(offset); if MoFiles.Find(idxname, idx) then begin Result := MoFiles.Objects[idx] as TMoFile; end else begin Result:=TMoFile.Create (realfilename, Offset, Size, UseMemoryMappedFiles); 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(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 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; FreeAndNil(list); inherited; end; procedure TTP_Retranslator.Execute; var i: integer; sl: TStrings; item: TTP_RetranslatorItem; newvalue: TranslatedUnicodeString; comp: TGnuGettextComponentMarker; ppi: PPropInfo; begin for i := 0 to list.Count - 1 do begin item := TObject(list.items[i]) as TTP_RetranslatorItem; if item.obj is TComponent then begin comp := TComponent(item.obj).FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker; if Assigned(comp) and (self <> comp.Retranslator) then begin comp.Retranslator.Execute; Continue; end; end; 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); (item.obj as TStrings).BeginUpdate; try (item.obj as TStrings).Text := sl.Text; finally (item.obj as TStrings).EndUpdate; end; finally FreeAndNil(sl); end; end else begin if (textdomain = '') or (textdomain = DefaultTextDomain) then newValue := ComponentGettext(item.OldValue, instance) else newValue := instance.dgettext(textdomain,item.OldValue); 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; end; end; end; procedure TTP_Retranslator.Remember(obj: TObject; PropName: ComponentNameString; OldValue: TranslatedUnicodeString); 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 FreeAndNil(Retranslator); inherited; end; { 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 {$ifndef CPU386} raise Exception.Create( 'This procedure only works on Intel i386 compatible processors.'); {$endif} oldproc := OldProcedure; newproc := NewProcedure; Reset(FollowJump); end; destructor THook.Destroy; begin Shutdown; inherited; 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 := patchPosition + 2; patchPosition := pansiChar(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; { TMoFile } function TMoFile.autoswap32(i: cardinal): cardinal; var cnv1, cnv2: record case integer of 0: (arr: array[0..3] of byte); 1: (int: cardinal); end; begin if doswap then begin cnv1.int := i; cnv2.arr[0] := cnv1.arr[3]; cnv2.arr[1] := cnv1.arr[2]; cnv2.arr[2] := cnv1.arr[1]; cnv2.arr[3] := cnv1.arr[0]; Result := cnv2.int; end else Result := i; end; function TMoFile.CardinalInMem(baseptr: PansiChar; Offset: cardinal): cardinal; var pc: ^cardinal; begin Inc(baseptr, offset); pc := Pointer(baseptr); Result := pc^; if doswap then autoswap32(Result); end; constructor TMoFile.Create(const filename: FilenameString; const Offset: int64; Size: int64; const xUseMemoryMappedFiles: Boolean); var i:cardinal; nn:integer; mofile:TFileStream; begin if sizeof(i) <> 4 then raise EGGProgrammingError.Create('TDomain in gnugettext is written for an architecture that has 32 bit integers.'); {$ifdef mswindows} FUseMemoryMappedFiles := xUseMemoryMappedFiles; {$endif} {$ifdef linux} FUseMemoryMappedFiles := False; {$endif} if FUseMemoryMappedFiles then begin // Map the mo file into memory and let the operating system decide how to cache mo:=createfile (PChar(filename),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0); if mo=INVALID_HANDLE_VALUE then raise EGGIOError.Create ('Cannot open file '+filename); momapping:=CreateFileMapping (mo, nil, PAGE_READONLY, 0, 0, nil); if momapping=0 then raise EGGIOError.Create ('Cannot create memory map on file '+filename); momemoryHandle:=MapViewOfFile (momapping,FILE_MAP_READ,0,0,0); if momemoryHandle=nil then begin raise EGGIOError.Create ('Cannot map file '+filename+' into memory. Reason: '+GetLastWinError); end; momemory:=momemoryHandle+offset; end else begin // Read the whole file into memory mofile:=TFileStream.Create (filename, fmOpenRead or fmShareDenyNone); try if (size = 0) then size := mofile.Size; Getmem (momemoryHandle, size); momemory := momemoryHandle; mofile.Seek(offset, soBeginning); mofile.ReadBuffer(momemory^, size); finally FreeAndNil(mofile); end; end; // Check the magic number doswap := False; i := CardinalInMem(momemory, 0); if (i <> $950412DE) and (i <> $DE120495) then raise 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(momemory, 4); // Read the version number, but don't use it for anything. N := CardinalInMem(momemory, 8); // Get string count O := CardinalInMem(momemory, 12); // Get offset of original strings T := CardinalInMem(momemory, 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; destructor TMoFile.Destroy; begin if FUseMemoryMappedFiles then begin UnMapViewOfFile (momemoryHandle); CloseHandle (momapping); CloseHandle (mo); end else begin FreeMem (momemoryHandle); end; inherited; end; function TMoFile.gettext(const msgid: RawUtf8String; var found: boolean): RawUtf8String; var i, step: cardinal; offset, pos: cardinal; CompareResult: integer; msgidptr, a, b: PAnsiChar; abidx: integer; size, msgidsize: integer; begin found := False; msgidptr := PAnsiChar(msgid); 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(momemory, pos + 4); size := CardinalInMem(momemory, pos); a := msgidptr; b := momemory + offset; abidx := size; if msgidsize < abidx then abidx := msgidsize; CompareResult := 0; while abidx <> 0 do begin CompareResult := integer(byte(a^)) - integer(byte(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(momemory, pos + 4); size := CardinalInMem(momemory, pos); SetString(Result, momemory + offset, size); 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; var param0: string; initialization {$ifdef DXGETTEXTDEBUG} {$ifdef MSWINDOWS} MessageBox (0,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.','Information',MB_OK); {$endif} {$ifdef LINUX} writeln (stderr,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.'); {$endif} {$endif} {$ifdef FPC} {$ifdef LINUX} SetLocale(LC_ALL, ''); SetCWidestringManager; {$endif LINUX} {$endif FPC} // Get DLL/shared object filename SetLength(ExecutableFilename, 300); // MAX_PATH ? {$ifdef MSWINDOWS} SetLength(ExecutableFilename, GetModuleFileName(HInstance, PChar(ExecutableFilename), Length(ExecutableFilename))); {$endif} {$ifdef LINUX} if ModuleIsLib or ModuleIsPackage then begin // This line has not been tested on Linux, yet, but should work. SetLength(ExecutableFilename, GetModuleFileName(0, PChar(ExecutableFilename), Length(ExecutableFilename))); end else ExecutableFilename:=Paramstr(0); {$endif} FileLocator:=TFileLocator.Create; FileLocator.Analyze; ResourceStringDomainList := TStringList.Create; ResourceStringDomainList.Add(DefaultTextDomain); ResourceStringDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create; ComponentDomainList:=TStringList.Create; ComponentDomainList.Add(DefaultTextDomain); ComponentDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create; DefaultInstance:=TGnuGettextInstance.Create; {$ifdef MSWINDOWS} Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT); {$endif} // replace Borlands LoadResString with gettext enabled version: {$ifdef UNICODE} HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringW); {$else} HookLoadResString := THook.Create(@system.LoadResString, @LoadResStringA); {$endif} HookLoadStr := THook.Create(@SysUtils.LoadStr, @SysUtilsLoadStr); HookFmtLoadStr := THook.Create(@SysUtils.FmtLoadStr, @SysUtilsFmtLoadStr); param0 := lowercase(extractfilename(ParamStr(0))); if (param0 <> 'delphi32.exe') and (param0 <> 'kylix') and (param0 <> 'bds.exe') then HookIntoResourceStrings(AutoCreateHooks, False); param0 := ''; finalization FreeAndNil (DefaultInstance); FreeAndNil (ResourceStringDomainListCS); FreeAndNil (ResourceStringDomainList); FreeAndNil (ComponentDomainListCS); FreeAndNil (ComponentDomainList); FreeAndNil (HookFmtLoadStr); FreeAndNil (HookLoadStr); FreeAndNil (HookLoadResString); FreeAndNil (FileLocator); end.