|
|
@@ -0,0 +1,3910 @@
|
|
|
+{ *------------------------------------------------------------------------------
|
|
|
+ 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
|
|
|
+ ------------------------------------------------------------------------------- }
|
|
|
+unit gnugettext;
|
|
|
+(* ************************************************************ *)
|
|
|
+(* *)
|
|
|
+(* (C) Copyright by Lars B. Dybdahl and others *)
|
|
|
+(* E-mail: [email protected], phone +45 70201241 *)
|
|
|
+(* *)
|
|
|
+(* Contributors: Peter Thornqvist, Troy Wolbrink, *)
|
|
|
+(* Frank Andreas de Groot, Igor Siticov, *)
|
|
|
+(* Jacques Garcia Vazquez, Igor Gitman, *)
|
|
|
+(* Arvid Winkelsdorf *)
|
|
|
+(* *)
|
|
|
+(* See http://dybdahl.dk/dxgettext/ for more information *)
|
|
|
+(* *)
|
|
|
+(* ************************************************************ *)
|
|
|
+
|
|
|
+// Changes J. Rathlev (kontakt(a)rathlev-home.de)
|
|
|
+// see: JR - 2011-07-29 / 2012-09-10
|
|
|
+// All Delphi version related compiler switches removed - needs at least Delphi XE2
|
|
|
+// GetWindowsLanguage uses GetUserPreferredUILanguages (Sept. 2023)
|
|
|
+
|
|
|
+// Information about this file:
|
|
|
+// $LastChangedDate: 2024-08-24 $
|
|
|
+
|
|
|
+// 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 }
|
|
|
+
|
|
|
+uses
|
|
|
+{$IFDEF MSWINDOWS}
|
|
|
+ Winapi.Windows,
|
|
|
+{$ELSE}
|
|
|
+ Libc,
|
|
|
+{$IFDEF FPC}
|
|
|
+ CWString,
|
|
|
+{$ENDIF}
|
|
|
+{$ENDIF}
|
|
|
+ System.Classes, System.StrUtils, System.SysUtils, System.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 gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString;
|
|
|
+function gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString;
|
|
|
+function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString)
|
|
|
+ : TranslatedUnicodeString;
|
|
|
+function dgettext_NoExtract(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;
|
|
|
+function ngettext_NoExtract(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);
|
|
|
+procedure AddDomains(const Domains: array of 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 = True;
|
|
|
+ // 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: 220 $';
|
|
|
+
|
|
|
+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 *)
|
|
|
+(* *)
|
|
|
+(* *************************************************************************** *)
|
|
|
+
|
|
|
+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;
|
|
|
+
|
|
|
+ { *------------------------------------------------------------------------------
|
|
|
+ Interface to implement if you want to register as a language change listener
|
|
|
+ ------------------------------------------------------------------------------- }
|
|
|
+ IGnuGettextInstanceWhenNewLanguageListener = interface
|
|
|
+ procedure WhenNewLanguage(const LanguageID: LanguageString);
|
|
|
+ end;
|
|
|
+
|
|
|
+ { *------------------------------------------------------------------------------
|
|
|
+ The main translation engine.
|
|
|
+ ------------------------------------------------------------------------------- }
|
|
|
+ TGnuGettextInstance = class
|
|
|
+ private
|
|
|
+ fOnDebugLine: TOnDebugLine;
|
|
|
+ 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}
|
|
|
+ procedure RegisterWhenNewLanguageListener
|
|
|
+ (Listener: IGnuGettextInstanceWhenNewLanguageListener);
|
|
|
+ procedure UnregisterWhenNewLanguageListener
|
|
|
+ (Listener: IGnuGettextInstanceWhenNewLanguageListener);
|
|
|
+ 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;
|
|
|
+
|
|
|
+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 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 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;
|
|
|
+
|
|
|
+ function ngettext_NoExtract(const singular, plural: MsgIdString;
|
|
|
+ Number: longint): 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 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, N, pc: Cardinal;
|
|
|
+ buf: array of Char;
|
|
|
+ langcode: WideString;
|
|
|
+ CountryName: array [0 .. 4] of widechar;
|
|
|
+ LanguageName: array [0 .. 4] of widechar;
|
|
|
+ works: boolean;
|
|
|
+ begin
|
|
|
+ if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 6)
|
|
|
+ then
|
|
|
+ begin
|
|
|
+ pc := 0; // Retrieve the UI language (not the localeinfo) JR - Sept. 2023
|
|
|
+ works := GetUserPreferredUILanguages(MUI_LANGUAGE_NAME, @N, nil,
|
|
|
+ @pc); // available since Vista
|
|
|
+ if works then
|
|
|
+ begin
|
|
|
+ SetLength(buf, pc);
|
|
|
+ works := GetUserPreferredUILanguages(MUI_LANGUAGE_NAME, @N,
|
|
|
+ @buf[0], @pc);
|
|
|
+ if works then
|
|
|
+ langcode := ReplaceStr(PChar(@buf[0]), '-', '_');
|
|
|
+ buf := nil;
|
|
|
+ end;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin // XP and older
|
|
|
+ // 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;
|
|
|
+ end;
|
|
|
+ if not works then
|
|
|
+ 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: HINST;
|
|
|
+ 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: NativeInt): string;
|
|
|
+ var
|
|
|
+ StrData: TStrData;
|
|
|
+ begin
|
|
|
+ StrData.Ident := Ident;
|
|
|
+ StrData.str := '';
|
|
|
+ EnumResourceModules(SysUtilsEnumStringModules, @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 AddDomains(const Domains: array of DomainString);
|
|
|
+ var
|
|
|
+ i: Integer;
|
|
|
+ begin
|
|
|
+ for i := 0 to High(Domains) do
|
|
|
+ AddDomainForResourceString(Domains[i]);
|
|
|
+ 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
|
|
|
+{$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;
|
|
|
+ fWhenNewLanguageListeners := TInterfaceList.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);
|
|
|
+ fWhenNewLanguageListeners.Free;
|
|
|
+{$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
|
|
|
+ // prevent items in RadioGroup from duplicate translation - JR - 2011-07-29
|
|
|
+ if AnObject.ClassName = 'TGroupButton' then
|
|
|
+ exit;
|
|
|
+{$IFDEF DXGETTEXTDEBUG}
|
|
|
+ if AnObject is TComponent then
|
|
|
+ DebugWriteln('Translating ' + AnObject.ClassName + '.' +
|
|
|
+ Propname + ' (' + TComponent(AnObject).name + ')')
|
|
|
+ else
|
|
|
+ DebugWriteln('Translating ' + AnObject.ClassName + '.' +
|
|
|
+ Propname);;
|
|
|
+{$ENDIF}
|
|
|
+ case PropInfo^.PropType^.Kind of
|
|
|
+ tkString, tkLString:
|
|
|
+ old := GetStrProp(AnObject, Propname);
|
|
|
+ tkWString:
|
|
|
+ old := GetWideStrProp(AnObject, Propname);
|
|
|
+{$IFDEF UNICODE}
|
|
|
+ tkUString:
|
|
|
+ old := GetUnicodeStrProp(AnObject, Propname);
|
|
|
+{$ENDIF}
|
|
|
+ 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 TP_Retranslator <> nil then
|
|
|
+ if textdomain = '' then
|
|
|
+ (TP_Retranslator as TTP_Retranslator).textdomain := curmsgdomain
|
|
|
+ else
|
|
|
+ (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({$IFDEF CPUx64}NativeInt{$ELSE}Integer{$ENDIF CPUx64}) = SizeOf(TObject));
|
|
|
+ objid := IntToHex
|
|
|
+ ({$IFDEF CPUx64}NativeInt{$ELSE}Integer{$ENDIF CPUx64}(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.UnregisterWhenNewLanguageListener
|
|
|
+ (Listener: IGnuGettextInstanceWhenNewLanguageListener);
|
|
|
+ begin
|
|
|
+ fWhenNewLanguageListeners.Remove(Listener);
|
|
|
+ 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;
|
|
|
+ originalOwnsObjects: boolean;
|
|
|
+ begin
|
|
|
+ if sl.Count > 0 then
|
|
|
+ begin
|
|
|
+ // From D2009 onward, the TStringList class has a OwnsObjects property, just like
|
|
|
+ // TObjectList has. This means that when we will be calling Clear on the given
|
|
|
+ // list in the sl parameter, we could destroy the objects it contains.
|
|
|
+ // To avoid this we must disable OwnsObjects while we replace the strings, but
|
|
|
+ // only if sl is a TStringList instance and if using Delphi 2009 or upper.
|
|
|
+ originalOwnsObjects := false; // avoid warning
|
|
|
+ if sl is TStringList then
|
|
|
+ slAsTStringList := TStringList(sl)
|
|
|
+ else
|
|
|
+ slAsTStringList := nil;
|
|
|
+
|
|
|
+ sl.BeginUpdate;
|
|
|
+ try
|
|
|
+ s := TStringList.Create;
|
|
|
+ try
|
|
|
+ // don't use Assign here as it will propagate the Sorted property (among others)
|
|
|
+ // in versions of Delphi from Delphi XE ownard
|
|
|
+ s.AddStrings(sl);
|
|
|
+
|
|
|
+ for i := 0 to s.Count - 1 do
|
|
|
+ begin
|
|
|
+ Line := s.Strings[i];
|
|
|
+ if Line <> '' then
|
|
|
+ if textdomain = '' then
|
|
|
+ s.Strings[i] := ComponentGettext(Line)
|
|
|
+ else
|
|
|
+ s.Strings[i] := dgettext(textdomain, Line);
|
|
|
+ end;
|
|
|
+
|
|
|
+ if Assigned(slAsTStringList) then
|
|
|
+ begin
|
|
|
+ originalOwnsObjects := slAsTStringList.OwnsObjects;
|
|
|
+ slAsTStringList.OwnsObjects := false;
|
|
|
+ end;
|
|
|
+ try
|
|
|
+ // same here, we don't want to modify the properties of the orignal string list
|
|
|
+ sl.Clear;
|
|
|
+ sl.AddStrings(s);
|
|
|
+ finally
|
|
|
+ if Assigned(slAsTStringList) then
|
|
|
+ slAsTStringList.OwnsObjects := originalOwnsObjects;
|
|
|
+ end;
|
|
|
+ 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);
|
|
|
+ var
|
|
|
+ i: Integer;
|
|
|
+ begin
|
|
|
+ for i := 0 to fWhenNewLanguageListeners.Count - 1 do
|
|
|
+ IGnuGettextInstanceWhenNewLanguageListener
|
|
|
+ (fWhenNewLanguageListeners[i]).WhenNewLanguage(LanguageID);
|
|
|
+ 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}
|
|
|
+ // Create the file if needed
|
|
|
+ if (not FileExists(filename)) or (not append) then
|
|
|
+ fileclose(filecreate(filename));
|
|
|
+
|
|
|
+ // Open file
|
|
|
+ fs := TFileStream.Create(filename, fmOpenWrite or fmShareDenyWrite);
|
|
|
+ if append then
|
|
|
+ fs.Seek(0, soFromEnd);
|
|
|
+
|
|
|
+ // Write header if appending
|
|
|
+ if fs.Position <> 0 then
|
|
|
+ begin
|
|
|
+ marker := sLinebreak +
|
|
|
+ '==========================================================================='
|
|
|
+ + sLinebreak;
|
|
|
+ fs.WriteBuffer(marker[1], length(marker));
|
|
|
+ end;
|
|
|
+
|
|
|
+ // Copy the memorystream contents to the file
|
|
|
+ if DebugLog <> nil then
|
|
|
+ begin
|
|
|
+ DebugLog.Seek(0, soFromBeginning);
|
|
|
+ fs.CopyFrom(DebugLog, 0);
|
|
|
+ end;
|
|
|
+
|
|
|
+ // 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}
|
|
|
+ Result := ResourceStringGettext(Result);
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure TGnuGettextInstance.RegisterWhenNewLanguageListener
|
|
|
+ (Listener: IGnuGettextInstanceWhenNewLanguageListener);
|
|
|
+ begin
|
|
|
+ fWhenNewLanguageListeners.Add(Listener);
|
|
|
+ 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 param ReReadMoFileOnSameLanguage is set, use the ReTranslate
|
|
|
+ // function nevertheless if the current language is the same like the
|
|
|
+ // new (-> reread the current .mo-file from the file system).
|
|
|
+ if ReReadMoFileOnSameLanguage or (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;
|
|
|
+
|
|
|
+ // Changed to "Analyze" with old signature to be compatible to older programs
|
|
|
+ // and to the assemble routine in GgtTranslate
|
|
|
+ // JR - 2012-09-10
|
|
|
+ procedure TFileLocator.Analyze;
|
|
|
+ var
|
|
|
+ s: AnsiString;
|
|
|
+ i: Integer;
|
|
|
+ Offset: int64;
|
|
|
+ fs: TFileStream;
|
|
|
+ fi: TEmbeddedFileInfo;
|
|
|
+ filename: AnsiString;
|
|
|
+ // change from FilenameString to AnsiString, JR - 2010-04-10
|
|
|
+ begin
|
|
|
+ // "ggassemble" will search for this GUI and replace the trailing #0s by a pointer
|
|
|
+ // to the begin of the embedded mo files
|
|
|
+ s := '6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0; // constant
|
|
|
+ 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(filename, Offset - fs.Position);
|
|
|
+ fs.ReadBuffer(filename[1], Offset - fs.Position);
|
|
|
+ filename := trim(filename);
|
|
|
+ if PreferExternal and System.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;
|
|
|
+
|
|
|
+ (* procedure TFileLocator.Analyze;
|
|
|
+ var
|
|
|
+ HeaderSize,
|
|
|
+ PrefixSize: Integer;
|
|
|
+ dummysig,
|
|
|
+ headerpre,
|
|
|
+ headerbeg,
|
|
|
+ headerend:RawByteString;
|
|
|
+ i:integer;
|
|
|
+ headerbeginpos,
|
|
|
+ headerendpos:integer;
|
|
|
+ offset,
|
|
|
+ tableoffset:int64;
|
|
|
+ fs:TFileStream;
|
|
|
+ fi:TEmbeddedFileInfo;
|
|
|
+ filename:FilenameString;
|
|
|
+ filename8bit:RawByteString;
|
|
|
+ const
|
|
|
+ // DetectionSignature: used solely to detect gnugettext usage by assemble
|
|
|
+ DetectionSignature: array[0..35] of AnsiChar='2E23E563-31FA-4C24-B7B3-90BE720C6B1A';
|
|
|
+ // Embedded Header Begin Signature (without dynamic prefix written by assemble)
|
|
|
+ BeginHeaderSignature: array[0..35] of AnsiChar='BD7F1BE4-9FCF-4E3A-ABA7-3443D11AB362';
|
|
|
+ // Embedded Header End Signature (without dynamic prefix written by assemble)
|
|
|
+ EndHeaderSignature: array[0..35] of AnsiChar='1C58841C-D8A0-4457-BF54-D8315D4CF49D';
|
|
|
+ // Assemble Prefix (do not put before the Header Signatures!)
|
|
|
+ SignaturePrefix: array[0..2] of AnsiChar='DXG'; // written from assemble
|
|
|
+ begin
|
|
|
+ // Attn: Ensure all Signatures have the same size!
|
|
|
+ HeaderSize := High(BeginHeaderSignature) - Low(BeginHeaderSignature) + 1;
|
|
|
+ PrefixSize := High(SignaturePrefix) - Low(SignaturePrefix) + 1;
|
|
|
+
|
|
|
+ // dummy usage of DetectionSignature (otherwise not compiled into exe)
|
|
|
+ SetLength(dummysig, HeaderSize);
|
|
|
+ for i := 0 to HeaderSize-1 do
|
|
|
+ dummysig[i+1] := DetectionSignature[i];
|
|
|
+
|
|
|
+ // copy byte by byte (D2009+ compatible)
|
|
|
+ SetLength(headerpre, PrefixSize);
|
|
|
+ for i:= 0 to PrefixSize-1 do
|
|
|
+ headerpre[i+1] := SignaturePrefix[i];
|
|
|
+
|
|
|
+ SetLength(headerbeg, HeaderSize);
|
|
|
+ for i:= 0 to HeaderSize-1 do
|
|
|
+ headerbeg[i+1] := BeginHeaderSignature[i];
|
|
|
+
|
|
|
+ SetLength(headerend, HeaderSize);
|
|
|
+ for i:= 0 to HeaderSize-1 do
|
|
|
+ headerend[i+1] := EndHeaderSignature[i];
|
|
|
+
|
|
|
+ BaseDirectory:=ExtractFilePath(ExecutableFilename);
|
|
|
+ try
|
|
|
+ fs:=TFileStream.Create(ExecutableFilename,fmOpenRead or fmShareDenyNone);
|
|
|
+ try
|
|
|
+ // try to find new header begin and end signatures
|
|
|
+ headerbeginpos := FindSignaturePos(headerpre+headerbeg, fs);
|
|
|
+ headerendpos := FindSignaturePos(headerpre+headerend, fs);
|
|
|
+
|
|
|
+ if (headerbeginpos > 0) and (headerendpos > 0) then
|
|
|
+ begin
|
|
|
+ // adjust positions (to the end of each signature)
|
|
|
+ headerbeginpos := headerbeginpos + HeaderSize + PrefixSize;
|
|
|
+
|
|
|
+ // get file table offset (8 byte, stored directly before the end header)
|
|
|
+ fs.Seek(headerendpos - 8, soFromBeginning);
|
|
|
+ // get relative offset and convert to absolute offset during runtime
|
|
|
+ tableoffset := headerbeginpos + ReadInt64(fs);
|
|
|
+
|
|
|
+ // go to beginning of embedded block
|
|
|
+ fs.Seek(headerbeginpos, soFromBeginning);
|
|
|
+
|
|
|
+ offset := tableoffset;
|
|
|
+ Assert(sizeof(offset)=8);
|
|
|
+ while (true) and (fs.Position<headerendpos) do begin
|
|
|
+ fs.Seek(offset,soFromBeginning);
|
|
|
+ offset:=ReadInt64(fs);
|
|
|
+ if offset=0 then
|
|
|
+ exit;
|
|
|
+ offset:=headerbeginpos+offset;
|
|
|
+ fi:=TEmbeddedFileInfo.Create;
|
|
|
+ try
|
|
|
+ // get embedded file info (adjusting dynamic to real offsets now)
|
|
|
+ fi.Offset:=headerbeginpos+ReadInt64(fs);
|
|
|
+ fi.Size:=ReadInt64(fs);
|
|
|
+ SetLength (filename8bit, offset-fs.position);
|
|
|
+ fs.ReadBuffer (filename8bit[1], offset-fs.position);
|
|
|
+ filename:=trim(utf8decode(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;
|
|
|
+ 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 not Assigned(item.obj) then
|
|
|
+ continue; // JR 20223-04-18 to avoid protection faults
|
|
|
+ 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}
|
|
|
+{$IFNDEF CPUx64}
|
|
|
+ raise Exception.Create
|
|
|
+ ('This procedure only works on Intel i386 or x64 compatible processors.');
|
|
|
+{$ENDIF}
|
|
|
+{$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(PatchPosition, 2); // skip the jump
|
|
|
+ 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, soFromBeginning);
|
|
|
+ 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);
|
|
|
+ try
|
|
|
+ CloseHandle(momapping);
|
|
|
+ except
|
|
|
+ end;
|
|
|
+ try
|
|
|
+ CloseHandle(mo);
|
|
|
+ except
|
|
|
+ end;
|
|
|
+ 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 // msgid<s
|
|
|
+ if i < 1 + step then
|
|
|
+ i := 1
|
|
|
+ else
|
|
|
+ i := i - step;
|
|
|
+ step := step shr 1;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin // msgid>s
|
|
|
+ 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(@System.SysUtils.LoadStr, @SysUtilsLoadStr);
|
|
|
+HookFmtLoadStr := THook.Create(@System.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.
|
glscene