gnugettext.pas
Upload User: hbtlgg88
Upload Date: 2021-04-09
Package Size: 855k
Code Size: 62k
Category:

Delphi VCL

Development Platform:

C++ Builder

  1. unit gnugettext;
  2. (**************************************************************)
  3. (*                                                            *)
  4. (*  (C) Copyright by Lars B. Dybdahl and others               *)
  5. (*  E-mail: Lars@dybdahl.dk, phone +45 70201241               *)
  6. (*  You may distribute and modify this file as you wish       *)
  7. (*  for free                                                  *)
  8. (*                                                            *)
  9. (*  Contributors: Peter Thornqvist, Troy Wolbrink,            *) 
  10. (*                Frank Andreas de Groot                      *)
  11. (*                                                            *)
  12. (*  See http://dybdahl.dk/dxgettext/ for more information     *)
  13. (*                                                            *)
  14. (**************************************************************)
  15. interface
  16. uses
  17.   Classes, SysUtils, TypInfo;
  18. (*****************************************************************************)
  19. (*                                                                           *)
  20. (*  MAIN API                                                                 *)
  21. (*                                                                           *)
  22. (*****************************************************************************)
  23. // All these identical functions translate a text
  24. function _(const szMsgId: widestring): widestring;
  25. function gettext(const szMsgId: widestring): widestring;
  26. // Translates a component (form, frame etc.) to the currently selected language.
  27. // Put TranslateComponent(self) in the OnCreate event of all your forms.
  28. // See the FAQ on the homepage if your application takes a long time to start.
  29. procedure TranslateComponent(AnObject: TComponent; TextDomain:string='');
  30. // Add more domains that resourcestrings can be extracted from. If a translation
  31. // is not found in the default domain, this domain will be searched, too.
  32. // This is useful for adding mo files for certain runtime libraries and 3rd
  33. // party component libraries
  34. procedure AddDomainForResourceString (domain:string);
  35. // Set language to use
  36. procedure UseLanguage(LanguageCode: string);
  37. // Unicode-enabled way to get resourcestrings, automatically translated
  38. // Use like this: ws:=LoadResStringW(@NameOfResourceString);
  39. function LoadResString(ResStringRec: PResStringRec): widestring;
  40. function LoadResStringA(ResStringRec: PResStringRec): ansistring;
  41. function LoadResStringW(ResStringRec: PResStringRec): widestring;
  42. // This returns an empty string if not translated or translator name is not specified.
  43. function GetTranslatorNameAndEmail:widestring;
  44. (*****************************************************************************)
  45. (*                                                                           *)
  46. (*  ADVANCED FUNCTIONALITY                                                   *)
  47. (*                                                                           *)
  48. (*****************************************************************************)
  49. const
  50.   DefaultTextDomain = 'default';
  51.   RuntimePackageSupportEnabled=false; // This is experimental code. Don't set this to true unless you know what you do.
  52. var
  53.   ExecutableFilename:string;    // This is set to paramstr(0). Modify it for dll-files to point to the full dll path filename.
  54. (*
  55.  Make sure that the next TranslateProperties(self) will ignore
  56.  the string property specified, e.g.:
  57.  TP_Ignore (self,'ButtonOK.Caption');   // Ignores caption on ButtonOK
  58.  TP_Ignore (self,'MyDBGrid');           // Ignores all properties on component MyDBGrid
  59.  TP_Ignore (self,'.Caption');           // Ignores self's caption
  60.  Only use this function just before calling TranslateProperties(self).
  61.  If this function is being used, please only call TP_Ignore and TranslateProperties
  62.  From the main thread.
  63. *)
  64. procedure TP_Ignore(AnObject:TObject; const name:string);
  65. // Make TranslateProperties() not translate any objects descending from IgnClass
  66. procedure TP_GlobalIgnoreClass (IgnClass:TClass);
  67. // Make TranslateProperties() not translate a named property in all objects
  68. // descending from IgnClass
  69. procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
  70. type
  71.   TTranslator=procedure (obj:TObject) of object;
  72. // Make TranslateProperties() not translate any objects descending from HClass
  73. // but instead call the specified Handler on each of these objects. The Name
  74. // property of TComponent is already added and doesn't have to be added.
  75. procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
  76. // Translate a component's properties and all subcomponents
  77. // Use this on a Delphi TForm or a CLX program's QForm.
  78. // It will only translate string properties, but see TP_ functions
  79. // below if there are things you don't want to have translated.
  80. procedure TranslateProperties(AnObject: TObject; TextDomain:string='');
  81. // Load an external GNU gettext dll to be used instead of the internal
  82. // implementation. Returns true if the dll is loaded. If the dll was already
  83. // loaded, this function can be used to query whether it was loaded.
  84. // On Linux, this function enables the Libc version of GNU gettext
  85. // After calling this function, you must set all settings again
  86. function LoadDLLifPossible (dllname:string='gnu_gettext.dll'):boolean;
  87. function GetCurrentLanguage:string;
  88. // These functions are also from the orginal GNU gettext implementation.
  89. // Only use these, if you need to split up your translation into several
  90. // .mo files.
  91. function dgettext(const szDomain: string; const szMsgId: widestring): widestring; 
  92. function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
  93. function ngettext(const singular,plural: widestring; Number:longint): widestring;
  94. procedure textdomain(const szDomain: string);
  95. function getcurrenttextdomain: string;
  96. procedure bindtextdomain(const szDomain: string; const szDirectory: string);
  97. (*****************************************************************************)
  98. (*                                                                           *)
  99. (*  CLASS based implementation. Use this to have more than one language      *)
  100. (*  in your application at the same time                                     *)
  101. (*  Do not exploit this feature if you plan to use LoadDLLifPossible()       *)
  102. (*                                                                           *)
  103. (*****************************************************************************)
  104. type
  105.   TExecutable=
  106.     class
  107.       procedure Execute; virtual; abstract;
  108.     end;
  109.   TGetPluralForm=function (Number:Longint):Integer;
  110.   TGnuGettextInstance=
  111.     class   // Do not create multiple instances on Linux!
  112.     public
  113.       Enabled:Boolean;      // Set this to false to disable translations
  114.       constructor Create;
  115.       destructor Destroy; override;
  116.       procedure UseLanguage(LanguageCode: string);
  117.       function gettext(const szMsgId: widestring): widestring;
  118.       function ngettext(const singular,plural:widestring;Number:longint):widestring;
  119.       function GetCurrentLanguage:string;
  120.       function GetTranslationProperty (Propertyname:string):WideString;
  121.       function GetTranslatorNameAndEmail:widestring;
  122.       // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites()
  123.       procedure TP_Ignore(AnObject:TObject; const name:string);
  124.       procedure TP_GlobalIgnoreClass (IgnClass:TClass);
  125.       procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
  126.       procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
  127.       function TP_CreateRetranslator:TExecutable;  // Must be freed by caller!
  128.       procedure TranslateProperties(AnObject: TObject; textdomain:string='');
  129.       procedure TranslateComponent(AnObject: TComponent; TextDomain:string='');
  130.       // Multi-domain functions
  131.       function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
  132.       function dngettext(const szDomain,singular,plural:widestring;Number:longint):widestring;
  133.       procedure textdomain(const szDomain: string);
  134.       function getcurrenttextdomain: string;
  135.       procedure bindtextdomain(const szDomain: string; const szDirectory: string);
  136.       // Debugging and advanced tools
  137.       procedure SaveUntranslatedMsgids(filename: string);
  138.     protected
  139.       procedure TranslateStrings (sl:TStrings;TextDomain:string);
  140.     private
  141.       curlang: string;
  142.       curGetPluralForm:TGetPluralForm;
  143.       curmsgdomain: string;
  144.       savefileCS: TMultiReadExclusiveWriteSynchronizer;
  145.       savefile: TextFile;
  146.       savememory: TStringList;
  147.       DefaultDomainDirectory:string;
  148.       domainlist: TStringList;     // List of domain names. Objects are TDomain.
  149.       TP_IgnoreList:TStringList;   // Temporary list, reset each time TranslateProperties is called
  150.       TP_ClassHandling:TList;      // Items are TClassMode. If a is derived from b, a comes first
  151.       TP_Retranslator:TExecutable; // Cast this to TTP_Retranslator
  152.       procedure SaveCheck(szMsgId: widestring);
  153.       procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;
  154.         TodoList: TStrings; TextDomain:string);  // Translates a single property of an object
  155.     end;
  156. var
  157.   DefaultInstance:TGnuGettextInstance;
  158. implementation
  159. {$ifndef MSWINDOWS}
  160. {$ifndef LINUX}
  161.   'This version of gnugettext.pas is only meant to be compiled with Kylix 3,'
  162.   'Delphi 6, Delphi 7 and later versions. If you use other versions, please'
  163.   'get the gnugettext.pas version from the Delphi 5 directory.'
  164. {$endif}
  165. {$endif}
  166. {$ifdef MSWINDOWS}
  167. {$ifndef VER140}
  168. {$WARN UNSAFE_TYPE OFF}
  169. {$WARN UNSAFE_CODE OFF}
  170. {$WARN UNSAFE_CAST OFF}
  171. {$endif}
  172. {$endif}
  173. uses
  174.   {$ifdef MSWINDOWS}
  175.   Windows;
  176.   {$endif}
  177.   {$ifdef LINUX}
  178.   Libc;
  179.   {$endif}
  180. type
  181.   TTP_RetranslatorItem=
  182.     class
  183.       obj:TObject;
  184.       Propname:string;
  185.       OldValue:WideString;
  186.     end;
  187.   TTP_Retranslator=
  188.     class (TExecutable)
  189.       TextDomain:string;
  190.       Instance:TGnuGettextInstance;
  191.       constructor Create;
  192.       destructor Destroy; override;
  193.       procedure Remember (obj:TObject; PropName:String; OldValue:WideString);
  194.       procedure Execute; override;
  195.     private
  196.       list:TList;
  197.     end;
  198.   TAssemblyFileInfo=
  199.     class
  200.       offset,size:int64;
  201.     end;
  202.   TAssemblyAnalyzer=
  203.     class
  204.       constructor Create;
  205.       destructor Destroy; override;
  206.       procedure Analyze;
  207.       function FileExists (filename:string):boolean;
  208.       procedure GetFileInfo (filename:string; var realfilename:string; var offset, size:int64);
  209.     private
  210.       basedirectory:string;
  211.       filelist:TStringList; //Objects are TAssemblyFileInfo. Filenames are relative to .exe file
  212.       function ReadInt64 (str:TStream):int64;
  213.     end;
  214.   TGnuGettextComponentMarker=
  215.     class (TComponent)
  216.     public
  217.       LastLanguage:string;
  218.       Retranslator:TExecutable;
  219.       destructor Destroy; override;
  220.     end;
  221.   TDomain =
  222.     class
  223.     private
  224.       vDirectory: string;
  225.       procedure setDirectory(dir: string);
  226.     public                    
  227.       Domain: string;
  228.       property Directory: string read vDirectory write setDirectory;
  229.       constructor Create;
  230.       destructor Destroy; override;
  231.       procedure SetLanguageCode (langcode:string);
  232.       function gettext(msgid: ansistring): ansistring; // uses mo file
  233.     private
  234.       moCS: TMultiReadExclusiveWriteSynchronizer; // Covers next three lines
  235.       doswap: boolean;
  236.       N, O, T: Cardinal; // Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html
  237.       FileOffset:int64;
  238.       {$ifdef mswindows}
  239.       mo: THandle;
  240.       momapping: THandle;
  241.       {$endif}
  242.       momemoryHandle:PChar;
  243.       momemory: PChar;
  244.       curlang: string;
  245.       isopen, moexists: boolean;
  246.       procedure OpenMoFile;
  247.       procedure CloseMoFile;
  248.       function gettextbyid(id: cardinal): ansistring;
  249.       function getdsttextbyid(id: cardinal): ansistring;
  250.       function autoswap32(i: cardinal): cardinal;
  251.       function CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;
  252.     end;
  253.   TClassMode=
  254.     class
  255.       HClass:TClass;
  256.       SpecialHandler:TTranslator;
  257.       PropertiesToIgnore:TStringList; // This is ignored if Handler is set
  258.       constructor Create;
  259.       destructor Destroy; override;
  260.     end;
  261.   TRStrinfo = record
  262.     strlength, stroffset: cardinal;
  263.   end;
  264.   TStrInfoArr = array[0..10000000] of TRStrinfo;
  265.   PStrInfoArr = ^TStrInfoArr;
  266.   {$ifdef MSWindows}
  267.   tpgettext = function(const szMsgId: PChar): PChar; cdecl;
  268.   tpdgettext = function(const szDomain: PChar; const szMsgId: PChar): PChar; cdecl;
  269.   tpdcgettext = function(const szDomain: PChar; const szMsgId: PChar; iCategory: integer): PChar; cdecl;
  270.   tptextdomain = function(const szDomain: PChar): PChar; cdecl;
  271.   tpbindtextdomain = function(const szDomain: PChar; const szDirectory: PChar): PChar; cdecl;
  272.   tpgettext_putenv = function(const envstring: PChar): integer; cdecl;
  273.   TCharArray5=array[0..4] of ansichar;
  274.   THook=  // Replaces a runtime library procedure with a custom procedure
  275.     class
  276.     public
  277.       constructor Create (OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);
  278.       destructor Destroy; override;  // Restores unhooked state
  279.       procedure Disable;
  280.       procedure Enable;
  281.     private
  282.       ov: cardinal;
  283.       Patch:TCharArray5;
  284.       Original:TCharArray5;
  285.       PatchPosition:PChar;
  286.     end;
  287.   {$endif}
  288. var
  289.   Win32PlatformIsUnicode:boolean=False;
  290.   AssemblyAnalyzer:TAssemblyAnalyzer;
  291.   TPDomainListCS:TMultiReadExclusiveWriteSynchronizer;
  292.   TPDomainList:TStringList;
  293.   DLLisLoaded: boolean=false;
  294.   {$ifdef MSWINDOWS}
  295.   pgettext: tpgettext;
  296.   pdgettext: tpdgettext;
  297.   ptextdomain: tptextdomain;
  298.   pbindtextdomain: tpbindtextdomain;
  299.   pgettext_putenv: tpgettext_putenv;
  300.   dllmodule: THandle;
  301.   HookLoadResString:THook;
  302.   {$endif}
  303. function StripCR (s:string):string;
  304. var
  305.   i:integer;
  306. begin
  307.   i:=1;
  308.   while i<=length(s) do begin
  309.     if s[i]=#13 then delete (s,i,1) else inc (i);
  310.   end;
  311.   Result:=s;
  312. end;
  313. function GGGetEnvironmentVariable (name:string):string;
  314. begin
  315.   Result:=SysUtils.GetEnvironmentVariable(name);
  316. end;
  317. function LF2LineBreakA (s:string):string;
  318. {$ifdef MSWINDOWS}
  319. var
  320.   i:integer;
  321. {$endif}
  322. begin
  323.   {$ifdef MSWINDOWS}
  324.   Assert (sLinebreak=#13#10);
  325.   i:=1;
  326.   while i<=length(s) do begin
  327.     if (s[i]=#10) and (copy(s,i-1,1)<>#13) then begin
  328.       insert (#13,s,i);
  329.       inc (i,2);
  330.     end else
  331.       inc (i);
  332.   end;
  333.   {$endif}
  334.   Result:=s;
  335. end;
  336. function IsWriteProp(Info: PPropInfo): Boolean;
  337. begin
  338.   Result := Assigned(Info) and (Info^.SetProc <> nil);
  339. end;
  340. procedure SaveUntranslatedMsgids(filename: string);
  341. begin
  342.   DefaultInstance.SaveUntranslatedMsgids(filename);
  343. end;
  344. function string2csyntax(s: string): string;
  345. // Converts a string to the syntax that is used in .po files
  346. var
  347.   i: integer;
  348.   c: char;
  349. begin
  350.   Result := '';
  351.   for i := 1 to length(s) do begin
  352.     c := s[i];
  353.     case c of
  354.       #32..#33, #35..#255: Result := Result + c;
  355.       #13: Result := Result + 'r';
  356.       #10: Result := Result + 'n"'#13#10'"';
  357.       #34: Result := Result + '"';
  358.     else
  359.       Result := Result + 'x' + IntToHex(ord(c), 2);
  360.     end;
  361.   end;
  362.   Result := '"' + Result + '"';
  363. end;
  364. function ResourceStringGettext(MsgId: widestring): widestring;
  365. var
  366.   i:integer;
  367. begin
  368.   if TPDomainListCS=nil then begin
  369.     // This only happens during very complicated program startups that fail
  370.     Result:=MsgId;
  371.     exit;
  372.   end;
  373.   TPDomainListCS.BeginRead;
  374.   try
  375.     for i:=0 to TPDomainList.Count-1 do begin
  376.       Result:=dgettext(TPDomainList.Strings[i], MsgId);
  377.       if Result<>MsgId then
  378.         break;
  379.     end;
  380.   finally
  381.     TPDomainListCS.EndRead;
  382.   end;
  383. end;
  384. function gettext(const szMsgId: widestring): widestring;
  385. begin
  386.   Result:=DefaultInstance.gettext(szMsgId);
  387. end;
  388. function _(const szMsgId: widestring): widestring;
  389. begin
  390.   Result:=DefaultInstance.gettext(szMsgId);
  391. end;
  392. function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
  393. begin
  394.   Result:=DefaultInstance.dgettext(szDomain, szMsgId);
  395. end;
  396. function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
  397. begin
  398.   Result:=DefaultInstance.dngettext(szDomain,singular,plural,Number);
  399. end;
  400. function ngettext(const singular,plural: widestring; Number:longint): widestring;
  401. begin
  402.   Result:=DefaultInstance.ngettext(singular,plural,Number);
  403. end;
  404. procedure textdomain(const szDomain: string);
  405. begin
  406.   DefaultInstance.textdomain(szDomain);
  407. end;
  408. procedure SetGettextEnabled (enabled:boolean);
  409. begin
  410.   DefaultInstance.Enabled:=enabled;
  411. end;
  412. function getcurrenttextdomain: string;
  413. begin
  414.   Result:=DefaultInstance.getcurrenttextdomain;
  415. end;
  416. procedure bindtextdomain(const szDomain: string; const szDirectory: string);
  417. begin
  418.   DefaultInstance.bindtextdomain(szDomain, szDirectory);
  419. end;
  420. procedure TP_Ignore(AnObject:TObject; const name:string);
  421. begin
  422.   DefaultInstance.TP_Ignore(AnObject, name);
  423. end;
  424. procedure TP_GlobalIgnoreClass (IgnClass:TClass);
  425. begin
  426.   DefaultInstance.TP_GlobalIgnoreClass(IgnClass);
  427. end;
  428. procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
  429. begin
  430.   DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass,propertyname);
  431. end;
  432. procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
  433. begin
  434.   DefaultInstance.TP_GlobalHandleClass (HClass, Handler);
  435. end;
  436. procedure TranslateProperties(AnObject: TObject; TextDomain:string='');
  437. begin
  438.   DefaultInstance.TranslateProperties(AnObject, TextDomain);
  439. end;
  440. procedure TranslateComponent(AnObject: TComponent; TextDomain:string='');
  441. begin
  442.   DefaultInstance.TranslateComponent(AnObject, TextDomain);
  443. end;
  444. {$ifdef MSWINDOWS}
  445. // These constants are only used in Windows 95
  446. // Thanks to Frank Andreas de Groot for this table
  447. const
  448.   IDAfrikaans                 = $0436;  IDAlbanian                  = $041C;
  449.   IDArabicAlgeria             = $1401;  IDArabicBahrain             = $3C01;
  450.   IDArabicEgypt               = $0C01;  IDArabicIraq                = $0801;
  451.   IDArabicJordan              = $2C01;  IDArabicKuwait              = $3401;
  452.   IDArabicLebanon             = $3001;  IDArabicLibya               = $1001;
  453.   IDArabicMorocco             = $1801;  IDArabicOman                = $2001;
  454.   IDArabicQatar               = $4001;  IDArabic                    = $0401;
  455.   IDArabicSyria               = $2801;  IDArabicTunisia             = $1C01;
  456.   IDArabicUAE                 = $3801;  IDArabicYemen               = $2401;
  457.   IDArmenian                  = $042B;  IDAssamese                  = $044D;
  458.   IDAzeriCyrillic             = $082C;  IDAzeriLatin                = $042C;
  459.   IDBasque                    = $042D;  IDByelorussian              = $0423;
  460.   IDBengali                   = $0445;  IDBulgarian                 = $0402;
  461.   IDBurmese                   = $0455;  IDCatalan                   = $0403;
  462.   IDChineseHongKong           = $0C04;  IDChineseMacao              = $1404;
  463.   IDSimplifiedChinese         = $0804;  IDChineseSingapore          = $1004;
  464.   IDTraditionalChinese        = $0404;  IDCroatian                  = $041A;
  465.   IDCzech                     = $0405;  IDDanish                    = $0406;
  466.   IDBelgianDutch              = $0813;  IDDutch                     = $0413;
  467.   IDEnglishAUS                = $0C09;  IDEnglishBelize             = $2809;
  468.   IDEnglishCanadian           = $1009;  IDEnglishCaribbean          = $2409;
  469.   IDEnglishIreland            = $1809;  IDEnglishJamaica            = $2009;
  470.   IDEnglishNewZealand         = $1409;  IDEnglishPhilippines        = $3409;
  471.   IDEnglishSouthAfrica        = $1C09;  IDEnglishTrinidad           = $2C09;
  472.   IDEnglishUK                 = $0809;  IDEnglishUS                 = $0409;
  473.   IDEnglishZimbabwe           = $3009;  IDEstonian                  = $0425;
  474.   IDFaeroese                  = $0438;  IDFarsi                     = $0429;
  475.   IDFinnish                   = $040B;  IDBelgianFrench             = $080C;
  476.   IDFrenchCameroon            = $2C0C;  IDFrenchCanadian            = $0C0C;
  477.   IDFrenchCotedIvoire         = $300C;  IDFrench                    = $040C;
  478.   IDFrenchLuxembourg          = $140C;  IDFrenchMali                = $340C;
  479.   IDFrenchMonaco              = $180C;  IDFrenchReunion             = $200C;
  480.   IDFrenchSenegal             = $280C;  IDSwissFrench               = $100C;
  481.   IDFrenchWestIndies          = $1C0C;  IDFrenchZaire               = $240C;
  482.   IDFrisianNetherlands        = $0462;  IDGaelicIreland             = $083C;
  483.   IDGaelicScotland            = $043C;  IDGalician                  = $0456;
  484.   IDGeorgian                  = $0437;  IDGermanAustria             = $0C07;
  485.   IDGerman                    = $0407;  IDGermanLiechtenstein       = $1407;
  486.   IDGermanLuxembourg          = $1007;  IDSwissGerman               = $0807;
  487.   IDGreek                     = $0408;  IDGujarati                  = $0447;
  488.   IDHebrew                    = $040D;  IDHindi                     = $0439;
  489.   IDHungarian                 = $040E;  IDIcelandic                 = $040F;
  490.   IDIndonesian                = $0421;  IDItalian                   = $0410;
  491.   IDSwissItalian              = $0810;  IDJapanese                  = $0411;
  492.   IDKannada                   = $044B;  IDKashmiri                  = $0460;
  493.   IDKazakh                    = $043F;  IDKhmer                     = $0453;
  494.   IDKirghiz                   = $0440;  IDKonkani                   = $0457;
  495.   IDKorean                    = $0412;  IDLao                       = $0454;
  496.   IDLatvian                   = $0426;  IDLithuanian                = $0427;
  497.   IDMacedonian                = $042F;  IDMalaysian                 = $043E;
  498.   IDMalayBruneiDarussalam     = $083E;  IDMalayalam                 = $044C;
  499.   IDMaltese                   = $043A;  IDManipuri                  = $0458;
  500.   IDMarathi                   = $044E;  IDMongolian                 = $0450;
  501.   IDNepali                    = $0461;  IDNorwegianBokmol           = $0414;
  502.   IDNorwegianNynorsk          = $0814;  IDOriya                     = $0448;
  503.   IDPolish                    = $0415;  IDBrazilianPortuguese       = $0416;
  504.   IDPortuguese                = $0816;  IDPunjabi                   = $0446;
  505.   IDRhaetoRomanic             = $0417;  IDRomanianMoldova           = $0818;
  506.   IDRomanian                  = $0418;  IDRussianMoldova            = $0819;
  507.   IDRussian                   = $0419;  IDSamiLappish               = $043B;
  508.   IDSanskrit                  = $044F;  IDSerbianCyrillic           = $0C1A;
  509.   IDSerbianLatin              = $081A;  IDSesotho                   = $0430;
  510.   IDSindhi                    = $0459;  IDSlovak                    = $041B;
  511.   IDSlovenian                 = $0424;  IDSorbian                   = $042E;
  512.   IDSpanishArgentina          = $2C0A;  IDSpanishBolivia            = $400A;
  513.   IDSpanishChile              = $340A;  IDSpanishColombia           = $240A;
  514.   IDSpanishCostaRica          = $140A;  IDSpanishDominicanRepublic  = $1C0A;
  515.   IDSpanishEcuador            = $300A;  IDSpanishElSalvador         = $440A;
  516.   IDSpanishGuatemala          = $100A;  IDSpanishHonduras           = $480A;
  517.   IDMexicanSpanish            = $080A;  IDSpanishNicaragua          = $4C0A;
  518.   IDSpanishPanama             = $180A;  IDSpanishParaguay           = $3C0A;
  519.   IDSpanishPeru               = $280A;  IDSpanishPuertoRico         = $500A;
  520.   IDSpanishModernSort         = $0C0A;  IDSpanish                   = $040A;
  521.   IDSpanishUruguay            = $380A;  IDSpanishVenezuela          = $200A;
  522.   IDSutu                      = $0430;  IDSwahili                   = $0441;
  523.   IDSwedishFinland            = $081D;  IDSwedish                   = $041D;
  524.   IDTajik                     = $0428;  IDTamil                     = $0449;
  525.   IDTatar                     = $0444;  IDTelugu                    = $044A;
  526.   IDThai                      = $041E;  IDTibetan                   = $0451;
  527.   IDTsonga                    = $0431;  IDTswana                    = $0432;
  528.   IDTurkish                   = $041F;  IDTurkmen                   = $0442;
  529.   IDUkrainian                 = $0422;  IDUrdu                      = $0420;
  530.   IDUzbekCyrillic             = $0843;  IDUzbekLatin                = $0443;
  531.   IDVenda                     = $0433;  IDVietnamese                = $042A;
  532.   IDWelsh                     = $0452;  IDXhosa                     = $0434;
  533.   IDZulu                      = $0435;
  534. function GetWindowsLanguage: string;
  535. var
  536.   langid: Cardinal;
  537.   langcode: string;
  538.   CountryName: array[0..4] of char;
  539.   LanguageName: array[0..4] of char;
  540.   works: boolean;
  541. begin
  542.   // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero
  543.   works := 3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName));
  544.   works := works and (3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName,
  545.     SizeOf(CountryName)));
  546.   if works then begin
  547.     // Windows 98, Me, NT4, 2000, XP and newer
  548.     LangCode := PChar(@LanguageName[0]) + '_' + PChar(@CountryName[0]);
  549.   end else begin
  550.     // This part should only happen on Windows 95.
  551.     langid := GetThreadLocale;
  552.     case langid of
  553.       IDBelgianDutch: langcode := 'nl_BE';
  554.       IDBelgianFrench: langcode := 'fr_BE';
  555.       IDBrazilianPortuguese: langcode := 'pt_BR';
  556.       IDDanish: langcode := 'da_DK';
  557.       IDDutch: langcode := 'nl_NL';
  558.       IDEnglishUK: langcode := 'en_UK';
  559.       IDEnglishUS: langcode := 'en_US';
  560.       IDFinnish: langcode := 'fi_FI';
  561.       IDFrench: langcode := 'fr_FR';
  562.       IDFrenchCanadian: langcode := 'fr_CA';
  563.       IDGerman: langcode := 'de_DE';
  564.       IDGermanLuxembourg: langcode := 'de_LU';
  565.       IDGreek: langcode := 'gr_GR';
  566.       IDIcelandic: langcode := 'is_IS';
  567.       IDItalian: langcode := 'it_IT';
  568.       IDKorean: langcode := 'ko_KO';
  569.       IDNorwegianBokmol: langcode := 'no_NO';
  570.       IDNorwegianNynorsk: langcode := 'nn_NO';
  571.       IDPolish: langcode := 'pl_PL';
  572.       IDPortuguese: langcode := 'pt_PT';
  573.       IDRussian: langcode := 'ru_RU';
  574.       IDSpanish, IDSpanishModernSort: langcode := 'es_ES';
  575.       IDSwedish: langcode := 'sv_SE';
  576.       IDSwedishFinland: langcode := 'fi_SE';
  577.     else
  578.       langcode := 'C';
  579.     end;
  580.   end;
  581.   Result := langcode;
  582. end;
  583. {$endif}
  584. function LoadResStringA(ResStringRec: PResStringRec): string;
  585. begin
  586.   Result:=LoadResString(ResStringRec);
  587. end;
  588. procedure gettext_putenv(const envstring: string);
  589. begin
  590.   {$ifdef mswindows}
  591.   if DLLisLoaded and Assigned(pgettext_putenv) then
  592.     pgettext_putenv(PChar(envstring));
  593.   {$endif}
  594. end;
  595. function GetTranslatorNameAndEmail:widestring;
  596. begin
  597.   Result:=DefaultInstance.GetTranslatorNameAndEmail;
  598. end;
  599. procedure UseLanguage(LanguageCode: string);
  600. begin
  601.   DefaultInstance.UseLanguage(LanguageCode);
  602. end;
  603. function LoadResString(ResStringRec: PResStringRec): widestring;
  604. {$ifdef MSWINDOWS}
  605. var
  606.   Len: Integer;
  607.   Buffer: array [0..1023] of char;
  608. {$endif}
  609. begin
  610.   if (ResStringRec = nil) then
  611.     exit;
  612.   if ResStringRec.Identifier >= 64*1024 then
  613.     Result:=PChar(ResStringRec.Identifier)
  614.   else
  615.   {$ifdef LINUX}
  616.   // This works with Unicode if the Linux has utf-8 character set
  617.   Result:=System.LoadResString(ResStringRec);
  618.   {$endif}
  619.   {$ifdef MSWINDOWS}
  620.   if not Win32PlatformIsUnicode then begin
  621.     SetString(Result, Buffer,
  622.       LoadString(FindResourceHInstance(ResStringRec.Module^),
  623.         ResStringRec.Identifier, Buffer, SizeOf(Buffer)))
  624.   end else begin
  625.     Result := '';
  626.     Len := 0;
  627.     While Len = Length(Result) do begin
  628.       if Length(Result) = 0 then
  629.         SetLength(Result, 1024)
  630.       else
  631.         SetLength(Result, Length(Result) * 2);
  632.       Len := LoadStringW(FindResourceHInstance(ResStringRec.Module^),
  633.         ResStringRec.Identifier, PWideChar(Result), Length(Result));
  634.     end;
  635.     SetLength(Result, Len);
  636.   end;
  637.   {$endif}
  638.   Result:=ResourceStringGettext(Result);
  639. end;
  640. function LoadResStringW(ResStringRec: PResStringRec): widestring;
  641. begin
  642.   Result:=LoadResString(ResStringRec);
  643. end;
  644. function GetCurrentLanguage:string;
  645. begin
  646.   Result:=DefaultInstance.GetCurrentLanguage;
  647. end;
  648. function getdomain(list:TStringList; domain, DefaultDomainDirectory, CurLang: string): TDomain;
  649. // Retrieves the TDomain object for the specified domain.
  650. // Creates one, if none there, yet.
  651. var
  652.   idx: integer;
  653. begin
  654.   idx := list.IndexOf(Domain);
  655.   if idx = -1 then begin
  656.     Result := TDomain.Create;
  657.     Result.Domain := Domain;
  658.     Result.Directory := DefaultDomainDirectory;
  659.     Result.SetLanguageCode(curlang);
  660.     list.AddObject(Domain, Result);
  661.   end else begin
  662.     Result := list.Objects[idx] as TDomain;
  663.   end;
  664. end;
  665. { TDomain }
  666. function TDomain.CardinalInMem (baseptr:PChar; Offset:Cardinal):Cardinal;
  667. var pc:^Cardinal;
  668. begin
  669.   inc (baseptr,offset);
  670.   pc:=Pointer(baseptr);
  671.   Result:=pc^;
  672.   if doswap then
  673.     autoswap32(Result);
  674. end;
  675. function TDomain.autoswap32(i: cardinal): cardinal;
  676. var
  677.   cnv1, cnv2:
  678.     record
  679.       case integer of
  680.         0: (arr: array[0..3] of byte);
  681.         1: (int: cardinal);
  682.     end;
  683. begin
  684.   if doswap then begin
  685.     cnv1.int := i;
  686.     cnv2.arr[0] := cnv1.arr[3];
  687.     cnv2.arr[1] := cnv1.arr[2];
  688.     cnv2.arr[2] := cnv1.arr[1];
  689.     cnv2.arr[3] := cnv1.arr[0];
  690.     Result := cnv2.int;
  691.   end else
  692.     Result := i;
  693. end;
  694. procedure TDomain.CloseMoFile;
  695. begin
  696.   moCS.BeginWrite;
  697.   try
  698.     if isopen then begin
  699.       {$ifdef mswindows}
  700.       UnMapViewOfFile (momemoryHandle);
  701.       CloseHandle (momapping);
  702.       CloseHandle (mo);
  703.       {$endif}
  704.       {$ifdef linux}
  705.       FreeMem (momemoryHandle);
  706.       {$endif}
  707.       isopen := False;
  708.     end;
  709.     moexists := True;
  710.   finally
  711.     moCS.EndWrite;
  712.   end;
  713. end;
  714. constructor TDomain.Create;
  715. begin
  716.   moCS := TMultiReadExclusiveWriteSynchronizer.Create;
  717.   isOpen := False;
  718.   moexists := True;
  719. end;
  720. destructor TDomain.Destroy;
  721. begin
  722.   CloseMoFile;
  723.   FreeAndNil(moCS);
  724.   inherited;
  725. end;
  726. function TDomain.gettextbyid(id: cardinal): ansistring;
  727. var
  728.   offset, size: cardinal;
  729. begin
  730.   offset:=CardinalInMem (momemory,O+8*id+4);
  731.   size:=CardinalInMem (momemory,O+8*id);
  732.   SetString (Result,momemory+offset,size);
  733. end;
  734. function TDomain.getdsttextbyid(id: cardinal): ansistring;
  735. var
  736.   offset, size: cardinal;
  737. begin
  738.   offset:=CardinalInMem (momemory,T+8*id+4);
  739.   size:=CardinalInMem (momemory,T+8*id);
  740.   SetString (Result,momemory+offset,size);
  741. end;
  742. function TDomain.gettext(msgid: ansistring): ansistring;
  743. var
  744.   i, nn, step: cardinal;
  745.   s: string;
  746. begin
  747.   if (not isopen) and moexists then
  748.     OpenMoFile;
  749.   if not isopen then begin
  750.     Result := msgid;
  751.     exit;
  752.   end;
  753.   // Calculate start conditions for a binary search
  754.   nn := N;
  755.   i := 1;
  756.   while nn <> 0 do begin
  757.     nn := nn shr 1;
  758.     i := i shl 1;
  759.   end;
  760.   i := i shr 1;
  761.   step := i shr 1;
  762.   // Do binary search
  763.   while true do begin
  764.     // Get string for index i
  765.     s := gettextbyid(i-1);
  766.     if msgid = s then begin
  767.       // Found the msgid
  768.       Result := getdsttextbyid(i-1);
  769.       break;
  770.     end;
  771.     if step = 0 then begin
  772.       // Not found
  773.       Result := msgid;
  774.       break;
  775.     end;
  776.     if msgid < s then begin
  777.       if i < 1+step then
  778.         i := 1
  779.       else
  780.         i := i - step;
  781.       step := step shr 1;
  782.     end else
  783.     if msgid > s then begin
  784.       i := i + step;
  785.       if i > N then
  786.         i := N;
  787.       step := step shr 1;
  788.     end;
  789.   end;
  790. end;
  791. {$ifdef mswindows}
  792. function GetLastWinError:string;
  793. var
  794.   errcode:Cardinal;
  795. begin
  796.   SetLength (Result,2000);
  797.   errcode:=GetLastError();
  798.   Windows.FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PChar(Result),2000,nil);
  799.   Result:=StrPas(PChar(Result));
  800. end;
  801. {$endif}
  802. procedure TDomain.OpenMoFile;
  803. var
  804.   i: cardinal;
  805.   filename: string;
  806.   offset,size:Int64;
  807. {$ifdef linux}
  808.   mofile:TFileStream;
  809. {$endif}
  810. begin
  811.   moCS.BeginWrite;
  812.   try
  813.     // Check if it is already open
  814.     if isopen then
  815.       exit;
  816.     // Check if it has been attempted to open the file before
  817.     if not moexists then
  818.       exit;
  819.     if sizeof(i) <> 4 then
  820.       raise Exception.Create('TDomain in gnugettext is written for an architecture that has 32 bit integers.');
  821.     filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
  822.     if (not AssemblyAnalyzer.FileExists(filename)) and (not fileexists(filename)) then
  823.       filename := Directory + copy(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
  824.     if (not AssemblyAnalyzer.FileExists(filename)) and (not fileexists(filename)) then begin
  825.       moexists := False;
  826.       exit;
  827.     end;
  828.     AssemblyAnalyzer.GetFileInfo(filename,filename,offset,size);
  829.     FileOffset:=offset;
  830.     {$ifdef mswindows}
  831.     // The next two lines are necessary because otherwise MapViewOfFile fails
  832.     size:=0;
  833.     offset:=0;
  834.     // Map the mo file into memory and let the operating system decide how to cache
  835.     mo:=createfile (PChar(filename),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0);
  836.     if mo=INVALID_HANDLE_VALUE then
  837.       raise Exception.Create ('Cannot open file '+filename);
  838.     momapping:=CreateFileMapping (mo, nil, PAGE_READONLY, 0, 0, nil);
  839.     if momapping=0 then
  840.       raise Exception.Create ('Cannot create memory map on file '+filename);
  841.     momemoryHandle:=MapViewOfFile (momapping,FILE_MAP_READ,offset shr 32,offset and $FFFFFFFF,size);
  842.     if momemoryHandle=nil then begin
  843.       raise Exception.Create ('Cannot map file '+filename+' into memory. Reason: '+GetLastWinError);
  844.     end;
  845.     momemory:=momemoryHandle+FileOffset;
  846.     {$endif}
  847.     {$ifdef linux}
  848.     // Read the whole file into memory
  849.     mofile:=TFileStream.Create (filename, fmOpenRead or fmShareDenyNone);
  850.     try
  851.       if size=0 then
  852.         size:=mofile.Size;
  853.       Getmem (momemoryHandle,size);
  854.       momemory:=momemoryHandle;
  855.       mofile.Seek(FileOffset,soFromBeginning);
  856.       mofile.ReadBuffer(momemory^,size);
  857.     finally
  858.       FreeAndNil (mofile);
  859.     end;
  860.     {$endif}
  861.     isOpen := True;
  862.     // Check the magic number
  863.     doswap:=False;
  864.     i:=CardinalInMem(momemory,0);
  865.     if (i <> $950412DE) and (i <> $DE120495) then
  866.       raise Exception.Create('This file is not a valid GNU gettext mo file: ' + filename);
  867.     doswap := (i = $DE120495);
  868.     CardinalInMem(momemory,4);       // Read the version number, but don't use it for anything.
  869.     N:=CardinalInMem(momemory,8);    // Get string count
  870.     O:=CardinalInMem(momemory,12);   // Get offset of original strings
  871.     T:=CardinalInMem(momemory,16);   // Get offset of translated strings
  872.   finally
  873.     moCS.EndWrite;
  874.   end;
  875. end;
  876. procedure TDomain.setDirectory(dir: string);
  877. begin
  878.   vDirectory := IncludeTrailingPathDelimiter(dir);
  879.   CloseMoFile;
  880. end;
  881. function LoadDLLifPossible (dllname:string='gnu_gettext.dll'):boolean;
  882. begin
  883.   {$ifdef MSWINDOWS}
  884.   if not DLLisLoaded then begin
  885.     dllmodule := LoadLibraryEx(PChar(dllname), 0, 0);
  886.     DLLisLoaded := (dllmodule <> 0);
  887.     if DLLisLoaded then begin
  888.       pgettext := tpgettext(GetProcAddress(dllmodule, 'gettext'));
  889.       pdgettext := tpdgettext(GetProcAddress(dllmodule, 'dgettext'));
  890.       ptextdomain := tptextdomain(GetProcAddress(dllmodule, 'textdomain'));
  891.       pbindtextdomain := tpbindtextdomain(GetProcAddress(dllmodule, 'bindtextdomain'));
  892.       pgettext_putenv := tpgettext_putenv(GetProcAddress(dllmodule, 'gettext_putenv'));
  893.     end;
  894.   end;
  895. {$endif}
  896. {$ifdef LINUX}
  897.   // On Linux, gettext is always there as part of the Libc library.
  898.   // But default is not to use it, but to use the internal implementation instead.
  899.   DLLisLoaded := False;
  900. {$endif}
  901.   Result:=DLLisLoaded;
  902. end;
  903. procedure AddDomainForResourceString (domain:string);
  904. begin
  905.   TPDomainListCS.BeginWrite;
  906.   try
  907.     TPDomainList.Add (domain);
  908.   finally
  909.     TPDomainListCS.EndWrite;
  910.   end;
  911. end;
  912. procedure TDomain.SetLanguageCode(langcode: string);
  913. begin
  914.   CloseMoFile;
  915.   curlang:=langcode;
  916. end;
  917. function GetPluralForm2EN(Number: Integer): Integer;
  918. begin
  919.   Number:=abs(Number);
  920.   if Number=1 then Result:=0 else Result:=1;
  921. end;
  922. function GetPluralForm1(Number: Integer): Integer;
  923. begin
  924.   Result:=0;
  925. end;
  926. function GetPluralForm2FR(Number: Integer): Integer;
  927. begin
  928.   Number:=abs(Number);
  929.   if (Number=1) or (Number=0) then Result:=0 else Result:=1;
  930. end;
  931. function GetPluralForm3LV(Number: Integer): Integer;
  932. begin
  933.   Number:=abs(Number);
  934.   if (Number mod 10=1) and (Number mod 100<>11) then
  935.     Result:=0
  936.   else
  937.     if Number<>0 then Result:=1
  938.                  else Result:=2;
  939. end;
  940. function GetPluralForm3GA(Number: Integer): Integer;
  941. begin
  942.   Number:=abs(Number);
  943.   if Number=1 then Result:=0
  944.   else if Number=2 then Result:=1
  945.   else Result:=2;
  946. end;
  947. function GetPluralForm3LT(Number: Integer): Integer;
  948. var
  949.   n1,n2:byte;
  950. begin
  951.   Number:=abs(Number);
  952.   n1:=Number mod 10;
  953.   n2:=Number mod 100;
  954.   if (n1=1) and (n2<>11) then
  955.     Result:=0
  956.   else
  957.     if (n1>=2) and ((n2<10) or (n2>=20)) then Result:=1
  958.     else Result:=2;
  959. end;
  960. function GetPluralForm3PL(Number: Integer): Integer;
  961. var
  962.   n1,n2:byte;
  963. begin
  964.   Number:=abs(Number);
  965.   n1:=Number mod 10;
  966.   n2:=Number mod 100;
  967.   if n1=1 then Result:=0
  968.   else if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
  969.   else Result:=2;
  970. end;
  971. function GetPluralForm3RU(Number: Integer): Integer;
  972. var
  973.   n1,n2:byte;
  974. begin
  975.   Number:=abs(Number);
  976.   n1:=Number mod 10;
  977.   n2:=Number mod 100;
  978.   if (n1=1) and (n2<>11) then
  979.     Result:=0
  980.   else
  981.     if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
  982.     else Result:=2;
  983. end;
  984. function GetPluralForm4SL(Number: Integer): Integer;
  985. var
  986.   n2:byte;
  987. begin
  988.   Number:=abs(Number);
  989.   n2:=Number mod 100;
  990.   if n2=1 then Result:=0
  991.   else
  992.   if n2=2 then Result:=1
  993.   else
  994.   if (n2=3) or (n2=4) then Result:=2
  995.   else
  996.     Result:=3;
  997. end;
  998. { TGnuGettextInstance }
  999. procedure TGnuGettextInstance.bindtextdomain(const szDomain,
  1000.   szDirectory: string);
  1001. var
  1002.   dir:string;
  1003. begin
  1004.   dir:=IncludeTrailingPathDelimiter(szDirectory);
  1005.   getdomain(domainlist,szDomain,DefaultDomainDirectory,CurLang).Directory := dir;
  1006.   {$ifdef LINUX}
  1007.   dir:=ExcludeTrailingPathDelimiter(szDirectory);
  1008.   Libc.bindtextdomain(PChar(szDomain), PChar(dir));
  1009.   {$endif}
  1010.   {$ifdef MSWINDOWS}
  1011.   if DLLisLoaded then
  1012.     pbindtextdomain(PChar(szDomain), PChar(dir));
  1013.   {$endif}
  1014. end;
  1015. constructor TGnuGettextInstance.Create;
  1016. var
  1017.   lang: string;
  1018. begin
  1019.   curGetPluralForm:=GetPluralForm2EN;
  1020.   Enabled:=True;
  1021.   curmsgdomain:=DefaultTextDomain;
  1022.   savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;
  1023.   domainlist := TStringList.Create;
  1024.   TP_IgnoreList:=TStringList.Create;
  1025.   TP_IgnoreList.Sorted:=True;
  1026.   TP_ClassHandling:=TList.Create;
  1027.   // Set some settings
  1028.   DefaultDomainDirectory := IncludeTrailingPathDelimiter(extractfilepath(ExecutableFilename))+'locale';
  1029.   UseLanguage(lang);
  1030.   bindtextdomain(DefaultTextDomain, DefaultDomainDirectory);
  1031.   textdomain(DefaultTextDomain);
  1032.   {$ifdef LINUX}
  1033.   bind_textdomain_codeset(DefaultTextDomain,'utf-8');
  1034.   {$endif}
  1035.   // Add default properties to ignore
  1036.   TP_GlobalIgnoreClassProperty(TComponent,'Name');
  1037.   TP_GlobalIgnoreClassProperty(TCollection,'PropName');
  1038. end;
  1039. destructor TGnuGettextInstance.Destroy;
  1040. begin
  1041.   if savememory <> nil then begin
  1042.     savefileCS.BeginWrite;
  1043.     try
  1044.       CloseFile(savefile);
  1045.     finally
  1046.       savefileCS.EndWrite;
  1047.     end;
  1048.     FreeAndNil(savememory);
  1049.   end;
  1050.   FreeAndNil (savefileCS);
  1051.   FreeAndNil (TP_IgnoreList);
  1052.   while TP_ClassHandling.Count<>0 do begin
  1053.     TObject(TP_ClassHandling.Items[0]).Free;
  1054.     TP_ClassHandling.Delete(0);
  1055.   end;
  1056.   FreeAndNil (TP_ClassHandling);
  1057.   while domainlist.Count <> 0 do begin
  1058.     domainlist.Objects[0].Free;
  1059.     domainlist.Delete(0);
  1060.   end;
  1061.   FreeAndNil(domainlist);
  1062.   inherited;
  1063. end;
  1064. function TGnuGettextInstance.dgettext(const szDomain: string;
  1065.   const szMsgId: widestring): widestring;
  1066. begin
  1067.   if not Enabled then begin
  1068.     Result:=szMsgId;
  1069.     exit;
  1070.   end;
  1071.   if DLLisLoaded then begin
  1072.     {$ifdef LINUX}
  1073.     Result := utf8decode(StrPas(Libc.dgettext(PChar(szDomain), PChar(utf8encode(szMsgId)))));
  1074.     {$endif}
  1075.     {$ifdef MSWINDOWS}
  1076.     Result := utf8decode(LF2LineBreakA(StrPas(pdgettext(PChar(szDomain), PChar(StripCR(utf8encode((szMsgId))))))));
  1077.     {$endif}
  1078.   end else begin
  1079.     Result:=UTF8Decode(LF2LineBreakA(getdomain(domainlist,szDomain,DefaultDomainDirectory,CurLang).gettext(StripCR(utf8encode(szMsgId)))));
  1080.   end;
  1081.   if (szMsgId<>'') and (Result='') then
  1082.     raise Exception.Create (Format('Error: Could not translate %s. Probably because the mo file doesn''t contain utf-8 encoded translations.',[szMsgId]));
  1083.   if (Result = szMsgId) and (szDomain = DefaultTextDomain) then
  1084.     SaveCheck(szMsgId);
  1085. end;
  1086. function TGnuGettextInstance.GetCurrentLanguage: string;
  1087. begin
  1088.   Result:=curlang;
  1089. end;
  1090. function TGnuGettextInstance.getcurrenttextdomain: string;
  1091. begin
  1092.   if DLLisLoaded then begin
  1093.     {$ifdef LINUX}
  1094.     Result := StrPas(Libc.textdomain(nil));
  1095.     {$endif}
  1096.     {$ifdef MSWINDOWS}
  1097.     Result := StrPas(ptextdomain(nil));
  1098.     {$endif}
  1099.   end else
  1100.     Result := curmsgdomain;
  1101. end;
  1102. function TGnuGettextInstance.gettext(
  1103.   const szMsgId: widestring): widestring;
  1104. begin
  1105.   Result := dgettext(curmsgdomain, szMsgId);
  1106. end;
  1107. procedure TGnuGettextInstance.SaveCheck(szMsgId: widestring);
  1108. var
  1109.   i: integer;
  1110. begin
  1111.   savefileCS.BeginWrite;
  1112.   try
  1113.     if (savememory <> nil) and (szMsgId <> '') then begin
  1114.       if not savememory.Find(szMsgId, i) then begin
  1115.         savememory.Add(szMsgId);
  1116.         Writeln(savefile, 'msgid ' + string2csyntax(utf8encode(szMsgId)));
  1117.         writeln(savefile, 'msgstr ""');
  1118.         writeln(savefile);
  1119.       end;
  1120.     end;
  1121.   finally
  1122.     savefileCS.EndWrite;
  1123.   end;
  1124. end;
  1125. procedure TGnuGettextInstance.SaveUntranslatedMsgids(filename: string);
  1126. begin
  1127.   // If this happens, it is an internal error made by the programmer.
  1128.   if savememory <> nil then
  1129.     raise Exception.Create(_('You may not call SaveUntranslatedMsgids twice in this program.'));
  1130.   AssignFile(savefile, filename);
  1131.   Rewrite(savefile);
  1132.   writeln(savefile, 'msgid ""');
  1133.   writeln(savefile, 'msgstr ""');
  1134.   writeln(savefile);
  1135.   savememory := TStringList.Create;
  1136.   savememory.Sorted := true;
  1137. end;
  1138. procedure TGnuGettextInstance.textdomain(const szDomain: string);
  1139. begin
  1140.   curmsgdomain := szDomain;
  1141.   {$ifdef LINUX}
  1142.   Libc.textdomain(PChar(szDomain));
  1143.   {$endif}
  1144.   {$ifdef MSWINDOWS}
  1145.   if DLLisLoaded then begin
  1146.     ptextdomain(PChar(szDomain));
  1147.   end;
  1148.   {$endif}
  1149. end;
  1150. function TGnuGettextInstance.TP_CreateRetranslator : TExecutable;
  1151. var
  1152.   ttpr:TTP_Retranslator;
  1153. begin
  1154.   ttpr:=TTP_Retranslator.Create;
  1155.   ttpr.Instance:=self;
  1156.   TP_Retranslator:=ttpr;
  1157.   Result:=ttpr;
  1158. end;
  1159. procedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass;
  1160.   Handler: TTranslator);
  1161. var
  1162.   cm:TClassMode;
  1163.   i:integer;
  1164. begin
  1165.   for i:=0 to TP_ClassHandling.Count-1 do begin
  1166.     cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;
  1167.     if cm.HClass=HClass then
  1168.       raise Exception.Create ('You cannot set a handler for a class that has already been assigned otherwise.');
  1169.     if HClass.InheritsFrom(cm.HClass) then begin
  1170.       // This is the place to insert this class
  1171.       cm:=TClassMode.Create;
  1172.       cm.HClass:=HClass;
  1173.       cm.SpecialHandler:=Handler;
  1174.       TP_ClassHandling.Insert(i,cm);
  1175.       exit;
  1176.     end;
  1177.   end;
  1178.   cm:=TClassMode.Create;
  1179.   cm.HClass:=HClass;
  1180.   cm.SpecialHandler:=Handler;
  1181.   TP_ClassHandling.Add(cm);
  1182. end;
  1183. procedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass);
  1184. var
  1185.   cm:TClassMode;
  1186.   i:integer;
  1187. begin
  1188.   for i:=0 to TP_ClassHandling.Count-1 do begin
  1189.     cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;
  1190.     if cm.HClass=IgnClass then
  1191.       raise Exception.Create ('You cannot add a class to the ignore list that is already on that list: '+IgnClass.ClassName);
  1192.     if IgnClass.InheritsFrom(cm.HClass) then begin
  1193.       // This is the place to insert this class
  1194.       cm:=TClassMode.Create;
  1195.       cm.HClass:=IgnClass;
  1196.       TP_ClassHandling.Insert(i,cm);
  1197.       exit;
  1198.     end;
  1199.   end;
  1200.   cm:=TClassMode.Create;
  1201.   cm.HClass:=IgnClass;
  1202.   TP_ClassHandling.Add(cm);
  1203. end;
  1204. procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(
  1205.   IgnClass: TClass; propertyname: string);
  1206. var
  1207.   cm:TClassMode;
  1208.   i:integer;
  1209. begin
  1210.   propertyname:=uppercase(propertyname);
  1211.   for i:=0 to TP_ClassHandling.Count-1 do begin
  1212.     cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;
  1213.     if cm.HClass=IgnClass then begin
  1214.       if Assigned(cm.SpecialHandler) then
  1215.         raise Exception.Create ('You cannot ignore a class property for a class that has a handler set.');
  1216.       cm.PropertiesToIgnore.Add(propertyname);
  1217.       exit;
  1218.     end;
  1219.     if IgnClass.InheritsFrom(cm.HClass) then begin
  1220.       // This is the place to insert this class
  1221.       cm:=TClassMode.Create;
  1222.       cm.HClass:=IgnClass;
  1223.       cm.PropertiesToIgnore.Add(propertyname);
  1224.       TP_ClassHandling.Insert(i,cm);
  1225.       exit;
  1226.     end;
  1227.   end;
  1228.   cm:=TClassMode.Create;
  1229.   cm.HClass:=IgnClass;
  1230.   cm.PropertiesToIgnore.Add(propertyname);
  1231.   TP_ClassHandling.Add(cm);
  1232. end;
  1233. procedure TGnuGettextInstance.TP_Ignore(AnObject: TObject;
  1234.   const name: string);
  1235. begin
  1236.   TP_IgnoreList.Add(uppercase(name));
  1237. end;
  1238. procedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent;
  1239.   TextDomain: string);
  1240. var
  1241.   comp:TGnuGettextComponentMarker;
  1242. begin
  1243.   comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
  1244.   if comp=nil then begin
  1245.     comp:=TGnuGettextComponentMarker.Create (nil);
  1246.     comp.Name:='GNUgettextMarker';
  1247.     comp.Retranslator:=TP_CreateRetranslator;
  1248.     TranslateProperties (AnObject, TextDomain);
  1249.     AnObject.InsertComponent(comp);
  1250.   end else begin
  1251.     if comp.LastLanguage<>curlang then begin
  1252.       comp.Retranslator.Execute;
  1253.     end;
  1254.   end;
  1255.   comp.LastLanguage:=curlang;
  1256. end;
  1257. procedure TGnuGettextInstance.TranslateProperty (AnObject:TObject; PropInfo:PPropInfo; TodoList:TStrings; TextDomain:string);
  1258. var
  1259.   ppi:PPropInfo;
  1260.   ws: WideString;
  1261.   old: WideString;
  1262.   obj:TObject;
  1263.   sl:TStrings;
  1264.   i, k:integer;
  1265.   Propname:string;
  1266. begin
  1267.   PropName:=PropInfo^.Name;
  1268.   try
  1269.     // Translate certain types of properties
  1270.     case PropInfo^.PropType^.Kind of
  1271.       tkString, tkLString, tkWString:
  1272.         begin
  1273.           old := GetWideStrProp(AnObject, PropName);
  1274.           if (old <> '') and (IsWriteProp(PropInfo)) then begin
  1275.             if TP_Retranslator<>nil then
  1276.               (TP_Retranslator as TTP_Retranslator).Remember(AnObject, PropName, old);
  1277.             ws := dgettext(textdomain,old);
  1278.             if ws <> old then begin
  1279.               ppi:=GetPropInfo(AnObject, Propname);
  1280.               if ppi=nil then
  1281.                 raise Exception.Create ('Property disappeared...');
  1282.               SetWideStrProp(AnObject, ppi, ws);
  1283.             end;
  1284.           end;
  1285.         end { case item };
  1286.       tkClass:
  1287.         begin
  1288.           obj:=GetObjectProp(AnObject, PropName);
  1289.           if obj<>nil then begin
  1290.             // Check the global class ignore list
  1291.             for k:=0 to TP_ClassHandling.Count-1 do begin
  1292.               if AnObject.InheritsFrom(TClass(TP_ClassHandling.Items[k])) then
  1293.                 exit;
  1294.             end;
  1295.             // Check for TStrings translation
  1296.             if obj is TStrings then begin
  1297.               sl:=obj as TStrings;
  1298.               if (sl.Text<>'') and (TP_Retranslator<>nil) then
  1299.                 (TP_Retranslator as TTP_Retranslator).Remember(obj, 'Text', sl.Text);
  1300.               TranslateStrings (sl,TextDomain);
  1301.             end else
  1302.             // Check for TCollection
  1303.             if obj is TCollection then
  1304.               for i := 0 to TCollection(obj).Count - 1 do
  1305.                 TodoList.AddObject('',TCollection(obj).Items[i]);
  1306.             // Check for TComponent
  1307.             if obj is TComponent then
  1308.               TodoList.AddObject ('',obj);
  1309.           end { if not nil };
  1310.         end { case item };
  1311.       end { case };
  1312.   except
  1313.     on E:Exception do
  1314.       raise Exception.Create ('Property cannot be translated.'+sLineBreak+
  1315.         'Use TP_GlobalIgnoreClassProperty('+AnObject.ClassName+','+PropName+') or'+sLineBreak+
  1316.         'TP_Ignore (self,''.'+PropName+''') to prevent this message.'+sLineBreak+
  1317.         'Reason: '+e.Message);
  1318.   end;
  1319. end;
  1320. procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; textdomain:string='');
  1321. var
  1322.   TodoList:TStringList; // List of Name/TObject's that is to be processed
  1323.   DoneList:TStringList; // List of hex codes representing pointers to objects that have been done
  1324.   i, j, Count: integer;
  1325.   PropList: PPropList;
  1326.   UPropName: string;
  1327.   PropInfo: PPropInfo;
  1328.   comp:TComponent;
  1329.   cm,currentcm:TClassMode;
  1330.   ObjectPropertyIgnoreList:TStringList;
  1331.   objid, Name:string;
  1332. begin
  1333.   if textdomain='' then
  1334.     textdomain:=curmsgdomain;
  1335.   if TP_Retranslator<>nil then
  1336.     (TP_Retranslator as TTP_Retranslator).TextDomain:=textdomain;
  1337.   DoneList:=TStringList.Create;
  1338.   TodoList:=TStringList.Create;
  1339.   ObjectPropertyIgnoreList:=TStringList.Create;
  1340.   try
  1341.     TodoList.AddObject('', AnObject);
  1342.     DoneList.Sorted:=True;
  1343.     ObjectPropertyIgnoreList.Sorted:=True;
  1344.     ObjectPropertyIgnoreList.Duplicates:=dupIgnore;
  1345.     ObjectPropertyIgnoreList.CaseSensitive:=False;
  1346.     DoneList.Duplicates:=dupError;
  1347.     DoneList.CaseSensitive:=True;
  1348.     while TodoList.Count<>0 do begin
  1349.       AnObject:=TodoList.Objects[0];
  1350.       Name:=TodoList.Strings[0];
  1351.       TodoList.Delete(0);
  1352.       if AnObject<>nil then begin
  1353.         // Make sure each object is only translated once
  1354.         Assert (sizeof(integer)=sizeof(TObject));
  1355.         objid:=IntToHex(integer(AnObject),8);
  1356.         if DoneList.Find(objid,i) then begin
  1357.           continue;
  1358.         end else begin
  1359.           DoneList.Add(objid);
  1360.         end;
  1361.         ObjectPropertyIgnoreList.Clear;
  1362.         // Find out if there is special handling of this object
  1363.         currentcm:=nil;
  1364.         for j:=0 to TP_ClassHandling.Count-1 do begin
  1365.           cm:=TObject(TP_ClassHandling.Items[j]) as TClassMode;
  1366.           if AnObject.InheritsFrom(cm.HClass) then begin
  1367.             if cm.PropertiesToIgnore.Count<>0 then begin
  1368.               ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);
  1369.             end else begin
  1370.               currentcm:=cm;
  1371.               break;
  1372.             end;
  1373.           end;
  1374.         end;
  1375.         if currentcm<>nil then begin
  1376.           ObjectPropertyIgnoreList.Clear;
  1377.           // Ignore or use special handler
  1378.           if Assigned(currentcm.SpecialHandler) then
  1379.             currentcm.SpecialHandler (AnObject);
  1380.           continue;
  1381.         end;
  1382.         Count := GetPropList(AnObject, PropList);
  1383.         try
  1384.           for j := 0 to Count - 1 do begin
  1385.             PropInfo := PropList[j];
  1386.             UPropName:=uppercase(PropInfo^.Name);
  1387.             // Ignore properties that are meant to be ignored
  1388.             if ((currentcm=nil) or (not currentcm.PropertiesToIgnore.Find(UPropName,i))) and
  1389.                (not TP_IgnoreList.Find(Name+'.'+UPropName,i)) and
  1390.                (not ObjectPropertyIgnoreList.Find(UPropName,i)) then begin
  1391.               TranslateProperty (AnObject,PropInfo,TodoList,TextDomain);
  1392.             end;  // if
  1393.           end;  // for
  1394.         finally
  1395.           if Count<>0 then
  1396.             FreeMem (PropList);
  1397.         end;
  1398.         if AnObject is TStrings then begin
  1399.           TranslateStrings (AnObject as TStrings,TextDomain);
  1400.         end;
  1401.         if AnObject is TComponent then
  1402.           for i := 0 to TComponent(AnObject).ComponentCount - 1 do begin
  1403.             comp:=TComponent(AnObject).Components[i];
  1404.             if not TP_IgnoreList.Find(uppercase(comp.Name),j) then begin
  1405.               TodoList.AddObject(uppercase(comp.Name),comp);
  1406.             end;
  1407.           end;
  1408.       end { if AnObject<>nil };
  1409.     end { while todolist.count<>0 };
  1410.   finally
  1411.     FreeAndNil (todolist);
  1412.     FreeAndNil (ObjectPropertyIgnoreList);
  1413.     FreeAndNil (DoneList);
  1414.   end;
  1415.   TP_IgnoreList.Clear;
  1416.   TP_Retranslator:=nil;
  1417. end;
  1418. procedure TGnuGettextInstance.UseLanguage(LanguageCode: string);
  1419. var
  1420.   i,p:integer;
  1421.   dom:TDomain;
  1422.   l2:string[2];
  1423. begin
  1424.   if LanguageCode='' then begin
  1425.     LanguageCode:=GGGetEnvironmentVariable('LANG');
  1426.     {$ifdef MSWINDOWS}
  1427.     if LanguageCode='' then
  1428.       LanguageCode:=GetWindowsLanguage;
  1429.     {$endif}
  1430.     p:=pos('.',LanguageCode);
  1431.     if p<>0 then
  1432.       LanguageCode:=copy(LanguageCode,1,p-1);
  1433.   end;
  1434.   curlang := LanguageCode;
  1435.   gettext_putenv('LANG=' + LanguageCode);
  1436.   for i:=0 to domainlist.Count-1 do begin
  1437.     dom:=domainlist.Objects[i] as TDomain;
  1438.     dom.SetLanguageCode (curlang);
  1439.   end;
  1440.   {$ifdef LINUX}
  1441.   setlocale (LC_MESSAGES, PChar(LanguageCode));
  1442.   {$endif}
  1443.   l2:=lowercase(copy(curlang,1,2));
  1444.   if (l2='en') or (l2='de') then curGetPluralForm:=GetPluralForm2EN else
  1445.   if (l2='hu') or (l2='ko') or (l2='zh') or (l2='ja') or (l2='tr') then curGetPluralForm:=GetPluralForm1 else
  1446.   if (l2='fr') or (l2='fa') or (lowercase(curlang)='pt_br') then curGetPluralForm:=GetPluralForm2FR else
  1447.   if (l2='lv') then curGetPluralForm:=GetPluralForm3LV else
  1448.   if (l2='ga') then curGetPluralForm:=GetPluralForm3GA else
  1449.   if (l2='lt') then curGetPluralForm:=GetPluralForm3LT else
  1450.   if (l2='ru') or (l2='cs') or (l2='sk') or (l2='uk') or (l2='hr') then curGetPluralForm:=GetPluralForm3RU else
  1451.   if (l2='pl') then curGetPluralForm:=GetPluralForm3PL else
  1452.   if (l2='sl') then curGetPluralForm:=GetPluralForm4SL else
  1453.     curGetPluralForm:=GetPluralForm2EN
  1454. end;
  1455. procedure TGnuGettextInstance.TranslateStrings(sl: TStrings;TextDomain:string);
  1456. var
  1457.   s:TStringList;
  1458.   line:string;
  1459.   i:integer;
  1460. begin
  1461.   s:=TStringList.Create;
  1462.   try
  1463.     s.AddStrings (sl);
  1464.     for i:=0 to s.Count-1 do begin
  1465.       line:=s.Strings[i];
  1466.       if line<>'' then
  1467.         s.Strings[i]:=dgettext(TextDomain,line);
  1468.     end;
  1469.     sl.Text:=s.Text;
  1470.   finally
  1471.     FreeAndNil (s);
  1472.   end;
  1473. end;
  1474. function TGnuGettextInstance.GetTranslatorNameAndEmail: widestring;
  1475. begin
  1476.   Result:=GetTranslationProperty('LAST-TRANSLATOR');
  1477. end;
  1478. function TGnuGettextInstance.GetTranslationProperty(
  1479.   Propertyname: string): WideString;
  1480. var
  1481.   sl:TStringList;
  1482.   i:integer;
  1483.   s:string;
  1484. begin
  1485.   Propertyname:=uppercase(Propertyname)+': ';
  1486.   sl:=TStringList.Create;
  1487.   try
  1488.     sl.Text:=utf8encode(gettext(''));
  1489.     for i:=0 to sl.Count-1 do begin
  1490.       s:=sl.Strings[i];
  1491.       if uppercase(copy(s,1,length(Propertyname)))=Propertyname then begin
  1492.         Result:=utf8decode(trim(copy(s,length(PropertyName)+1,maxint)));
  1493.         exit;
  1494.       end;
  1495.     end;
  1496.   finally
  1497.     FreeAndNil (sl);
  1498.   end;
  1499.   Result:='';
  1500. end;
  1501. function TGnuGettextInstance.dngettext(const szDomain,singular, plural: widestring;
  1502.   Number: Integer): widestring;
  1503. var
  1504.   org,trans:widestring;
  1505.   idx:integer;
  1506.   p:integer;
  1507. begin
  1508.   org:=singular+#0+plural;
  1509.   trans:=dgettext(szDomain,org);
  1510.   if org=trans then
  1511.     idx:=GetPluralForm2EN(Number)
  1512.   else
  1513.     idx:=curGetPluralForm(Number);
  1514.   while true do begin
  1515.     p:=pos(#0,trans);
  1516.     if p=0 then begin
  1517.       Result:=trans;
  1518.       exit;
  1519.     end;
  1520.     if idx=0 then begin
  1521.       Result:=copy(trans,1,p-1);
  1522.       exit;
  1523.     end;
  1524.     delete (trans,1,p);
  1525.     dec (idx);
  1526.   end;
  1527. end;
  1528. function TGnuGettextInstance.ngettext(const singular, plural: widestring;
  1529.   Number: Integer): widestring;
  1530. begin
  1531.   Result := dngettext(curmsgdomain, singular, plural, Number);
  1532. end;
  1533. { TClassMode }
  1534. constructor TClassMode.Create;
  1535. begin
  1536.   PropertiesToIgnore:=TStringList.Create;
  1537.   PropertiesToIgnore.Sorted:=True;
  1538.   PropertiesToIgnore.Duplicates:=dupIgnore;
  1539. end;
  1540. destructor TClassMode.Destroy;
  1541. begin
  1542.   FreeAndNil (PropertiesToIgnore);
  1543.   inherited;
  1544. end;
  1545. { TAssemblyAnalyzer }
  1546. procedure TAssemblyAnalyzer.Analyze;
  1547. var
  1548.   s:ansistring;
  1549.   i:integer;
  1550.   offset:int64;
  1551.   fs:TFileStream;
  1552.   fi:TAssemblyFileInfo;
  1553.   filename:string;
  1554. begin
  1555.   s:='6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0;
  1556.   s:=copy(s,length(s)-7,8);
  1557.   offset:=0;
  1558.   for i:=8 downto 1 do
  1559.     offset:=offset shl 8+ord(s[i]);  
  1560.   if offset=0 then
  1561.     exit;
  1562.   BaseDirectory:=ExtractFilePath(ExecutableFilename);
  1563.   try
  1564.     fs:=TFileStream.Create(ExecutableFilename,fmOpenRead or fmShareDenyNone);
  1565.     try
  1566.       while true do begin
  1567.         fs.Seek(offset,soFromBeginning);
  1568.         offset:=ReadInt64(fs);
  1569.         if offset=0 then
  1570.           exit;
  1571.         fi:=TAssemblyFileInfo.Create;
  1572.         try
  1573.           fi.Offset:=ReadInt64(fs);
  1574.           fi.Size:=ReadInt64(fs);
  1575.           SetLength (filename, offset-fs.position);
  1576.           fs.ReadBuffer (filename[1],offset-fs.position);
  1577.           filename:=trim(filename);
  1578.           filelist.AddObject(filename,fi);
  1579.         except
  1580.           FreeAndNil (fi);
  1581.           raise;
  1582.         end;
  1583.       end;
  1584.     finally
  1585.       FreeAndNil (fs);
  1586.     end;
  1587.   except
  1588.   end;
  1589. end;
  1590. constructor TAssemblyAnalyzer.Create;
  1591. begin
  1592.   filelist:=TStringList.Create;
  1593.   {$ifdef LINUX}
  1594.   filelist.Duplicates:=dupError;
  1595.   filelist.CaseSensitive:=True;
  1596.   {$endif}
  1597.   filelist.Duplicates:=dupError;
  1598.   filelist.CaseSensitive:=False;
  1599.   filelist.Sorted:=True;
  1600. end;
  1601. destructor TAssemblyAnalyzer.Destroy;
  1602. begin
  1603.   while filelist.count<>0 do begin
  1604.     filelist.Objects[0].Free;
  1605.     filelist.Delete (0);
  1606.   end;
  1607.   FreeAndNil (filelist);
  1608.   inherited;
  1609. end;
  1610. function TAssemblyAnalyzer.FileExists(filename: string): boolean;
  1611. var
  1612.   idx:integer;
  1613. begin
  1614.   if copy(filename,1,length(basedirectory))=basedirectory then 
  1615.     filename:=copy(filename,length(basedirectory)+1,maxint);
  1616.   Result:=filelist.Find(filename,idx);
  1617. end;
  1618. procedure TAssemblyAnalyzer.GetFileInfo(filename: string;
  1619.   var realfilename: string; var offset, size: int64);
  1620. var
  1621.   fi:TAssemblyFileInfo;
  1622.   idx:integer;
  1623. begin
  1624.   offset:=0;
  1625.   size:=0;
  1626.   realfilename:=filename;
  1627.   if copy(filename,1,length(basedirectory))=basedirectory then begin
  1628.     filename:=copy(filename,length(basedirectory)+1,maxint);
  1629.     idx:=filelist.IndexOf(filename);
  1630.     if idx<>-1 then begin
  1631.       fi:=filelist.Objects[idx] as TAssemblyFileInfo;
  1632.       realfilename:=ExecutableFilename;
  1633.       offset:=fi.offset;
  1634.       size:=fi.size;
  1635.     end;
  1636.   end;
  1637. end;
  1638. function TAssemblyAnalyzer.ReadInt64(str: TStream): int64;
  1639. begin
  1640.   Assert (sizeof(Result)=8);
  1641.   str.ReadBuffer(Result,8);
  1642. end;
  1643. { TTP_Retranslator }
  1644. constructor TTP_Retranslator.Create;
  1645. begin
  1646.   list:=TList.Create;
  1647. end;
  1648. destructor TTP_Retranslator.Destroy;
  1649. var
  1650.   i:integer;
  1651. begin
  1652.   for i:=0 to list.Count-1 do
  1653.     TObject(list.Items[i]).Free;
  1654.   FreeAndNil (list);
  1655.   inherited;
  1656. end;
  1657. procedure TTP_Retranslator.Execute;
  1658. var
  1659.   i:integer;
  1660.   sl:TStrings;
  1661.   item:TTP_RetranslatorItem;
  1662.   newvalue:WideString;
  1663.   ppi:PPropInfo;
  1664. begin
  1665.   for i:=0 to list.Count-1 do begin
  1666.     item:=TObject(list.items[i]) as TTP_RetranslatorItem;
  1667.     if item.obj is TStrings then begin
  1668.       sl:=item.obj as TStrings;
  1669.       sl.Text:=item.OldValue;
  1670.       Instance.TranslateStrings(sl,textdomain);
  1671.     end else begin
  1672.       newValue:=instance.dgettext(textdomain,item.OldValue);
  1673.       ppi:=GetPropInfo(item.obj, item.Propname);
  1674.       if ppi=nil then
  1675.         raise Exception.Create ('Property disappeared...');
  1676.       SetWideStrProp(item.obj, ppi, newValue);
  1677.     end;
  1678.   end;
  1679. end;
  1680. procedure TTP_Retranslator.Remember(obj: TObject; PropName: String;
  1681.   OldValue: WideString);
  1682. var
  1683.   item:TTP_RetranslatorItem;
  1684. begin
  1685.   item:=TTP_RetranslatorItem.Create;
  1686.   item.obj:=obj;
  1687.   item.Propname:=Propname;
  1688.   item.OldValue:=OldValue;
  1689.   list.Add(item);
  1690. end;
  1691. { TGnuGettextComponentMarker }
  1692. destructor TGnuGettextComponentMarker.Destroy;
  1693. begin
  1694.   FreeAndNil (Retranslator);
  1695.   inherited;
  1696. end;
  1697. { THook }
  1698. {$ifdef MSWINDOWS}
  1699. constructor THook.Create(OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);
  1700. { Idea and original code from Igor Siticov }
  1701. { Modified by Jacques Garcia Vazquez and Lars Dybdahl }
  1702. var
  1703.   offset: integer;
  1704. begin
  1705.   {$ifndef CPU386}
  1706.   'This procedure only works on Intel i386 compatible processors.'
  1707.   {$endif}
  1708.   if FollowJump and (Word(OldProcedure^) = $25FF) then begin
  1709.     // This finds the correct procedure if a virtual jump has been inserted
  1710.     // at the procedure address
  1711.     Inc(Integer(OldProcedure), 2); // skip the jump
  1712.     OldProcedure := Pointer(Pointer(OldProcedure^)^);
  1713.   end;
  1714.   PatchPosition:=PChar(OldProcedure);
  1715.   offset:=integer(NewProcedure)-integer(OldProcedure)-5;
  1716.   Patch[0] := char($E9);
  1717.   Patch[1] := char(offset and 255);
  1718.   Patch[2] := char((offset shr 8) and 255);
  1719.   Patch[3] := char((offset shr 16) and 255);
  1720.   Patch[4] := char((offset shr 24) and 255);
  1721.   Original[0]:=PatchPosition[0];
  1722.   Original[1]:=PatchPosition[1];
  1723.   Original[2]:=PatchPosition[2];
  1724.   Original[3]:=PatchPosition[3];
  1725.   Original[4]:=PatchPosition[4];
  1726.   if not VirtualProtect(Pointer(PatchPosition), 5, PAGE_EXECUTE_READWRITE, @ov) then
  1727.     RaiseLastOSError;
  1728.   Enable;
  1729. end;
  1730. destructor THook.Destroy;
  1731. var
  1732.   ov2:Cardinal;
  1733. begin
  1734.   Disable;
  1735.   if not VirtualProtect(Pointer(PatchPosition), 5, ov, @ov2) then
  1736.     RaiseLastOSError;
  1737.   inherited;
  1738. end;
  1739. procedure THook.Disable;
  1740. begin
  1741.   PatchPosition[0]:=Original[0];
  1742.   PatchPosition[1]:=Original[1];
  1743.   PatchPosition[2]:=Original[2];
  1744.   PatchPosition[3]:=Original[3];
  1745.   PatchPosition[4]:=Original[4];
  1746. end;
  1747. procedure THook.Enable;
  1748. begin
  1749.   PatchPosition[0]:=Patch[0];
  1750.   PatchPosition[1]:=Patch[1];
  1751.   PatchPosition[2]:=Patch[2];
  1752.   PatchPosition[3]:=Patch[3];
  1753.   PatchPosition[4]:=Patch[4];
  1754. end;
  1755. {$endif}
  1756. initialization
  1757.   ExecutableFilename:=Paramstr(0);
  1758.   AssemblyAnalyzer:=TAssemblyAnalyzer.Create;
  1759.   AssemblyAnalyzer.Analyze;
  1760.   TPDomainList:=TStringList.Create;
  1761.   TPDomainList.Add(DefaultTextDomain);
  1762.   TPDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create;
  1763.   DefaultInstance:=TGnuGettextInstance.Create;
  1764.   {$ifdef MSWINDOWS}
  1765.   Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
  1766.   // replace Borlands LoadResString with gettext enabled version:
  1767.   HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringA, RuntimePackageSupportEnabled);
  1768.   {$endif}
  1769. finalization
  1770.   FreeAndNil (DefaultInstance);
  1771.   FreeAndNil (TPDomainListCS);
  1772.   FreeAndNil (TPDomainList);
  1773.   {$ifdef mswindows}
  1774.   // Unload the dll
  1775.   if dllmodule <> 0 then
  1776.     FreeLibrary(dllmodule);
  1777.   FreeAndNil (HookLoadResString);
  1778.   {$endif}
  1779.   FreeAndNil (AssemblyAnalyzer);
  1780. end.