|
Server : Apache/2.4.43 (Win64) OpenSSL/1.1.1g PHP/7.4.6 System : Windows NT USER-PC 6.1 build 7601 (Windows 7 Professional Edition Service Pack 1) AMD64 User : User ( 0) PHP Version : 7.4.6 Disable Function : NONE Directory : C:/xampp/src/xampp-control-panel/ |
{ *------------------------------------------------------------------------------
GNU gettext translation system for Delphi, Kylix, C++ Builder and others.
All parts of the translation system are kept in this unit.
@author Lars B. Dybdahl and others
@version $LastChangedRevision$
@see http://dybdahl.dk/dxgettext/
------------------------------------------------------------------------------- }
unit gnugettext;
(* ************************************************************ *)
(* *)
(* (C) Copyright by Lars B. Dybdahl and others *)
(* E-mail: Lars@dybdahl.dk, phone +45 70201241 *)
(* *)
(* Contributors: Peter Thornqvist, Troy Wolbrink, *)
(* Frank Andreas de Groot, Igor Siticov, *)
(* Jacques Garcia Vazquez, Igor Gitman *)
(* *)
(* See http://dybdahl.dk/dxgettext/ for more information *)
(* *)
(* ************************************************************ *)
// Information about this file:
// $LastChangedDate$
// $LastChangedRevision$
// $HeadURL$
// Redistribution and use in source and binary forms, with or without
// modification, are permitted provided that the following conditions are met:
//
// The names of any contributor may not be used to endorse or promote
// products derived from this software without specific prior written permission.
//
// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
// ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
// LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
interface
// If the conditional define DXGETTEXTDEBUG is defined, debugging log is activated.
// Use DefaultInstance.DebugLogToFile() to write the log to a file.
{ $define DXGETTEXTDEBUG }
{$IFDEF VER140}
// Delphi 6
{$DEFINE DELPHI2007OROLDER}
{$IFDEF MSWINDOWS}
{$DEFINE DELPHI6OROLDER}
{$ENDIF}
{$ENDIF}
{$IFDEF VER150}
// Delphi 7
{$DEFINE DELPHI2007OROLDER}
{$ENDIF}
{$IFDEF VER160}
// Delphi 8
{$DEFINE DELPHI2007OROLDER}
{$ENDIF}
{$IFDEF VER170}
// Delphi 2005
{$DEFINE DELPHI2007OROLDER}
{$ENDIF}
{$IFDEF VER180}
// Delphi 2006
{$DEFINE DELPHI2007OROLDER}
{$ENDIF}
{$IFDEF VER190}
// Delphi 2007
{$DEFINE DELPHI2007OROLDER}
{$ENDIF}
{$IFDEF VER200}
// Delphi 2009 with Unicode
{$ENDIF}
uses
{$IFDEF MSWINDOWS}
Windows,
{$ELSE}
Libc,
{$IFDEF FPC}
CWString,
{$ENDIF}
{$ENDIF}
Classes, StrUtils, SysUtils, TypInfo;
(* *************************************************************************** *)
(* *)
(* MAIN API *)
(* *)
(* *************************************************************************** *)
type
{$IFNDEF UNICODE}
UnicodeString = WideString;
RawUtf8String = AnsiString;
RawByteString = AnsiString;
{$ELSE}
RawUtf8String = RawByteString;
{$ENDIF}
DomainString = string;
LanguageString = string;
ComponentNameString = string;
FilenameString = string;
MsgIdString = UnicodeString;
TranslatedUnicodeString = UnicodeString;
// Main GNU gettext functions. See documentation for instructions on how to use them.
function _(const szMsgId: MsgIdString): TranslatedUnicodeString;
function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString;
function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;
function dngettext(const szDomain: DomainString; const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString;
function ngettext(const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString;
procedure textdomain(const szDomain: DomainString);
function getcurrenttextdomain: DomainString;
procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString);
// Set language to use
procedure UseLanguage(LanguageCode: LanguageString);
function GetCurrentLanguage: LanguageString;
// Translates a component (form, frame etc.) to the currently selected language.
// Put TranslateComponent(self) in the OnCreate event of all your forms.
// See the manual for documentation on these functions
type
TTranslator = procedure(obj: TObject) of object;
procedure TP_Ignore(AnObject: TObject; const name: ComponentNameString);
procedure TP_IgnoreClass(IgnClass: TClass);
procedure TP_IgnoreClassProperty(IgnClass: TClass; const propertyname: ComponentNameString);
procedure TP_GlobalIgnoreClass(IgnClass: TClass);
procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const propertyname: ComponentNameString);
procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator);
procedure TranslateComponent(AnObject: TComponent; const textdomain: DomainString = '');
procedure RetranslateComponent(AnObject: TComponent; const textdomain: DomainString = '');
// Add more domains that resourcestrings can be extracted from. If a translation
// is not found in the default domain, this domain will be searched, too.
// This is useful for adding mo files for certain runtime libraries and 3rd
// party component libraries
procedure AddDomainForResourceString(const domain: DomainString);
procedure RemoveDomainForResourceString(const domain: DomainString);
// Unicode-enabled way to get resourcestrings, automatically translated
// Use like this: ws:=LoadResStringW(@NameOfResourceString);
function LoadResString(ResStringRec: PResStringRec): WideString;
function LoadResStringW(ResStringRec: PResStringRec): UnicodeString;
// This returns an empty string if not translated or translator name is not specified.
function GetTranslatorNameAndEmail: TranslatedUnicodeString;
(* *************************************************************************** *)
(* *)
(* ADVANCED FUNCTIONALITY *)
(* *)
(* *************************************************************************** *)
const
DefaultTextDomain = 'default';
var
ExecutableFilename: FilenameString;
// This is set to paramstr(0) or the name of the DLL you are creating.
const
PreferExternal = false;
// Set to true, to prefer external *.mo over embedded translation
const
// Subversion source code version control version information
VCSVersion = '$LastChangedRevision$';
type
EGnuGettext = class(Exception);
EGGProgrammingError = class(EGnuGettext);
EGGComponentError = class(EGnuGettext);
EGGIOError = class(EGnuGettext);
EGGAnsi2WideConvError = class(EGnuGettext);
// This function will turn resourcestring hooks on or off, eventually with BPL file support.
// Please do not activate BPL file support when the package is in design mode.
const
AutoCreateHooks = true;
procedure HookIntoResourceStrings(enabled: boolean = true; SupportPackages: boolean = false);
(* *************************************************************************** *)
(* *)
(* CLASS based implementation. *)
(* Use TGnuGettextInstance to have more than one language *)
(* in your application at the same time *)
(* *)
(* *************************************************************************** *)
{$IFDEF MSWINDOWS}
{$IFNDEF DELPHI6OROLDER}
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CODE OFF}
{$WARN UNSAFE_CAST OFF}
{$ENDIF}
{$ENDIF}
type
TOnDebugLine = Procedure(Sender: TObject; const Line: String; var Discard: boolean) of Object;
// Set Discard to false if output should still go to ordinary debug log
TGetPluralForm = function(Number: longint): Integer;
TDebugLogger = procedure(Line: AnsiString) of object;
{ *------------------------------------------------------------------------------
Handles .mo files, in separate files or inside the exe file.
Don't use this class. It's for internal use.
------------------------------------------------------------------------------- }
TMoFile = class
/// Threadsafe. Only constructor and destructor are writing to memory
private
doswap: boolean;
public
Users: Integer;
/// Reference count. If it reaches zero, this object should be destroyed.
constructor Create(filename: FilenameString; Offset, Size: int64);
destructor Destroy; override;
function gettext(const msgid: RawUtf8String; var found: boolean): RawUtf8String; // uses mo file and utf-8
property isSwappedArchitecture: boolean read doswap;
private
N, O, T: Cardinal;
/// Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html
startindex, startstep: Integer;
{$IFDEF mswindows}
mo: THandle;
momapping: THandle;
{$ENDIF}
momemoryHandle: PAnsiChar;
momemory: PAnsiChar;
function autoswap32(i: Cardinal): Cardinal;
function CardinalInMem(baseptr: PAnsiChar; Offset: Cardinal): Cardinal;
end;
{ *------------------------------------------------------------------------------
Handles all issues regarding a specific domain.
Don't use this class. It's for internal use.
------------------------------------------------------------------------------- }
TDomain = class
private
enabled: boolean;
vDirectory: FilenameString;
procedure setDirectory(const dir: FilenameString);
public
DebugLogger: TDebugLogger;
domain: DomainString;
property Directory: FilenameString read vDirectory write setDirectory;
constructor Create;
destructor Destroy; override;
// Set parameters
procedure SetLanguageCode(const langcode: LanguageString);
procedure SetFilename(const filename: FilenameString);
// Bind this domain to a specific file
// Get information
procedure GetListOfLanguages(list: TStrings);
function GetTranslationProperty(propertyname: ComponentNameString): TranslatedUnicodeString;
function gettext(const msgid: RawUtf8String): RawUtf8String;
// uses mo file and utf-8
private
mofile: TMoFile;
SpecificFilename: FilenameString;
curlang: LanguageString;
OpenHasFailedBefore: boolean;
procedure OpenMoFile;
procedure CloseMoFile;
end;
{ *------------------------------------------------------------------------------
Helper class for invoking events.
------------------------------------------------------------------------------- }
TExecutable = class
procedure Execute; virtual; abstract;
end;
{ *------------------------------------------------------------------------------
The main translation engine.
------------------------------------------------------------------------------- }
TGnuGettextInstance = class
private
fOnDebugLine: TOnDebugLine;
CreatorThread: Cardinal;
/// Only this thread can use LoadResString
public
enabled: boolean;
/// Set this to false to disable translations
DesignTimeCodePage: Integer;
/// See MultiByteToWideChar() in Win32 API for documentation
constructor Create;
destructor Destroy; override;
procedure UseLanguage(LanguageCode: LanguageString);
procedure GetListOfLanguages(const domain: DomainString; list: TStrings);
// Puts list of language codes, for which there are translations in the specified domain, into list
{$IFNDEF UNICODE}
function gettext(const szMsgId: AnsiString): TranslatedUnicodeString; overload; virtual;
function ngettext(const singular, plural: AnsiString; Number: longint): TranslatedUnicodeString; overload; virtual;
{$ENDIF}
function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString; overload; virtual;
function gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString;
function ngettext(const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString; overload; virtual;
function ngettext_NoExtract(const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString;
function GetCurrentLanguage: LanguageString;
function GetTranslationProperty(const propertyname: ComponentNameString): TranslatedUnicodeString;
function GetTranslatorNameAndEmail: TranslatedUnicodeString;
// Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites()
procedure TP_Ignore(AnObject: TObject; const name: ComponentNameString);
procedure TP_IgnoreClass(IgnClass: TClass);
procedure TP_IgnoreClassProperty(IgnClass: TClass; propertyname: ComponentNameString);
procedure TP_GlobalIgnoreClass(IgnClass: TClass);
procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; propertyname: ComponentNameString);
procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator);
procedure TranslateProperties(AnObject: TObject; textdomain: DomainString = '');
procedure TranslateComponent(AnObject: TComponent; const textdomain: DomainString = '');
procedure RetranslateComponent(AnObject: TComponent; const textdomain: DomainString = '');
// Multi-domain functions
{$IFNDEF UNICODE}
function dgettext(const szDomain: DomainString; const szMsgId: AnsiString): TranslatedUnicodeString; overload; virtual;
function dngettext(const szDomain: DomainString; const singular, plural: AnsiString; Number: longint): TranslatedUnicodeString; overload; virtual;
{$ENDIF}
function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; overload; virtual;
function dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;
function dngettext(const szDomain: DomainString; const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString;
overload; virtual;
function dngettext_NoExtract(const szDomain: DomainString; const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString;
procedure textdomain(const szDomain: DomainString);
function getcurrenttextdomain: DomainString;
procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString);
procedure bindtextdomainToFile(const szDomain: DomainString; const filename: FilenameString);
// Also works with files embedded in exe file
// Windows API functions
function LoadResString(ResStringRec: PResStringRec): UnicodeString;
// Output all log info to this file. This may only be called once.
procedure DebugLogToFile(const filename: FilenameString; append: boolean = false);
procedure DebugLogPause(PauseEnabled: boolean);
property OnDebugLine: TOnDebugLine read fOnDebugLine write fOnDebugLine;
// If set, all debug output goes here
{$IFNDEF UNICODE}
// Conversion according to design-time character set
function ansi2wideDTCP(const s: AnsiString): MsgIdString;
// Convert using Design Time Code Page
{$ENDIF}
protected
procedure TranslateStrings(sl: TStrings; const textdomain: DomainString);
// Override these three, if you want to inherited from this class
// to create a new class that handles other domain and language dependent
// issues
procedure WhenNewLanguage(const LanguageID: LanguageString); virtual;
// Override to know when language changes
procedure WhenNewDomain(const textdomain: DomainString); virtual;
// Override to know when text domain changes. Directory is purely informational
procedure WhenNewDomainDirectory(const textdomain: DomainString; const Directory: FilenameString); virtual;
// Override to know when any text domain's directory changes. It won't be called if a domain is fixed to a specific file.
private
curlang: LanguageString;
curGetPluralForm: TGetPluralForm;
curmsgdomain: DomainString;
savefileCS: TMultiReadExclusiveWriteSynchronizer;
savefile: TextFile;
savememory: TStringList;
DefaultDomainDirectory: FilenameString;
domainlist: TStringList;
/// List of domain names. Objects are TDomain.
TP_IgnoreList: TStringList;
/// Temporary list, reset each time TranslateProperties is called
TP_ClassHandling: TList;
/// Items are TClassMode. If a is derived from b, a comes first
TP_GlobalClassHandling: TList;
/// Items are TClassMode. If a is derived from b, a comes first
TP_Retranslator: TExecutable;
/// Cast this to TTP_Retranslator
{$IFDEF DXGETTEXTDEBUG}
DebugLogCS: TMultiReadExclusiveWriteSynchronizer;
DebugLog: TStream;
DebugLogOutputPaused: boolean;
{$ENDIF}
function TP_CreateRetranslator: TExecutable; // Must be freed by caller!
procedure FreeTP_ClassHandlingItems;
{$IFDEF DXGETTEXTDEBUG}
procedure DebugWriteln(Line: AnsiString);
{$ENDIF}
procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo; TodoList: TStrings; const textdomain: DomainString);
function Getdomain(const domain: DomainString; const DefaultDomainDirectory: FilenameString; const curlang: LanguageString): TDomain;
// Translates a single property of an object
end;
const
LOCALE_SISO639LANGNAME = $59; // Used by Lazarus software development tool
LOCALE_SISO3166CTRYNAME = $5A; // Used by Lazarus software development tool
var
DefaultInstance: TGnuGettextInstance;
/// Default instance of the main API for singlethreaded applications.
implementation
{$IFNDEF MSWINDOWS}
{$IFNDEF LINUX}
'This version of gnugettext.pas is only meant to be compiled with Kylix 3,'
'Delphi 6, Delphi 7 and later versions. If you use other versions, please' 'get the gnugettext.pas version from the Delphi 5 directory.'
{$ENDIF}
{$ENDIF}
(* ************************************************************************ *)
// Some comments on the implementation:
// This unit should be independent of other units where possible.
// It should have a small footprint in any way.
(* ************************************************************************ *)
// TMultiReadExclusiveWriteSynchronizer is used instead of TCriticalSection
// because it makes this unit independent of the SyncObjs unit
(* ************************************************************************ *)
{$B-,R+,I+,Q+}
type TTP_RetranslatorItem = class obj: TObject;
Propname:
ComponentNameString;
OldValue:
TranslatedUnicodeString;
end;
TTP_Retranslator = class(TExecutable)textdomain: DomainString;
Instance:
TGnuGettextInstance;
constructor Create;
destructor Destroy; override;
procedure Remember(obj: TObject; Propname: ComponentNameString; OldValue: TranslatedUnicodeString);
procedure Execute; override;
private
list: TList;
end;
TEmbeddedFileInfo = class Offset, Size: int64;
end;
TFileLocator = class
// This class finds files even when embedded inside executable
constructor Create;
destructor Destroy;
override;
procedure Analyze; // List files embedded inside executable
function FileExists(filename: FilenameString): boolean;
function GetMoFile(filename: FilenameString; DebugLogger: TDebugLogger): TMoFile;
procedure ReleaseMoFile(mofile: TMoFile);
private
basedirectory: FilenameString;
filelist: TStringList;
// Objects are TEmbeddedFileInfo. Filenames are relative to .exe file
MoFilesCS: TMultiReadExclusiveWriteSynchronizer;
MoFiles: TStringList;
// Objects are filenames+offset, objects are TMoFile
function ReadInt64(str: TStream): int64;
end;
TGnuGettextComponentMarker = class(TComponent)public LastLanguage: LanguageString;
Retranslator: TExecutable;
destructor Destroy;
override;
end;
TClassMode = class HClass: TClass;
SpecialHandler: TTranslator;
PropertiesToIgnore: TStringList; // This is ignored if Handler is set
constructor Create;
destructor Destroy;
override;
end;
TRStrinfo = record strlength, stroffset: Cardinal;
end;
TStrInfoArr = array [0 .. 10000000] of TRStrinfo;
PStrInfoArr = ^TStrInfoArr;
TCharArray5 = array [0 .. 4] of ansichar;
THook = // Replaces a runtime library procedure with a custom procedure
class public constructor Create(OldProcedure, NewProcedure: pointer; FollowJump: boolean = false);
destructor Destroy;
override; // Restores unhooked state
procedure Reset(FollowJump: boolean = false);
// Disables and picks up patch points again
procedure Disable;
procedure Enable;
private
oldproc, newproc: pointer;
Patch: TCharArray5;
Original: TCharArray5;
PatchPosition: PAnsiChar;
procedure Shutdown;
// Same as destroy, except that object is not destroyed
end;
var
// System information
Win32PlatformIsUnicode: boolean = false;
// Information about files embedded inside .exe file
FileLocator: TFileLocator;
// Hooks into runtime library functions
ResourceStringDomainListCS: TMultiReadExclusiveWriteSynchronizer;
ResourceStringDomainList: TStringList;
HookLoadResString: THook;
HookLoadStr: THook;
HookFmtLoadStr: THook;
function GGGetEnvironmentVariable(const name: WideString): WideString;
var
Len: Integer;
W: WideString;
begin
Result := '';
SetLength(W, 1);
Len := Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(W), 1);
if Len > 0 then
begin
SetLength(Result, Len - 1);
Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(Result), Len);
end;
end;
function StripCRRawMsgId(s: RawUtf8String): RawUtf8String;
var
i: Integer;
begin
i := 1;
while i <= length(s) do
begin
if s[i] = #13 then
delete(s, i, 1)
else
inc(i);
end;
Result := s;
end;
function EnsureLineBreakInTranslatedString(s: RawUtf8String): RawUtf8String;
{$IFDEF MSWINDOWS}
var
i: Integer;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
Assert(sLinebreak = AnsiString(#13#10));
i := 1;
while i <= length(s) do
begin
if (s[i] = #10) and (MidStr(s, i - 1, 1) <> #13) then
begin
insert(#13, s, i);
inc(i, 2);
end
else
inc(i);
end;
{$ENDIF}
Result := s;
end;
function IsWriteProp(Info: PPropInfo): boolean;
begin
Result := Assigned(Info) and (Info^.SetProc <> nil);
end;
function ResourceStringGettext(msgid: MsgIdString): TranslatedUnicodeString;
var
i: Integer;
begin
if (msgid = '') or (ResourceStringDomainListCS = nil) then
begin
// This only happens during very complicated program startups that fail,
// or when Msgid=''
Result := msgid;
exit;
end;
ResourceStringDomainListCS.BeginRead;
try
for i := 0 to ResourceStringDomainList.Count - 1 do
begin
Result := dgettext(ResourceStringDomainList.Strings[i], msgid);
if Result <> msgid then
break;
end;
finally
ResourceStringDomainListCS.EndRead;
end;
end;
function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString;
begin
Result := DefaultInstance.gettext(szMsgId);
end;
{ *------------------------------------------------------------------------------
This is the main translation procedure used in programs. It takes a parameter,
looks it up in the translation dictionary, and returns the translation.
If no translation is found, the parameter is returned.
@param szMsgId The text, that should be displayed if no translation is found.
------------------------------------------------------------------------------- }
function _(const szMsgId: MsgIdString): TranslatedUnicodeString;
begin
Result := DefaultInstance.gettext(szMsgId);
end;
{ *------------------------------------------------------------------------------
Translates a text, using a specified translation domain.
If no translation is found, the parameter is returned.
@param szDomain Which translation domain that should be searched for a translation.
@param szMsgId The text, that should be displayed if no translation is found.
------------------------------------------------------------------------------- }
function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;
begin
Result := DefaultInstance.dgettext(szDomain, szMsgId);
end;
function dngettext(const szDomain: DomainString; const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString;
begin
Result := DefaultInstance.dngettext(szDomain, singular, plural, Number);
end;
function ngettext(const singular, plural: MsgIdString; Number: longint): TranslatedUnicodeString;
begin
Result := DefaultInstance.ngettext(singular, plural, Number);
end;
procedure textdomain(const szDomain: DomainString);
begin
DefaultInstance.textdomain(szDomain);
end;
procedure SetGettextEnabled(enabled: boolean);
begin
DefaultInstance.enabled := enabled;
end;
function getcurrenttextdomain: DomainString;
begin
Result := DefaultInstance.getcurrenttextdomain;
end;
procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString);
begin
DefaultInstance.bindtextdomain(szDomain, szDirectory);
end;
procedure TP_Ignore(AnObject: TObject; const name: FilenameString);
begin
DefaultInstance.TP_Ignore(AnObject, name);
end;
procedure TP_GlobalIgnoreClass(IgnClass: TClass);
begin
DefaultInstance.TP_GlobalIgnoreClass(IgnClass);
end;
procedure TP_IgnoreClass(IgnClass: TClass);
begin
DefaultInstance.TP_IgnoreClass(IgnClass);
end;
procedure TP_IgnoreClassProperty(IgnClass: TClass; const propertyname: ComponentNameString);
begin
DefaultInstance.TP_IgnoreClassProperty(IgnClass, propertyname);
end;
procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const propertyname: ComponentNameString);
begin
DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass, propertyname);
end;
procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator);
begin
DefaultInstance.TP_GlobalHandleClass(HClass, Handler);
end;
procedure TranslateComponent(AnObject: TComponent; const textdomain: DomainString = '');
begin
DefaultInstance.TranslateComponent(AnObject, textdomain);
end;
procedure RetranslateComponent(AnObject: TComponent; const textdomain: DomainString = '');
begin
DefaultInstance.RetranslateComponent(AnObject, textdomain);
end;
{$IFDEF MSWINDOWS}
// These constants are only used in Windows 95
// Thanks to Frank Andreas de Groot for this table
const
IDAfrikaans = $0436;
IDAlbanian = $041C;
IDArabicAlgeria = $1401;
IDArabicBahrain = $3C01;
IDArabicEgypt = $0C01;
IDArabicIraq = $0801;
IDArabicJordan = $2C01;
IDArabicKuwait = $3401;
IDArabicLebanon = $3001;
IDArabicLibya = $1001;
IDArabicMorocco = $1801;
IDArabicOman = $2001;
IDArabicQatar = $4001;
IDArabic = $0401;
IDArabicSyria = $2801;
IDArabicTunisia = $1C01;
IDArabicUAE = $3801;
IDArabicYemen = $2401;
IDArmenian = $042B;
IDAssamese = $044D;
IDAzeriCyrillic = $082C;
IDAzeriLatin = $042C;
IDBasque = $042D;
IDByelorussian = $0423;
IDBengali = $0445;
IDBulgarian = $0402;
IDBurmese = $0455;
IDCatalan = $0403;
IDChineseHongKong = $0C04;
IDChineseMacao = $1404;
IDSimplifiedChinese = $0804;
IDChineseSingapore = $1004;
IDTraditionalChinese = $0404;
IDCroatian = $041A;
IDCzech = $0405;
IDDanish = $0406;
IDBelgianDutch = $0813;
IDDutch = $0413;
IDEnglishAUS = $0C09;
IDEnglishBelize = $2809;
IDEnglishCanadian = $1009;
IDEnglishCaribbean = $2409;
IDEnglishIreland = $1809;
IDEnglishJamaica = $2009;
IDEnglishNewZealand = $1409;
IDEnglishPhilippines = $3409;
IDEnglishSouthAfrica = $1C09;
IDEnglishTrinidad = $2C09;
IDEnglishUK = $0809;
IDEnglishUS = $0409;
IDEnglishZimbabwe = $3009;
IDEstonian = $0425;
IDFaeroese = $0438;
IDFarsi = $0429;
IDFinnish = $040B;
IDBelgianFrench = $080C;
IDFrenchCameroon = $2C0C;
IDFrenchCanadian = $0C0C;
IDFrenchCotedIvoire = $300C;
IDFrench = $040C;
IDFrenchLuxembourg = $140C;
IDFrenchMali = $340C;
IDFrenchMonaco = $180C;
IDFrenchReunion = $200C;
IDFrenchSenegal = $280C;
IDSwissFrench = $100C;
IDFrenchWestIndies = $1C0C;
IDFrenchZaire = $240C;
IDFrisianNetherlands = $0462;
IDGaelicIreland = $083C;
IDGaelicScotland = $043C;
IDGalician = $0456;
IDGeorgian = $0437;
IDGermanAustria = $0C07;
IDGerman = $0407;
IDGermanLiechtenstein = $1407;
IDGermanLuxembourg = $1007;
IDSwissGerman = $0807;
IDGreek = $0408;
IDGujarati = $0447;
IDHebrew = $040D;
IDHindi = $0439;
IDHungarian = $040E;
IDIcelandic = $040F;
IDIndonesian = $0421;
IDItalian = $0410;
IDSwissItalian = $0810;
IDJapanese = $0411;
IDKannada = $044B;
IDKashmiri = $0460;
IDKazakh = $043F;
IDKhmer = $0453;
IDKirghiz = $0440;
IDKonkani = $0457;
IDKorean = $0412;
IDLao = $0454;
IDLatvian = $0426;
IDLithuanian = $0427;
IDMacedonian = $042F;
IDMalaysian = $043E;
IDMalayBruneiDarussalam = $083E;
IDMalayalam = $044C;
IDMaltese = $043A;
IDManipuri = $0458;
IDMarathi = $044E;
IDMongolian = $0450;
IDNepali = $0461;
IDNorwegianBokmol = $0414;
IDNorwegianNynorsk = $0814;
IDOriya = $0448;
IDPolish = $0415;
IDBrazilianPortuguese = $0416;
IDPortuguese = $0816;
IDPunjabi = $0446;
IDRhaetoRomanic = $0417;
IDRomanianMoldova = $0818;
IDRomanian = $0418;
IDRussianMoldova = $0819;
IDRussian = $0419;
IDSamiLappish = $043B;
IDSanskrit = $044F;
IDSerbianCyrillic = $0C1A;
IDSerbianLatin = $081A;
IDSesotho = $0430;
IDSindhi = $0459;
IDSlovak = $041B;
IDSlovenian = $0424;
IDSorbian = $042E;
IDSpanishArgentina = $2C0A;
IDSpanishBolivia = $400A;
IDSpanishChile = $340A;
IDSpanishColombia = $240A;
IDSpanishCostaRica = $140A;
IDSpanishDominicanRepublic = $1C0A;
IDSpanishEcuador = $300A;
IDSpanishElSalvador = $440A;
IDSpanishGuatemala = $100A;
IDSpanishHonduras = $480A;
IDMexicanSpanish = $080A;
IDSpanishNicaragua = $4C0A;
IDSpanishPanama = $180A;
IDSpanishParaguay = $3C0A;
IDSpanishPeru = $280A;
IDSpanishPuertoRico = $500A;
IDSpanishModernSort = $0C0A;
IDSpanish = $040A;
IDSpanishUruguay = $380A;
IDSpanishVenezuela = $200A;
IDSutu = $0430;
IDSwahili = $0441;
IDSwedishFinland = $081D;
IDSwedish = $041D;
IDTajik = $0428;
IDTamil = $0449;
IDTatar = $0444;
IDTelugu = $044A;
IDThai = $041E;
IDTibetan = $0451;
IDTsonga = $0431;
IDTswana = $0432;
IDTurkish = $041F;
IDTurkmen = $0442;
IDUkrainian = $0422;
IDUrdu = $0420;
IDUzbekCyrillic = $0843;
IDUzbekLatin = $0443;
IDVenda = $0433;
IDVietnamese = $042A;
IDWelsh = $0452;
IDXhosa = $0434;
IDZulu = $0435;
function GetWindowsLanguage: WideString;
var
langid: Cardinal;
langcode: WideString;
CountryName: array [0 .. 4] of widechar;
LanguageName: array [0 .. 4] of widechar;
works: boolean;
begin
// The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero
works := 3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName));
works := works and (3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName, SizeOf(CountryName)));
if works then
begin
// Windows 98, Me, NT4, 2000, XP and newer
langcode := PWideChar(@(LanguageName[0]));
if lowercase(langcode) = 'no' then
langcode := 'nb';
langcode := langcode + '_' + PWideChar(@CountryName[0]);
end
else
begin
// This part should only happen on Windows 95.
langid := GetThreadLocale;
case langid of
IDBelgianDutch:
langcode := 'nl_BE';
IDBelgianFrench:
langcode := 'fr_BE';
IDBrazilianPortuguese:
langcode := 'pt_BR';
IDDanish:
langcode := 'da_DK';
IDDutch:
langcode := 'nl_NL';
IDEnglishUK:
langcode := 'en_GB';
IDEnglishUS:
langcode := 'en_US';
IDFinnish:
langcode := 'fi_FI';
IDFrench:
langcode := 'fr_FR';
IDFrenchCanadian:
langcode := 'fr_CA';
IDGerman:
langcode := 'de_DE';
IDGermanLuxembourg:
langcode := 'de_LU';
IDGreek:
langcode := 'el_GR';
IDIcelandic:
langcode := 'is_IS';
IDItalian:
langcode := 'it_IT';
IDKorean:
langcode := 'ko_KO';
IDNorwegianBokmol:
langcode := 'nb_NO';
IDNorwegianNynorsk:
langcode := 'nn_NO';
IDPolish:
langcode := 'pl_PL';
IDPortuguese:
langcode := 'pt_PT';
IDRussian:
langcode := 'ru_RU';
IDSpanish, IDSpanishModernSort:
langcode := 'es_ES';
IDSwedish:
langcode := 'sv_SE';
IDSwedishFinland:
langcode := 'sv_FI';
else
langcode := 'C';
end;
end;
Result := langcode;
end;
{$ENDIF}
{$IFNDEF UNICODE}
function LoadResStringA(ResStringRec: PResStringRec): AnsiString;
begin
Result := DefaultInstance.LoadResString(ResStringRec);
end;
{$ENDIF}
function GetTranslatorNameAndEmail: TranslatedUnicodeString;
begin
Result := DefaultInstance.GetTranslatorNameAndEmail;
end;
procedure UseLanguage(LanguageCode: LanguageString);
begin
DefaultInstance.UseLanguage(LanguageCode);
end;
type
PStrData = ^TStrData;
TStrData = record
Ident: Integer;
str: String;
end;
function SysUtilsEnumStringModules(Instance: NativeInt; Data: pointer): boolean;
{$IFDEF MSWINDOWS}
var
Buffer: array [0 .. 1023] of Char;
// WideChar in Delphi 2008, AnsiChar before that
begin
with PStrData(Data)^ do
begin
SetString(str, Buffer, LoadString(HInstance, Ident, @Buffer[0], SizeOf(Buffer)));
Result := str = '';
end;
end;
{$ENDIF}
{$IFDEF LINUX}
var
rs: TResStringRec;
Module: HModule;
begin
Module := Instance;
rs.Module := @Module;
with PStrData(Data)^ do
begin
rs.Identifier := Ident;
str := System.LoadResString(@rs);
Result := str = '';
end;
end;
{$ENDIF}
function SysUtilsFindStringResource(Ident: Integer): string;
var
StrData: TStrData;
begin
StrData.Ident := Ident;
StrData.str := '';
EnumResourceModules(SysUtilsEnumStringModules, @StrData);
Result := StrData.str;
end;
function SysUtilsLoadStr(Ident: Integer): string;
begin
{$IFDEF DXGETTEXTDEBUG}
DefaultInstance.DebugWriteln('Sysutils.LoadRes(' + IntToStr(Ident) + ') called');
{$ENDIF}
Result := ResourceStringGettext(SysUtilsFindStringResource(Ident));
end;
function SysUtilsFmtLoadStr(Ident: Integer; const Args: array of const): string;
begin
{$IFDEF DXGETTEXTDEBUG}
DefaultInstance.DebugWriteln('Sysutils.FmtLoadRes(' + IntToStr(Ident) + ',Args) called');
{$ENDIF}
FmtStr(Result, ResourceStringGettext(SysUtilsFindStringResource(Ident)), Args);
end;
function LoadResString(ResStringRec: PResStringRec): WideString;
begin
Result := DefaultInstance.LoadResString(ResStringRec);
end;
function LoadResStringW(ResStringRec: PResStringRec): UnicodeString;
begin
Result := DefaultInstance.LoadResString(ResStringRec);
end;
function GetCurrentLanguage: LanguageString;
begin
Result := DefaultInstance.GetCurrentLanguage;
end;
{ TDomain }
procedure TDomain.CloseMoFile;
begin
if mofile <> nil then
begin
FileLocator.ReleaseMoFile(mofile);
mofile := nil;
end;
OpenHasFailedBefore := false;
end;
destructor TDomain.Destroy;
begin
CloseMoFile;
inherited;
end;
{$IFDEF mswindows}
function GetLastWinError: WideString;
var
errcode: Cardinal;
begin
SetLength(Result, 2000);
errcode := GetLastError();
Windows.FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM, nil, errcode, 0, PWideChar(Result), 2000, nil);
Result := PWideChar(Result);
end;
{$ENDIF}
procedure TDomain.OpenMoFile;
var
filename: FilenameString;
begin
// Check if it is already open
if mofile <> nil then
exit;
// Check if it has been attempted to open the file before
if OpenHasFailedBefore then
exit;
if SpecificFilename <> '' then
begin
filename := SpecificFilename;
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('Domain ' + domain + ' is bound to specific file ' + filename);
{$ENDIF}
end
else
begin
filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
if (not FileLocator.FileExists(filename)) and (not FileExists(filename)) then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('Domain ' + domain + ': File does not exist, neither embedded or in file system: ' + filename);
{$ENDIF}
filename := Directory + MidStr(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('Domain ' + domain + ' will attempt to use this file: ' + filename);
{$ENDIF}
end
else
begin
{$IFDEF DXGETTEXTDEBUG}
if FileLocator.FileExists(filename) then
DebugLogger('Domain ' + domain + ' will attempt to use this embedded file: ' + filename)
else
DebugLogger('Domain ' + domain + ' will attempt to use this file that was found on the file system: ' + filename);
{$ENDIF}
end;
end;
if (not FileLocator.FileExists(filename)) and (not FileExists(filename)) then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('Domain ' + domain + ' failed to locate the file: ' + filename);
{$ENDIF}
OpenHasFailedBefore := true;
exit;
end;
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('Domain ' + domain + ' now accesses the file.');
{$ENDIF}
mofile := FileLocator.GetMoFile(filename, DebugLogger);
{$IFDEF DXGETTEXTDEBUG}
if mofile.isSwappedArchitecture then
DebugLogger('.mo file is swapped (comes from another CPU architecture)');
{$ENDIF}
// Check, that the contents of the file is utf-8
if pos('CHARSET=UTF-8', uppercase(GetTranslationProperty('Content-Type'))) = 0 then
begin
CloseMoFile;
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('The translation for the language code ' + curlang + ' (in ' + filename +
') does not have charset=utf-8 in its Content-Type. Translations are turned off.');
{$ENDIF}
{$IFDEF MSWINDOWS}
MessageBoxW(0, PWideChar(WideString('The translation for the language code ' + curlang + ' (in ' + filename +
') does not have charset=utf-8 in its Content-Type. Translations are turned off.')), 'Localization problem', MB_OK);
{$ELSE}
writeln(stderr, 'The translation for the language code ' + curlang + ' (in ' + filename +
') does not have charset=utf-8 in its Content-Type. Translations are turned off.');
{$ENDIF}
enabled := false;
end;
end;
{$IFDEF UNICODE}
function utf8decode(s: RawByteString): UnicodeString; inline;
begin
Result := UTF8ToWideString(s);
end;
{$ENDIF}
function TDomain.GetTranslationProperty(propertyname: ComponentNameString): TranslatedUnicodeString;
var
sl: TStringList;
i: Integer;
s: string;
begin
propertyname := uppercase(propertyname) + ': ';
sl := TStringList.Create;
try
sl.Text := utf8decode(gettext(''));
for i := 0 to sl.Count - 1 do
begin
s := sl.Strings[i];
if uppercase(MidStr(s, 1, length(propertyname))) = propertyname then
begin
Result := trim(MidStr(s, length(propertyname) + 1, maxint));
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('GetTranslationProperty(' + propertyname + ') returns ''' + Result + '''.');
{$ENDIF}
exit;
end;
end;
finally
FreeAndNil(sl);
end;
Result := '';
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('GetTranslationProperty(' + propertyname + ') did not find any value. An empty string is returned.');
{$ENDIF}
end;
procedure TDomain.setDirectory(const dir: FilenameString);
begin
vDirectory := IncludeTrailingPathDelimiter(dir);
SpecificFilename := '';
CloseMoFile;
end;
procedure AddDomainForResourceString(const domain: DomainString);
begin
{$IFDEF DXGETTEXTDEBUG}
DefaultInstance.DebugWriteln('Extra domain for resourcestring: ' + domain);
{$ENDIF}
ResourceStringDomainListCS.BeginWrite;
try
if ResourceStringDomainList.IndexOf(domain) = -1 then
ResourceStringDomainList.Add(domain);
finally
ResourceStringDomainListCS.EndWrite;
end;
end;
procedure RemoveDomainForResourceString(const domain: DomainString);
var
i: Integer;
begin
{$IFDEF DXGETTEXTDEBUG}
DefaultInstance.DebugWriteln('Remove domain for resourcestring: ' + domain);
{$ENDIF}
ResourceStringDomainListCS.BeginWrite;
try
i := ResourceStringDomainList.IndexOf(domain);
if i <> -1 then
ResourceStringDomainList.delete(i);
finally
ResourceStringDomainListCS.EndWrite;
end;
end;
procedure TDomain.SetLanguageCode(const langcode: LanguageString);
begin
CloseMoFile;
curlang := langcode;
end;
function GetPluralForm2EN(Number: Integer): Integer;
begin
Number := abs(Number);
if Number = 1 then
Result := 0
else
Result := 1;
end;
function GetPluralForm1(Number: Integer): Integer;
begin
Result := 0;
end;
function GetPluralForm2FR(Number: Integer): Integer;
begin
Number := abs(Number);
if (Number = 1) or (Number = 0) then
Result := 0
else
Result := 1;
end;
function GetPluralForm3LV(Number: Integer): Integer;
begin
Number := abs(Number);
if (Number mod 10 = 1) and (Number mod 100 <> 11) then
Result := 0
else if Number <> 0 then
Result := 1
else
Result := 2;
end;
function GetPluralForm3GA(Number: Integer): Integer;
begin
Number := abs(Number);
if Number = 1 then
Result := 0
else if Number = 2 then
Result := 1
else
Result := 2;
end;
function GetPluralForm3LT(Number: Integer): Integer;
var
n1, n2: byte;
begin
Number := abs(Number);
n1 := Number mod 10;
n2 := Number mod 100;
if (n1 = 1) and (n2 <> 11) then
Result := 0
else if (n1 >= 2) and ((n2 < 10) or (n2 >= 20)) then
Result := 1
else
Result := 2;
end;
function GetPluralForm3PL(Number: Integer): Integer;
var
n1, n2: byte;
begin
Number := abs(Number);
n1 := Number mod 10;
n2 := Number mod 100;
if Number = 1 then
Result := 0
else if (n1 >= 2) and (n1 <= 4) and ((n2 < 10) or (n2 >= 20)) then
Result := 1
else
Result := 2;
end;
function GetPluralForm3RU(Number: Integer): Integer;
var
n1, n2: byte;
begin
Number := abs(Number);
n1 := Number mod 10;
n2 := Number mod 100;
if (n1 = 1) and (n2 <> 11) then
Result := 0
else if (n1 >= 2) and (n1 <= 4) and ((n2 < 10) or (n2 >= 20)) then
Result := 1
else
Result := 2;
end;
function GetPluralForm3SK(Number: Integer): Integer;
begin
Number := abs(Number);
if Number = 1 then
Result := 0
else if (Number < 5) and (Number <> 0) then
Result := 1
else
Result := 2;
end;
function GetPluralForm4SL(Number: Integer): Integer;
var
n2: byte;
begin
Number := abs(Number);
n2 := Number mod 100;
if n2 = 1 then
Result := 0
else if n2 = 2 then
Result := 1
else if (n2 = 3) or (n2 = 4) then
Result := 2
else
Result := 3;
end;
procedure TDomain.GetListOfLanguages(list: TStrings);
var
sr: TSearchRec;
more: boolean;
filename, path: FilenameString;
langcode: LanguageString;
i, j: Integer;
begin
list.Clear;
// Iterate through filesystem
more := FindFirst(Directory + '*', faAnyFile, sr) = 0;
try
while more do
begin
if (sr.Attr and faDirectory <> 0) and (sr.name <> '.') and (sr.name <> '..') then
begin
filename := Directory + sr.name + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
if FileExists(filename) then
begin
langcode := lowercase(sr.name);
if list.IndexOf(langcode) = -1 then
list.Add(langcode);
end;
end;
more := FindNext(sr) = 0;
end;
finally
FindClose(sr);
end;
// Iterate through embedded files
for i := 0 to FileLocator.filelist.Count - 1 do
begin
filename := FileLocator.basedirectory + FileLocator.filelist.Strings[i];
path := Directory;
{$IFDEF MSWINDOWS}
path := uppercase(path);
filename := uppercase(filename);
{$ENDIF}
j := length(path);
if MidStr(filename, 1, j) = path then
begin
path := PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
{$IFDEF MSWINDOWS}
path := uppercase(path);
{$ENDIF}
if MidStr(filename, length(filename) - length(path) + 1, length(path)) = path then
begin
langcode := lowercase(MidStr(filename, j + 1, length(filename) - length(path) - j));
langcode := LeftStr(langcode, 3) + uppercase(MidStr(langcode, 4, maxint));
if list.IndexOf(langcode) = -1 then
list.Add(langcode);
end;
end;
end;
end;
procedure TDomain.SetFilename(const filename: FilenameString);
begin
CloseMoFile;
vDirectory := '';
SpecificFilename := filename;
end;
function TDomain.gettext(const msgid: RawUtf8String): RawUtf8String;
var
found: boolean;
begin
if not enabled then
begin
Result := msgid;
exit;
end;
if (mofile = nil) and (not OpenHasFailedBefore) then
OpenMoFile;
if mofile = nil then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('.mo file is not open. Not translating "' + msgid + '"');
{$ENDIF}
Result := msgid;
end
else
begin
Result := mofile.gettext(msgid, found);
{$IFDEF DXGETTEXTDEBUG}
if found then
DebugLogger('Found in .mo (' + domain + '): "' + utf8encode(msgid) + '"->"' + utf8encode(Result) + '"')
else
DebugLogger('Translation not found in .mo file (' + domain + ') : "' + utf8encode(msgid) + '"');
{$ENDIF}
end;
end;
constructor TDomain.Create;
begin
inherited Create;
enabled := true;
end;
{ TGnuGettextInstance }
procedure TGnuGettextInstance.bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString);
var
dir: FilenameString;
begin
dir := IncludeTrailingPathDelimiter(szDirectory);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Text domain "' + szDomain + '" is now located at "' + dir + '"');
{$ENDIF}
Getdomain(szDomain, DefaultDomainDirectory, curlang).Directory := dir;
WhenNewDomainDirectory(szDomain, szDirectory);
end;
constructor TGnuGettextInstance.Create;
begin
CreatorThread := GetCurrentThreadId;
{$IFDEF MSWindows}
DesignTimeCodePage := CP_ACP;
{$ENDIF}
{$IFDEF DXGETTEXTDEBUG}
DebugLogCS := TMultiReadExclusiveWriteSynchronizer.Create;
DebugLog := TMemoryStream.Create;
DebugWriteln('Debug log started ' + DateTimeToStr(Now));
DebugWriteln('GNU gettext module version: ' + VCSVersion);
DebugWriteln('');
{$ENDIF}
curGetPluralForm := GetPluralForm2EN;
enabled := true;
curmsgdomain := DefaultTextDomain;
savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;
domainlist := TStringList.Create;
TP_IgnoreList := TStringList.Create;
TP_IgnoreList.Sorted := true;
TP_GlobalClassHandling := TList.Create;
TP_ClassHandling := TList.Create;
// Set some settings
DefaultDomainDirectory := IncludeTrailingPathDelimiter(extractfilepath(ExecutableFilename)) + 'locale';
UseLanguage('');
bindtextdomain(DefaultTextDomain, DefaultDomainDirectory);
textdomain(DefaultTextDomain);
// Add default properties to ignore
TP_GlobalIgnoreClassProperty(TComponent, 'Name');
TP_GlobalIgnoreClassProperty(TCollection, 'PropName');
end;
destructor TGnuGettextInstance.Destroy;
begin
if savememory <> nil then
begin
savefileCS.BeginWrite;
try
CloseFile(savefile);
finally
savefileCS.EndWrite;
end;
FreeAndNil(savememory);
end;
FreeAndNil(savefileCS);
FreeAndNil(TP_IgnoreList);
while TP_GlobalClassHandling.Count <> 0 do
begin
TObject(TP_GlobalClassHandling.Items[0]).Free;
TP_GlobalClassHandling.delete(0);
end;
FreeAndNil(TP_GlobalClassHandling);
FreeTP_ClassHandlingItems;
FreeAndNil(TP_ClassHandling);
while domainlist.Count <> 0 do
begin
domainlist.Objects[0].Free;
domainlist.delete(0);
end;
FreeAndNil(domainlist);
{$IFDEF DXGETTEXTDEBUG}
FreeAndNil(DebugLog);
FreeAndNil(DebugLogCS);
{$ENDIF}
inherited;
end;
{$IFNDEF UNICODE}
function TGnuGettextInstance.dgettext(const szDomain: DomainString; const szMsgId: AnsiString): TranslatedUnicodeString;
begin
Result := dgettext(szDomain, ansi2wideDTCP(szMsgId));
end;
{$ENDIF}
function TGnuGettextInstance.dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;
begin
if not enabled then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Translation has been disabled. Text is not being translated: ' + szMsgId);
{$ENDIF}
Result := szMsgId;
end
else
begin
Result := utf8decode(EnsureLineBreakInTranslatedString(Getdomain(szDomain, DefaultDomainDirectory, curlang)
.gettext(StripCRRawMsgId(utf8encode(szMsgId)))));
{$IFDEF DXGETTEXTDEBUG}
if (szMsgId <> '') and (Result = '') then
DebugWriteln(Format('Error: Translation of %s was an empty string. This may never occur.', [szMsgId]));
{$ENDIF}
end;
end;
function TGnuGettextInstance.dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;
begin
// This one is very useful for translating text in variables.
// This can sometimes be necessary, and by using this function,
// the source code scanner will not trigger warnings.
Result := dgettext(szDomain, szMsgId);
end;
function TGnuGettextInstance.GetCurrentLanguage: LanguageString;
begin
Result := curlang;
end;
function TGnuGettextInstance.getcurrenttextdomain: DomainString;
begin
Result := curmsgdomain;
end;
{$IFNDEF UNICODE}
function TGnuGettextInstance.gettext(const szMsgId: AnsiString): TranslatedUnicodeString;
begin
Result := dgettext(curmsgdomain, szMsgId);
end;
{$ENDIF}
function TGnuGettextInstance.gettext(const szMsgId: MsgIdString): TranslatedUnicodeString;
begin
Result := dgettext(curmsgdomain, szMsgId);
end;
function TGnuGettextInstance.gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString;
begin
// This one is very useful for translating text in variables.
// This can sometimes be necessary, and by using this function,
// the source code scanner will not trigger warnings.
Result := gettext(szMsgId);
end;
procedure TGnuGettextInstance.textdomain(const szDomain: DomainString);
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Changed text domain to "' + szDomain + '"');
{$ENDIF}
curmsgdomain := szDomain;
WhenNewDomain(szDomain);
end;
function TGnuGettextInstance.TP_CreateRetranslator: TExecutable;
var
ttpr: TTP_Retranslator;
begin
ttpr := TTP_Retranslator.Create;
ttpr.Instance := self;
TP_Retranslator := ttpr;
Result := ttpr;
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('A retranslator was created.');
{$ENDIF}
end;
procedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator);
var
cm: TClassMode;
i: Integer;
begin
for i := 0 to TP_GlobalClassHandling.Count - 1 do
begin
cm := TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
if cm.HClass = HClass then
raise EGGProgrammingError.Create('You cannot set a handler for a class that has already been assigned otherwise.');
if HClass.InheritsFrom(cm.HClass) then
begin
// This is the place to insert this class
cm := TClassMode.Create;
cm.HClass := HClass;
cm.SpecialHandler := Handler;
TP_GlobalClassHandling.insert(i, cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('A handler was set for class ' + HClass.ClassName + '.');
{$ENDIF}
exit;
end;
end;
cm := TClassMode.Create;
cm.HClass := HClass;
cm.SpecialHandler := Handler;
TP_GlobalClassHandling.Add(cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('A handler was set for class ' + HClass.ClassName + '.');
{$ENDIF}
end;
procedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass);
var
cm: TClassMode;
i: Integer;
begin
for i := 0 to TP_GlobalClassHandling.Count - 1 do
begin
cm := TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
if cm.HClass = IgnClass then
raise EGGProgrammingError.Create('You cannot add a class to the ignore list that is already on that list: ' + IgnClass.ClassName +
'. You should keep all TP_Global functions in one place in your source code.');
if IgnClass.InheritsFrom(cm.HClass) then
begin
// This is the place to insert this class
cm := TClassMode.Create;
cm.HClass := IgnClass;
TP_GlobalClassHandling.insert(i, cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Globally, class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
exit;
end;
end;
cm := TClassMode.Create;
cm.HClass := IgnClass;
TP_GlobalClassHandling.Add(cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Globally, class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
end;
procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(IgnClass: TClass; propertyname: ComponentNameString);
var
cm: TClassMode;
i, idx: Integer;
begin
propertyname := uppercase(propertyname);
for i := 0 to TP_GlobalClassHandling.Count - 1 do
begin
cm := TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
if cm.HClass = IgnClass then
begin
if Assigned(cm.SpecialHandler) then
raise EGGProgrammingError.Create('You cannot ignore a class property for a class that has a handler set.');
if not cm.PropertiesToIgnore.Find(propertyname, idx) then
cm.PropertiesToIgnore.Add(propertyname);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Globally, the ' + propertyname + ' property of class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
exit;
end;
if IgnClass.InheritsFrom(cm.HClass) then
begin
// This is the place to insert this class
cm := TClassMode.Create;
cm.HClass := IgnClass;
cm.PropertiesToIgnore.Add(propertyname);
TP_GlobalClassHandling.insert(i, cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Globally, the ' + propertyname + ' property of class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
exit;
end;
end;
cm := TClassMode.Create;
cm.HClass := IgnClass;
cm.PropertiesToIgnore.Add(propertyname);
TP_GlobalClassHandling.Add(cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Globally, the ' + propertyname + ' property of class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
end;
procedure TGnuGettextInstance.TP_Ignore(AnObject: TObject; const name: ComponentNameString);
begin
TP_IgnoreList.Add(uppercase(name));
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('On object with class name ' + AnObject.ClassName + ', ignore is set on ' + name);
{$ENDIF}
end;
procedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent; const textdomain: DomainString);
var
comp: TGnuGettextComponentMarker;
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('======================================================================');
DebugWriteln('TranslateComponent() was called for a component with name ' + AnObject.name + '.');
{$ENDIF}
comp := AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
if comp = nil then
begin
comp := TGnuGettextComponentMarker.Create(nil);
comp.name := 'GNUgettextMarker';
comp.Retranslator := TP_CreateRetranslator;
TranslateProperties(AnObject, textdomain);
AnObject.InsertComponent(comp);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln
('This is the first time, that this component has been translated. A retranslator component has been created for this component.');
{$ENDIF}
end
else
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('This is not the first time, that this component has been translated.');
{$ENDIF}
if comp.LastLanguage <> curlang then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln
('ERROR: TranslateComponent() was called twice with different languages. This indicates an attempt to switch language at runtime, but by using TranslateComponent every time. This API has changed - please use RetranslateComponent() instead.');
{$ENDIF}
{$IFDEF mswindows}
MessageBox(0,
'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.',
'Error', MB_OK);
{$ELSE}
writeln(stderr,
'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.');
{$ENDIF}
end
else
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln
('ERROR: TranslateComponent has been called twice, but with the same language chosen. This is a mistake, but in order to prevent that the application breaks, no exception is raised.');
{$ENDIF}
end;
end;
comp.LastLanguage := curlang;
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('======================================================================');
{$ENDIF}
end;
procedure TGnuGettextInstance.TranslateProperty(AnObject: TObject; PropInfo: PPropInfo; TodoList: TStrings; const textdomain: DomainString);
var
ppi: PPropInfo;
ws: TranslatedUnicodeString;
old: TranslatedUnicodeString;
compmarker: TComponent;
obj: TObject;
Propname: ComponentNameString;
begin
Propname := string(PropInfo^.name);
try
// Translate certain types of properties
case PropInfo^.PropType^.Kind of
{$IFDEF UNICODE}
// All dfm files returning tkUString
tkString, tkLString, tkWString, tkUString:
{$ELSE}
tkString, tkLString, tkWString:
{$ENDIF}
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Translating ' + AnObject.ClassName + '.' + Propname);
{$ENDIF}
case PropInfo^.PropType^.Kind of
tkString, tkLString:
old := GetStrProp(AnObject, Propname);
tkWString:
old := GetWideStrProp(AnObject, Propname);
{$IFDEF UNICODE}
tkUString:
old := GetUnicodeStrProp(AnObject, Propname);
{$ENDIF}
else
raise Exception.Create
('Internal error: Illegal property type. This problem needs to be solved by a programmer, try to find a workaround.');
end;
{$IFDEF DXGETTEXTDEBUG}
if old = '' then
DebugWriteln('(Empty, not translated)')
else
DebugWriteln('Old value: "' + old + '"');
{$ENDIF}
if (old <> '') and (IsWriteProp(PropInfo)) then
begin
if TP_Retranslator <> nil then
(TP_Retranslator as TTP_Retranslator).Remember(AnObject, Propname, old);
ws := dgettext(textdomain, old);
if ws <> old then
begin
ppi := GetPropInfo(AnObject, Propname);
if ppi <> nil then
begin
SetWideStrProp(AnObject, ppi, ws);
end
else
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('ERROR: Property disappeared: ' + Propname + ' for object of type ' + AnObject.ClassName);
{$ENDIF}
end;
end;
end;
end { case item };
tkClass:
begin
obj := GetObjectProp(AnObject, Propname);
if obj <> nil then
begin
if obj is TComponent then
begin
compmarker := TComponent(obj).FindComponent('GNUgettextMarker');
if Assigned(compmarker) then
exit;
end;
TodoList.AddObject('', obj);
end;
end { case item };
end { case };
except
on E: Exception do
raise EGGComponentError.Create('Property cannot be translated.' + sLinebreak + 'Add TP_GlobalIgnoreClassProperty(' + AnObject.ClassName +
',''' + Propname + ''') to your source code or use' + sLinebreak + 'TP_Ignore (self,''.' + Propname + ''') to prevent this message.' +
sLinebreak + 'Reason: ' + E.Message);
end;
end;
procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; textdomain: DomainString = '');
var
TodoList: TStringList; // List of Name/TObject's that is to be processed
DoneList: TStringList;
// List of hex codes representing pointers to objects that have been done
i, j, Count: Integer;
PropList: PPropList;
UPropName: ComponentNameString;
PropInfo: PPropInfo;
compmarker, comp: TComponent;
cm, currentcm: TClassMode;
// currentcm is nil or contains special information about how to handle the current object
ObjectPropertyIgnoreList: TStringList;
objid: string;
name: ComponentNameString;
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('----------------------------------------------------------------------');
DebugWriteln('TranslateProperties() was called for an object of class ' + AnObject.ClassName + ' with domain "' + textdomain + '".');
{$ENDIF}
if textdomain = '' then
textdomain := curmsgdomain;
if TP_Retranslator <> nil then
(TP_Retranslator as TTP_Retranslator).textdomain := textdomain;
{$IFDEF FPC}
DoneList := TCSStringList.Create;
TodoList := TCSStringList.Create;
ObjectPropertyIgnoreList := TCSStringList.Create;
{$ELSE}
DoneList := TStringList.Create;
TodoList := TStringList.Create;
ObjectPropertyIgnoreList := TStringList.Create;
{$ENDIF}
try
TodoList.AddObject('', AnObject);
DoneList.Sorted := true;
ObjectPropertyIgnoreList.Sorted := true;
ObjectPropertyIgnoreList.Duplicates := dupIgnore;
ObjectPropertyIgnoreList.CaseSensitive := false;
DoneList.Duplicates := dupError;
DoneList.CaseSensitive := true;
while TodoList.Count <> 0 do
begin
AnObject := TodoList.Objects[0];
Name := TodoList.Strings[0];
TodoList.delete(0);
if (AnObject <> nil) and (AnObject is TPersistent) then
begin
// Make sure each object is only translated once
Assert(SizeOf(Integer) = SizeOf(TObject));
objid := IntToHex(Integer(AnObject), 8);
if DoneList.Find(objid, i) then
begin
continue;
end
else
begin
DoneList.Add(objid);
end;
ObjectPropertyIgnoreList.Clear;
// Find out if there is special handling of this object
currentcm := nil;
// First check the local handling instructions
for j := 0 to TP_ClassHandling.Count - 1 do
begin
cm := TObject(TP_ClassHandling.Items[j]) as TClassMode;
if AnObject.InheritsFrom(cm.HClass) then
begin
if cm.PropertiesToIgnore.Count <> 0 then
begin
ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);
end
else
begin
// Ignore the entire class
currentcm := cm;
break;
end;
end;
end;
// Then check the global handling instructions
if currentcm = nil then
for j := 0 to TP_GlobalClassHandling.Count - 1 do
begin
cm := TObject(TP_GlobalClassHandling.Items[j]) as TClassMode;
if AnObject.InheritsFrom(cm.HClass) then
begin
if cm.PropertiesToIgnore.Count <> 0 then
begin
ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);
end
else
begin
// Ignore the entire class
currentcm := cm;
break;
end;
end;
end;
if currentcm <> nil then
begin
ObjectPropertyIgnoreList.Clear;
// Ignore or use special handler
if Assigned(currentcm.SpecialHandler) then
begin
currentcm.SpecialHandler(AnObject);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Special handler activated for ' + AnObject.ClassName);
{$ENDIF}
end
else
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Ignoring object ' + AnObject.ClassName);
{$ENDIF}
end;
continue;
end;
Count := GetPropList(AnObject, PropList);
try
for j := 0 to Count - 1 do
begin
PropInfo := PropList[j];
{$IFDEF UNICODE}
if not(PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString, tkClass, tkUString]) then
{$ELSE}
if not(PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString, tkClass]) then
{$ENDIF}
continue;
UPropName := uppercase(string(PropInfo^.name));
// Ignore properties that are meant to be ignored
if ((currentcm = nil) or (not currentcm.PropertiesToIgnore.Find(UPropName, i))) and
(not TP_IgnoreList.Find(Name + '.' + UPropName, i)) and (not ObjectPropertyIgnoreList.Find(UPropName, i)) then
begin
TranslateProperty(AnObject, PropInfo, TodoList, textdomain);
end; // if
end; // for
finally
if Count <> 0 then
FreeMem(PropList);
end;
if AnObject is TStrings then
begin
if ((AnObject as TStrings).Text <> '') and (TP_Retranslator <> nil) then
(TP_Retranslator as TTP_Retranslator).Remember(AnObject, 'Text', (AnObject as TStrings).Text);
TranslateStrings(AnObject as TStrings, textdomain);
end;
// Check for TCollection
if AnObject is TCollection then
begin
for i := 0 to (AnObject as TCollection).Count - 1 do
begin
// Only add the object if it's not totally ignored already
if not Assigned(currentcm) or not AnObject.InheritsFrom(currentcm.HClass) then
TodoList.AddObject('', (AnObject as TCollection).Items[i]);
end;
end;
if AnObject is TComponent then
begin
for i := 0 to TComponent(AnObject).ComponentCount - 1 do
begin
comp := TComponent(AnObject).Components[i];
if (not TP_IgnoreList.Find(uppercase(comp.name), j)) then
begin
// Only add the object if it's not totally ignored or translated already
if not Assigned(currentcm) or not AnObject.InheritsFrom(currentcm.HClass) then
begin
compmarker := comp.FindComponent('GNUgettextMarker');
if not Assigned(compmarker) then
TodoList.AddObject(uppercase(comp.name), comp);
end;
end;
end;
end;
end { if AnObject<>nil };
end { while todolist.count<>0 };
finally
FreeAndNil(TodoList);
FreeAndNil(ObjectPropertyIgnoreList);
FreeAndNil(DoneList);
end;
FreeTP_ClassHandlingItems;
TP_IgnoreList.Clear;
TP_Retranslator := nil;
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('----------------------------------------------------------------------');
{$ENDIF}
end;
procedure TGnuGettextInstance.UseLanguage(LanguageCode: LanguageString);
var
i, p: Integer;
dom: TDomain;
l2: string;
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('UseLanguage(''' + LanguageCode + '''); called');
{$ENDIF}
if LanguageCode = '' then
begin
LanguageCode := GGGetEnvironmentVariable('LANG');
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('LANG env variable is ''' + LanguageCode + '''.');
{$ENDIF}
{$IFDEF MSWINDOWS}
if LanguageCode = '' then
begin
LanguageCode := GetWindowsLanguage;
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Found Windows language code to be ''' + LanguageCode + '''.');
{$ENDIF}
end;
{$ENDIF}
p := pos('.', LanguageCode);
if p <> 0 then
LanguageCode := LeftStr(LanguageCode, p - 1);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Language code that will be set is ''' + LanguageCode + '''.');
{$ENDIF}
end;
curlang := LanguageCode;
for i := 0 to domainlist.Count - 1 do
begin
dom := domainlist.Objects[i] as TDomain;
dom.SetLanguageCode(curlang);
end;
l2 := lowercase(LeftStr(curlang, 2));
if (l2 = 'en') or (l2 = 'de') then
curGetPluralForm := GetPluralForm2EN
else if (l2 = 'hu') or (l2 = 'ko') or (l2 = 'zh') or (l2 = 'ja') or (l2 = 'tr') then
curGetPluralForm := GetPluralForm1
else if (l2 = 'fr') or (l2 = 'fa') or (lowercase(curlang) = 'pt_br') then
curGetPluralForm := GetPluralForm2FR
else if (l2 = 'lv') then
curGetPluralForm := GetPluralForm3LV
else if (l2 = 'ga') then
curGetPluralForm := GetPluralForm3GA
else if (l2 = 'lt') then
curGetPluralForm := GetPluralForm3LT
else if (l2 = 'ru') or (l2 = 'uk') or (l2 = 'hr') then
curGetPluralForm := GetPluralForm3RU
else if (l2 = 'cs') or (l2 = 'sk') then
curGetPluralForm := GetPluralForm3SK
else if (l2 = 'pl') then
curGetPluralForm := GetPluralForm3PL
else if (l2 = 'sl') then
curGetPluralForm := GetPluralForm4SL
else
begin
curGetPluralForm := GetPluralForm2EN;
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Plural form for the language was not found. English plurality system assumed.');
{$ENDIF}
end;
WhenNewLanguage(curlang);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('');
{$ENDIF}
end;
procedure TGnuGettextInstance.TranslateStrings(sl: TStrings; const textdomain: DomainString);
var
Line: string;
i: Integer;
s: TStringList;
begin
if sl.Count > 0 then
begin
sl.BeginUpdate;
try
s := TStringList.Create;
try
s.Assign(sl);
for i := 0 to s.Count - 1 do
begin
Line := s.Strings[i];
if Line <> '' then
s.Strings[i] := dgettext(textdomain, Line);
end;
sl.Assign(s);
finally
FreeAndNil(s);
end;
finally
sl.EndUpdate;
end;
end;
end;
function TGnuGettextInstance.GetTranslatorNameAndEmail: TranslatedUnicodeString;
begin
Result := GetTranslationProperty('LAST-TRANSLATOR');
end;
function TGnuGettextInstance.GetTranslationProperty(const propertyname: ComponentNameString): TranslatedUnicodeString;
begin
Result := Getdomain(curmsgdomain, DefaultDomainDirectory, curlang).GetTranslationProperty(propertyname);
end;
function TGnuGettextInstance.dngettext(const szDomain: DomainString; const singular, plural: MsgIdString; Number: Integer)
: TranslatedUnicodeString;
var
org: MsgIdString;
trans: TranslatedUnicodeString;
idx: Integer;
p: Integer;
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('dngettext translation (domain ' + szDomain + ', number is ' + IntToStr(Number) + ') of ' + singular + '/' + plural);
{$ENDIF}
org := singular + #0 + plural;
trans := dgettext(szDomain, org);
if org = trans then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Translation was equal to english version. English plural forms assumed.');
{$ENDIF}
idx := GetPluralForm2EN(Number)
end
else
idx := curGetPluralForm(Number);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Index ' + IntToStr(idx) + ' will be used');
{$ENDIF}
while true do
begin
p := pos(#0, trans);
if p = 0 then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Last translation used: ' + utf8encode(trans));
{$ENDIF}
Result := trans;
exit;
end;
if idx = 0 then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Translation found: ' + utf8encode(trans));
{$ENDIF}
Result := LeftStr(trans, p - 1);
exit;
end;
delete(trans, 1, p);
dec(idx);
end;
end;
function TGnuGettextInstance.dngettext_NoExtract(const szDomain: DomainString; const singular, plural: MsgIdString; Number: Integer)
: TranslatedUnicodeString;
begin
// This one is very useful for translating text in variables.
// This can sometimes be necessary, and by using this function,
// the source code scanner will not trigger warnings.
Result := dngettext(szDomain, singular, plural, Number);
end;
{$IFNDEF UNICODE}
function TGnuGettextInstance.ngettext(const singular, plural: AnsiString; Number: Integer): TranslatedUnicodeString;
begin
Result := dngettext(curmsgdomain, singular, plural, Number);
end;
{$ENDIF}
function TGnuGettextInstance.ngettext(const singular, plural: MsgIdString; Number: Integer): TranslatedUnicodeString;
begin
Result := dngettext(curmsgdomain, singular, plural, Number);
end;
function TGnuGettextInstance.ngettext_NoExtract(const singular, plural: MsgIdString; Number: Integer): TranslatedUnicodeString;
begin
// This one is very useful for translating text in variables.
// This can sometimes be necessary, and by using this function,
// the source code scanner will not trigger warnings.
Result := ngettext(singular, plural, Number);
end;
procedure TGnuGettextInstance.WhenNewDomain(const textdomain: DomainString);
begin
// This is meant to be empty.
end;
procedure TGnuGettextInstance.WhenNewLanguage(const LanguageID: LanguageString);
begin
// This is meant to be empty.
end;
procedure TGnuGettextInstance.WhenNewDomainDirectory(const textdomain: DomainString; const Directory: FilenameString);
begin
// This is meant to be empty.
end;
procedure TGnuGettextInstance.GetListOfLanguages(const domain: DomainString; list: TStrings);
begin
Getdomain(domain, DefaultDomainDirectory, curlang).GetListOfLanguages(list);
end;
procedure TGnuGettextInstance.bindtextdomainToFile(const szDomain: DomainString; const filename: FilenameString);
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Text domain "' + szDomain + '" is now bound to file named "' + filename + '"');
{$ENDIF}
Getdomain(szDomain, DefaultDomainDirectory, curlang).SetFilename(filename);
end;
procedure TGnuGettextInstance.DebugLogPause(PauseEnabled: boolean);
begin
{$IFDEF DXGETTEXTDEBUG}
DebugLogOutputPaused := PauseEnabled;
{$ENDIF}
end;
procedure TGnuGettextInstance.DebugLogToFile(const filename: FilenameString; append: boolean = false);
{$IFDEF DXGETTEXTDEBUG}
var
fs: TFileStream;
marker: AnsiString;
{$ENDIF}
begin
{$IFDEF DXGETTEXTDEBUG}
// Create the file if needed
if (not FileExists(filename)) or (not append) then
fileclose(filecreate(filename));
// Open file
fs := TFileStream.Create(filename, fmOpenWrite or fmShareDenyWrite);
if append then
fs.Seek(0, soFromEnd);
// Write header if appending
if fs.Position <> 0 then
begin
marker := sLinebreak + '===========================================================================' + sLinebreak;
fs.WriteBuffer(marker[1], length(marker));
end;
// Copy the memorystream contents to the file
DebugLog.Seek(0, soFromBeginning);
fs.CopyFrom(DebugLog, 0);
// Make DebugLog point to the filestream
FreeAndNil(DebugLog);
DebugLog := fs;
{$ENDIF}
end;
{$IFDEF DXGETTEXTDEBUG}
procedure TGnuGettextInstance.DebugWriteln(Line: AnsiString);
Var
Discard: boolean;
begin
Assert(DebugLogCS <> nil);
Assert(DebugLog <> nil);
DebugLogCS.BeginWrite;
try
if DebugLogOutputPaused then
exit;
if Assigned(fOnDebugLine) then
begin
Discard := true;
fOnDebugLine(self, Line, Discard);
If Discard then
exit;
end;
Line := Line + sLinebreak;
// Ensure that memory usage doesn't get too big.
if (DebugLog is TMemoryStream) and (DebugLog.Position > 1000000) then
begin
Line := sLinebreak + sLinebreak + sLinebreak + sLinebreak + sLinebreak + 'Debug log halted because memory usage grew too much.' +
sLinebreak + 'Specify a filename to store the debug log in or disable debug loggin in gnugettext.pas.' + sLinebreak + sLinebreak +
sLinebreak + sLinebreak + sLinebreak;
DebugLogOutputPaused := true;
end;
DebugLog.WriteBuffer(Line[1], length(Line));
finally
DebugLogCS.EndWrite;
end;
end;
{$ENDIF}
function TGnuGettextInstance.Getdomain(const domain: DomainString; const DefaultDomainDirectory: FilenameString;
const curlang: LanguageString): TDomain;
// Retrieves the TDomain object for the specified domain.
// Creates one, if none there, yet.
var
idx: Integer;
begin
idx := domainlist.IndexOf(domain);
if idx = -1 then
begin
Result := TDomain.Create;
{$IFDEF DXGETTEXTDEBUG}
Result.DebugLogger := DebugWriteln;
{$ENDIF}
Result.domain := domain;
Result.Directory := DefaultDomainDirectory;
Result.SetLanguageCode(curlang);
domainlist.AddObject(domain, Result);
end
else
begin
Result := domainlist.Objects[idx] as TDomain;
end;
end;
function TGnuGettextInstance.LoadResString(ResStringRec: PResStringRec): UnicodeString;
{$IFDEF MSWINDOWS}
var
Len: Integer;
{$IFDEF UNICODE}
Buffer: array [0 .. 1023] of widechar;
{$ELSE}
Buffer: array [0 .. 1023] of ansichar;
{$ENDIF}
{$ENDIF}
{$IFDEF LINUX }
const
ResStringTableLen = 16;
type
ResStringTable = array [0 .. ResStringTableLen - 1] of LongWord;
var
Handle: TResourceHandle;
Tab: ^ResStringTable;
ResMod: HModule;
{$ENDIF }
begin
if ResStringRec = nil then
exit;
if ResStringRec.Identifier >= 64 * 1024 then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('LoadResString was given an invalid ResStringRec.Identifier');
{$ENDIF}
Result := 'ERROR';
exit;
end
else
begin
{$IFDEF LINUX}
// This works with Unicode if the Linux has utf-8 character set
// Result:=System.LoadResString(ResStringRec);
ResMod := FindResourceHInstance(ResStringRec^.Module^);
Handle := FindResource(ResMod, PAnsiChar(ResStringRec^.Identifier div ResStringTableLen), PAnsiChar(6)); // RT_STRING
Tab := pointer(LoadResource(ResMod, Handle));
if Tab = nil then
Result := ''
else
Result := PWideChar(PAnsiChar(Tab) + Tab[ResStringRec^.Identifier mod ResStringTableLen]);
{$ENDIF}
{$IFDEF MSWINDOWS}
if not Win32PlatformIsUnicode then
begin
SetString(Result, Buffer, LoadString(FindResourceHInstance(ResStringRec.Module^), ResStringRec.Identifier, Buffer, SizeOf(Buffer)))
end
else
begin
Result := '';
Len := 0;
While length(Result) <= Len + 1 do
begin
if length(Result) = 0 then
SetLength(Result, 1024)
else
SetLength(Result, length(Result) * 2);
Len := LoadStringW(FindResourceHInstance(ResStringRec.Module^), ResStringRec.Identifier, PWideChar(Result), length(Result));
end;
SetLength(Result, Len);
end;
{$ENDIF}
end;
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Loaded resourcestring: ' + utf8encode(Result));
{$ENDIF}
if CreatorThread <> GetCurrentThreadId then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('LoadResString was called from an invalid thread. Resourcestring was not translated.');
{$ENDIF}
end
else
Result := ResourceStringGettext(Result);
end;
procedure TGnuGettextInstance.RetranslateComponent(AnObject: TComponent; const textdomain: DomainString);
var
comp: TGnuGettextComponentMarker;
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('======================================================================');
DebugWriteln('RetranslateComponent() was called for a component with name ' + AnObject.name + '.');
{$ENDIF}
comp := AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
if comp = nil then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Retranslate was called on an object that has not been translated before. An Exception is being raised.');
{$ENDIF}
raise EGGProgrammingError.Create
('Retranslate was called on an object that has not been translated before. Please use TranslateComponent() before RetranslateComponent().');
end
else
begin
if comp.LastLanguage <> curlang then
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('The retranslator is being executed.');
{$ENDIF}
comp.Retranslator.Execute;
end
else
begin
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('The language has not changed. The retranslator is not executed.');
{$ENDIF}
end;
end;
comp.LastLanguage := curlang;
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('======================================================================');
{$ENDIF}
end;
procedure TGnuGettextInstance.TP_IgnoreClass(IgnClass: TClass);
var
cm: TClassMode;
i: Integer;
begin
for i := 0 to TP_ClassHandling.Count - 1 do
begin
cm := TObject(TP_ClassHandling.Items[i]) as TClassMode;
if cm.HClass = IgnClass then
raise EGGProgrammingError.Create('You cannot add a class to the ignore list that is already on that list: ' + IgnClass.ClassName + '.');
if IgnClass.InheritsFrom(cm.HClass) then
begin
// This is the place to insert this class
cm := TClassMode.Create;
cm.HClass := IgnClass;
TP_ClassHandling.insert(i, cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Locally, class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
exit;
end;
end;
cm := TClassMode.Create;
cm.HClass := IgnClass;
TP_ClassHandling.Add(cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Locally, class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
end;
procedure TGnuGettextInstance.TP_IgnoreClassProperty(IgnClass: TClass; propertyname: ComponentNameString);
var
cm: TClassMode;
i: Integer;
begin
propertyname := uppercase(propertyname);
for i := 0 to TP_ClassHandling.Count - 1 do
begin
cm := TObject(TP_ClassHandling.Items[i]) as TClassMode;
if cm.HClass = IgnClass then
begin
if Assigned(cm.SpecialHandler) then
raise EGGProgrammingError.Create('You cannot ignore a class property for a class that has a handler set.');
cm.PropertiesToIgnore.Add(propertyname);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Globally, the ' + propertyname + ' property of class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
exit;
end;
if IgnClass.InheritsFrom(cm.HClass) then
begin
// This is the place to insert this class
cm := TClassMode.Create;
cm.HClass := IgnClass;
cm.PropertiesToIgnore.Add(propertyname);
TP_ClassHandling.insert(i, cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Locally, the ' + propertyname + ' property of class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
exit;
end;
end;
cm := TClassMode.Create;
cm.HClass := IgnClass;
cm.PropertiesToIgnore.Add(propertyname);
TP_GlobalClassHandling.Add(cm);
{$IFDEF DXGETTEXTDEBUG}
DebugWriteln('Locally, the ' + propertyname + ' property of class ' + IgnClass.ClassName + ' is being ignored.');
{$ENDIF}
end;
procedure TGnuGettextInstance.FreeTP_ClassHandlingItems;
begin
while TP_ClassHandling.Count <> 0 do
begin
TObject(TP_ClassHandling.Items[0]).Free;
TP_ClassHandling.delete(0);
end;
end;
{$IFNDEF UNICODE}
function TGnuGettextInstance.ansi2wideDTCP(const s: AnsiString): MsgIdString;
{$IFDEF MSWindows}
var
Len: Integer;
{$ENDIF}
begin
{$IFDEF MSWindows}
if DesignTimeCodePage = CP_ACP then
begin
// No design-time codepage specified. Using runtime codepage instead.
{$ENDIF}
Result := s;
{$IFDEF MSWindows}
end
else
begin
Len := length(s);
if Len = 0 then
Result := ''
else
begin
SetLength(Result, Len);
Len := MultiByteToWideChar(DesignTimeCodePage, 0, PAnsiChar(s), Len, PWideChar(Result), Len);
if Len = 0 then
raise EGGAnsi2WideConvError.Create('Cannot convert string to widestring:' + sLinebreak + s);
SetLength(Result, Len);
end;
end;
{$ENDIF}
end;
{$ENDIF}
{$IFNDEF UNICODE}
function TGnuGettextInstance.dngettext(const szDomain: DomainString; const singular, plural: AnsiString; Number: Integer)
: TranslatedUnicodeString;
begin
Result := dngettext(szDomain, ansi2wideDTCP(singular), ansi2wideDTCP(plural), Number);
end;
{$ENDIF}
{ TClassMode }
constructor TClassMode.Create;
begin
PropertiesToIgnore := TStringList.Create;
PropertiesToIgnore.Sorted := true;
PropertiesToIgnore.Duplicates := dupError;
PropertiesToIgnore.CaseSensitive := false;
end;
destructor TClassMode.Destroy;
begin
FreeAndNil(PropertiesToIgnore);
inherited;
end;
{ TFileLocator }
procedure TFileLocator.Analyze;
var
s: RawByteString;
i: Integer;
Offset: int64;
fs: TFileStream;
fi: TEmbeddedFileInfo;
filename: FilenameString;
filename8bit: RawByteString;
const
arrch: array [0 .. 43] of ansichar = '6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0;
begin
// Copy byte by byte, compatible with Delphi 2009 and older
SetLength(s, high(arrch) - low(arrch) + 1);
for i := 0 to 43 do
s[i + 1] := arrch[i];
s := MidStr(s, length(s) - 7, 8);
Offset := 0;
for i := 8 downto 1 do
Offset := Offset shl 8 + ord(s[i]);
if Offset = 0 then
exit;
basedirectory := extractfilepath(ExecutableFilename);
try
fs := TFileStream.Create(ExecutableFilename, fmOpenRead or fmShareDenyNone);
try
while true do
begin
fs.Seek(Offset, soFromBeginning);
Offset := ReadInt64(fs);
if Offset = 0 then
exit;
fi := TEmbeddedFileInfo.Create;
try
fi.Offset := ReadInt64(fs);
fi.Size := ReadInt64(fs);
SetLength(filename8bit, Offset - fs.Position);
fs.ReadBuffer(filename8bit[1], Offset - fs.Position);
filename := trim(utf8decode(filename8bit));
if PreferExternal and SysUtils.FileExists(basedirectory + filename) then
begin
// Disregard the internal version and use the external version instead
FreeAndNil(fi);
end
else
filelist.AddObject(filename, fi);
except
FreeAndNil(fi);
raise;
end;
end;
finally
FreeAndNil(fs);
end;
except
{$IFDEF DXGETTEXTDEBUG}
raise;
{$ENDIF}
end;
end;
constructor TFileLocator.Create;
begin
MoFilesCS := TMultiReadExclusiveWriteSynchronizer.Create;
MoFiles := TStringList.Create;
filelist := TStringList.Create;
{$IFDEF LINUX}
filelist.Duplicates := dupError;
filelist.CaseSensitive := true;
{$ENDIF}
MoFiles.Sorted := true;
MoFiles.Duplicates := dupError;
MoFiles.CaseSensitive := false;
{$IFDEF MSWINDOWS}
filelist.Duplicates := dupError;
filelist.CaseSensitive := false;
{$ENDIF}
filelist.Sorted := true;
end;
destructor TFileLocator.Destroy;
begin
while filelist.Count <> 0 do
begin
filelist.Objects[0].Free;
filelist.delete(0);
end;
FreeAndNil(filelist);
FreeAndNil(MoFiles);
FreeAndNil(MoFilesCS);
inherited;
end;
function TFileLocator.FileExists(filename: FilenameString): boolean;
var
idx: Integer;
begin
if LeftStr(filename, length(basedirectory)) = basedirectory then
begin
// Cut off basedirectory if the file is located beneath that base directory
filename := MidStr(filename, length(basedirectory) + 1, maxint);
end;
Result := filelist.Find(filename, idx);
end;
function TFileLocator.GetMoFile(filename: FilenameString; DebugLogger: TDebugLogger): TMoFile;
var
fi: TEmbeddedFileInfo;
idx: Integer;
idxname: FilenameString;
Offset, Size: int64;
realfilename: FilenameString;
begin
// Find real filename
Offset := 0;
Size := 0;
realfilename := filename;
if LeftStr(filename, length(basedirectory)) = basedirectory then
begin
filename := MidStr(filename, length(basedirectory) + 1, maxint);
idx := filelist.IndexOf(filename);
if idx <> -1 then
begin
fi := filelist.Objects[idx] as TEmbeddedFileInfo;
realfilename := ExecutableFilename;
Offset := fi.Offset;
Size := fi.Size;
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('Instead of ' + filename + ', using ' + realfilename + ' from offset ' + IntToStr(Offset) + ', size ' + IntToStr(Size));
{$ENDIF}
end;
end;
{$IFDEF DXGETTEXTDEBUG}
DebugLogger('Reading .mo data from file ''' + filename + '''');
{$ENDIF}
// Find TMoFile object
MoFilesCS.BeginWrite;
try
idxname := realfilename + ' //\\ ' + IntToStr(Offset);
if MoFiles.Find(idxname, idx) then
begin
Result := MoFiles.Objects[idx] as TMoFile;
end
else
begin
Result := TMoFile.Create(realfilename, Offset, Size);
MoFiles.AddObject(idxname, Result);
end;
inc(Result.Users);
finally
MoFilesCS.EndWrite;
end;
end;
function TFileLocator.ReadInt64(str: TStream): int64;
begin
Assert(SizeOf(Result) = 8);
str.ReadBuffer(Result, 8);
end;
procedure TFileLocator.ReleaseMoFile(mofile: TMoFile);
var
i: Integer;
begin
Assert(mofile <> nil);
MoFilesCS.BeginWrite;
try
dec(mofile.Users);
if mofile.Users <= 0 then
begin
i := MoFiles.Count - 1;
while i >= 0 do
begin
if MoFiles.Objects[i] = mofile then
begin
MoFiles.delete(i);
FreeAndNil(mofile);
break;
end;
dec(i);
end;
end;
finally
MoFilesCS.EndWrite;
end;
end;
{ TTP_Retranslator }
constructor TTP_Retranslator.Create;
begin
list := TList.Create;
end;
destructor TTP_Retranslator.Destroy;
var
i: Integer;
begin
for i := 0 to list.Count - 1 do
TObject(list.Items[i]).Free;
FreeAndNil(list);
inherited;
end;
procedure TTP_Retranslator.Execute;
var
i: Integer;
sl: TStrings;
item: TTP_RetranslatorItem;
newvalue: TranslatedUnicodeString;
comp: TGnuGettextComponentMarker;
ppi: PPropInfo;
begin
for i := 0 to list.Count - 1 do
begin
item := TObject(list.Items[i]) as TTP_RetranslatorItem;
if item.obj is TComponent then
begin
comp := TComponent(item.obj).FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
if Assigned(comp) and (self <> comp.Retranslator) then
begin
comp.Retranslator.Execute;
continue;
end;
end;
if item.obj is TStrings then
begin
// Since we don't know the order of items in sl, and don't have
// the original .Objects[] anywhere, we cannot anticipate anything
// about the current sl.Strings[] and sl.Objects[] values. We therefore
// have to discard both values. We can, however, set the original .Strings[]
// value into the list and retranslate that.
sl := TStringList.Create;
try
sl.Text := item.OldValue;
Instance.TranslateStrings(sl, textdomain);
(item.obj as TStrings).BeginUpdate;
try
(item.obj as TStrings).Text := sl.Text;
finally
(item.obj as TStrings).EndUpdate;
end;
finally
FreeAndNil(sl);
end;
end
else
begin
newvalue := Instance.dgettext(textdomain, item.OldValue);
ppi := GetPropInfo(item.obj, item.Propname);
if ppi <> nil then
begin
SetWideStrProp(item.obj, ppi, newvalue);
end
else
begin
{$IFDEF DXGETTEXTDEBUG}
Instance.DebugWriteln('ERROR: On retranslation, property disappeared: ' + item.Propname + ' for object of type ' + item.obj.ClassName);
{$ENDIF}
end;
end;
end;
end;
procedure TTP_Retranslator.Remember(obj: TObject; Propname: ComponentNameString; OldValue: TranslatedUnicodeString);
var
item: TTP_RetranslatorItem;
begin
item := TTP_RetranslatorItem.Create;
item.obj := obj;
item.Propname := Propname;
item.OldValue := OldValue;
list.Add(item);
end;
{ TGnuGettextComponentMarker }
destructor TGnuGettextComponentMarker.Destroy;
begin
FreeAndNil(Retranslator);
inherited;
end;
{ THook }
constructor THook.Create(OldProcedure, NewProcedure: pointer; FollowJump: boolean = false);
{ Idea and original code from Igor Siticov }
{ Modified by Jacques Garcia Vazquez and Lars Dybdahl }
begin
{$IFNDEF CPU386}
raise Exception.Create('This procedure only works on Intel i386 compatible processors.');
{$ENDIF}
oldproc := OldProcedure;
newproc := NewProcedure;
Reset(FollowJump);
end;
destructor THook.Destroy;
begin
Shutdown;
inherited;
end;
procedure THook.Disable;
begin
Assert(PatchPosition <> nil, 'Patch position in THook was nil when Disable was called');
PatchPosition[0] := Original[0];
PatchPosition[1] := Original[1];
PatchPosition[2] := Original[2];
PatchPosition[3] := Original[3];
PatchPosition[4] := Original[4];
end;
procedure THook.Enable;
begin
Assert(PatchPosition <> nil, 'Patch position in THook was nil when Enable was called');
PatchPosition[0] := Patch[0];
PatchPosition[1] := Patch[1];
PatchPosition[2] := Patch[2];
PatchPosition[3] := Patch[3];
PatchPosition[4] := Patch[4];
end;
procedure THook.Reset(FollowJump: boolean);
var
Offset: Integer;
{$IFDEF LINUX}
p: pointer;
pagesize: Integer;
{$ENDIF}
{$IFDEF MSWindows}
ov: Cardinal;
{$ENDIF}
begin
if PatchPosition <> nil then
Shutdown;
PatchPosition := oldproc;
if FollowJump and (Word(oldproc^) = $25FF) then
begin
// This finds the correct procedure if a virtual jump has been inserted
// at the procedure address
inc(Integer(PatchPosition), 2); // skip the jump
PatchPosition := PAnsiChar(pointer(pointer(PatchPosition)^)^);
end;
Offset := Integer(newproc) - Integer(pointer(PatchPosition)) - 5;
Patch[0] := ansichar($E9);
Patch[1] := ansichar(Offset and 255);
Patch[2] := ansichar((Offset shr 8) and 255);
Patch[3] := ansichar((Offset shr 16) and 255);
Patch[4] := ansichar((Offset shr 24) and 255);
Original[0] := PatchPosition[0];
Original[1] := PatchPosition[1];
Original[2] := PatchPosition[2];
Original[3] := PatchPosition[3];
Original[4] := PatchPosition[4];
{$IFDEF MSWINDOWS}
if not VirtualProtect(pointer(PatchPosition), 5, PAGE_EXECUTE_READWRITE, @ov) then
RaiseLastOSError;
{$ENDIF}
{$IFDEF LINUX}
pagesize := sysconf(_SC_PAGE_SIZE);
p := pointer(PatchPosition);
p := pointer((Integer(p) + pagesize - 1) and not(pagesize - 1) - pagesize);
if mprotect(p, pagesize, PROT_READ + PROT_WRITE + PROT_EXEC) <> 0 then
RaiseLastOSError;
{$ENDIF}
end;
procedure THook.Shutdown;
begin
Disable;
PatchPosition := nil;
end;
procedure HookIntoResourceStrings(enabled: boolean = true; SupportPackages: boolean = false);
begin
HookLoadResString.Reset(SupportPackages);
HookLoadStr.Reset(SupportPackages);
HookFmtLoadStr.Reset(SupportPackages);
if enabled then
begin
HookLoadResString.Enable;
HookLoadStr.Enable;
HookFmtLoadStr.Enable;
end;
end;
{ TMoFile }
function TMoFile.autoswap32(i: Cardinal): Cardinal;
var
cnv1, cnv2: record case Integer of 0: (arr: array [0 .. 3] of byte);
1: (int: Cardinal);
end;
begin
if doswap then
begin
cnv1.int := i;
cnv2.arr[0] := cnv1.arr[3];
cnv2.arr[1] := cnv1.arr[2];
cnv2.arr[2] := cnv1.arr[1];
cnv2.arr[3] := cnv1.arr[0];
Result := cnv2.int;
end
else
Result := i;
end;
function TMoFile.CardinalInMem(baseptr: PAnsiChar; Offset: Cardinal): Cardinal;
var
pc: ^Cardinal;
begin
inc(baseptr, Offset);
pc := pointer(baseptr);
Result := pc^;
if doswap then
autoswap32(Result);
end;
constructor TMoFile.Create(filename: FilenameString; Offset, Size: int64);
var
i: Cardinal;
nn: Integer;
{$IFDEF linux}
mofile: TFileStream;
{$ENDIF}
begin
if SizeOf(i) <> 4 then
raise EGGProgrammingError.Create('TDomain in gnugettext is written for an architecture that has 32 bit integers.');
{$IFDEF mswindows}
// Map the mo file into memory and let the operating system decide how to cache
mo := createfile(PChar(filename), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
if mo = INVALID_HANDLE_VALUE then
raise EGGIOError.Create('Cannot open file ' + filename);
momapping := CreateFileMapping(mo, nil, PAGE_READONLY, 0, 0, nil);
if momapping = 0 then
raise EGGIOError.Create('Cannot create memory map on file ' + filename);
momemoryHandle := MapViewOfFile(momapping, FILE_MAP_READ, 0, 0, 0);
if momemoryHandle = nil then
begin
raise EGGIOError.Create('Cannot map file ' + filename + ' into memory. Reason: ' + GetLastWinError);
end;
momemory := momemoryHandle + Offset;
{$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(Offset, soFromBeginning);
mofile.ReadBuffer(momemory^, Size);
finally
FreeAndNil(mofile);
end;
{$ENDIF}
// Check the magic number
doswap := false;
i := CardinalInMem(momemory, 0);
if (i <> $950412DE) and (i <> $DE120495) then
raise EGGIOError.Create('This file is not a valid GNU gettext mo file: ' + filename);
doswap := (i = $DE120495);
// Find the positions in the file according to the file format spec
CardinalInMem(momemory, 4);
// Read the version number, but don't use it for anything.
N := CardinalInMem(momemory, 8); // Get string count
O := CardinalInMem(momemory, 12); // Get offset of original strings
T := CardinalInMem(momemory, 16); // Get offset of translated strings
// Calculate start conditions for a binary search
nn := N;
startindex := 1;
while nn <> 0 do
begin
nn := nn shr 1;
startindex := startindex shl 1;
end;
startindex := startindex shr 1;
startstep := startindex shr 1;
end;
destructor TMoFile.Destroy;
begin
{$IFDEF mswindows}
UnMapViewOfFile(momemoryHandle);
CloseHandle(momapping);
CloseHandle(mo);
{$ENDIF}
{$IFDEF linux}
FreeMem(momemoryHandle);
{$ENDIF}
inherited;
end;
function TMoFile.gettext(const msgid: RawUtf8String; var found: boolean): RawUtf8String;
var
i, step: Cardinal;
Offset, pos: Cardinal;
CompareResult: Integer;
msgidptr, a, b: PAnsiChar;
abidx: Integer;
Size, msgidsize: Integer;
begin
found := false;
msgidptr := PAnsiChar(msgid);
msgidsize := length(msgid);
// Do binary search
i := startindex;
step := startstep;
while true do
begin
// Get string for index i
pos := O + 8 * (i - 1);
Offset := CardinalInMem(momemory, pos + 4);
Size := CardinalInMem(momemory, pos);
a := msgidptr;
b := momemory + Offset;
abidx := Size;
if msgidsize < abidx then
abidx := msgidsize;
CompareResult := 0;
while abidx <> 0 do
begin
CompareResult := Integer(byte(a^)) - Integer(byte(b^));
if CompareResult <> 0 then
break;
dec(abidx);
inc(a);
inc(b);
end;
if CompareResult = 0 then
CompareResult := msgidsize - Size;
if CompareResult = 0 then
begin // msgid=s
// Found the msgid
pos := T + 8 * (i - 1);
Offset := CardinalInMem(momemory, pos + 4);
Size := CardinalInMem(momemory, pos);
SetString(Result, momemory + Offset, Size);
found := true;
break;
end;
if step = 0 then
begin
// Not found
Result := msgid;
break;
end;
if CompareResult < 0 then
begin // msgid<s
if i < 1 + step then
i := 1
else
i := i - step;
step := step shr 1;
end
else
begin // msgid>s
i := i + step;
if i > N then
i := N;
step := step shr 1;
end;
end;
end;
var
param0: string;
initialization
{$IFDEF DXGETTEXTDEBUG}
{$IFDEF MSWINDOWS}
MessageBox(0, 'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.', 'Information', MB_OK);
{$ENDIF}
{$IFDEF LINUX}
writeln(stderr, 'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.');
{$ENDIF}
{$ENDIF}
{$IFDEF FPC}
{$IFDEF LINUX}
SetLocale(LC_ALL, '');
SetCWidestringManager;
{$ENDIF LINUX}
{$ENDIF FPC}
if IsLibrary then
begin
// Get DLL/shared object filename
SetLength(ExecutableFilename, 300);
{$IFDEF MSWINDOWS}
SetLength(ExecutableFilename, GetModuleFileName(FindClassHInstance(TGnuGettextInstance), PChar(ExecutableFilename), length(ExecutableFilename)));
{$ELSE}
SetLength(ExecutableFilename, GetModuleFileName(0, PAnsiChar(ExecutableFilename), length(ExecutableFilename)));
{$ENDIF}
end
else
ExecutableFilename := Paramstr(0);
FileLocator := TFileLocator.Create;
FileLocator.Analyze;
ResourceStringDomainList := TStringList.Create;
ResourceStringDomainList.Add(DefaultTextDomain);
ResourceStringDomainListCS := TMultiReadExclusiveWriteSynchronizer.Create;
DefaultInstance := TGnuGettextInstance.Create;
{$IFDEF MSWINDOWS}
Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
{$ENDIF}
// replace Borlands LoadResString with gettext enabled version:
{$IFDEF UNICODE}
HookLoadResString := THook.Create(@System.LoadResString, @LoadResStringW);
{$ELSE}
HookLoadResString := THook.Create(@System.LoadResString, @LoadResStringA);
{$ENDIF}
HookLoadStr := THook.Create(@SysUtils.LoadStr, @SysUtilsLoadStr);
HookFmtLoadStr := THook.Create(@SysUtils.FmtLoadStr, @SysUtilsFmtLoadStr);
param0 := lowercase(extractfilename(Paramstr(0)));
if (param0 <> 'delphi32.exe') and (param0 <> 'kylix') and (param0 <> 'bds.exe') then
HookIntoResourceStrings(AutoCreateHooks, false);
param0 := '';
finalization
FreeAndNil(DefaultInstance);
FreeAndNil(ResourceStringDomainListCS);
FreeAndNil(ResourceStringDomainList);
FreeAndNil(HookFmtLoadStr);
FreeAndNil(HookLoadStr);
FreeAndNil(HookLoadResString);
FreeAndNil(FileLocator);
end.