GLScene/Examples/AdvDemos/GLSViewer/Source/gnugettext.pas

{*------------------------------------------------------------------------------
  GNU gettext translation system for Delphi, Kylix, C++ Builder and others.
  All parts of the translation system are kept in this unit.

  @author Lars B. Dybdahl and others
  @version $LastChangedRevision: 220 $
  @see http://dxgettext.po.dk/
-------------------------------------------------------------------------------}
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, Andreas Hausladen,       *)
(*                Thomas Mueller (dummzeuch)                  *)
(*                Olivier Sannier (obones)                    *)
(*                Luebbe Onken (LO)                           *)
(*                                                            *)
(*  See http://dxgettext.po.dk/ for more information          *)
(*                                                            *)
(**************************************************************)

// $HeadURL: https://svn.code.sf.net/p/dxgettext/code/trunk/dxgettext/sample/gnugettext.pas $

// Redistribution and use in source and binary forms, with or without
// modification, are permitted provided that the following conditions are met:
//
// The names of any contributor may not be used to endorse or promote
// products derived from this software without specific prior written permission.
//
// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
// ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
// LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

interface

// If the conditional define DXGETTEXTDEBUG is defined, debugging log is activated.
// Use DefaultInstance.DebugLogToFile() to write the log to a file.
{.$define DXGETTEXTDEBUG}

// If the conditional define dx_ChangeProxyClassname is defined, THookedObjects.Proxify adds '!dx'
// to the class name. Default: off
{.$define dx_ChangeProxyClassname}

// If the conditional dx_EMPTY_TO_EMPTY is defined translating an empty string results in an
// empty string.
// This can also be set at runtime by setting the EmptyToEmpty field of a TGnuGettextInstance
// (e.g. the defaultInstance).
// The default behaviour is to return the header entry as per
// https://www.gnu.org/software/gettext/manual/html_node/PO-Files.html
{.$define dx_EMPTY_TO_EMPTY}

// Programs that are compiled with German Delphi will always show the German shortcut
// keys in menus and hints because the German RTL resourcestrings are not translated.
// This results in German menu shortcuts 'Strg+<X>', 'Umsch+<X>' to be shown instead of
// 'Ctrl+<X>', 'Shift+<X>', even if the applications language is not German.
//
// This function hooks into Vcl.Menus.ShortCutToText and replaces the German consts with
// their English counterparts if the current application language is *not* German.
// Tested with Rad Studio 10.2 Tokyo and 10.3.1 Rio
{.$define dx_German_Delphi_fix}

// if the conditional define dx_SupportsResources is defined the .mo files
// can also be added to the executable as Windows resources
// Be warned: This has not been thoroughly tested.
// Default is turned off.
{.$define dx_SupportsResources}

{$ifdef VER140}
  // Delphi 6
  {$DEFINE dx_Hinstance_is_Integer}
  {$DEFINE dx_NativeInt_is_Integer}
  {$DEFINE dx_NativeUInt_is_Cardinal}
{$endif}
{$ifdef VER150}
  // Delphi 7
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_Hinstance_is_Integer}
  {$DEFINE dx_NativeInt_is_Integer}
  {$DEFINE dx_NativeUInt_is_Cardinal}
{$endif}
{$ifdef VER160}
  // Delphi 8
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_Hinstance_is_Integer}
  {$DEFINE dx_NativeInt_is_Integer}
  {$DEFINE dx_NativeUInt_is_Cardinal}
{$endif}
{$ifdef VER170}
  // Delphi 2005
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_Hinstance_is_Integer}
  {$DEFINE dx_NativeInt_is_Integer}
  {$DEFINE dx_NativeUInt_is_Cardinal}
{$endif}
{$ifdef VER180}
  {$ifndef VER185}
  // Delphi 2006
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_Hinstance_is_Integer}
  {$DEFINE dx_NativeInt_is_Integer}
  {$DEFINE dx_NativeUInt_is_Cardinal}
  {$DEFINE dx_has_Inline}
  {$endif}
{$endif}
{$ifdef VER185}
  // Delphi 2007
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_Hinstance_is_Integer}
  {$DEFINE dx_NativeInt_is_Integer}
  {$DEFINE dx_NativeUInt_is_Cardinal}
  {$DEFINE dx_has_Inline}
{$endif}
// there was no VER190 ??
{$ifdef VER200}
  // Delphi 2009, first version with Unicode
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_Hinstance_is_Integer}
  {$DEFINE dx_NativeInt_is_Integer}
  {$DEFINE dx_NativeUInt_is_Cardinal}
  {$DEFINE dx_has_Inline}
  {$DEFINE dx_StringList_has_OwnsObjects}
  {$DEFINE dx_has_LpVoid}
  {$DEFINE dx_has_StringBuilder}
{$endif}
{$ifdef VER210}
  // Delphi 2010
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_Hinstance_is_Integer}
  {$DEFINE dx_NativeInt_is_Integer}
  {$DEFINE dx_NativeUInt_is_Cardinal}
  {$DEFINE dx_has_Inline}
  {$DEFINE dx_StringList_has_OwnsObjects}
  {$DEFINE dx_has_LpVoid}
  {$DEFINE dx_has_StringBuilder}
{$endif}
{$ifdef VER220}
  // Delphi 2011/XE
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_Hinstance_is_Integer}
  {$DEFINE dx_NativeInt_is_Integer}
  {$DEFINE dx_NativeUInt_is_Cardinal}
  {$DEFINE dx_has_Inline}
  {$DEFINE dx_has_LpVoid}
  {$DEFINE dx_StringList_has_OwnsObjects}
  {$DEFINE dx_has_StringBuilder}
{$endif}
{$ifdef VER230}
  // Delphi 2012/XE2
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_StringList_has_OwnsObjects}
  {$DEFINE dx_has_Inline}
  {$DEFINE dx_has_LpVoid}
  {$DEFINE dx_has_VclThemes}
  {$DEFINE dx_has_StringBuilder}
  {$DEFINE dx_has_dotted_unitnames}
{$endif}
{$ifdef VER240}
  // Delphi 2013/XE3
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_StringList_has_OwnsObjects}
  {$DEFINE dx_GetStrProp_reads_unicode}
  {$DEFINE dx_has_Inline}
  {$DEFINE dx_has_LpVoid}
  {$DEFINE dx_has_VclThemes}
  {$DEFINE dx_has_StringBuilder}
  {$DEFINE dx_has_dotted_unitnames}
{$endif}
{$if CompilerVersion >= 25}
  // Delphi XE4 and up
  {$DEFINE dx_has_Unsafe_Warnings}
  {$DEFINE dx_has_WideStrings}
  {$DEFINE dx_StringList_has_OwnsObjects}
  {$DEFINE dx_GetStrProp_reads_unicode}
  {$DEFINE dx_has_Inline}
  {$DEFINE dx_has_LpVoid}
  {$DEFINE dx_has_VclThemes}
  {$DEFINE dx_midstr_in_AnsiStrings}
  {$DEFINE dx_has_StringBuilder}
  {$DEFINE dx_has_dotted_unitnames}
{$ifend}

{$ifdef dx_has_Unsafe_Warnings}
  {$WARN UNSAFE_TYPE OFF}
  {$WARN UNSAFE_CODE OFF}
  {$WARN UNSAFE_CAST OFF}
{$endif dx_has_Unsafe_Warnings}

uses
{$ifdef MSWINDOWS}
  Windows,
{$else}
  Libc,
{$ifdef FPC}
  CWString,
{$endif}
{$endif}
{$IFDEF dx_midstr_in_AnsiStrings}
  System.AnsiStrings,
{$ENDIF dx_midstr_in_AnsiStrings}
{$IFDEF dx_has_WideStrings}
  WideStrings,
{$ENDIF dx_has_WideStrings}
  Types, Classes, StrUtils, SysUtils, TypInfo;

(*****************************************************************************)
(*                                                                           *)
(*  MAIN API                                                                 *)
(*                                                                           *)
(*****************************************************************************)

type
  {$IFNDEF UNICODE}
  UnicodeString=WideString;
  RawUtf8String=AnsiString;
  RawByteString=AnsiString;
  {$ELSE}
  RawUtf8String=RawByteString;
  {$ENDIF}
  DomainString=string;
  LanguageString=string;
  ComponentNameString=string;
  FilenameString=string;
  MsgIdString=UnicodeString;
  TranslatedUnicodeString=UnicodeString;

// Main GNU gettext functions. See documentation for instructions on how to use them.
function _(const szMsgId: MsgIdString): TranslatedUnicodeString;
function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString;
function 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 dgettext_NoOp(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;
function pgettext(const szMsgCtxt,szMsgId: MsgIdString): TranslatedUnicodeString;
function pdgettext(const szDomain: DomainString; const szMsgCtxt,szMsgId: MsgIdString): TranslatedUnicodeString;
function pngettext(const szMsgCtxt,singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;
function pdngettext(const szDomain: DomainString; const szMsgCtxt,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
///<summary>
/// A LocaleName usually has the form ll_CC. Where ll is an ISO 639 two-letter language code,
/// and CC is an ISO 3166 two-letter country code.
/// For example, for German in Germany, ll is de, and CC is DE which results in de_DE </summary>
procedure UseLanguage(LocaleName: LanguageString);
function GetCurrentLanguage:LanguageString; deprecated; // use GetCurrentLocaleName instead
///<summary>
/// @Returns the full locale name in the form ll_CC </summary>
function GetCurrentLocaleName: LanguageString;
///<summary>
/// @Returns the two letter language code of the current LocaleName </summary>
function GetCurrentLanguageCode: LanguageString;
///<summary>
/// @Returns the two letter language code of the given LocaleName </summary>
function LocaleNameToLanguageCode(const ALocaleName: LanguageString): 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);
function TP_TryGlobalIgnoreClass (IgnClass:TClass): boolean;
procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:ComponentNameString);
procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
procedure TP_Remember(AnObject: TObject; PropName:ComponentNameString; OldValue:TranslatedUnicodeString);
procedure TranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');
procedure RetranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');

// Add more domains that resourcestrings can be extracted from. If a translation
// is not found in the default domain, this domain will be searched, too.
// This is useful for adding mo files for certain runtime libraries and 3rd
// party component libraries
procedure AddDomainForResourceString (const domain:DomainString);
procedure RemoveDomainForResourceString (const domain:DomainString);

// Add more domains that component strings can be extracted from. If a translation
// is not found in the default domain, this domain will be searched, too.
// This is useful when an application inherits components from a 3rd
// party component libraries
procedure AddDomainForComponent (const domain:DomainString);
procedure RemoveDomainForComponent (const domain:DomainString);

// Unicode-enabled way to get resourcestrings, automatically translated
// Use like this: ws:=LoadResStringW(@NameOfResourceString);
function LoadResString(ResStringRec: PResStringRec): widestring;
function LoadResStringW(ResStringRec: PResStringRec): UnicodeString;
function PLoadResString(const szMsgCtxt: MsgIdString; ResStringRec: PResStringRec): widestring;
function PLoadResStringW(const szMsgCtxt: MsgIdString; ResStringRec: PResStringRec): UnicodeString;

// This returns an empty string if not translated or translator name is not specified.
function GetTranslatorNameAndEmail:TranslatedUnicodeString;


(*****************************************************************************)
(*                                                                           *)
(*  ADVANCED FUNCTIONALITY                                                   *)
(*                                                                           *)
(*****************************************************************************)

const
  DefaultTextDomain = 'default';

var
  ExecutableFilename: FilenameString; // This is set to paramstr(0) or the name of the DLL you are creating.

const
  PreferExternal             = False;       // Set to true, to prefer external *.mo over embedded translation
  UseMemoryMappedFiles       = True;        // Set to False, to use the mo-file as independent copy in memory (you can update the file while it is in use)
  ReReadMoFileOnSameLanguage = False;       // 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: string) 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;
                          const ResName: string);
      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
      ///<summary>
      /// Set this to true, if you want the empty string to be "translated" to an empty string.
      /// The default behaviour is to return the po file header.
      /// https://www.gnu.org/software/gettext/manual/html_node/PO-Files.html
      /// "An empty untranslated-string is reserved to contain the header entry with the meta
      ///  information (see Header Entry). This header entry should be the first entry of the file.
      ///  The empty untranslated-string is reserved for this purpose and must not be
      ///  used anywhere else. </summary>
      EmptyToEmpty: Boolean;
      DesignTimeCodePage:Integer;  /// See MultiByteToWideChar() in Win32 API for documentation
      SearchAllDomains: Boolean;  /// Should gettext and ngettext look in all other known domains after the current one

      ///<summary>
      /// If LocaleName is not '', the instance will be initialized for the given language / locale </summary>
      constructor Create(LocaleName: LanguageString = '');
      destructor Destroy; override;
      procedure UseLanguage(LocaleName: 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; deprecated; // use GetCurentLocaleName instead
      function GetCurrentLanguageCode:LanguageString;
      function GetCurrentLocaleName: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);
      function TP_TryGlobalIgnoreClass (IgnClass:TClass): boolean;
      procedure TP_GlobalIgnoreClass (IgnClass:TClass);
      procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:ComponentNameString);
      procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
      procedure TP_Remember(AnObject: TObject; PropName:ComponentNameString; OldValue:TranslatedUnicodeString);
      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 dgettext_NoOp(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

      // particular translations (context parameter)
      function pgettext(const szMsgCtxt,szMsgId: MsgIdString): TranslatedUnicodeString;
      function pdgettext(const szDomain: DomainString; const szMsgCtxt,szMsgId: MsgIdString): TranslatedUnicodeString;
      function pngettext(const szMsgCtxt,singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;
      function pdngettext(const szDomain: DomainString; const szMsgCtxt,singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;

      // Windows API functions
      function LoadResString(ResStringRec: PResStringRec): UnicodeString;
      function PLoadResString(const szMsgCtxt: MsgIdString; 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);
      {$IFDEF dx_has_WideStrings}
      procedure TranslateWideStrings (sl: TWideStrings;const TextDomain:DomainString);
      {$ENDIF dx_has_WideStrings}

      // 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;
      function ClassIsIgnored(AClass:TClass): Boolean;
      {$ifdef DXGETTEXTDEBUG}
      procedure DebugWriteln(Line: string);
      {$endif}
      procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;
        TodoList: TStrings; const TextDomain:DomainString);  // Translates a single property of an object
      function Getdomain(const domain:DomainString; const DefaultDomainDirectory:FilenameString;
        const LocaleName: LanguageString): TDomain;

      function GetResString(ResStringRec: PResStringRec): UnicodeString;
      function ResourceStringGettext(MsgId: MsgIdString): TranslatedUnicodeString;
      procedure pgettext_fixup(const szLookup,szMsgId: MsgIdString; var szTranslation: MsgIdString); {$ifdef dx_has_Inline}inline;{$endif}
    end;

const
  LOCALE_SISO639LANGNAME = $59;    // Used by Lazarus software development tool
  {$EXTERNALSYM LOCALE_SISO639LANGNAME}
  LOCALE_SISO3166CTRYNAME = $5A;   // Used by Lazarus software development tool
  {$EXTERNALSYM LOCALE_SISO3166CTRYNAME}
  GETTEXT_CONTEXT_GLUE = #4;

var
  DefaultInstance:TGnuGettextInstance;  /// Default instance of the main API for singlethreaded applications.

implementation

{$IFDEF dx_has_dotted_unitnames}
{$ifdef dx_has_VclThemes or dx_German_Delphi_fix}
uses
{$ifdef dx_has_VclThemes}
  Vcl.Themes{$ifdef dx_German_Delphi_fix},{$endif}
{$endif}
{$ifdef dx_German_Delphi_fix}
  Vcl.Consts,
  Vcl.Menus
{$endif dx_German_Delphi_fix}
  ;
{$endif dx_has_VclThemes or dx_German_Delphi_fix}
{$ELSE ~dx_has_dotted_unitnames}
{$ifdef dx_German_Delphi_fix}
uses
  Consts,
  Menus;
{$endif dx_has_VclThemes or dx_German_Delphi_fix}
{$ENDIF dx_has_dotted_unitnames}

{$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}

{$ifdef dx_NativeUInt_is_Cardinal}
type
  NativeUInt = cardinal;
{$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;
{$IFDEF dx_SupportsResources}
  TResourceFileInfo = class
  public
    ResourceName: string;
    constructor Create(const _ResourceName: string);
  end;
{$ENDIF dx_SupportsResources}
  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
{$IFDEF dx_SupportsResources}
      FResourceList: TStringList; // Objects are TResourceFileInfo, Filenames are relative to .exe file
{$ENDIF dx_SupportsResources}
      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;

  PProxyClassData = ^TProxyClassData;
  TProxyClassData = record
    SelfPtr: TClass;
    IntfTable: Pointer;
    AutoTable: Pointer;
    InitTable: Pointer;
    TypeInfo: PTypeInfo;
    FieldTable: Pointer;
    MethodTable: Pointer;
    DynamicTable: Pointer;
    ClassName: PShortString;
    InstanceSize: Integer;
    Parent: ^TClass;
  end;

  THookedObjects=
    class(TList)
    private
      interceptorClassDatas:TList;

      function findInterceptorClassData(aClass:TClass):Pointer;

      procedure BeforeDestructionHook;
      function GetBeforeDestructionHookAddress: Pointer;
    public
      constructor Create;
      destructor Destroy; override;

      procedure Proxify(obj:TObject);
      procedure Unproxify(obj:TObject);
    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;
{$ifdef dx_German_Delphi_fix}
  HookShortCutToText:THook;
{$endif dx_German_Delphi_fix}
  HookedObjects:THookedObjects;
  KnownRetranslators:TList;

// Helper functions to make the ugly ifdefs more readable
function doGetWideStrProp(AnObject:TObject; Propname:ComponentNameString):TranslatedUnicodeString;
begin
{$IFDEF dx_GetStrProp_reads_unicode}
  Result := GetStrProp(AnObject, PropName);
{$ELSE}
  Result := GetWideStrProp(AnObject, PropName)
{$ENDIF}
end;

{$IFDEF UNICODE}
function doGetUnicodeStrProp(AnObject:TObject; Propname:ComponentNameString):TranslatedUnicodeString;
begin
{$IFDEF dx_GetStrProp_reads_unicode}
  Result := GetStrProp(AnObject, PropName);
{$ELSE}
  Result := GetUnicodeStrProp(AnObject, PropName)
{$ENDIF}
end;
{$ENDIF UNICODE}

function GGGetEnvironmentVariable(const Name:widestring):widestring;
var
  Len: integer;
  W : WideString;
begin
  Result := '';
  SetLength(W,1);
  Len := Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(W), 1);
  if Len > 0 then begin
    SetLength(Result, Len - 1);
    Windows.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;

{$ifdef dx_midstr_in_AnsiStrings}
function MidStr(const AText: RawUtf8String; const AStart, ACount: Integer): RawUtf8String; overload; inline;
begin
  Result := System.AnsiStrings.MidStr(AText, AStart, ACount);
end;
{$endif dx_midstr_in_AnsiStrings}

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;
begin
  Result := DefaultInstance.ResourceStringGettext(MsgId);
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;

  // First, get the value from the default domain
  if Assigned(Instance) then
    Result:=Instance.dgettext(Instance.curmsgdomain, MsgId)
  else
    Result:=dgettext(DefaultInstance.curmsgdomain, MsgId);
  if Result<>MsgId then
    exit;

  // If it was not in the default domain, then go through the others
  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 dgettext_NoOp(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;
begin
  //*** With this function Strings can be added to the po-file without being
  //    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.dgettext_NoOp(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;

function pgettext(const szMsgCtxt,szMsgId: MsgIdString): TranslatedUnicodeString;
begin
  Result:=DefaultInstance.pgettext(szMsgCtxt,szMsgId);
end;

function pdgettext(const szDomain: DomainString; const szMsgCtxt,szMsgId: MsgIdString): TranslatedUnicodeString;
begin
  Result:=DefaultInstance.pdgettext(szDomain,szMsgCtxt,szMsgId);
end;

function pngettext(const szMsgCtxt,singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;
begin
  Result:=DefaultInstance.pngettext(szMsgCtxt,singular,plural,Number);
end;

function pdngettext(const szDomain: DomainString; const szMsgCtxt,singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;
begin
  Result:=DefaultInstance.pdngettext(szDomain,szMsgCtxt,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;

function TP_TryGlobalIgnoreClass (IgnClass:TClass): boolean;
begin
  Result := DefaultInstance.TP_TryGlobalIgnoreClass (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 TP_Remember(AnObject: TObject; PropName:ComponentNameString; OldValue:TranslatedUnicodeString);
begin
  DefaultInstance.TP_Remember(AnObject, PropName, OldValue);
end;

procedure TranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');
begin
  DefaultInstance.TranslateComponent(AnObject, TextDomain);
end;

procedure RetranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');
begin
  DefaultInstance.RetranslateComponent(AnObject, TextDomain);
end;

{$ifdef MSWINDOWS}

// These constants are only used in Windows 95
// Thanks to Frank Andreas de Groot for this table
const
  IDAfrikaans                 = $0436;  IDAlbanian                  = $041C;
  IDArabicAlgeria             = $1401;  IDArabicBahrain             = $3C01;
  IDArabicEgypt               = $0C01;  IDArabicIraq                = $0801;
  IDArabicJordan              = $2C01;  IDArabicKuwait              = $3401;
  IDArabicLebanon             = $3001;  IDArabicLibya               = $1001;
  IDArabicMorocco             = $1801;  IDArabicOman                = $2001;
  IDArabicQatar               = $4001;  IDArabic                    = $0401;
  IDArabicSyria               = $2801;  IDArabicTunisia             = $1C01;
  IDArabicUAE                 = $3801;  IDArabicYemen               = $2401;
  IDArmenian                  = $042B;  IDAssamese                  = $044D;
  IDAzeriCyrillic             = $082C;  IDAzeriLatin                = $042C;
  IDBasque                    = $042D;  IDByelorussian              = $0423;
  IDBengali                   = $0445;  IDBulgarian                 = $0402;
  IDBurmese                   = $0455;  IDCatalan                   = $0403;
  IDChineseHongKong           = $0C04;  IDChineseMacao              = $1404;
  IDSimplifiedChinese         = $0804;  IDChineseSingapore          = $1004;
  IDTraditionalChinese        = $0404;  IDCroatian                  = $041A;
  IDCzech                     = $0405;  IDDanish                    = $0406;
  IDBelgianDutch              = $0813;  IDDutch                     = $0413;
  IDEnglishAUS                = $0C09;  IDEnglishBelize             = $2809;
  IDEnglishCanadian           = $1009;  IDEnglishCaribbean          = $2409;
  IDEnglishIreland            = $1809;  IDEnglishJamaica            = $2009;
  IDEnglishNewZealand         = $1409;  IDEnglishPhilippines        = $3409;
  IDEnglishSouthAfrica        = $1C09;  IDEnglishTrinidad           = $2C09;
  IDEnglishUK                 = $0809;  IDEnglishUS                 = $0409;
  IDEnglishZimbabwe           = $3009;  IDEstonian                  = $0425;
  IDFaeroese                  = $0438;  IDFarsi                     = $0429;
  IDFinnish                   = $040B;  IDBelgianFrench             = $080C;
  IDFrenchCameroon            = $2C0C;  IDFrenchCanadian            = $0C0C;
  IDFrenchCotedIvoire         = $300C;  IDFrench                    = $040C;
  IDFrenchLuxembourg          = $140C;  IDFrenchMali                = $340C;
  IDFrenchMonaco              = $180C;  IDFrenchReunion             = $200C;
  IDFrenchSenegal             = $280C;  IDSwissFrench               = $100C;
  IDFrenchWestIndies          = $1C0C;  IDFrenchZaire               = $240C;
  IDFrisianNetherlands        = $0462;  IDGaelicIreland             = $083C;
  IDGaelicScotland            = $043C;  IDGalician                  = $0456;
  IDGeorgian                  = $0437;  IDGermanAustria             = $0C07;
  IDGerman                    = $0407;  IDGermanLiechtenstein       = $1407;
  IDGermanLuxembourg          = $1007;  IDSwissGerman               = $0807;
  IDGreek                     = $0408;  IDGujarati                  = $0447;
  IDHebrew                    = $040D;  IDHindi                     = $0439;
  IDHungarian                 = $040E;  IDIcelandic                 = $040F;
  IDIndonesian                = $0421;  IDItalian                   = $0410;
  IDSwissItalian              = $0810;  IDJapanese                  = $0411;
  IDKannada                   = $044B;  IDKashmiri                  = $0460;
  IDKazakh                    = $043F;  IDKhmer                     = $0453;
  IDKirghiz                   = $0440;  IDKonkani                   = $0457;
  IDKorean                    = $0412;  IDLao                       = $0454;
  IDLatvian                   = $0426;  IDLithuanian                = $0427;
  IDMacedonian                = $042F;  IDMalaysian                 = $043E;
  IDMalayBruneiDarussalam     = $083E;  IDMalayalam                 = $044C;
  IDMaltese                   = $043A;  IDManipuri                  = $0458;
  IDMarathi                   = $044E;  IDMongolian                 = $0450;
  IDNepali                    = $0461;  IDNorwegianBokmol           = $0414;
  IDNorwegianNynorsk          = $0814;  IDOriya                     = $0448;
  IDPolish                    = $0415;  IDBrazilianPortuguese       = $0416;
  IDPortuguese                = $0816;  IDPunjabi                   = $0446;
  IDRhaetoRomanic             = $0417;  IDRomanianMoldova           = $0818;
  IDRomanian                  = $0418;  IDRussianMoldova            = $0819;
  IDRussian                   = $0419;  IDSamiLappish               = $043B;
  IDSanskrit                  = $044F;  IDSerbianCyrillic           = $0C1A;
  IDSerbianLatin              = $081A;  IDSesotho                   = $0430;
  IDSindhi                    = $0459;  IDSlovak                    = $041B;
  IDSlovenian                 = $0424;  IDSorbian                   = $042E;
  IDSpanishArgentina          = $2C0A;  IDSpanishBolivia            = $400A;
  IDSpanishChile              = $340A;  IDSpanishColombia           = $240A;
  IDSpanishCostaRica          = $140A;  IDSpanishDominicanRepublic  = $1C0A;
  IDSpanishEcuador            = $300A;  IDSpanishElSalvador         = $440A;
  IDSpanishGuatemala          = $100A;  IDSpanishHonduras           = $480A;
  IDMexicanSpanish            = $080A;  IDSpanishNicaragua          = $4C0A;
  IDSpanishPanama             = $180A;  IDSpanishParaguay           = $3C0A;
  IDSpanishPeru               = $280A;  IDSpanishPuertoRico         = $500A;
  IDSpanishModernSort         = $0C0A;  IDSpanish                   = $040A;
  IDSpanishUruguay            = $380A;  IDSpanishVenezuela          = $200A;
  IDSutu                      = $0430;  IDSwahili                   = $0441;
  IDSwedishFinland            = $081D;  IDSwedish                   = $041D;
  IDTajik                     = $0428;  IDTamil                     = $0449;
  IDTatar                     = $0444;  IDTelugu                    = $044A;
  IDThai                      = $041E;  IDTibetan                   = $0451;
  IDTsonga                    = $0431;  IDTswana                    = $0432;
  IDTurkish                   = $041F;  IDTurkmen                   = $0442;
  IDUkrainian                 = $0422;  IDUrdu                      = $0420;
  IDUzbekCyrillic             = $0843;  IDUzbekLatin                = $0443;
  IDVenda                     = $0433;  IDVietnamese                = $042A;
  IDWelsh                     = $0452;  IDXhosa                     = $0434;
  IDZulu                      = $0435;

function GetWindowsLanguage: WideString;
var
  langid: Cardinal;
  langcode: WideString;
  CountryName: array[0..4] of widechar;
  LanguageName: array[0..4] of widechar;
  works: boolean;
begin
  // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero
  works := 3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName));
  works := works and (3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName, SizeOf(CountryName)));
  if works then begin
    // Windows 98, Me, NT4, 2000, XP and newer
    LangCode := PWideChar(@(LanguageName[0]));
    if lowercase(LangCode)='no' then LangCode:='nb';
    LangCode:=LangCode + '_' + PWideChar(@CountryName[0]);
  end else begin
    // This part should only happen on Windows 95.
    langid := GetThreadLocale;
    case langid of
      IDBelgianDutch: langcode := 'nl_BE';
      IDBelgianFrench: langcode := 'fr_BE';
      IDBrazilianPortuguese: langcode := 'pt_BR';
      IDDanish: langcode := 'da_DK';
      IDDutch: langcode := 'nl_NL';
      IDEnglishUK: langcode := 'en_GB';
      IDEnglishUS: langcode := 'en_US';
      IDFinnish: langcode := 'fi_FI';
      IDFrench: langcode := 'fr_FR';
      IDFrenchCanadian: langcode := 'fr_CA';
      IDGerman: langcode := 'de_DE';
      IDGermanLuxembourg: langcode := 'de_LU';
      IDGreek: langcode := 'el_GR';
      IDIcelandic: langcode := 'is_IS';
      IDItalian: langcode := 'it_IT';
      IDKorean: langcode := 'ko_KO';
      IDNorwegianBokmol: langcode := 'nb_NO';
      IDNorwegianNynorsk: langcode := 'nn_NO';
      IDPolish: langcode := 'pl_PL';
      IDPortuguese: langcode := 'pt_PT';
      IDRussian: langcode := 'ru_RU';
      IDSpanish, IDSpanishModernSort: langcode := 'es_ES';
      IDSwedish: langcode := 'sv_SE';
      IDSwedishFinland: langcode := 'sv_FI';
    else
      langcode := 'C';
    end;
  end;
  Result := langcode;
end;
{$endif}

{$ifndef UNICODE}
function LoadResStringA(ResStringRec: PResStringRec): ansistring;
begin
  Result:=DefaultInstance.LoadResString(ResStringRec);
end;
{$endif}

function GetTranslatorNameAndEmail:TranslatedUnicodeString;
begin
  Result:=DefaultInstance.GetTranslatorNameAndEmail;
end;

procedure UseLanguage(LocaleName: LanguageString);
begin
  DefaultInstance.UseLanguage(LocaleName);
end;

type
{$ifdef dx_Hinstance_is_Integer}
  THInstanceType = Integer;
{$else dx_Hinstance_is_Integer}
  THInstanceType = NativeInt;
{$endif dx_Hinstance_is_Integer}

{$ifdef dx_NativeInt_is_Integer}
  TNativeInt = Integer;
{$else dx_NativeInt_is_Integer}
  TNativeInt = NativeInt;
{$endif dx_NativeInt_is_Integer}

type
  PStrData = ^TStrData;
  TStrData = record
    Ident: TNativeInt;
    Str: String;
  end;

function SysUtilsEnumStringModules(Instance: THInstanceType; Data: Pointer): Boolean;
{$IFDEF MSWINDOWS}
var
  Buffer: array [0..1023] of Char; // WideChar in Delphi 2009, AnsiChar before that
begin
  with PStrData(Data)^ do begin
    SetString(Str, Buffer,
      LoadString(Instance, Ident, @Buffer[0], Length(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: TNativeInt): 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 PLoadResString(const szMsgCtxt: MsgIdString; ResStringRec: PResStringRec): widestring;
begin
  Result:=DefaultInstance.PLoadResString(szMsgCtxt,ResStringRec);
end;

function PLoadResStringW(const szMsgCtxt: MsgIdString; ResStringRec: PResStringRec): UnicodeString;
begin
  Result:=DefaultInstance.PLoadResString(szMsgCtxt,ResStringRec);
end;

function GetCurrentLanguage:LanguageString;
begin
  Result:=GetCurrentLocaleName;
end;

function GetCurrentLocaleName: LanguageString;
begin
  Result:=DefaultInstance.GetCurrentLocaleName;
end;

function GetCurrentLanguageCode: LanguageString;
begin
  Result := LocaleNameToLanguageCode(GetCurrentLocaleName);
end;

function LocaleNameToLanguageCode(const ALocaleName: LanguageString): LanguageString;
begin
  Result := LowerCase(LeftStr(ALocaleName, 2));
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();
  Windows.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; {$ifdef dx_has_Inline}inline;{$endif}
begin
  Result:=UTF8ToUnicodeString(s);
end;
{$endif}

function TDomain.GetTranslationProperty(
  Propertyname: ComponentNameString): TranslatedUnicodeString;
var
  sl:TStringList;
  i:integer;
  s:string;
begin
  Propertyname:=uppercase(Propertyname)+': ';
  sl:=TStringList.Create;
  try
    sl.Text:=utf8decode(gettext(''));
    for i:=0 to sl.Count-1 do begin
      s:=sl.Strings[i];
      if uppercase(MidStr(s,1,length(Propertyname)))=Propertyname then begin
        Result:=trim(MidStr(s,length(PropertyName)+1,maxint));

        {$ifdef DXGETTEXTDEBUG}
        DebugLogger ('GetTranslationProperty('+PropertyName+') returns '''+Result+'''.');
        {$endif}
        exit;
      end;
    end;
  finally
    FreeAndNil (sl);
  end;
  Result:='';
  {$ifdef DXGETTEXTDEBUG}
  DebugLogger ('GetTranslationProperty('+PropertyName+') did not find any value. An empty string is returned.');
  {$endif}
end;

procedure TDomain.setDirectory(const dir: FilenameString);
begin
  vDirectory := IncludeTrailingPathDelimiter(dir);
  SpecificFilename:='';
  CloseMoFile;
end;

procedure AddDomainForResourceString (const domain:DomainString);
begin
  {$ifdef DXGETTEXTDEBUG}
  DefaultInstance.DebugWriteln ('Extra domain for resourcestring: '+domain);
  {$endif}
  ResourceStringDomainListCS.BeginWrite;
  try
    if ResourceStringDomainList.IndexOf(domain)=-1 then
      ResourceStringDomainList.Add (domain);
  finally
    ResourceStringDomainListCS.EndWrite;
  end;
end;

procedure RemoveDomainForResourceString (const domain:DomainString);
var
  i:integer;
begin
  {$ifdef DXGETTEXTDEBUG}
  DefaultInstance.DebugWriteln ('Remove domain for resourcestring: '+domain);
  {$endif}
  ResourceStringDomainListCS.BeginWrite;
  try
    i:=ResourceStringDomainList.IndexOf(domain);
    if i<>-1 then
      ResourceStringDomainList.Delete (i);
  finally
    ResourceStringDomainListCS.EndWrite;
  end;
end;

procedure AddDomainForComponent (const domain:DomainString);
begin
  {$ifdef DXGETTEXTDEBUG}
  DefaultInstance.DebugWriteln ('Extra domain for component: '+domain);
  {$endif}
  ComponentDomainListCS.BeginWrite;
  try
    if ComponentDomainList.IndexOf(domain)=-1 then
      ComponentDomainList.Add (domain);
  finally
    ComponentDomainListCS.EndWrite;
  end;
end;

procedure RemoveDomainForComponent (const domain:DomainString);
var
  i:integer;
begin
  {$ifdef DXGETTEXTDEBUG}
  DefaultInstance.DebugWriteln ('Remove domain for component: '+domain);
  {$endif}
  ComponentDomainListCS.BeginWrite;
  try
    i:=ComponentDomainList.IndexOf(domain);
    if i<>-1 then
      ComponentDomainList.Delete (i);
  finally
    ComponentDomainListCS.EndWrite;
  end;
end;

procedure TDomain.SetLanguageCode(const langcode: LanguageString);
begin
  CloseMoFile;
  curlang:=langcode;
end;

function GetPluralForm2EN(Number: Integer): Integer;
begin
  Number:=abs(Number);
  if Number=1 then Result:=0 else Result:=1;
end;

function GetPluralForm1(Number: Integer): Integer;
begin
  Result:=0;
end;

function GetPluralForm2FR(Number: Integer): Integer;
begin
  Number:=abs(Number);
  if (Number=1) or (Number=0) then Result:=0 else Result:=1;
end;

function GetPluralForm3LV(Number: Integer): Integer;
begin
  Number:=abs(Number);
  if (Number mod 10=1) and (Number mod 100<>11) then
    Result:=0
  else
    if Number<>0 then Result:=1
                 else Result:=2;
end;

function GetPluralForm3GA(Number: Integer): Integer;
begin
  Number:=abs(Number);
  if Number=1 then Result:=0
  else if Number=2 then Result:=1
  else Result:=2;
end;

function GetPluralForm3LT(Number: Integer): Integer;
var
  n1,n2:byte;
begin
  Number:=abs(Number);
  n1:=Number mod 10;
  n2:=Number mod 100;
  if (n1=1) and (n2<>11) then
    Result:=0
  else
    if (n1>=2) and ((n2<10) or (n2>=20)) then Result:=1
    else Result:=2;
end;

function GetPluralForm3PL(Number: Integer): Integer;
var
  n1,n2:byte;
begin
  Number:=abs(Number);
  n1:=Number mod 10;
  n2:=Number mod 100;

  if Number=1 then Result:=0
  else if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
  else Result:=2;
end;

function GetPluralForm3RU(Number: Integer): Integer;
var
  n1,n2:byte;
begin
  Number:=abs(Number);
  n1:=Number mod 10;
  n2:=Number mod 100;
  if (n1=1) and (n2<>11) then
    Result:=0
  else
    if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
    else Result:=2;
end;

function GetPluralForm3SK(Number: Integer): Integer;
begin
  Number:=abs(Number);
  if number=1 then Result:=0
  else if (number<5) and (number<>0) then Result:=1
  else Result:=2;
end;

function GetPluralForm4SL(Number: Integer): Integer;
var
  n2:byte;
begin
  Number:=abs(Number);
  n2:=Number mod 100;
  if n2=1 then Result:=0
  else
  if n2=2 then Result:=1
  else
  if (n2=3) or (n2=4) then Result:=2
  else
    Result:=3;
end;

procedure TDomain.GetListOfLanguages(list: TStrings);
var
  sr:TSearchRec;
  more:boolean;
  filename, path:FilenameString;
  langcode:LanguageString;
  i, j:integer;
begin
  list.Clear;

  // Iterate through filesystem
  more:=FindFirst (Directory+'*',faAnyFile,sr)=0;
  try
    while more do begin
      if (sr.Attr and faDirectory<>0) and (sr.name<>'.') and (sr.name<>'..') then begin
        filename := Directory + sr.Name + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
        if fileexists(filename) then begin
          langcode:=lowercase(sr.name);
          if list.IndexOf(langcode)=-1 then
            list.Add(langcode);
        end;
      end;
      more:=FindNext (sr)=0;
    end;
  finally
    FindClose (sr);
  end;

  // Iterate through embedded files
  for i:=0 to FileLocator.filelist.Count-1 do begin
    filename:=FileLocator.basedirectory+FileLocator.filelist.Strings[i];
    path:=Directory;
    {$ifdef MSWINDOWS}
    path:=uppercase(path);
    filename:=uppercase(filename);
    {$endif}
    j:=length(path);
    if MidStr(filename,1,j)=path then begin
      path:=PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
      {$ifdef MSWINDOWS}
      path:=uppercase(path);
      {$endif}
      if MidStr(filename,length(filename)-length(path)+1,length(path))=path then begin
        langcode:=lowercase(MidStr(filename,j+1,length(filename)-length(path)-j));
        langcode:=LeftStr(langcode,3)+uppercase(MidStr(langcode,4,maxint));
        if list.IndexOf(langcode)=-1 then
          list.Add(langcode);
      end;
    end;
  end;
end;

procedure TDomain.SetFilename(const filename: FilenameString);
begin
  CloseMoFile;
  vDirectory := '';
  SpecificFilename:=filename;
end;

function TDomain.gettext(const msgid: RawUtf8String): RawUtf8String;
var
  found:boolean;
begin
  if not Enabled then begin
    Result:=msgid;
    exit;
  end;
  if (mofile=nil) and (not OpenHasFailedBefore) then
    OpenMoFile;
  if mofile=nil then begin
    {$ifdef DXGETTEXTDEBUG}
    DebugLogger('.mo file is not open. Not translating "'+string(msgid)+'"');
    {$endif}
    Result := msgid;
  end else begin
    Result:=mofile.gettext(msgid,found);
    {$ifdef DXGETTEXTDEBUG}
    if found then
      DebugLogger ('Found in .mo ('+Domain+'): "'+string(utf8encode(msgid))+'"->"'+string(utf8encode(Result))+'"')
    else
      DebugLogger ('Translation not found in .mo file ('+Domain+') : "'+string(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(LocaleName: LanguageString = '');
begin
  {$ifdef dx_EMPTY_TO_EMPTY}
  EmptyToEmpty := True;
  {$endif}

  {$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;
  SearchAllDomains:=False;
  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(LocaleName);

  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
    if EmptyToEmpty and (szMsgId = '') then begin
      Result := '';
    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;
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.dgettext_NoOp(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;
begin
  Result := gettext_NoOp( szMsgId);
end;

function TGnuGettextInstance.GetCurrentLanguage: LanguageString;
begin
  Result:=GetCurrentLocaleName;
end;

function TGnuGettextInstance.GetCurrentLanguageCode: LanguageString;
begin
  Result := LocaleNameToLanguageCode(GetCurrentLocaleName);
end;

function TGnuGettextInstance.GetCurrentLocaleName: LanguageString;
begin
  Result:=curlang;
end;

function TGnuGettextInstance.getcurrenttextdomain: DomainString;
begin
  Result := curmsgdomain;
end;

{$ifndef UNICODE}
function TGnuGettextInstance.gettext(
  const szMsgId: ansistring): TranslatedUnicodeString;
var
  domain: DomainString;
  domainIndex: Integer;
begin
  Result := dgettext(curmsgdomain, szMsgId);
  if SearchAllDomains and (szMsgId <> '') then begin
    domainIndex := 0;
    while (Result = szMsgId) and (domainIndex < domainlist.count) do begin
      domain := domainlist[domainIndex];
      Result := dgettext(domain, szMsgId);
      Inc(domainIndex);
    end;
  end;
end;
{$endif}

function TGnuGettextInstance.gettext(
  const szMsgId: MsgIdString): TranslatedUnicodeString;
var
  domain: DomainString;
  domainIndex: Integer;
begin
  Result := dgettext(curmsgdomain, szMsgId);
  if SearchAllDomains and (szMsgId <> '') then begin
    domainIndex := 0;
    while (Result = szMsgId) and (domainIndex < domainlist.count) do begin
      domain := domainlist[domainIndex];
      Result := dgettext(domain, szMsgId);
      Inc(domainIndex);
    end;
  end;
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 being
  //    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.pgettext_fixup(const szLookup,szMsgId: MsgIdString; var szTranslation: MsgIdString);
begin
  if szTranslation = szLookup then
    szTranslation := szMsgId;
end;

function TGnuGettextInstance.pgettext(const szMsgCtxt,szMsgId: MsgIdString): TranslatedUnicodeString;
var
  lookup: MsgIdString;
begin
  lookup := szMsgCtxt + GETTEXT_CONTEXT_GLUE + szMsgId;
  Result := gettext(lookup);
  pgettext_fixup(lookup, szMsgId, Result);
end;

function TGnuGettextInstance.pdgettext(const szDomain: DomainString; const szMsgCtxt,szMsgId: MsgIdString): TranslatedUnicodeString;
var
  lookup: MsgIdString;
begin
  lookup := szMsgCtxt + GETTEXT_CONTEXT_GLUE + szMsgId;
  Result := dgettext(szDomain, lookup);
  pgettext_fixup(lookup, szMsgId, Result);
end;

function TGnuGettextInstance.pngettext(const szMsgCtxt,singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;
var
  lookup: MsgIdString;
begin
  lookup := szMsgCtxt + GETTEXT_CONTEXT_GLUE + singular;
  Result := ngettext(lookup, plural, Number);
  pgettext_fixup(lookup, singular, Result);
end;

function TGnuGettextInstance.pdngettext(const szDomain: DomainString; const szMsgCtxt,singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;
var
  lookup: MsgIdString;
begin
  lookup := szMsgCtxt + GETTEXT_CONTEXT_GLUE + singular;
  Result := dngettext(szDomain, lookup, plural, Number);
  pgettext_fixup(lookup, singular, Result);
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;

function TGnuGettextInstance.TP_TryGlobalIgnoreClass (IgnClass:TClass): boolean;
var
  cm:TClassMode;
  i:integer;
begin
  Result := false;
  for i:=0 to TP_GlobalClassHandling.Count-1 do begin
    cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
    if cm.HClass=IgnClass then
      exit; // class already in ignore list
    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);
      Result := true;
      {$ifdef DXGETTEXTDEBUG}
      DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');
      {$endif}
      exit;
    end;
  end;
  cm:=TClassMode.Create;
  cm.HClass:=IgnClass;
  TP_GlobalClassHandling.Add(cm);
  Result := true;
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');
  {$endif}
end;

procedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass);
begin
  if not TP_TryGlobalIgnoreClass(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.');
end;

procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(
  IgnClass: TClass; propertyname: ComponentNameString);
var
  cm:TClassMode;
  i,idx:integer;
begin
  propertyname:=uppercase(propertyname);
  for i:=0 to TP_GlobalClassHandling.Count-1 do begin
    cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
    if cm.HClass=IgnClass then begin
      if Assigned(cm.SpecialHandler) then
        raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.');
      if not cm.PropertiesToIgnore.Find(propertyname,idx) then
        cm.PropertiesToIgnore.Add(propertyname);
      {$ifdef DXGETTEXTDEBUG}
      DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
      {$endif}
      exit;
    end;
    if IgnClass.InheritsFrom(cm.HClass) then begin
      // This is the place to insert this class
      cm:=TClassMode.Create;
      cm.HClass:=IgnClass;
      cm.PropertiesToIgnore.Add(propertyname);
      TP_GlobalClassHandling.Insert(i,cm);
      {$ifdef DXGETTEXTDEBUG}
      DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
      {$endif}
      exit;
    end;
  end;
  cm:=TClassMode.Create;
  cm.HClass:=IgnClass;
  cm.PropertiesToIgnore.Add(propertyname);
  TP_GlobalClassHandling.Add(cm);
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
  {$endif}
end;

procedure TGnuGettextInstance.TP_Ignore(AnObject: TObject;
  const name: ComponentNameString);
begin
  TP_IgnoreList.Add(uppercase(name));
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln ('On object with class name '+AnObject.ClassName+', ignore is set on '+name);
  {$endif}
end;

procedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent;
  const TextDomain: DomainString);
var
  comp:TGnuGettextComponentMarker;
begin
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln ('======================================================================');
  DebugWriteln ('TranslateComponent() was called for a component with name '+AnObject.Name+'.');
  {$endif}
  comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
  if comp=nil then begin
    comp:=TGnuGettextComponentMarker.Create (nil);
    comp.Name:='GNUgettextMarker';
    comp.Retranslator:=TP_CreateRetranslator;
    TranslateProperties (AnObject, TextDomain);
    AnObject.InsertComponent(comp);
    {$ifdef DXGETTEXTDEBUG}
    DebugWriteln ('This is the first time, that this component has been translated. A retranslator component has been created for this component.');
    {$endif}
  end else begin
    {$ifdef DXGETTEXTDEBUG}
    DebugWriteln ('This is not the first time, that this component has been translated.');
    {$endif}
    if comp.LastLanguage<>curlang then begin
      {$ifdef DXGETTEXTDEBUG}
      DebugWriteln ('ERROR: TranslateComponent() was called twice with different languages. This indicates an attempt to switch language at runtime, but by using TranslateComponent every time. This API has changed - please use RetranslateComponent() instead.');
      {$endif}
      {$ifdef mswindows}
      MessageBox (0,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.','Error',MB_OK);
      {$else}
      writeln (stderr,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.');
      {$endif}
    end else begin
      {$ifdef DXGETTEXTDEBUG}
      DebugWriteln ('ERROR: TranslateComponent has been called twice, but with the same language chosen. This is a mistake, but in order to prevent that the application breaks, no exception is raised.');
      {$endif}
    end;
  end;
  comp.LastLanguage:=curlang;
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln ('======================================================================');
  {$endif}
end;

procedure TGnuGettextInstance.TranslateProperty (AnObject:TObject; PropInfo:PPropInfo; TodoList:TStrings; const TextDomain:DomainString);
var
  ppi:PPropInfo;
  ws: TranslatedUnicodeString;
  old: TranslatedUnicodeString;
  compmarker:TComponent;
  obj:TObject;
  Propname:ComponentNameString;
begin
  PropName:=string(PropInfo^.Name);
  try
    // Translate certain types of properties
    case PropInfo^.PropType^.Kind of
      {$IFDEF UNICODE}
      // All dfm files returning tkUString
      tkString, tkLString, tkWString, tkUString:
      {$ELSE}
      tkString, tkLString, tkWString:
      {$ENDIF}
        begin
          {$ifdef DXGETTEXTDEBUG}
          DebugWriteln ('Translating '+AnObject.ClassName+'.'+PropName);
          {$endif}
          case PropInfo^.PropType^.Kind of
            tkString, tkLString :
              old := GetStrProp(AnObject, PropName);
            tkWString :
              old := doGetWideStrProp(AnObject, Propname);
            {$IFDEF UNICODE}
            tkUString :
              old := doGetUnicodeStrProp(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, Self)
            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;

function ObjectHasAssignedAction(AnObject: TObject; PropList: PPropList; Count: Integer; var ActionProperty: TObject): Boolean;
var
  I: Integer;
  PropInfo: PPropInfo;
  Obj: TObject;
begin
  Result := False;
  I := 0;
  while not Result and (I < Count) do
  begin
    PropInfo := PropList[I];
    if (PropInfo^.PropType^.Kind = tkClass) then
    begin
      Obj := GetObjectProp(AnObject, string(PropInfo.Name));
      Result := Obj is TBasicAction;
      if Result then
        ActionProperty := Obj;
    end;

    Inc(I);
  end;
end;

function TGnuGettextInstance.ClassIsIgnored(AClass:TClass): Boolean;
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 AClass.InheritsFrom(cm.HClass) and (cm.PropertiesToIgnore.Count = 0) then
    begin
      Result := True;
      exit;
    end;
  end;
  for i:=0 to TP_ClassHandling.Count-1 do begin
    cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;
    if AClass.InheritsFrom(cm.HClass) then
    begin
      Result := True;
      exit;
    end;
  end;
  Result := False;
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;
  ActionProperty:TObject;
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
          if ObjectHasAssignedAction(AnObject, PropList, Count, ActionProperty) and not ClassIsIgnored(ActionProperty.ClassType) then
            Continue;

          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;
        {$IFDEF dx_has_WideStrings}
        if AnObject is TWideStrings then begin
          if ((AnObject as TWideStrings).Text<>'') and (TP_Retranslator<>nil) then
            (TP_Retranslator as TTP_Retranslator).Remember(AnObject, 'Text', (AnObject as TWideStrings).Text);
          TranslateWideStrings (AnObject as TWideStrings,TextDomain);
        end;
        {$ENDIF dx_has_WideStrings}
        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(LocaleName: LanguageString);
var
  i,p:integer;
  dom:TDomain;
  l2:string;
begin
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln('UseLanguage('''+LocaleName+'''); called');
  {$endif}

  if LocaleName='' then begin
    LocaleName:=GGGetEnvironmentVariable('LANG');
    {$ifdef DXGETTEXTDEBUG}
    DebugWriteln ('LANG env variable is '''+LocaleName+'''.');
    {$endif}
    {$ifdef MSWINDOWS}
    if LocaleName='' then begin
      LocaleName:=GetWindowsLanguage;
      {$ifdef DXGETTEXTDEBUG}
      DebugWriteln ('Found Windows language code to be '''+LocaleName+'''.');
      {$endif}
    end;
    {$endif}
    p:=pos('.',LocaleName);
    if p<>0 then
      LocaleName:=LeftStr(LocaleName,p-1);
    {$ifdef DXGETTEXTDEBUG}
    DebugWriteln ('Language code that will be set is '''+LocaleName+'''.');
    {$endif}
  end;

  curlang := LocaleName;
  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;
  tempSL: TStringList;
  {$ifdef dx_StringList_has_OwnsObjects}
  slAsTStringList: TStringList;
  originalOwnsObjects: Boolean;
  {$endif dx_StringList_has_OwnsObjects}
begin
  if sl.Count > 0 then begin
    {$ifdef dx_StringList_has_OwnsObjects}
    // From D2009 onward, the TStringList class has an OwnsObjects property, just like
    // TObjectList has. This means that if we call 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 later.
    originalOwnsObjects := False; // avoid warning
    if sl is TStringList then
      slAsTStringList := TStringList(sl)
    else
      slAsTStringList := nil;
    {$endif dx_StringList_has_OwnsObjects}

    sl.BeginUpdate;
    try
      tempSL:=TStringList.Create;
      try
        // don't use Assign here as it will propagate the Sorted property (among others)
        // in versions of Delphi from Delphi XE onward
        tempSL.AddStrings(sl);

        for i:=0 to tempSL.Count-1 do begin
          line:=tempSL.Strings[i];
          if line<>'' then
            if (TextDomain = '') or (TextDomain = DefaultTextDomain) then
              tempSL.Strings[i]:=ComponentGettext(line, Self)
            else
              tempSL.Strings[i]:=dgettext(TextDomain,line);
        end;

        //DH Fix 2013-09-19: Only refill sl if changed
        if sl.Text<>tempSL.Text then
        begin
          {$ifdef dx_StringList_has_OwnsObjects}
          if Assigned(slAsTStringList) then begin
            originalOwnsObjects := slAsTStringList.OwnsObjects;
            slAsTStringList.OwnsObjects := False;
          end;
          {$endif dx_StringList_has_OwnsObjects}
          try
            {$ifdef dx_StringList_has_OwnsObjects}
            if Assigned(slAsTStringList) and slAsTStringList.Sorted then
            begin
              // TStringList doesn't release the objects in PutObject, so we use this to get
              // sl.Clear to not destroy the objects in classes that inherit from TStringList
              // but do a ClearObject in Clear.
              //
              // todo: Check whether this should be
              //   if sl is TStringList then
              // instead.
              if sl.ClassType <> TStringList then
                for I := 0 to sl.Count - 1 do
                  sl.Objects[I] := nil;

              // same here, we don't use assign because we don't want to modify the properties of the orignal string list
              sl.Clear;
              sl.AddStrings(tempSL);
            end
            else
            {$endif dx_StringList_has_OwnsObjects}
            begin
              for i := 0 to sl.Count - 1 do
                sl[i] := tempSL[i];
            end;
          finally
            {$ifdef dx_StringList_has_OwnsObjects}
            if Assigned(slAsTStringList) then
              slAsTStringList.OwnsObjects := originalOwnsObjects;
            {$endif dx_StringList_has_OwnsObjects}
          end;
        end;
      finally
        FreeAndNil (tempSL);
      end;
    finally
      sl.EndUpdate;
    end;
  end;
end;

{$IFDEF dx_has_WideStrings}
procedure TGnuGettextInstance.TranslateWideStrings(sl: TWideStrings;
  const TextDomain: DomainString);
var
  line: string;
  i: integer;
  tempSL:TWideStringList;
  {$ifdef dx_StringList_has_OwnsObjects}
  slAsTWideStringList:TWideStringList;
  originalOwnsObjects: Boolean;
  {$endif dx_StringList_has_OwnsObjects}
begin
  if sl.Count > 0 then begin
    {$ifdef dx_StringList_has_OwnsObjects}
    // From D2009 onward, the TWideStringList class has an OwnsObjects property, just like
    // TObjectList has. This means that if we call 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 TWideStringList instance and if using Delphi 2009 or later.
    originalOwnsObjects := False; // avoid warning
    if sl is TWideStringList then
      slAsTWideStringList := TWideStringList(sl)
    else
      slAsTWideStringList := nil;
    {$endif dx_StringList_has_OwnsObjects}

    sl.BeginUpdate;
    try
      tempSL:=TWideStringList.Create;
      try
        // don't use Assign here as it will propagate the Sorted property (among others)
        // in versions of Delphi from Delphi XE ownard
        tempSL.AddStrings(sl);

        for i:=0 to tempSL.Count-1 do begin
          line:=tempSL.Strings[i];
          if line<>'' then
            if TextDomain = '' then
              tempSL.Strings[i]:=ComponentGettext(line, Self)
            else
              tempSL.Strings[i]:=dgettext(TextDomain,line);
        end;

        //DH Fix 2013-09-19: Only refill sl if changed
        if sl.Text<>tempSL.Text then
        begin
          {$ifdef dx_StringList_has_OwnsObjects}
          if Assigned(slAsTWideStringList) then begin
            originalOwnsObjects := slAsTWideStringList.OwnsObjects;
            slAsTWideStringList.OwnsObjects := False;
          end;
          {$endif dx_StringList_has_OwnsObjects}
          try
            {$ifdef dx_StringList_has_OwnsObjects}
            if Assigned(slAsTWideStringList) and slAsTWideStringList.Sorted then
            begin
              // TWideStringList doesn't release the objects in PutObject, so we use this to get
              // sl.Clear to not destroy the objects in classes that inherit from TWideStringList
              // but do a ClearObject in Clear.
              //
              // todo: Check whether this should be
              //   if sl is TWideStringList then
              // instead.
              if sl.ClassType <> TWideStringList then
                for I := 0 to sl.Count - 1 do
                  sl.Objects[I] := nil;

              // same here, we don't use assign because we don't want to modify the properties of the orignal string list
              sl.Clear;
              sl.AddStrings(tempSL);
            end
            else
            {$endif dx_StringList_has_OwnsObjects}
            begin
              for i := 0 to sl.Count - 1 do
                sl[i] := tempSL[i];
            end;
          finally
            {$ifdef dx_StringList_has_OwnsObjects}
            if Assigned(slAsTWideStringList) then
              slAsTWideStringList.OwnsObjects := originalOwnsObjects;
            {$endif dx_StringList_has_OwnsObjects}
          end;
        end;
      finally
        FreeAndNil (tempSL);
      end;
    finally
      sl.EndUpdate;
    end;
  end;
end;
{$ENDIF dx_has_WideStrings}

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: '+string(utf8encode(trans)));
      {$endif}
      Result:=trans;
      exit;
    end;
    if idx=0 then begin
      {$ifdef DXGETTEXTDEBUG}
      DebugWriteln ('Translation found: '+string(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;
var
  domain: DomainString;
  domainIndex: Integer;
begin
  Result := dngettext(curmsgdomain, singular, plural, Number);
  if SearchAllDomains then begin
    domainIndex := 0;
    while (Result <> singular) and (Result <> plural) and (domainIndex < domainlist.count) do begin
      domain := domainlist[domainIndex];
      Result := dngettext(domain, singular, plural, Number);
      Inc(domainIndex);
    end;
  end;
end;
{$endif}

function TGnuGettextInstance.ngettext(const singular, plural: MsgIdString;
  Number: Integer): TranslatedUnicodeString;
var
  domain: DomainString;
  domainIndex: Integer;
begin
  Result := dngettext(curmsgdomain, singular, plural, Number);
  if SearchAllDomains then begin
    domainIndex := 0;
    while (Result <> singular) and (Result <> plural) and (domainIndex < domainlist.count) do begin
      domain := domainlist[domainIndex];
      Result := dngettext(domain, singular, plural, Number);
      Inc(domainIndex);
    end;
  end;
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: string);
Var
  Discard: Boolean;
  ALine: AnsiString;
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;

    ALine := AnsiString(Line);
    ALine:=ALine+sLineBreak;

    // Ensure that memory usage doesn't get too big.
    if (DebugLog is TMemoryStream) and (DebugLog.Position>1000000) then begin
      ALine:=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(ALine[1],length(ALine));
  finally
    DebugLogCS.EndWrite;
  end;
end;
{$endif}

function TGnuGettextInstance.Getdomain(const domain:DomainString; const DefaultDomainDirectory:FilenameString;
  const LocaleName: 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(LocaleName);
    domainlist.AddObject(Domain, Result);
  end else begin
    Result := domainlist.Objects[idx] as TDomain;
  end;
end;

function TGnuGettextInstance.GetResString(ResStringRec: PResStringRec): UnicodeString;
{$ifdef MSWINDOWS}
var
  Len: Integer;
  Buffer: array [0..1023] of char;
{$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;
  {$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, Length(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}
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln ('Loaded resourcestring: '+string(utf8encode(Result)));
  {$endif}
end;

function TGnuGettextInstance.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 TGnuGettextInstance.LoadResString(
  ResStringRec: PResStringRec): UnicodeString;
begin
  Result:=ResourceStringGettext(GetResString(ResStringRec));
end;

function TGnuGettextInstance.PLoadResString(const szMsgCtxt: MsgIdString; ResStringRec: PResStringRec): UnicodeString;
begin
  Result:=PGettext(szMsgCtxt, GetResString(ResStringRec));
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.TP_Remember(AnObject: TObject;
  PropName: ComponentNameString; OldValue: TranslatedUnicodeString);
begin
  if Assigned(TP_Retranslator) then
    (TP_Retranslator as TTP_Retranslator).Remember(AnObject, PropName, OldValue)
  else
    raise EGGProgrammingError.Create ('You can only call TP_Remember when doing the initial translation (TP_Retranslator is not set).');
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.ReadBuffer(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;
{$IF CompilerVersion<34}
  // this causes a hint in Delphi 10.4 and newer
  Result:=0;
{$IFEND}
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.Position := offset;
          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;
  MoFiles.Sorted:=True;
  MoFiles.Duplicates:=dupError;
  MoFiles.CaseSensitive:=False;

  filelist:=TStringList.Create;
  filelist.Duplicates:=dupError;
  { TODO : what if it's neither LINUX nor MSWINDOWS? }
  {$ifdef LINUX}
  filelist.CaseSensitive:=True;
  {$endif}
  {$ifdef MSWINDOWS}
  filelist.CaseSensitive:=False;
  {$endif}
  filelist.Sorted:=True;

  {$IFDEF dx_SupportsResources}
  FResourceList := TStringList.Create;
  FResourceList.Duplicates := dupError;
  FResourceList.CaseSensitive := False;
  FResourceList.Sorted := True;
{$ENDIF dx_SupportsResources}
end;

destructor TFileLocator.Destroy;
var
  Idx: integer;
begin
{$IFDEF dx_SupportsResources}
  if Assigned(FResourceList) then begin
    while FResourceList.Count > 0 do begin
      Idx := FResourceList.Count - 1;
      FResourceList.Objects[Idx].Free;
      FResourceList.Delete(Idx);
    end;
    FreeAndNil(FResourceList);
  end;
{$ENDIF dx_SupportsResources}

  for Idx := 0 to filelist.Count-1  do
    FileList.Objects[Idx].Free;
  FreeAndNil (filelist);

  FreeAndNil (MoFiles);
  FreeAndNil (MoFilesCS);
  inherited;
end;

function TFileLocator.FileExists(filename: FilenameString): boolean;
var
  idx:integer;
{$IFDEF dx_SupportsResources}
  ResName: string;
  HResInfo: HRSRC;
{$ENDIF dx_SupportsResources}
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);

{$IFDEF dx_SupportsResources}
  if not Result then begin
    Result := FResourceList.Find(filename, Idx);
    if not Result then begin
      ResName := UpperCase(filename);
      ResName := StringReplace(ResName,  '/', '_', [rfReplaceAll]);
      ResName := StringReplace(ResName,  '\', '_', [rfReplaceAll]);
      ResName := StringReplace(ResName, '_LC_MESSAGES_', '_', [rfReplaceAll]);
      ResName := StringReplace(ResName, '.MO', '', [rfReplaceAll]);
      HResInfo := FindResource(hInstance, PChar(ResName), RT_RCDATA);
      Result := (HResInfo <> 0);
      if Result then
        FResourceList.AddObject(filename, TResourceFileInfo.Create(ResName));
    end;
  end;
{$ENDIF dx_SupportsResources}
end;

function TFileLocator.GetMoFile(filename: FilenameString; DebugLogger:TDebugLogger): TMoFile;
var
  fi:TEmbeddedFileInfo;
  idx:integer;
  idxname:FilenameString;
  Offset, Size: Int64;
  realfilename:FilenameString;
  ResName: string;
begin
  // Find real filename
  offset:=0;
  size:=0;
  Resname := '';
  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
{$IFDEF dx_SupportsResources}
    else begin
      Idx := FResourceList.IndexOf(filename);
      if Idx <> -1 then begin
        realfilename := ExecutableFilename;
        ResName := (FResourceList.Objects[Idx] as TResourceFileInfo).ResourceName;
  {$ifdef DXGETTEXTDEBUG}
      DebugLogger ('Instead of '+filename+', using resource '+ResName+' from '+realfilename);
  {$endif}
      end;
    end;
{$ENDIF dx_SupportsResources}
  end;


  {$ifdef DXGETTEXTDEBUG}
  DebugLogger ('Reading .mo data from file '''+filename+'''');
  {$endif}

  // Find TMoFile object
  MoFilesCS.BeginWrite;
  try
{$IFDEF dx_SupportsResources}
    if ResName <> '' then begin
      idxname := realfilename + ' //\\ ' + ResName;
    end else
{$ENDIF dx_SupportsResources}
      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, ResName);
      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;
  KnownRetranslators.Add(Self);
end;

destructor TTP_Retranslator.Destroy;
var
  i:integer;
begin
  for i:=0 to list.Count-1 do
    TObject(list.Items[i]).Free;
  FreeAndNil (list);

  // some times, we are finalized before the main form's unit
  if Assigned(KnownRetranslators) then
    KnownRetranslators.Remove(Self);

  inherited;
end;

procedure RemoveFromKnowRetranslators(obj: TObject); {$ifdef dx_has_Inline}inline;{$endif}
var
  retranslatorIndex:Integer;
  retranslator:TTP_Retranslator;
  itemIndex:Integer;
  item:TTP_RetranslatorItem;
begin
  for retranslatorIndex:=0 to KnownRetranslators.Count-1 do
  begin
    retranslator:=TTP_Retranslator(KnownRetranslators.List[retranslatorIndex]);
    itemIndex:=0;
    while itemIndex<retranslator.list.Count do
    begin
      item:=TTP_RetranslatorItem(retranslator.list.List[itemIndex]);
      if item.obj=obj then
      begin
        item.Free;
        retranslator.list.delete(itemIndex);
      end
      else
      begin
        inc(itemIndex);
      end;
    end;
  end;
end;

procedure TTP_Retranslator.Execute;
var
  i:integer;
  sl:TStrings;
  item:TTP_RetranslatorItem;
  newvalue:TranslatedUnicodeString;
  comp:TGnuGettextComponentMarker;
  ppi:PPropInfo;
begin
  for i:=0 to list.Count-1 do begin
    item:=TObject(list.items[i]) as TTP_RetranslatorItem;
    if item.obj is TComponent then begin
      comp:=TComponent(item.obj).FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
      if Assigned(comp) and (self<>comp.Retranslator) then begin
        comp.Retranslator.Execute;
        Continue;
      end;
    end;
    if item.obj is TStrings then begin
      // Since we don't know the order of items in sl, and don't have
      // the original .Objects[] anywhere, we cannot anticipate anything
      // about the current sl.Strings[] and sl.Objects[] values. We therefore
      // have to discard both values. We can, however, set the original .Strings[]
      // value into the list and retranslate that.
      sl:=TStringList.Create;
      try
        sl.Text:=item.OldValue;
        Instance.TranslateStrings(sl,textdomain);
        (item.obj as TStrings).BeginUpdate;
        try
          (item.obj as TStrings).Text:=sl.Text;
        finally
          (item.obj as TStrings).EndUpdate;
        end;
      finally
        FreeAndNil (sl);
      end;
    end else begin
      if (textdomain = '') or (textdomain = DefaultTextDomain) then
        newValue := ComponentGettext(item.OldValue, instance)
      else
        newValue := instance.dgettext(textdomain,item.OldValue);
      ppi:=GetPropInfo(item.obj, item.Propname);
      if ppi<>nil then begin
        SetWideStrProp(item.obj, ppi, newValue);
      end else begin
        {$ifdef DXGETTEXTDEBUG}
        Instance.DebugWriteln ('ERROR: On retranslation, property disappeared: '+item.Propname+' for object of type '+item.obj.ClassName);
        {$endif}
      end;
    end;
  end;
end;

procedure TTP_Retranslator.Remember(obj: TObject; PropName: ComponentNameString;
  OldValue: TranslatedUnicodeString);
var
  item:TTP_RetranslatorItem;
begin
  item:=TTP_RetranslatorItem.Create;
  item.obj:=obj;
  item.Propname:=Propname;
  item.OldValue:=OldValue;
  list.Add(item);

  // As we are storing a reference to an object in our list, we must be notified
  // when that object is deleted.
  // The only way to do that for any instance of TObject is to hook into
  // BeforeDestruction via the virtual method table.
  HookedObjects.Proxify(obj);
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
    {$IFDEF CPUX64}
    patchPosition := pansiChar(Pointer(patchPosition + 4 + PInteger(patchPosition)^)^);
    {$ELSE}
    patchPosition := pansiChar(Pointer(pointer(patchPosition)^)^);
    {$ENDIF CPUX64}
  end;
  offset:=pansiChar(NewProc)-pansiChar(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((pansichar(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;
                           const ResName: string);
var
  i:cardinal;
  nn:integer;
  mofile:TStream;
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}

{$IFDEF dx_SupportsResources}
  if ResName <> '' then begin
    // Read the whole file into memory
    mofile:=TResourceStream.Create(HInstance, ResName, RT_RCDATA);
    try
      size := mofile.Size;
      Getmem (momemoryHandle, size);
      momemory := momemoryHandle;
      mofile.ReadBuffer(momemory^, size);
    finally
      FreeAndNil(mofile);
    end;
  end else
{$endif dx_SupportsResources}
  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.Position := offset;
      mofile.ReadBuffer(momemory^, size);
    finally
      FreeAndNil(mofile);
    end;
  end;

  // Check the magic number
  doswap:=False;
  i:=CardinalInMem(momemory,0);
  if (i <> $950412DE) and (i <> $DE120495) then
    raise EGGIOError.Create('This file is not a valid GNU gettext mo file: ' + filename);
  doswap := (i = $DE120495);


  // Find the positions in the file according to the file format spec
  CardinalInMem(momemory,4);       // Read the version number, but don't use it for anything.
  N:=CardinalInMem(momemory,8);    // Get string count
  O:=CardinalInMem(momemory,12);   // Get offset of original strings
  T:=CardinalInMem(momemory,16);   // Get offset of translated strings

  // Calculate start conditions for a binary search
  nn := N;
  startindex := 1;
  while nn <> 0 do begin
    nn := nn shr 1;
    startindex := startindex shl 1;
  end;
  startindex := startindex shr 1;
  startstep := startindex shr 1;
end;

destructor TMoFile.Destroy;
begin
  if FUseMemoryMappedFiles then
  begin
    UnMapViewOfFile (momemoryHandle);
    CloseHandle (momapping);
    CloseHandle (mo);
  end
  else
  begin
    FreeMem (momemoryHandle);
  end;

  inherited;
end;

function TMoFile.gettext(const msgid: RawUtf8String;var found:boolean): RawUtf8String;
var
  i, step: cardinal;
  offset, pos: cardinal;
  CompareResult:integer;
  msgidptr,a,b:PAnsiChar;
  abidx:integer;
  size, msgidsize:integer;
begin
  found:=false;
  msgidptr:=PAnsiChar(msgid);
  msgidsize:=length(msgid);

  // Do binary search
  i:=startindex;
  step:=startstep;
  while true do begin
    // Get string for index i
    pos:=O+8*(i-1);
    offset:=CardinalInMem (momemory,pos+4);
    size:=CardinalInMem (momemory,pos);
    a:=msgidptr;
    b:=momemory+offset;
    abidx:=size;
    if msgidsize<abidx then
      abidx:=msgidsize;
    CompareResult:=0;
    while abidx<>0 do begin
      CompareResult:=integer(byte(a^))-integer(byte(b^));
      if CompareResult<>0 then
        break;
      dec (abidx);
      inc (a);
      inc (b);
    end;
    if CompareResult=0 then
      CompareResult:=msgidsize-size;
    if CompareResult=0 then begin  // msgid=s
      // Found the msgid
      pos:=T+8*(i-1);
      offset:=CardinalInMem (momemory,pos+4);
      size:=CardinalInMem (momemory,pos);
      SetString (Result,momemory+offset,size);
      found:=True;
      break;
    end;
    if step=0 then begin
      // Not found
      Result:=msgid;
      break;
    end;
    if CompareResult<0 then begin  // 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;

{ THookedObjects }

function getClassData(aClass:TClass):PProxyClassData; overload; {$ifdef dx_has_Inline}inline;{$endif}
begin
  Result:=PProxyClassData((PAnsiChar(aClass) + vmtSelfPtr));
end;

function getClassData(obj:TObject):PProxyClassData; overload; {$ifdef dx_has_Inline}inline;{$endif}
begin
  Result:=getClassData(obj.ClassType);
end;

function GetBeforeDestructionVmtAddress(AClass: TClass): PPointer; overload;
asm
  {$IFDEF CPU386}
  lea eax, eax + VMTOFFSET TObject.BeforeDestruction
  {$ENDIF CPU386}
  {$IFDEF CPUx64}
  lea rax, rcx + VMTOFFSET TObject.BeforeDestruction
  {$ENDIF CPUx64}
end;

procedure THookedObjects.BeforeDestructionHook;
type
  TOriginalBeforeDestruction = procedure of object;
var
  method:TMethod;
begin
  // NOTE: this method is declared inside THookedObjects to have access
  // to Self, but because it is used as a hook for other classes' BeforeDestruction,
  // Self will not be an instance of THookedObjects but one of the hooked class.

  // remove ourselves from known retranslators
  RemoveFromKnowRetranslators(Self);

  // call the inherited BeforeDestruction
  // we must do it via the parent class type because simply writing
  // inherited BeforeDestruction will be resolved at compile time to
  // TObject.BeforeDestruction which is not what we want
  method.Code:=GetBeforeDestructionVmtAddress(getClassData(ClassType)^.Parent^)^;
  method.Data:=Self;
  TOriginalBeforeDestruction(method);

  // Remove from hooked objects (Remember, Self is not a THookedObjects instance)
  HookedObjects.Remove(Self);
end;

constructor THookedObjects.Create;
begin
  inherited Create;

  interceptorClassDatas:=TList.Create;
end;

destructor THookedObjects.Destroy;
var
  i:Integer;
begin
  for i:=0 to Count-1 do
    Unproxify(TObject(Items[i]));

  for i:=0 to interceptorClassDatas.Count-1 do
    FreeMem(interceptorClassDatas[i]);
  interceptorClassDatas.Free;

  inherited Destroy;
end;

function THookedObjects.GetBeforeDestructionHookAddress: Pointer;
type
  TBeforeDestructionHook=procedure of object;
var
  m:TBeforeDestructionHook;
begin
  m:=BeforeDestructionHook;
  Result:=TMethod(m).Code;
end;

function THookedObjects.findInterceptorClassData(aClass:TClass):Pointer;
var
  i:Integer;
  proxyClassData:Pointer;
begin
  i:=0;
  Result:=nil;
  while (i<interceptorClassDatas.Count) and (Result=nil) do
  begin
    proxyClassData:=interceptorClassDatas[i];
    if (PProxyClassData(proxyClassData)^.Parent^=aClass) or (PProxyClassData(proxyClassData)^.SelfPtr=aClass) then
      Result:=proxyClassData;

    Inc(i);
  end;
end;

{$ifdef dx_has_VclThemes}
type
  TCustomStyleEngineAccess=
    class(TCustomStyleEngine)
    public
      class property RegisteredStyleHooks;
    end;
{$endif dx_has_VclThemes}

procedure THookedObjects.Proxify(obj:TObject);
const
  growthCapacity=50;
var
  proxyClass:TClass;
  proxyClassData:Pointer;
  objClassData:PProxyClassData;
  size,classOfs:Integer;
  beforeDestructionVmtAddr:PPointer;
  hookedClassNameLength:Cardinal;
begin
  if IndexOf(obj)<0 then
  begin
    classOfs:=-vmtSelfPtr;
    proxyClassData:=findInterceptorClassData(obj.ClassType);
    if proxyClassData=nil then
    begin
      // According to Allen Bauer, we know that the ClassName is stored right after the
      // virtual method pointers.
      // So to figure out the size, we take the difference between the start of the VMT
      // and the location of ClassName.
      // See the following link for reference:
      // http://stackoverflow.com/questions/760513/where-can-i-find-information-on-the-structure-of-the-delphi-vmt
      objClassData:=getClassData(obj.ClassType);
      hookedClassNameLength:=Length(objClassData.ClassName^)+3;
      if hookedClassNameLength>255 then
        hookedClassNameLength:=255;
      size:=NativeUInt(objClassData.ClassName)-NativeUInt(objClassData)+hookedClassNameLength+2;

      proxyClassData:=AllocMem(size);
      interceptorClassDatas.Add(proxyClassData);

      proxyClass:=TClass(PAnsiChar(proxyClassData) + classOfs);

      // Copy everything from the original class data then do the following adjustments:
      // - Parent points to the address of the original data SelfPtr.
      // - SelfPtr points to ourselves
      // - ClassName points at the end of our structure to respect compiler layout (see above)
      // - ClassName gets a suffix as it helps when debugging
      System.Move(objClassData^, proxyClassData^, size);
      PProxyClassData(proxyClassData)^.Parent:=@(objClassData^.SelfPtr);
      PProxyClassData(proxyClassData)^.SelfPtr:=proxyClass;
{$IFDEF dx_ChangeProxyClassname}
      PProxyClassData(proxyClassData)^.ClassName:=PShortString(PAnsiChar(proxyClassData)+size-hookedClassNameLength-2);
      SetLength(PProxyClassData(proxyClassData)^.ClassName^,hookedClassNameLength);
      System.Move(AnsiString('!dx'#0),(PAnsiChar(PProxyClassData(proxyClassData)^.ClassName)+hookedClassNameLength+1-3)^,4);
{$ENDIF}

      // Place our BeforeDestruction virtual method in the metaclass VMT
      beforeDestructionVmtAddr:=GetBeforeDestructionVmtAddress(proxyClass);
      beforeDestructionVmtAddr^:=GetBeforeDestructionHookAddress;

      {$ifdef dx_has_VclThemes}
      // As we replace the metaclass for the object, the style engine will not
      // know about our new metaclass, and thus we must tell it it exists.
      if TCustomStyleEngineAccess.RegisteredStyleHooks.ContainsKey(obj.ClassType) and
         not TCustomStyleEngineAccess.RegisteredStyleHooks.ContainsKey(proxyClass) then
        TCustomStyleEngine.RegisterStyleHook(proxyClass, TCustomStyleEngineAccess.RegisteredStyleHooks[obj.ClassType].Last);
      {$endif dx_has_VclThemes}
    end
    else
    begin
      proxyClass:=TClass(PAnsiChar(proxyClassData) + classOfs);
    end;

    PPointer(obj)^:=proxyClass;
    Add(obj);
  end;
end;

procedure THookedObjects.Unproxify(obj:TObject);
begin
  PPointer(obj)^:=getClassData(obj)^.Parent^;
end;
{$ifdef dx_German_Delphi_fix}
function VclMenusShortCutToText(ShortCut: TShortCut): string;
{$IfDEF dx_has_StringBuilder}
var
  sbShortCut: TStringBuilder;
begin
  HookShortCutToText.Disable;
  try
    // Call original function to get shortcut
{$IFDEF dx_has_dotted_unitnames}
    Result := Vcl.Menus.ShortCutToText(ShortCut);
{$ELSE ~dx_has_dotted_unitnames}
    Result := Menus.ShortCutToText(ShortCut);
{$ENDIF dx_has_dotted_unitnames}

    // Shortcuts are in German by default, so
    // if currently used language is not German: replace the German names by English names
    if not SameText(GetCurrentLanguageCode, 'de') then
      begin
        // Use a Stringbuilder as it is way more performant in replace operations than StringReplace
        sbShortCut := TStringBuilder.Create(Result);
        try
          // Replace German shortcut names
{$IFDEF dx_has_dotted_unitnames}
          sbShortCut.
            Replace(Vcl.Consts.SmkcBkSp, 'BkSp'). // 'Rueck'
            Replace(Vcl.Consts.SmkcEnter, 'Enter'). // 'Eingabe'
            Replace(Vcl.Consts.SmkcSpace, 'Space'). // 'Leer'
            Replace(Vcl.Consts.SmkcPgUp, 'PgUp'). // 'BildAuf'
            Replace(Vcl.Consts.SmkcPgDn, 'PgDn'). // 'BildAb'
            Replace(Vcl.Consts.SmkcEnd, 'End'). // 'Ende'
            Replace(Vcl.Consts.SmkcHome, 'Home'). // 'Pos1'
            Replace(Vcl.Consts.SmkcLeft, 'Left'). // 'Links'
            Replace(Vcl.Consts.SmkcUp, 'Up'). // 'Auf'
            Replace(Vcl.Consts.SmkcRight, 'Right'). // 'Rechts'
            Replace(Vcl.Consts.SmkcDown, 'Down'). // 'Ab'
            Replace(Vcl.Consts.SmkcIns, 'Ins'). // 'Einfg'
            Replace(Vcl.Consts.SmkcDel, 'Del'). // 'Entf'
            Replace(Vcl.Consts.SmkcShift, 'Shift+'). // 'Umsch+'
            Replace(Vcl.Consts.SmkcCtrl, 'Ctrl+'); // 'Strg+'
{$ELSE ~dx_has_dotted_unitnames}
          sbShortCut.
            Replace(Consts.SmkcBkSp, 'BkSp'). // 'Rueck'
            Replace(Consts.SmkcEnter, 'Enter'). // 'Eingabe'
            Replace(Consts.SmkcSpace, 'Space'). // 'Leer'
            Replace(Consts.SmkcPgUp, 'PgUp'). // 'BildAuf'
            Replace(Consts.SmkcPgDn, 'PgDn'). // 'BildAb'
            Replace(Consts.SmkcEnd, 'End'). // 'Ende'
            Replace(Consts.SmkcHome, 'Home'). // 'Pos1'
            Replace(Consts.SmkcLeft, 'Left'). // 'Links'
            Replace(Consts.SmkcUp, 'Up'). // 'Auf'
            Replace(Consts.SmkcRight, 'Right'). // 'Rechts'
            Replace(Consts.SmkcDown, 'Down'). // 'Ab'
            Replace(Consts.SmkcIns, 'Ins'). // 'Einfg'
            Replace(Consts.SmkcDel, 'Del'). // 'Entf'
            Replace(Consts.SmkcShift, 'Shift+'). // 'Umsch+'
            Replace(Consts.SmkcCtrl, 'Ctrl+'); // 'Strg+'
{$ENDIF dx_has_dotted_unitnames}
          Result := sbShortCut.ToString;
        finally
          sbShortCut.Free;
        end;
      end;
  finally
    HookShortCutToText.Enable;
  end;
end;
{$ELSE ~ dx_has_StringBuilder}
begin
  HookShortCutToText.Disable;
  try
    // Call original function to get shortcut
    Result := Menus.ShortCutToText(ShortCut);

    // Shortcuts are in German by default, so
    // if currently used language is not German: replace the German names by English names
    if not SameText(GetCurrentLanguageCode, 'de') then
      begin
        Result := StringReplace(Result, Consts.SmkcBkSp, 'BkSp', []); // 'Rueck'
        Result := StringReplace(Result, Consts.SmkcEnter, 'Enter', []); // 'Eingabe'
        Result := StringReplace(Result, Consts.SmkcSpace, 'Space', []); // 'Leer'
        Result := StringReplace(Result, Consts.SmkcPgUp, 'PgUp', []); // 'BildAuf'
        Result := StringReplace(Result, Consts.SmkcPgDn, 'PgDn', []); // 'BildAb'
        Result := StringReplace(Result, Consts.SmkcEnd, 'End', []); // 'Ende'
        Result := StringReplace(Result, Consts.SmkcHome, 'Home', []); // 'Pos1'
        Result := StringReplace(Result, Consts.SmkcLeft, 'Left', []); // 'Links'
        Result := StringReplace(Result, Consts.SmkcUp, 'Up', []); // 'Auf'
        Result := StringReplace(Result, Consts.SmkcRight, 'Right', []); // 'Rechts'
        Result := StringReplace(Result, Consts.SmkcDown, 'Down', []); // 'Ab'
        Result := StringReplace(Result, Consts.SmkcIns, 'Ins', []); // 'Einfg'
        Result := StringReplace(Result, Consts.SmkcDel, 'Del', []); // 'Entf'
        Result := StringReplace(Result, Consts.SmkcShift, 'Shift+', []); // 'Umsch+'
        Result := StringReplace(Result, Consts.SmkcCtrl, 'Ctrl+', []); // 'Strg+'
      end;
  finally
    HookShortCutToText.Enable;
  end;
end;
{$ENDIF dx_has_StringBuilder}
{$endif dx_German_Delphi_fix}

{$IFDEF dx_SupportsResources}
{ TResourceFileInfo }

constructor TResourceFileInfo.Create(const _ResourceName: string);
begin
  inherited Create;
  ResourceName := _ResourceName;
end;
{$ENDIF dx_SupportsResources}

var
  param0:string;

initialization
  {$ifdef DXGETTEXTDEBUG}
  {$ifdef MSWINDOWS}
  MessageBox (0,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.','Information',MB_OK);
  {$endif}
  {$ifdef LINUX}
  writeln (stderr,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.');
  {$endif}
  {$endif}
  {$ifdef FPC}
    {$ifdef LINUX}
      SetLocale(LC_ALL, '');
      SetCWidestringManager;
    {$endif LINUX}
  {$endif FPC}
  // Get DLL/shared object filename
  SetLength(ExecutableFilename, 300); // MAX_PATH ?
  {$ifdef MSWINDOWS}
  SetLength(ExecutableFilename, GetModuleFileName(HInstance,
    PChar(ExecutableFilename), Length(ExecutableFilename)));
  {$endif}
  {$ifdef LINUX}
  if ModuleIsLib or ModuleIsPackage then
  begin
    // This line has not been tested on Linux, yet, but should work.
    SetLength(ExecutableFilename, GetModuleFileName(0, PChar(ExecutableFilename),
      Length(ExecutableFilename)));
  end else
    ExecutableFilename:=Paramstr(0);
  {$endif}
  FileLocator:=TFileLocator.Create;
  FileLocator.Analyze;
  ResourceStringDomainList:=TStringList.Create;
  ResourceStringDomainList.Add(DefaultTextDomain);
  ResourceStringDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create;
  ComponentDomainList:=TStringList.Create;
  ComponentDomainList.Add(DefaultTextDomain);
  ComponentDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create;
  DefaultInstance:=TGnuGettextInstance.Create;
  {$ifdef MSWINDOWS}
  Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
  {$endif}

  // replace Borlands LoadResString with gettext enabled version:
  {$ifdef UNICODE}
  HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringW);
  {$else}
  HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringA);
  {$endif}
  HookLoadStr:=THook.Create (@sysutils.LoadStr, @SysUtilsLoadStr);
  HookFmtLoadStr:=THook.Create (@sysutils.FmtLoadStr, @SysUtilsFmtLoadStr);
{$ifdef dx_German_Delphi_fix}
  // Create hook for Vcl.Menus.ShortCutToText to translate shortcut strings.
{$IFDEF dx_has_dotted_unitnames}
  HookShortCutToText := THook.Create(@Vcl.Menus.ShortCutToText, @VclMenusShortCutToText);
{$ELSE ~dx_has_dotted_unitnames}
  HookShortCutToText := THook.Create(@Menus.ShortCutToText, @VclMenusShortCutToText);
{$ENDIF dx_has_dotted_unitnames}
{$endif dx_German_Delphi_fix}
  param0:=lowercase(extractfilename(paramstr(0)));
  if (param0<>'delphi32.exe') and (param0<>'kylix') and (param0<>'bds.exe') then
    begin
      HookIntoResourceStrings (AutoCreateHooks,false);
{$ifdef dx_German_Delphi_fix}
      HookShortCutToText.Enable;
{$endif dx_German_Delphi_fix}
    end;
  param0:='';

  HookedObjects:=THookedObjects.Create;
  KnownRetranslators:=TList.Create;

finalization
  FreeAndNil (DefaultInstance);
  FreeAndNil (ResourceStringDomainListCS);
  FreeAndNil (ResourceStringDomainList);
  FreeAndNil (ComponentDomainListCS);
  FreeAndNil (ComponentDomainList);
  FreeAndNil (HookFmtLoadStr);
  FreeAndNil (HookLoadStr);
  FreeAndNil (HookLoadResString);
  FreeAndNil (FileLocator);
  FreeAndNil (HookedObjects);
  FreeAndNil (KnownRetranslators);
{$ifdef dx_German_Delphi_fix}
  FreeAndNil (HookShortCutToText);
{$endif dx_German_Delphi_fix}

end.