Code/Resource
Windows Develop
Linux-Unix program
Internet-Socket-Network
Web Server
Browser Client
Ftp Server
Ftp Client
Browser Plugins
Proxy Server
Email Server
Email Client
WEB Mail
Firewall-Security
Telnet Server
Telnet Client
ICQ-IM-Chat
Search Engine
Sniffer Package capture
Remote Control
xml-soap-webservice
P2P
WEB(ASP,PHP,...)
TCP/IP Stack
SNMP
Grid Computing
SilverLight
DNS
Cluster Service
Network Security
Communication-Mobile
Game Program
Editor
Multimedia program
Graph program
Compiler program
Compress-Decompress algrithms
Crypt_Decrypt algrithms
Mathimatics-Numerical algorithms
MultiLanguage
Disk/Storage
Java Develop
assembly language
Applications
Other systems
Database system
Embeded-SCM Develop
FlashMX/Flex
source in ebook
Delphi VCL
OS Develop
MiddleWare
MPI
MacOS develop
LabView
ELanguage
Software/Tools
E-Books
Artical/Document
gnugettext.pas
Package: ComPort.rar [view]
Upload User: hbtlgg88
Upload Date: 2021-04-09
Package Size: 855k
Code Size: 62k
Category:
Delphi VCL
Development Platform:
C++ Builder
- unit gnugettext;
- (**************************************************************)
- (* *)
- (* (C) Copyright by Lars B. Dybdahl and others *)
- (* E-mail: Lars@dybdahl.dk, phone +45 70201241 *)
- (* You may distribute and modify this file as you wish *)
- (* for free *)
- (* *)
- (* Contributors: Peter Thornqvist, Troy Wolbrink, *)
- (* Frank Andreas de Groot *)
- (* *)
- (* See http://dybdahl.dk/dxgettext/ for more information *)
- (* *)
- (**************************************************************)
- interface
- uses
- Classes, SysUtils, TypInfo;
- (*****************************************************************************)
- (* *)
- (* MAIN API *)
- (* *)
- (*****************************************************************************)
- // All these identical functions translate a text
- function _(const szMsgId: widestring): widestring;
- function gettext(const szMsgId: widestring): widestring;
- // Translates a component (form, frame etc.) to the currently selected language.
- // Put TranslateComponent(self) in the OnCreate event of all your forms.
- // See the FAQ on the homepage if your application takes a long time to start.
- procedure TranslateComponent(AnObject: TComponent; TextDomain:string='');
- // Add more domains that resourcestrings can be extracted from. If a translation
- // is not found in the default domain, this domain will be searched, too.
- // This is useful for adding mo files for certain runtime libraries and 3rd
- // party component libraries
- procedure AddDomainForResourceString (domain:string);
- // Set language to use
- procedure UseLanguage(LanguageCode: string);
- // Unicode-enabled way to get resourcestrings, automatically translated
- // Use like this: ws:=LoadResStringW(@NameOfResourceString);
- function LoadResString(ResStringRec: PResStringRec): widestring;
- function LoadResStringA(ResStringRec: PResStringRec): ansistring;
- function LoadResStringW(ResStringRec: PResStringRec): widestring;
- // This returns an empty string if not translated or translator name is not specified.
- function GetTranslatorNameAndEmail:widestring;
- (*****************************************************************************)
- (* *)
- (* ADVANCED FUNCTIONALITY *)
- (* *)
- (*****************************************************************************)
- const
- DefaultTextDomain = 'default';
- RuntimePackageSupportEnabled=false; // This is experimental code. Don't set this to true unless you know what you do.
- var
- ExecutableFilename:string; // This is set to paramstr(0). Modify it for dll-files to point to the full dll path filename.
- (*
- Make sure that the next TranslateProperties(self) will ignore
- the string property specified, e.g.:
- TP_Ignore (self,'ButtonOK.Caption'); // Ignores caption on ButtonOK
- TP_Ignore (self,'MyDBGrid'); // Ignores all properties on component MyDBGrid
- TP_Ignore (self,'.Caption'); // Ignores self's caption
- Only use this function just before calling TranslateProperties(self).
- If this function is being used, please only call TP_Ignore and TranslateProperties
- From the main thread.
- *)
- procedure TP_Ignore(AnObject:TObject; const name:string);
- // Make TranslateProperties() not translate any objects descending from IgnClass
- procedure TP_GlobalIgnoreClass (IgnClass:TClass);
- // Make TranslateProperties() not translate a named property in all objects
- // descending from IgnClass
- procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
- type
- TTranslator=procedure (obj:TObject) of object;
- // Make TranslateProperties() not translate any objects descending from HClass
- // but instead call the specified Handler on each of these objects. The Name
- // property of TComponent is already added and doesn't have to be added.
- procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
- // Translate a component's properties and all subcomponents
- // Use this on a Delphi TForm or a CLX program's QForm.
- // It will only translate string properties, but see TP_ functions
- // below if there are things you don't want to have translated.
- procedure TranslateProperties(AnObject: TObject; TextDomain:string='');
- // Load an external GNU gettext dll to be used instead of the internal
- // implementation. Returns true if the dll is loaded. If the dll was already
- // loaded, this function can be used to query whether it was loaded.
- // On Linux, this function enables the Libc version of GNU gettext
- // After calling this function, you must set all settings again
- function LoadDLLifPossible (dllname:string='gnu_gettext.dll'):boolean;
- function GetCurrentLanguage:string;
- // These functions are also from the orginal GNU gettext implementation.
- // Only use these, if you need to split up your translation into several
- // .mo files.
- function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
- function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
- function ngettext(const singular,plural: widestring; Number:longint): widestring;
- procedure textdomain(const szDomain: string);
- function getcurrenttextdomain: string;
- procedure bindtextdomain(const szDomain: string; const szDirectory: string);
- (*****************************************************************************)
- (* *)
- (* CLASS based implementation. Use this to have more than one language *)
- (* in your application at the same time *)
- (* Do not exploit this feature if you plan to use LoadDLLifPossible() *)
- (* *)
- (*****************************************************************************)
- type
- TExecutable=
- class
- procedure Execute; virtual; abstract;
- end;
- TGetPluralForm=function (Number:Longint):Integer;
- TGnuGettextInstance=
- class // Do not create multiple instances on Linux!
- public
- Enabled:Boolean; // Set this to false to disable translations
- constructor Create;
- destructor Destroy; override;
- procedure UseLanguage(LanguageCode: string);
- function gettext(const szMsgId: widestring): widestring;
- function ngettext(const singular,plural:widestring;Number:longint):widestring;
- function GetCurrentLanguage:string;
- function GetTranslationProperty (Propertyname:string):WideString;
- function GetTranslatorNameAndEmail:widestring;
- // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites()
- procedure TP_Ignore(AnObject:TObject; const name:string);
- procedure TP_GlobalIgnoreClass (IgnClass:TClass);
- procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
- procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
- function TP_CreateRetranslator:TExecutable; // Must be freed by caller!
- procedure TranslateProperties(AnObject: TObject; textdomain:string='');
- procedure TranslateComponent(AnObject: TComponent; TextDomain:string='');
- // Multi-domain functions
- function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
- function dngettext(const szDomain,singular,plural:widestring;Number:longint):widestring;
- procedure textdomain(const szDomain: string);
- function getcurrenttextdomain: string;
- procedure bindtextdomain(const szDomain: string; const szDirectory: string);
- // Debugging and advanced tools
- procedure SaveUntranslatedMsgids(filename: string);
- protected
- procedure TranslateStrings (sl:TStrings;TextDomain:string);
- private
- curlang: string;
- curGetPluralForm:TGetPluralForm;
- curmsgdomain: string;
- savefileCS: TMultiReadExclusiveWriteSynchronizer;
- savefile: TextFile;
- savememory: TStringList;
- DefaultDomainDirectory:string;
- domainlist: TStringList; // List of domain names. Objects are TDomain.
- TP_IgnoreList:TStringList; // Temporary list, reset each time TranslateProperties is called
- TP_ClassHandling:TList; // Items are TClassMode. If a is derived from b, a comes first
- TP_Retranslator:TExecutable; // Cast this to TTP_Retranslator
- procedure SaveCheck(szMsgId: widestring);
- procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;
- TodoList: TStrings; TextDomain:string); // Translates a single property of an object
- end;
- var
- DefaultInstance:TGnuGettextInstance;
- implementation
- {$ifndef MSWINDOWS}
- {$ifndef LINUX}
- 'This version of gnugettext.pas is only meant to be compiled with Kylix 3,'
- 'Delphi 6, Delphi 7 and later versions. If you use other versions, please'
- 'get the gnugettext.pas version from the Delphi 5 directory.'
- {$endif}
- {$endif}
- {$ifdef MSWINDOWS}
- {$ifndef VER140}
- {$WARN UNSAFE_TYPE OFF}
- {$WARN UNSAFE_CODE OFF}
- {$WARN UNSAFE_CAST OFF}
- {$endif}
- {$endif}
- uses
- {$ifdef MSWINDOWS}
- Windows;
- {$endif}
- {$ifdef LINUX}
- Libc;
- {$endif}
- type
- TTP_RetranslatorItem=
- class
- obj:TObject;
- Propname:string;
- OldValue:WideString;
- end;
- TTP_Retranslator=
- class (TExecutable)
- TextDomain:string;
- Instance:TGnuGettextInstance;
- constructor Create;
- destructor Destroy; override;
- procedure Remember (obj:TObject; PropName:String; OldValue:WideString);
- procedure Execute; override;
- private
- list:TList;
- end;
- TAssemblyFileInfo=
- class
- offset,size:int64;
- end;
- TAssemblyAnalyzer=
- class
- constructor Create;
- destructor Destroy; override;
- procedure Analyze;
- function FileExists (filename:string):boolean;
- procedure GetFileInfo (filename:string; var realfilename:string; var offset, size:int64);
- private
- basedirectory:string;
- filelist:TStringList; //Objects are TAssemblyFileInfo. Filenames are relative to .exe file
- function ReadInt64 (str:TStream):int64;
- end;
- TGnuGettextComponentMarker=
- class (TComponent)
- public
- LastLanguage:string;
- Retranslator:TExecutable;
- destructor Destroy; override;
- end;
- TDomain =
- class
- private
- vDirectory: string;
- procedure setDirectory(dir: string);
- public
- Domain: string;
- property Directory: string read vDirectory write setDirectory;
- constructor Create;
- destructor Destroy; override;
- procedure SetLanguageCode (langcode:string);
- function gettext(msgid: ansistring): ansistring; // uses mo file
- private
- moCS: TMultiReadExclusiveWriteSynchronizer; // Covers next three lines
- doswap: boolean;
- N, O, T: Cardinal; // Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html
- FileOffset:int64;
- {$ifdef mswindows}
- mo: THandle;
- momapping: THandle;
- {$endif}
- momemoryHandle:PChar;
- momemory: PChar;
- curlang: string;
- isopen, moexists: boolean;
- procedure OpenMoFile;
- procedure CloseMoFile;
- function gettextbyid(id: cardinal): ansistring;
- function getdsttextbyid(id: cardinal): ansistring;
- function autoswap32(i: cardinal): cardinal;
- function CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;
- 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;
- {$ifdef MSWindows}
- tpgettext = function(const szMsgId: PChar): PChar; cdecl;
- tpdgettext = function(const szDomain: PChar; const szMsgId: PChar): PChar; cdecl;
- tpdcgettext = function(const szDomain: PChar; const szMsgId: PChar; iCategory: integer): PChar; cdecl;
- tptextdomain = function(const szDomain: PChar): PChar; cdecl;
- tpbindtextdomain = function(const szDomain: PChar; const szDirectory: PChar): PChar; cdecl;
- tpgettext_putenv = function(const envstring: PChar): integer; cdecl;
- 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 Disable;
- procedure Enable;
- private
- ov: cardinal;
- Patch:TCharArray5;
- Original:TCharArray5;
- PatchPosition:PChar;
- end;
- {$endif}
- var
- Win32PlatformIsUnicode:boolean=False;
- AssemblyAnalyzer:TAssemblyAnalyzer;
- TPDomainListCS:TMultiReadExclusiveWriteSynchronizer;
- TPDomainList:TStringList;
- DLLisLoaded: boolean=false;
- {$ifdef MSWINDOWS}
- pgettext: tpgettext;
- pdgettext: tpdgettext;
- ptextdomain: tptextdomain;
- pbindtextdomain: tpbindtextdomain;
- pgettext_putenv: tpgettext_putenv;
- dllmodule: THandle;
- HookLoadResString:THook;
- {$endif}
- function StripCR (s:string):string;
- var
- i:integer;
- begin
- i:=1;
- while i<=length(s) do begin
- if s[i]=#13 then delete (s,i,1) else inc (i);
- end;
- Result:=s;
- end;
- function GGGetEnvironmentVariable (name:string):string;
- begin
- Result:=SysUtils.GetEnvironmentVariable(name);
- end;
- function LF2LineBreakA (s:string):string;
- {$ifdef MSWINDOWS}
- var
- i:integer;
- {$endif}
- begin
- {$ifdef MSWINDOWS}
- Assert (sLinebreak=#13#10);
- i:=1;
- while i<=length(s) do begin
- if (s[i]=#10) and (copy(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;
- procedure SaveUntranslatedMsgids(filename: string);
- begin
- DefaultInstance.SaveUntranslatedMsgids(filename);
- end;
- function string2csyntax(s: string): string;
- // Converts a string to the syntax that is used in .po files
- var
- i: integer;
- c: char;
- begin
- Result := '';
- for i := 1 to length(s) do begin
- c := s[i];
- case c of
- #32..#33, #35..#255: Result := Result + c;
- #13: Result := Result + 'r';
- #10: Result := Result + 'n"'#13#10'"';
- #34: Result := Result + '"';
- else
- Result := Result + 'x' + IntToHex(ord(c), 2);
- end;
- end;
- Result := '"' + Result + '"';
- end;
- function ResourceStringGettext(MsgId: widestring): widestring;
- var
- i:integer;
- begin
- if TPDomainListCS=nil then begin
- // This only happens during very complicated program startups that fail
- Result:=MsgId;
- exit;
- end;
- TPDomainListCS.BeginRead;
- try
- for i:=0 to TPDomainList.Count-1 do begin
- Result:=dgettext(TPDomainList.Strings[i], MsgId);
- if Result<>MsgId then
- break;
- end;
- finally
- TPDomainListCS.EndRead;
- end;
- end;
- function gettext(const szMsgId: widestring): widestring;
- begin
- Result:=DefaultInstance.gettext(szMsgId);
- end;
- function _(const szMsgId: widestring): widestring;
- begin
- Result:=DefaultInstance.gettext(szMsgId);
- end;
- function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
- begin
- Result:=DefaultInstance.dgettext(szDomain, szMsgId);
- end;
- function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
- begin
- Result:=DefaultInstance.dngettext(szDomain,singular,plural,Number);
- end;
- function ngettext(const singular,plural: widestring; Number:longint): widestring;
- begin
- Result:=DefaultInstance.ngettext(singular,plural,Number);
- end;
- procedure textdomain(const szDomain: string);
- begin
- DefaultInstance.textdomain(szDomain);
- end;
- procedure SetGettextEnabled (enabled:boolean);
- begin
- DefaultInstance.Enabled:=enabled;
- end;
- function getcurrenttextdomain: string;
- begin
- Result:=DefaultInstance.getcurrenttextdomain;
- end;
- procedure bindtextdomain(const szDomain: string; const szDirectory: string);
- begin
- DefaultInstance.bindtextdomain(szDomain, szDirectory);
- end;
- procedure TP_Ignore(AnObject:TObject; const name:string);
- begin
- DefaultInstance.TP_Ignore(AnObject, name);
- end;
- procedure TP_GlobalIgnoreClass (IgnClass:TClass);
- begin
- DefaultInstance.TP_GlobalIgnoreClass(IgnClass);
- end;
- procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
- begin
- DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass,propertyname);
- end;
- procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
- begin
- DefaultInstance.TP_GlobalHandleClass (HClass, Handler);
- end;
- procedure TranslateProperties(AnObject: TObject; TextDomain:string='');
- begin
- DefaultInstance.TranslateProperties(AnObject, TextDomain);
- end;
- procedure TranslateComponent(AnObject: TComponent; TextDomain:string='');
- begin
- DefaultInstance.TranslateComponent(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: string;
- var
- langid: Cardinal;
- langcode: string;
- CountryName: array[0..4] of char;
- LanguageName: array[0..4] of char;
- works: boolean;
- begin
- // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero
- works := 3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName));
- works := works and (3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName,
- SizeOf(CountryName)));
- if works then begin
- // Windows 98, Me, NT4, 2000, XP and newer
- LangCode := PChar(@LanguageName[0]) + '_' + PChar(@CountryName[0]);
- end else begin
- // This part should only happen on Windows 95.
- langid := GetThreadLocale;
- case langid of
- IDBelgianDutch: langcode := 'nl_BE';
- IDBelgianFrench: langcode := 'fr_BE';
- IDBrazilianPortuguese: langcode := 'pt_BR';
- IDDanish: langcode := 'da_DK';
- IDDutch: langcode := 'nl_NL';
- IDEnglishUK: langcode := 'en_UK';
- IDEnglishUS: langcode := 'en_US';
- IDFinnish: langcode := 'fi_FI';
- IDFrench: langcode := 'fr_FR';
- IDFrenchCanadian: langcode := 'fr_CA';
- IDGerman: langcode := 'de_DE';
- IDGermanLuxembourg: langcode := 'de_LU';
- IDGreek: langcode := 'gr_GR';
- IDIcelandic: langcode := 'is_IS';
- IDItalian: langcode := 'it_IT';
- IDKorean: langcode := 'ko_KO';
- IDNorwegianBokmol: langcode := 'no_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 := 'fi_SE';
- else
- langcode := 'C';
- end;
- end;
- Result := langcode;
- end;
- {$endif}
- function LoadResStringA(ResStringRec: PResStringRec): string;
- begin
- Result:=LoadResString(ResStringRec);
- end;
- procedure gettext_putenv(const envstring: string);
- begin
- {$ifdef mswindows}
- if DLLisLoaded and Assigned(pgettext_putenv) then
- pgettext_putenv(PChar(envstring));
- {$endif}
- end;
- function GetTranslatorNameAndEmail:widestring;
- begin
- Result:=DefaultInstance.GetTranslatorNameAndEmail;
- end;
- procedure UseLanguage(LanguageCode: string);
- begin
- DefaultInstance.UseLanguage(LanguageCode);
- end;
- function LoadResString(ResStringRec: PResStringRec): widestring;
- {$ifdef MSWINDOWS}
- var
- Len: Integer;
- Buffer: array [0..1023] of char;
- {$endif}
- begin
- if (ResStringRec = nil) then
- exit;
- if ResStringRec.Identifier >= 64*1024 then
- Result:=PChar(ResStringRec.Identifier)
- else
- {$ifdef LINUX}
- // This works with Unicode if the Linux has utf-8 character set
- Result:=System.LoadResString(ResStringRec);
- {$endif}
- {$ifdef MSWINDOWS}
- if not Win32PlatformIsUnicode then begin
- SetString(Result, Buffer,
- LoadString(FindResourceHInstance(ResStringRec.Module^),
- ResStringRec.Identifier, Buffer, SizeOf(Buffer)))
- end else begin
- Result := '';
- Len := 0;
- While Len = Length(Result) do begin
- if Length(Result) = 0 then
- SetLength(Result, 1024)
- else
- SetLength(Result, Length(Result) * 2);
- Len := LoadStringW(FindResourceHInstance(ResStringRec.Module^),
- ResStringRec.Identifier, PWideChar(Result), Length(Result));
- end;
- SetLength(Result, Len);
- end;
- {$endif}
- Result:=ResourceStringGettext(Result);
- end;
- function LoadResStringW(ResStringRec: PResStringRec): widestring;
- begin
- Result:=LoadResString(ResStringRec);
- end;
- function GetCurrentLanguage:string;
- begin
- Result:=DefaultInstance.GetCurrentLanguage;
- end;
- function getdomain(list:TStringList; domain, DefaultDomainDirectory, CurLang: string): TDomain;
- // Retrieves the TDomain object for the specified domain.
- // Creates one, if none there, yet.
- var
- idx: integer;
- begin
- idx := list.IndexOf(Domain);
- if idx = -1 then begin
- Result := TDomain.Create;
- Result.Domain := Domain;
- Result.Directory := DefaultDomainDirectory;
- Result.SetLanguageCode(curlang);
- list.AddObject(Domain, Result);
- end else begin
- Result := list.Objects[idx] as TDomain;
- end;
- end;
- { TDomain }
- function TDomain.CardinalInMem (baseptr:PChar; Offset:Cardinal):Cardinal;
- var pc:^Cardinal;
- begin
- inc (baseptr,offset);
- pc:=Pointer(baseptr);
- Result:=pc^;
- if doswap then
- autoswap32(Result);
- end;
- function TDomain.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;
- procedure TDomain.CloseMoFile;
- begin
- moCS.BeginWrite;
- try
- if isopen then begin
- {$ifdef mswindows}
- UnMapViewOfFile (momemoryHandle);
- CloseHandle (momapping);
- CloseHandle (mo);
- {$endif}
- {$ifdef linux}
- FreeMem (momemoryHandle);
- {$endif}
- isopen := False;
- end;
- moexists := True;
- finally
- moCS.EndWrite;
- end;
- end;
- constructor TDomain.Create;
- begin
- moCS := TMultiReadExclusiveWriteSynchronizer.Create;
- isOpen := False;
- moexists := True;
- end;
- destructor TDomain.Destroy;
- begin
- CloseMoFile;
- FreeAndNil(moCS);
- inherited;
- end;
- function TDomain.gettextbyid(id: cardinal): ansistring;
- var
- offset, size: cardinal;
- begin
- offset:=CardinalInMem (momemory,O+8*id+4);
- size:=CardinalInMem (momemory,O+8*id);
- SetString (Result,momemory+offset,size);
- end;
- function TDomain.getdsttextbyid(id: cardinal): ansistring;
- var
- offset, size: cardinal;
- begin
- offset:=CardinalInMem (momemory,T+8*id+4);
- size:=CardinalInMem (momemory,T+8*id);
- SetString (Result,momemory+offset,size);
- end;
- function TDomain.gettext(msgid: ansistring): ansistring;
- var
- i, nn, step: cardinal;
- s: string;
- begin
- if (not isopen) and moexists then
- OpenMoFile;
- if not isopen then begin
- Result := msgid;
- exit;
- end;
- // Calculate start conditions for a binary search
- nn := N;
- i := 1;
- while nn <> 0 do begin
- nn := nn shr 1;
- i := i shl 1;
- end;
- i := i shr 1;
- step := i shr 1;
- // Do binary search
- while true do begin
- // Get string for index i
- s := gettextbyid(i-1);
- if msgid = s then begin
- // Found the msgid
- Result := getdsttextbyid(i-1);
- break;
- end;
- if step = 0 then begin
- // Not found
- Result := msgid;
- break;
- end;
- if msgid < s then begin
- if i < 1+step then
- i := 1
- else
- i := i - step;
- step := step shr 1;
- end else
- if msgid > s then begin
- i := i + step;
- if i > N then
- i := N;
- step := step shr 1;
- end;
- end;
- end;
- {$ifdef mswindows}
- function GetLastWinError:string;
- var
- errcode:Cardinal;
- begin
- SetLength (Result,2000);
- errcode:=GetLastError();
- Windows.FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PChar(Result),2000,nil);
- Result:=StrPas(PChar(Result));
- end;
- {$endif}
- procedure TDomain.OpenMoFile;
- var
- i: cardinal;
- filename: string;
- offset,size:Int64;
- {$ifdef linux}
- mofile:TFileStream;
- {$endif}
- begin
- moCS.BeginWrite;
- try
- // Check if it is already open
- if isopen then
- exit;
- // Check if it has been attempted to open the file before
- if not moexists then
- exit;
- if sizeof(i) <> 4 then
- raise Exception.Create('TDomain in gnugettext is written for an architecture that has 32 bit integers.');
- filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
- if (not AssemblyAnalyzer.FileExists(filename)) and (not fileexists(filename)) then
- filename := Directory + copy(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
- if (not AssemblyAnalyzer.FileExists(filename)) and (not fileexists(filename)) then begin
- moexists := False;
- exit;
- end;
- AssemblyAnalyzer.GetFileInfo(filename,filename,offset,size);
- FileOffset:=offset;
- {$ifdef mswindows}
- // The next two lines are necessary because otherwise MapViewOfFile fails
- size:=0;
- offset:=0;
- // 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 Exception.Create ('Cannot open file '+filename);
- momapping:=CreateFileMapping (mo, nil, PAGE_READONLY, 0, 0, nil);
- if momapping=0 then
- raise Exception.Create ('Cannot create memory map on file '+filename);
- momemoryHandle:=MapViewOfFile (momapping,FILE_MAP_READ,offset shr 32,offset and $FFFFFFFF,size);
- if momemoryHandle=nil then begin
- raise Exception.Create ('Cannot map file '+filename+' into memory. Reason: '+GetLastWinError);
- end;
- momemory:=momemoryHandle+FileOffset;
- {$endif}
- {$ifdef linux}
- // Read the whole file into memory
- mofile:=TFileStream.Create (filename, fmOpenRead or fmShareDenyNone);
- try
- if size=0 then
- size:=mofile.Size;
- Getmem (momemoryHandle,size);
- momemory:=momemoryHandle;
- mofile.Seek(FileOffset,soFromBeginning);
- mofile.ReadBuffer(momemory^,size);
- finally
- FreeAndNil (mofile);
- end;
- {$endif}
- isOpen := True;
- // Check the magic number
- doswap:=False;
- i:=CardinalInMem(momemory,0);
- if (i <> $950412DE) and (i <> $DE120495) then
- raise Exception.Create('This file is not a valid GNU gettext mo file: ' + filename);
- doswap := (i = $DE120495);
- 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
- finally
- moCS.EndWrite;
- end;
- end;
- procedure TDomain.setDirectory(dir: string);
- begin
- vDirectory := IncludeTrailingPathDelimiter(dir);
- CloseMoFile;
- end;
- function LoadDLLifPossible (dllname:string='gnu_gettext.dll'):boolean;
- begin
- {$ifdef MSWINDOWS}
- if not DLLisLoaded then begin
- dllmodule := LoadLibraryEx(PChar(dllname), 0, 0);
- DLLisLoaded := (dllmodule <> 0);
- if DLLisLoaded then begin
- pgettext := tpgettext(GetProcAddress(dllmodule, 'gettext'));
- pdgettext := tpdgettext(GetProcAddress(dllmodule, 'dgettext'));
- ptextdomain := tptextdomain(GetProcAddress(dllmodule, 'textdomain'));
- pbindtextdomain := tpbindtextdomain(GetProcAddress(dllmodule, 'bindtextdomain'));
- pgettext_putenv := tpgettext_putenv(GetProcAddress(dllmodule, 'gettext_putenv'));
- end;
- end;
- {$endif}
- {$ifdef LINUX}
- // On Linux, gettext is always there as part of the Libc library.
- // But default is not to use it, but to use the internal implementation instead.
- DLLisLoaded := False;
- {$endif}
- Result:=DLLisLoaded;
- end;
- procedure AddDomainForResourceString (domain:string);
- begin
- TPDomainListCS.BeginWrite;
- try
- TPDomainList.Add (domain);
- finally
- TPDomainListCS.EndWrite;
- end;
- end;
- procedure TDomain.SetLanguageCode(langcode: string);
- begin
- CloseMoFile;
- curlang:=langcode;
- end;
- function GetPluralForm2EN(Number: Integer): Integer;
- begin
- Number:=abs(Number);
- if Number=1 then Result:=0 else Result:=1;
- end;
- function GetPluralForm1(Number: Integer): Integer;
- begin
- Result:=0;
- end;
- function GetPluralForm2FR(Number: Integer): Integer;
- begin
- Number:=abs(Number);
- if (Number=1) or (Number=0) then Result:=0 else Result:=1;
- end;
- function GetPluralForm3LV(Number: Integer): Integer;
- begin
- Number:=abs(Number);
- if (Number mod 10=1) and (Number mod 100<>11) then
- Result:=0
- else
- if Number<>0 then Result:=1
- else Result:=2;
- end;
- function GetPluralForm3GA(Number: Integer): Integer;
- begin
- Number:=abs(Number);
- if Number=1 then Result:=0
- else if Number=2 then Result:=1
- else Result:=2;
- end;
- function GetPluralForm3LT(Number: Integer): Integer;
- var
- n1,n2:byte;
- begin
- Number:=abs(Number);
- n1:=Number mod 10;
- n2:=Number mod 100;
- if (n1=1) and (n2<>11) then
- Result:=0
- else
- if (n1>=2) and ((n2<10) or (n2>=20)) then Result:=1
- else Result:=2;
- end;
- function GetPluralForm3PL(Number: Integer): Integer;
- var
- n1,n2:byte;
- begin
- Number:=abs(Number);
- n1:=Number mod 10;
- n2:=Number mod 100;
- if n1=1 then Result:=0
- else if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
- else Result:=2;
- end;
- function GetPluralForm3RU(Number: Integer): Integer;
- var
- n1,n2:byte;
- begin
- Number:=abs(Number);
- n1:=Number mod 10;
- n2:=Number mod 100;
- if (n1=1) and (n2<>11) then
- Result:=0
- else
- if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
- else Result:=2;
- end;
- function GetPluralForm4SL(Number: Integer): Integer;
- var
- n2:byte;
- begin
- Number:=abs(Number);
- n2:=Number mod 100;
- if n2=1 then Result:=0
- else
- if n2=2 then Result:=1
- else
- if (n2=3) or (n2=4) then Result:=2
- else
- Result:=3;
- end;
- { TGnuGettextInstance }
- procedure TGnuGettextInstance.bindtextdomain(const szDomain,
- szDirectory: string);
- var
- dir:string;
- begin
- dir:=IncludeTrailingPathDelimiter(szDirectory);
- getdomain(domainlist,szDomain,DefaultDomainDirectory,CurLang).Directory := dir;
- {$ifdef LINUX}
- dir:=ExcludeTrailingPathDelimiter(szDirectory);
- Libc.bindtextdomain(PChar(szDomain), PChar(dir));
- {$endif}
- {$ifdef MSWINDOWS}
- if DLLisLoaded then
- pbindtextdomain(PChar(szDomain), PChar(dir));
- {$endif}
- end;
- constructor TGnuGettextInstance.Create;
- var
- lang: string;
- begin
- curGetPluralForm:=GetPluralForm2EN;
- Enabled:=True;
- curmsgdomain:=DefaultTextDomain;
- savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;
- domainlist := TStringList.Create;
- TP_IgnoreList:=TStringList.Create;
- TP_IgnoreList.Sorted:=True;
- TP_ClassHandling:=TList.Create;
- // Set some settings
- DefaultDomainDirectory := IncludeTrailingPathDelimiter(extractfilepath(ExecutableFilename))+'locale';
- UseLanguage(lang);
- bindtextdomain(DefaultTextDomain, DefaultDomainDirectory);
- textdomain(DefaultTextDomain);
- {$ifdef LINUX}
- bind_textdomain_codeset(DefaultTextDomain,'utf-8');
- {$endif}
- // 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_ClassHandling.Count<>0 do begin
- TObject(TP_ClassHandling.Items[0]).Free;
- TP_ClassHandling.Delete(0);
- end;
- FreeAndNil (TP_ClassHandling);
- while domainlist.Count <> 0 do begin
- domainlist.Objects[0].Free;
- domainlist.Delete(0);
- end;
- FreeAndNil(domainlist);
- inherited;
- end;
- function TGnuGettextInstance.dgettext(const szDomain: string;
- const szMsgId: widestring): widestring;
- begin
- if not Enabled then begin
- Result:=szMsgId;
- exit;
- end;
- if DLLisLoaded then begin
- {$ifdef LINUX}
- Result := utf8decode(StrPas(Libc.dgettext(PChar(szDomain), PChar(utf8encode(szMsgId)))));
- {$endif}
- {$ifdef MSWINDOWS}
- Result := utf8decode(LF2LineBreakA(StrPas(pdgettext(PChar(szDomain), PChar(StripCR(utf8encode((szMsgId))))))));
- {$endif}
- end else begin
- Result:=UTF8Decode(LF2LineBreakA(getdomain(domainlist,szDomain,DefaultDomainDirectory,CurLang).gettext(StripCR(utf8encode(szMsgId)))));
- end;
- if (szMsgId<>'') and (Result='') then
- raise Exception.Create (Format('Error: Could not translate %s. Probably because the mo file doesn''t contain utf-8 encoded translations.',[szMsgId]));
- if (Result = szMsgId) and (szDomain = DefaultTextDomain) then
- SaveCheck(szMsgId);
- end;
- function TGnuGettextInstance.GetCurrentLanguage: string;
- begin
- Result:=curlang;
- end;
- function TGnuGettextInstance.getcurrenttextdomain: string;
- begin
- if DLLisLoaded then begin
- {$ifdef LINUX}
- Result := StrPas(Libc.textdomain(nil));
- {$endif}
- {$ifdef MSWINDOWS}
- Result := StrPas(ptextdomain(nil));
- {$endif}
- end else
- Result := curmsgdomain;
- end;
- function TGnuGettextInstance.gettext(
- const szMsgId: widestring): widestring;
- begin
- Result := dgettext(curmsgdomain, szMsgId);
- end;
- procedure TGnuGettextInstance.SaveCheck(szMsgId: widestring);
- var
- i: integer;
- begin
- savefileCS.BeginWrite;
- try
- if (savememory <> nil) and (szMsgId <> '') then begin
- if not savememory.Find(szMsgId, i) then begin
- savememory.Add(szMsgId);
- Writeln(savefile, 'msgid ' + string2csyntax(utf8encode(szMsgId)));
- writeln(savefile, 'msgstr ""');
- writeln(savefile);
- end;
- end;
- finally
- savefileCS.EndWrite;
- end;
- end;
- procedure TGnuGettextInstance.SaveUntranslatedMsgids(filename: string);
- begin
- // If this happens, it is an internal error made by the programmer.
- if savememory <> nil then
- raise Exception.Create(_('You may not call SaveUntranslatedMsgids twice in this program.'));
- AssignFile(savefile, filename);
- Rewrite(savefile);
- writeln(savefile, 'msgid ""');
- writeln(savefile, 'msgstr ""');
- writeln(savefile);
- savememory := TStringList.Create;
- savememory.Sorted := true;
- end;
- procedure TGnuGettextInstance.textdomain(const szDomain: string);
- begin
- curmsgdomain := szDomain;
- {$ifdef LINUX}
- Libc.textdomain(PChar(szDomain));
- {$endif}
- {$ifdef MSWINDOWS}
- if DLLisLoaded then begin
- ptextdomain(PChar(szDomain));
- end;
- {$endif}
- end;
- function TGnuGettextInstance.TP_CreateRetranslator : TExecutable;
- var
- ttpr:TTP_Retranslator;
- begin
- ttpr:=TTP_Retranslator.Create;
- ttpr.Instance:=self;
- TP_Retranslator:=ttpr;
- Result:=ttpr;
- end;
- procedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass;
- Handler: TTranslator);
- 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=HClass then
- raise Exception.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_ClassHandling.Insert(i,cm);
- exit;
- end;
- end;
- cm:=TClassMode.Create;
- cm.HClass:=HClass;
- cm.SpecialHandler:=Handler;
- TP_ClassHandling.Add(cm);
- end;
- procedure TGnuGettextInstance.TP_GlobalIgnoreClass(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 Exception.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);
- exit;
- end;
- end;
- cm:=TClassMode.Create;
- cm.HClass:=IgnClass;
- TP_ClassHandling.Add(cm);
- end;
- procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(
- IgnClass: TClass; propertyname: string);
- 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 Exception.Create ('You cannot ignore a class property for a class that has a handler set.');
- cm.PropertiesToIgnore.Add(propertyname);
- 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);
- exit;
- end;
- end;
- cm:=TClassMode.Create;
- cm.HClass:=IgnClass;
- cm.PropertiesToIgnore.Add(propertyname);
- TP_ClassHandling.Add(cm);
- end;
- procedure TGnuGettextInstance.TP_Ignore(AnObject: TObject;
- const name: string);
- begin
- TP_IgnoreList.Add(uppercase(name));
- end;
- procedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent;
- TextDomain: string);
- var
- comp:TGnuGettextComponentMarker;
- begin
- 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);
- end else begin
- if comp.LastLanguage<>curlang then begin
- comp.Retranslator.Execute;
- end;
- end;
- comp.LastLanguage:=curlang;
- end;
- procedure TGnuGettextInstance.TranslateProperty (AnObject:TObject; PropInfo:PPropInfo; TodoList:TStrings; TextDomain:string);
- var
- ppi:PPropInfo;
- ws: WideString;
- old: WideString;
- obj:TObject;
- sl:TStrings;
- i, k:integer;
- Propname:string;
- begin
- PropName:=PropInfo^.Name;
- try
- // Translate certain types of properties
- case PropInfo^.PropType^.Kind of
- tkString, tkLString, tkWString:
- begin
- old := GetWideStrProp(AnObject, PropName);
- if (old <> '') and (IsWriteProp(PropInfo)) then begin
- if TP_Retranslator<>nil then
- (TP_Retranslator as TTP_Retranslator).Remember(AnObject, PropName, old);
- ws := dgettext(textdomain,old);
- if ws <> old then begin
- ppi:=GetPropInfo(AnObject, Propname);
- if ppi=nil then
- raise Exception.Create ('Property disappeared...');
- SetWideStrProp(AnObject, ppi, ws);
- end;
- end;
- end { case item };
- tkClass:
- begin
- obj:=GetObjectProp(AnObject, PropName);
- if obj<>nil then begin
- // Check the global class ignore list
- for k:=0 to TP_ClassHandling.Count-1 do begin
- if AnObject.InheritsFrom(TClass(TP_ClassHandling.Items[k])) then
- exit;
- end;
- // Check for TStrings translation
- if obj is TStrings then begin
- sl:=obj as TStrings;
- if (sl.Text<>'') and (TP_Retranslator<>nil) then
- (TP_Retranslator as TTP_Retranslator).Remember(obj, 'Text', sl.Text);
- TranslateStrings (sl,TextDomain);
- end else
- // Check for TCollection
- if obj is TCollection then
- for i := 0 to TCollection(obj).Count - 1 do
- TodoList.AddObject('',TCollection(obj).Items[i]);
- // Check for TComponent
- if obj is TComponent then
- TodoList.AddObject ('',obj);
- end { if not nil };
- end { case item };
- end { case };
- except
- on E:Exception do
- raise Exception.Create ('Property cannot be translated.'+sLineBreak+
- 'Use TP_GlobalIgnoreClassProperty('+AnObject.ClassName+','+PropName+') or'+sLineBreak+
- 'TP_Ignore (self,''.'+PropName+''') to prevent this message.'+sLineBreak+
- 'Reason: '+e.Message);
- end;
- end;
- procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; textdomain:string='');
- 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: string;
- PropInfo: PPropInfo;
- comp:TComponent;
- cm,currentcm:TClassMode;
- ObjectPropertyIgnoreList:TStringList;
- objid, Name:string;
- begin
- if textdomain='' then
- textdomain:=curmsgdomain;
- if TP_Retranslator<>nil then
- (TP_Retranslator as TTP_Retranslator).TextDomain:=textdomain;
- DoneList:=TStringList.Create;
- TodoList:=TStringList.Create;
- ObjectPropertyIgnoreList:=TStringList.Create;
- try
- TodoList.AddObject('', AnObject);
- DoneList.Sorted:=True;
- ObjectPropertyIgnoreList.Sorted:=True;
- ObjectPropertyIgnoreList.Duplicates:=dupIgnore;
- 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 then begin
- // Make sure each object is only translated once
- Assert (sizeof(integer)=sizeof(TObject));
- objid:=IntToHex(integer(AnObject),8);
- if DoneList.Find(objid,i) then begin
- continue;
- end else begin
- DoneList.Add(objid);
- end;
- ObjectPropertyIgnoreList.Clear;
- // Find out if there is special handling of this object
- currentcm:=nil;
- 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
- currentcm:=cm;
- break;
- end;
- end;
- end;
- if currentcm<>nil then begin
- ObjectPropertyIgnoreList.Clear;
- // Ignore or use special handler
- if Assigned(currentcm.SpecialHandler) then
- currentcm.SpecialHandler (AnObject);
- continue;
- end;
- Count := GetPropList(AnObject, PropList);
- try
- for j := 0 to Count - 1 do begin
- PropInfo := PropList[j];
- UPropName:=uppercase(PropInfo^.Name);
- // Ignore properties that are meant to be ignored
- if ((currentcm=nil) or (not currentcm.PropertiesToIgnore.Find(UPropName,i))) and
- (not TP_IgnoreList.Find(Name+'.'+UPropName,i)) and
- (not ObjectPropertyIgnoreList.Find(UPropName,i)) then begin
- TranslateProperty (AnObject,PropInfo,TodoList,TextDomain);
- end; // if
- end; // for
- finally
- if Count<>0 then
- FreeMem (PropList);
- end;
- if AnObject is TStrings then begin
- TranslateStrings (AnObject as TStrings,TextDomain);
- end;
- if AnObject is TComponent then
- 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
- TodoList.AddObject(uppercase(comp.Name),comp);
- end;
- end;
- end { if AnObject<>nil };
- end { while todolist.count<>0 };
- finally
- FreeAndNil (todolist);
- FreeAndNil (ObjectPropertyIgnoreList);
- FreeAndNil (DoneList);
- end;
- TP_IgnoreList.Clear;
- TP_Retranslator:=nil;
- end;
- procedure TGnuGettextInstance.UseLanguage(LanguageCode: string);
- var
- i,p:integer;
- dom:TDomain;
- l2:string[2];
- begin
- if LanguageCode='' then begin
- LanguageCode:=GGGetEnvironmentVariable('LANG');
- {$ifdef MSWINDOWS}
- if LanguageCode='' then
- LanguageCode:=GetWindowsLanguage;
- {$endif}
- p:=pos('.',LanguageCode);
- if p<>0 then
- LanguageCode:=copy(LanguageCode,1,p-1);
- end;
- curlang := LanguageCode;
- gettext_putenv('LANG=' + LanguageCode);
- for i:=0 to domainlist.Count-1 do begin
- dom:=domainlist.Objects[i] as TDomain;
- dom.SetLanguageCode (curlang);
- end;
- {$ifdef LINUX}
- setlocale (LC_MESSAGES, PChar(LanguageCode));
- {$endif}
- l2:=lowercase(copy(curlang,1,2));
- if (l2='en') or (l2='de') then curGetPluralForm:=GetPluralForm2EN else
- if (l2='hu') or (l2='ko') or (l2='zh') or (l2='ja') or (l2='tr') then curGetPluralForm:=GetPluralForm1 else
- if (l2='fr') or (l2='fa') or (lowercase(curlang)='pt_br') then curGetPluralForm:=GetPluralForm2FR else
- if (l2='lv') then curGetPluralForm:=GetPluralForm3LV else
- if (l2='ga') then curGetPluralForm:=GetPluralForm3GA else
- if (l2='lt') then curGetPluralForm:=GetPluralForm3LT else
- if (l2='ru') or (l2='cs') or (l2='sk') or (l2='uk') or (l2='hr') then curGetPluralForm:=GetPluralForm3RU else
- if (l2='pl') then curGetPluralForm:=GetPluralForm3PL else
- if (l2='sl') then curGetPluralForm:=GetPluralForm4SL else
- curGetPluralForm:=GetPluralForm2EN
- end;
- procedure TGnuGettextInstance.TranslateStrings(sl: TStrings;TextDomain:string);
- var
- s:TStringList;
- line:string;
- i:integer;
- begin
- s:=TStringList.Create;
- try
- s.AddStrings (sl);
- for i:=0 to s.Count-1 do begin
- line:=s.Strings[i];
- if line<>'' then
- s.Strings[i]:=dgettext(TextDomain,line);
- end;
- sl.Text:=s.Text;
- finally
- FreeAndNil (s);
- end;
- end;
- function TGnuGettextInstance.GetTranslatorNameAndEmail: widestring;
- begin
- Result:=GetTranslationProperty('LAST-TRANSLATOR');
- end;
- function TGnuGettextInstance.GetTranslationProperty(
- Propertyname: string): WideString;
- var
- sl:TStringList;
- i:integer;
- s:string;
- begin
- Propertyname:=uppercase(Propertyname)+': ';
- sl:=TStringList.Create;
- try
- sl.Text:=utf8encode(gettext(''));
- for i:=0 to sl.Count-1 do begin
- s:=sl.Strings[i];
- if uppercase(copy(s,1,length(Propertyname)))=Propertyname then begin
- Result:=utf8decode(trim(copy(s,length(PropertyName)+1,maxint)));
- exit;
- end;
- end;
- finally
- FreeAndNil (sl);
- end;
- Result:='';
- end;
- function TGnuGettextInstance.dngettext(const szDomain,singular, plural: widestring;
- Number: Integer): widestring;
- var
- org,trans:widestring;
- idx:integer;
- p:integer;
- begin
- org:=singular+#0+plural;
- trans:=dgettext(szDomain,org);
- if org=trans then
- idx:=GetPluralForm2EN(Number)
- else
- idx:=curGetPluralForm(Number);
- while true do begin
- p:=pos(#0,trans);
- if p=0 then begin
- Result:=trans;
- exit;
- end;
- if idx=0 then begin
- Result:=copy(trans,1,p-1);
- exit;
- end;
- delete (trans,1,p);
- dec (idx);
- end;
- end;
- function TGnuGettextInstance.ngettext(const singular, plural: widestring;
- Number: Integer): widestring;
- begin
- Result := dngettext(curmsgdomain, singular, plural, Number);
- end;
- { TClassMode }
- constructor TClassMode.Create;
- begin
- PropertiesToIgnore:=TStringList.Create;
- PropertiesToIgnore.Sorted:=True;
- PropertiesToIgnore.Duplicates:=dupIgnore;
- end;
- destructor TClassMode.Destroy;
- begin
- FreeAndNil (PropertiesToIgnore);
- inherited;
- end;
- { TAssemblyAnalyzer }
- procedure TAssemblyAnalyzer.Analyze;
- var
- s:ansistring;
- i:integer;
- offset:int64;
- fs:TFileStream;
- fi:TAssemblyFileInfo;
- filename:string;
- begin
- s:='6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0;
- s:=copy(s,length(s)-7,8);
- offset:=0;
- for i:=8 downto 1 do
- offset:=offset shl 8+ord(s[i]);
- if offset=0 then
- exit;
- BaseDirectory:=ExtractFilePath(ExecutableFilename);
- try
- fs:=TFileStream.Create(ExecutableFilename,fmOpenRead or fmShareDenyNone);
- try
- while true do begin
- fs.Seek(offset,soFromBeginning);
- offset:=ReadInt64(fs);
- if offset=0 then
- exit;
- fi:=TAssemblyFileInfo.Create;
- try
- fi.Offset:=ReadInt64(fs);
- fi.Size:=ReadInt64(fs);
- SetLength (filename, offset-fs.position);
- fs.ReadBuffer (filename[1],offset-fs.position);
- filename:=trim(filename);
- filelist.AddObject(filename,fi);
- except
- FreeAndNil (fi);
- raise;
- end;
- end;
- finally
- FreeAndNil (fs);
- end;
- except
- end;
- end;
- constructor TAssemblyAnalyzer.Create;
- begin
- filelist:=TStringList.Create;
- {$ifdef LINUX}
- filelist.Duplicates:=dupError;
- filelist.CaseSensitive:=True;
- {$endif}
- filelist.Duplicates:=dupError;
- filelist.CaseSensitive:=False;
- filelist.Sorted:=True;
- end;
- destructor TAssemblyAnalyzer.Destroy;
- begin
- while filelist.count<>0 do begin
- filelist.Objects[0].Free;
- filelist.Delete (0);
- end;
- FreeAndNil (filelist);
- inherited;
- end;
- function TAssemblyAnalyzer.FileExists(filename: string): boolean;
- var
- idx:integer;
- begin
- if copy(filename,1,length(basedirectory))=basedirectory then
- filename:=copy(filename,length(basedirectory)+1,maxint);
- Result:=filelist.Find(filename,idx);
- end;
- procedure TAssemblyAnalyzer.GetFileInfo(filename: string;
- var realfilename: string; var offset, size: int64);
- var
- fi:TAssemblyFileInfo;
- idx:integer;
- begin
- offset:=0;
- size:=0;
- realfilename:=filename;
- if copy(filename,1,length(basedirectory))=basedirectory then begin
- filename:=copy(filename,length(basedirectory)+1,maxint);
- idx:=filelist.IndexOf(filename);
- if idx<>-1 then begin
- fi:=filelist.Objects[idx] as TAssemblyFileInfo;
- realfilename:=ExecutableFilename;
- offset:=fi.offset;
- size:=fi.size;
- end;
- end;
- end;
- function TAssemblyAnalyzer.ReadInt64(str: TStream): int64;
- begin
- Assert (sizeof(Result)=8);
- str.ReadBuffer(Result,8);
- end;
- { TTP_Retranslator }
- constructor TTP_Retranslator.Create;
- begin
- list:=TList.Create;
- end;
- destructor TTP_Retranslator.Destroy;
- var
- i:integer;
- begin
- for i:=0 to list.Count-1 do
- TObject(list.Items[i]).Free;
- FreeAndNil (list);
- inherited;
- end;
- procedure TTP_Retranslator.Execute;
- var
- i:integer;
- sl:TStrings;
- item:TTP_RetranslatorItem;
- newvalue:WideString;
- ppi:PPropInfo;
- begin
- for i:=0 to list.Count-1 do begin
- item:=TObject(list.items[i]) as TTP_RetranslatorItem;
- if item.obj is TStrings then begin
- sl:=item.obj as TStrings;
- sl.Text:=item.OldValue;
- Instance.TranslateStrings(sl,textdomain);
- end else begin
- newValue:=instance.dgettext(textdomain,item.OldValue);
- ppi:=GetPropInfo(item.obj, item.Propname);
- if ppi=nil then
- raise Exception.Create ('Property disappeared...');
- SetWideStrProp(item.obj, ppi, newValue);
- end;
- end;
- end;
- procedure TTP_Retranslator.Remember(obj: TObject; PropName: String;
- OldValue: WideString);
- var
- item:TTP_RetranslatorItem;
- begin
- item:=TTP_RetranslatorItem.Create;
- item.obj:=obj;
- item.Propname:=Propname;
- item.OldValue:=OldValue;
- list.Add(item);
- end;
- { TGnuGettextComponentMarker }
- destructor TGnuGettextComponentMarker.Destroy;
- begin
- FreeAndNil (Retranslator);
- inherited;
- end;
- { THook }
- {$ifdef MSWINDOWS}
- constructor THook.Create(OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);
- { Idea and original code from Igor Siticov }
- { Modified by Jacques Garcia Vazquez and Lars Dybdahl }
- var
- offset: integer;
- begin
- {$ifndef CPU386}
- 'This procedure only works on Intel i386 compatible processors.'
- {$endif}
- if FollowJump and (Word(OldProcedure^) = $25FF) then begin
- // This finds the correct procedure if a virtual jump has been inserted
- // at the procedure address
- Inc(Integer(OldProcedure), 2); // skip the jump
- OldProcedure := Pointer(Pointer(OldProcedure^)^);
- end;
- PatchPosition:=PChar(OldProcedure);
- offset:=integer(NewProcedure)-integer(OldProcedure)-5;
- Patch[0] := char($E9);
- Patch[1] := char(offset and 255);
- Patch[2] := char((offset shr 8) and 255);
- Patch[3] := char((offset shr 16) and 255);
- Patch[4] := char((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];
- if not VirtualProtect(Pointer(PatchPosition), 5, PAGE_EXECUTE_READWRITE, @ov) then
- RaiseLastOSError;
- Enable;
- end;
- destructor THook.Destroy;
- var
- ov2:Cardinal;
- begin
- Disable;
- if not VirtualProtect(Pointer(PatchPosition), 5, ov, @ov2) then
- RaiseLastOSError;
- inherited;
- end;
- procedure THook.Disable;
- begin
- 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
- PatchPosition[0]:=Patch[0];
- PatchPosition[1]:=Patch[1];
- PatchPosition[2]:=Patch[2];
- PatchPosition[3]:=Patch[3];
- PatchPosition[4]:=Patch[4];
- end;
- {$endif}
- initialization
- ExecutableFilename:=Paramstr(0);
- AssemblyAnalyzer:=TAssemblyAnalyzer.Create;
- AssemblyAnalyzer.Analyze;
- TPDomainList:=TStringList.Create;
- TPDomainList.Add(DefaultTextDomain);
- TPDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create;
- DefaultInstance:=TGnuGettextInstance.Create;
- {$ifdef MSWINDOWS}
- Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
- // replace Borlands LoadResString with gettext enabled version:
- HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringA, RuntimePackageSupportEnabled);
- {$endif}
- finalization
- FreeAndNil (DefaultInstance);
- FreeAndNil (TPDomainListCS);
- FreeAndNil (TPDomainList);
- {$ifdef mswindows}
- // Unload the dll
- if dllmodule <> 0 then
- FreeLibrary(dllmodule);
- FreeAndNil (HookLoadResString);
- {$endif}
- FreeAndNil (AssemblyAnalyzer);
- end.