3546 lines
103 KiB
ObjectPascal
3546 lines
103 KiB
ObjectPascal
unit JvGnugettext;
|
|
(**************************************************************)
|
|
(* *)
|
|
(* (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 *)
|
|
(* Andreas Hausladen *)
|
|
(* *)
|
|
(* See http://dybdahl.dk/dxgettext/ for more information *)
|
|
(* *)
|
|
(**************************************************************)
|
|
|
|
// 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 VER100}
|
|
// Delphi 3
|
|
{$DEFINE DELPHI5OROLDER}
|
|
{$DEFINE DELPHI6OROLDER}
|
|
{$DEFINE DELPHI7OROLDER}
|
|
{$endif}
|
|
{$ifdef VER110}
|
|
// C++ Builder 3
|
|
{$DEFINE DELPHI5OROLDER}
|
|
{$DEFINE DELPHI6OROLDER}
|
|
{$DEFINE DELPHI7OROLDER}
|
|
{$endif}
|
|
{$ifdef VER120}
|
|
// Delphi 4
|
|
{$DEFINE DELPHI5OROLDER}
|
|
{$DEFINE DELPHI6OROLDER}
|
|
{$DEFINE DELPHI7OROLDER}
|
|
{$endif}
|
|
{$ifdef VER125}
|
|
// C++ Builder 4
|
|
{$DEFINE DELPHI5OROLDER}
|
|
{$DEFINE DELPHI6OROLDER}
|
|
{$DEFINE DELPHI7OROLDER}
|
|
{$endif}
|
|
{$ifdef VER130}
|
|
// Delphi 5
|
|
{$DEFINE DELPHI5OROLDER}
|
|
{$DEFINE DELPHI6OROLDER}
|
|
{$DEFINE DELPHI7OROLDER}
|
|
{$ifdef WIN32}
|
|
{$DEFINE MSWINDOWS}
|
|
{$endif}
|
|
{$endif}
|
|
{$ifdef VER135}
|
|
// C++ Builder 5
|
|
{$DEFINE DELPHI5OROLDER}
|
|
{$DEFINE DELPHI6OROLDER}
|
|
{$DEFINE DELPHI7OROLDER}
|
|
{$ifdef WIN32}
|
|
{$DEFINE MSWINDOWS}
|
|
{$endif}
|
|
{$endif}
|
|
{$ifdef VER140}
|
|
// Delphi 6
|
|
{$DEFINE DELPHI6OROLDER}
|
|
{$DEFINE DELPHI7OROLDER}
|
|
{$endif}
|
|
{$ifdef VER150}
|
|
{$DEFINE DELPHI7OROLDER}
|
|
// Delphi 7
|
|
{$endif}
|
|
{$ifdef VER160}
|
|
// Delphi 8
|
|
{$endif}
|
|
|
|
uses
|
|
{$ifdef DELPHI5OROLDER}
|
|
JvGnugettextD5,
|
|
{$endif}
|
|
{$ifdef MSWINDOWS}
|
|
Windows,
|
|
{$endif}
|
|
{$ifdef LINUX}
|
|
Libc,
|
|
{$endif}
|
|
Classes, SysUtils, Contnrs, TypInfo;
|
|
|
|
(*****************************************************************************)
|
|
(* *)
|
|
(* MAIN API *)
|
|
(* *)
|
|
(*****************************************************************************)
|
|
|
|
// Main GNU gettext functions. See documentation for instructions on how to use them.
|
|
{$ifdef DELPHI5OROLDER}
|
|
function _(const szMsgId: WideString): WideString;
|
|
function gettext(const szMsgId: WideString): WideString;
|
|
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;
|
|
{$endif}
|
|
{$ifndef DELPHI5OROLDER}
|
|
function _(const szMsgId: AnsiString): WideString; overload;
|
|
function _(const szMsgId: WideString): WideString; overload;
|
|
function gettext(const szMsgId: AnsiString): WideString; overload;
|
|
function gettext(const szMsgId: WideString): WideString; overload;
|
|
function dgettext(const szDomain: string; const szMsgId: AnsiString): WideString; overload;
|
|
function dgettext(const szDomain: string; const szMsgId: WideString): WideString; overload;
|
|
function dngettext(const szDomain: string; const singular, plural: AnsiString; Number: Longint): WideString; overload;
|
|
function dngettext(const szDomain: string; const singular, plural: WideString; Number: Longint): WideString; overload;
|
|
function ngettext(const singular, plural: AnsiString; Number: Longint): WideString; overload;
|
|
function ngettext(const singular, plural: WideString; Number: Longint): WideString; overload;
|
|
{$endif}
|
|
procedure textdomain(const szDomain: string);
|
|
function getcurrenttextdomain: string;
|
|
procedure bindtextdomain(const szDomain, szDirectory: string);
|
|
|
|
// Set language to use
|
|
procedure UseLanguage(const LanguageCode: string);
|
|
function GetCurrentLanguage: string;
|
|
|
|
// 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: AnsiString);
|
|
procedure TP_IgnoreClass(IgnClass: TClass);
|
|
procedure TP_IgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString);
|
|
procedure TP_GlobalIgnoreClass(IgnClass: TClass);
|
|
procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString);
|
|
procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator);
|
|
procedure TranslateComponent(AnObject: TComponent; const TextDomain: string = '');
|
|
procedure RetranslateComponent(AnObject: TComponent; const 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(const domain: string);
|
|
procedure RemoveDomainForResourceString(const domain: string);
|
|
|
|
{$ifndef CLR}
|
|
// 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;
|
|
{$endif}
|
|
|
|
// This returns an empty string if not translated or translator name is not specified.
|
|
function GetTranslatorNameAndEmail: WideString;
|
|
|
|
|
|
(*****************************************************************************)
|
|
(* *)
|
|
(* ADVANCED FUNCTIONALITY *)
|
|
(* *)
|
|
(*****************************************************************************)
|
|
|
|
const
|
|
DefaultTextDomain = 'default';
|
|
|
|
var
|
|
ExecutableFilename: string;
|
|
// This is set to paramstr(0) or the name of the DLL you are creating.
|
|
|
|
type
|
|
EGnuGettext = class(Exception);
|
|
EGGProgrammingError = class(EGnuGettext);
|
|
EGGComponentError = class(EGnuGettext);
|
|
EGGIOError = class(EGnuGettext);
|
|
EGGAnsi2WideConvError = class(EGnuGettext);
|
|
|
|
{$ifndef CLR}
|
|
// 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);
|
|
{$endif}
|
|
|
|
|
|
|
|
(*****************************************************************************)
|
|
(* *)
|
|
(* 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}
|
|
{$ifndef DELPHI7OROLDER}
|
|
{$WARN SYMBOL_PLATFORM OFF}
|
|
{$WARN SYMBOL_DEPRECATED OFF}
|
|
{$endif}
|
|
|
|
type
|
|
TOnDebugLine = procedure(Sender: TObject; const Line: AnsiString;
|
|
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;
|
|
|
|
TMoFile = class // Don't use this class. It's for internal use.
|
|
// Threadsafe. Only constructor and destructor are writing to memory
|
|
private
|
|
doswap: Boolean;
|
|
public
|
|
Users: Integer;
|
|
// Reference count. If it reaches zero, this object should be destroyed.
|
|
constructor Create(const Filename: string; Offset, Size: Int64);
|
|
function gettext(const msgid: AnsiString; var Found: Boolean): AnsiString;
|
|
// uses mo file
|
|
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;
|
|
moMemory: array of byte;
|
|
function CardinalInMem(Offset: Cardinal): Cardinal;
|
|
end;
|
|
|
|
TDomain = class // Don't use this class. It's for internal use.
|
|
private
|
|
Enabled: Boolean;
|
|
vDirectory: string;
|
|
procedure SetDirectory(const Value: string);
|
|
public
|
|
DebugLogger: TDebugLogger;
|
|
Domain: string;
|
|
property Directory: string read vDirectory write SetDirectory;
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
// Set parameters
|
|
procedure SetLanguageCode(const LangCode: string);
|
|
procedure SetFilename(const Filename: string); // Bind this domain to a specific file
|
|
// Get information
|
|
procedure GetListOfLanguages(List: TStrings);
|
|
function GetTranslationProperty(PropertyName: string): WideString;
|
|
function gettext(const msgid: AnsiString): AnsiString; // uses mo file
|
|
private
|
|
moFile: TMoFile;
|
|
SpecificFilename: string;
|
|
curlang: string;
|
|
OpenHasFailedBefore: Boolean;
|
|
procedure OpenMoFile;
|
|
procedure CloseMoFile;
|
|
end;
|
|
|
|
TExecutable = class
|
|
procedure Execute; virtual; abstract;
|
|
end;
|
|
|
|
TGnuGettextInstance = class
|
|
private
|
|
fOnDebugLine: TOnDebugLine;
|
|
{$ifndef CLR}
|
|
CreatorThread: Cardinal; // Only this thread can use LoadResString
|
|
{$endif}
|
|
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: string);
|
|
procedure GetListOfLanguages(const domain: string; List: TStrings); // Puts List of language codes, for which there are translations in the specified domain, into List
|
|
{$ifdef DELPHI5OROLDER}
|
|
function gettext(const szMsgId: WideString): WideString;
|
|
function ngettext(const singular, plural: WideString; Number: Longint): WideString;
|
|
{$endif}
|
|
{$ifndef DELPHI5OROLDER}
|
|
function gettext(const szMsgId: AnsiString): WideString; overload;
|
|
function gettext(const szMsgId: WideString): WideString; overload;
|
|
function ngettext(const singular, plural: AnsiString; Number: Longint): WideString; overload;
|
|
function ngettext(const singular, plural: WideString; Number: Longint): WideString; overload;
|
|
{$endif}
|
|
function GetCurrentLanguage: string;
|
|
function GetTranslationProperty(const PropertyName: AnsiString): 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: AnsiString);
|
|
procedure TP_IgnoreClass(IgnClass: TClass);
|
|
procedure TP_IgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString);
|
|
procedure TP_GlobalIgnoreClass(IgnClass: TClass);
|
|
procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString);
|
|
procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator);
|
|
procedure TranslateProperties(AnObject: TObject; TextDomain: string = '');
|
|
procedure TranslateComponent(AnObject: TComponent; const TextDomain: string = '');
|
|
procedure RetranslateComponent(AnObject: TComponent; const TextDomain: string = '');
|
|
|
|
// Multi-domain functions
|
|
{$ifdef DELPHI5OROLDER}
|
|
function dgettext(const szDomain: string; const szMsgId: WideString): WideString;
|
|
function dngettext(const szDomain: string; singular, plural: WideString; Number: Longint): WideString;
|
|
{$endif}
|
|
{$ifndef DELPHI5OROLDER}
|
|
function dgettext(const szDomain: string; const szMsgId: AnsiString): WideString; overload;
|
|
function dgettext(const szDomain: string; const szMsgId: WideString): WideString; overload;
|
|
function dngettext(const szDomain: string; singular, plural: AnsiString; Number: Longint): WideString; overload;
|
|
function dngettext(const szDomain: string; singular, plural: WideString; Number: Longint): WideString; overload;
|
|
{$endif}
|
|
procedure textdomain(const szDomain: string);
|
|
function getcurrenttextdomain: string;
|
|
procedure bindtextdomain(const szDomain, szDirectory: string);
|
|
procedure bindtextdomainToFile(const szDomain, Filename: string);
|
|
// Also works with files embedded in exe file
|
|
|
|
{$ifndef CLR}
|
|
// Windows API functions
|
|
function LoadResString(ResStringRec: PResStringRec): WideString;
|
|
{$endif}
|
|
|
|
// Output all log info to this file. This may only be called once.
|
|
procedure DebugLogToFile(const Filename: string; append: Boolean = False);
|
|
procedure DebugLogPause(PauseEnabled: Boolean);
|
|
property OnDebugLine: TOnDebugLine read fOnDebugLine write fOnDebugLine;
|
|
// If set, all debug output goes here
|
|
|
|
// Conversion according to design-time character set
|
|
function ansi2wide(const s: AnsiString): WideString;
|
|
protected
|
|
procedure TranslateStrings(sl: TStrings; const TextDomain: string);
|
|
|
|
// 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: AnsiString); virtual;
|
|
// Override to know when language changes
|
|
procedure WhenNewDomain(const TextDomain: string); virtual;
|
|
// Override to know when text domain changes. Directory is purely informational
|
|
procedure WhenNewDomainDirectory(const TextDomain, Directory: string); 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: 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: TObjectList;
|
|
// Items are TClassMode. If a is derived from b, a comes first
|
|
TP_GlobalClassHandling: TObjectList;
|
|
// Items are TClassMode. If a is derived from b, a comes first
|
|
TP_Retranslator: TExecutable; // Cast this to TTP_Retranslator
|
|
DebugLogCS: TMultiReadExclusiveWriteSynchronizer;
|
|
DebugLog: TStream;
|
|
DebugLogOutputPaused: Boolean;
|
|
function TP_CreateRetranslator: TExecutable; // Must be freed by caller!
|
|
procedure DebugWriteln(Line: AnsiString);
|
|
function Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain;
|
|
// Translates a single property of an object
|
|
{$ifndef CLR}
|
|
procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;
|
|
TodoList: TStrings; const TextDomain: string);
|
|
{$endif}
|
|
end;
|
|
|
|
var
|
|
DefaultInstance: TGnuGettextInstance;
|
|
|
|
implementation
|
|
|
|
(**************************************************************************)
|
|
// 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
|
|
(**************************************************************************)
|
|
|
|
{$ifdef CLR}
|
|
uses
|
|
System.Globalization, System.Diagnostics, System.Windows.Forms;
|
|
{$endif}
|
|
|
|
type
|
|
TTP_RetranslatorItem = class
|
|
obj: TObject;
|
|
Propname: AnsiString;
|
|
OldValue: WideString;
|
|
end;
|
|
|
|
TTP_Retranslator = class(TExecutable)
|
|
TextDomain: string;
|
|
Instance: TGnuGettextInstance;
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Remember(obj: TObject; const PropName: AnsiString; OldValue: WideString);
|
|
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: string): Boolean;
|
|
function GetMoFile(Filename: string; DebugLogger: TDebugLogger): TMoFile;
|
|
procedure ReleaseMoFile(var moFile: TMoFile);
|
|
private
|
|
BaseDirectory: string;
|
|
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: AnsiString;
|
|
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;
|
|
|
|
{$ifndef CLR}
|
|
THook = class // Replaces a runtime library procedure with a custom procedure
|
|
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: PChar;
|
|
procedure Shutdown; // Same as destroy, except that object is not destroyed
|
|
end;
|
|
{$endif}
|
|
|
|
var
|
|
// System information
|
|
Win32PlatformIsUnicode: Boolean = False;
|
|
|
|
// Information about files embedded inside .exe file
|
|
FileLocator: TFileLocator;
|
|
|
|
ResourceStringDomainListCS: TMultiReadExclusiveWriteSynchronizer;
|
|
ResourceStringDomainList: TStringList;
|
|
{$ifndef CLR}
|
|
// Hooks into runtime library functions
|
|
HookLoadResString: THook;
|
|
HookLoadStr: THook;
|
|
HookFmtLoadStr: THook;
|
|
{$endif}
|
|
|
|
function Utf8EncodeChar(wc: WideChar): AnsiString;
|
|
var
|
|
w: Word;
|
|
begin
|
|
w := Ord(wc);
|
|
case w of
|
|
0..$7F:
|
|
Result := AnsiChar(w);
|
|
$80..$3FF:
|
|
Result := AnsiChar($C0 + (w shr 6)) +
|
|
AnsiChar($80 + (w and $3F));
|
|
$400..$FFFF:
|
|
Result := AnsiChar($E0 +(w shr 12))+
|
|
AnsiChar($80 +((w shr 6) and $3F)) +
|
|
AnsiChar($80 +(w and $3F));
|
|
else
|
|
raise Exception.Create('Huh, what happened here?');
|
|
end;
|
|
end;
|
|
|
|
function Utf8Encode(ws: WideString): AnsiString;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := '';
|
|
for i := 1 to Length(ws) do
|
|
Result := Result + Utf8EncodeChar(ws[i]);
|
|
end;
|
|
|
|
// If dummychar is #0, it will raise Exception when an error occurs
|
|
function Utf8Decode(s: AnsiString; dummychar: WideChar = #0): WideString;
|
|
var
|
|
i: Integer;
|
|
b: Byte;
|
|
c: Cardinal;
|
|
mode: 0..5;
|
|
begin
|
|
Result := '';
|
|
mode := 0;
|
|
c := 0;
|
|
for i := 1 to Length(s) do
|
|
begin
|
|
b := Ord(s[i]);
|
|
if mode = 0 then
|
|
begin
|
|
case b of
|
|
0..$7F:
|
|
Result := Result + WideChar(b);
|
|
$80..$BF, $FF:
|
|
begin
|
|
if dummychar = #0 then
|
|
raise Exception.Create ('Invalid byte sequence encountered in utf-8 string')
|
|
else
|
|
Result := Result + dummychar;
|
|
mode := 0;
|
|
end;
|
|
$C0..$DF:
|
|
begin
|
|
c := (b and $1F);
|
|
mode := 1;
|
|
end;
|
|
$E0..$EF:
|
|
begin
|
|
c := (b and $F);
|
|
mode := 2;
|
|
end;
|
|
$F0..$F7:
|
|
begin
|
|
c := (b and $7);
|
|
mode := 3;
|
|
end;
|
|
$F8..$FB:
|
|
begin
|
|
c := (b and $3);
|
|
mode := 4;
|
|
end;
|
|
$FC..$FE:
|
|
begin
|
|
c := (b and $1);
|
|
mode := 5;
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
case b of
|
|
$00..$7F, $C0..$FF:
|
|
if dummychar = #0 then
|
|
raise Exception.Create('Invalid byte sequence encountered in utf-8 string')
|
|
else
|
|
Result:=Result+dummychar;
|
|
$80..$BF:
|
|
begin
|
|
c := c * $40 + (b and $3F);
|
|
Dec(mode);
|
|
if mode = 0 then
|
|
begin
|
|
if c <= $FFFF then
|
|
Result := Result + WideChar(c)
|
|
else
|
|
begin
|
|
if dummychar = #0 then
|
|
raise Exception.Create('Utf-8 string contained unicode character larger than $FFFF. This is not supported.')
|
|
else
|
|
Result := Result + dummychar;
|
|
end;
|
|
end;
|
|
end;
|
|
else
|
|
raise Exception.Create ('Huh? More than 256 different values in a byte?');
|
|
end;
|
|
end;
|
|
end;
|
|
if mode <> 0 then begin
|
|
if dummychar = #0 then
|
|
raise Exception.Create ('Utf-8 string terminated unexpectedly in the middle of a multibyte sequence')
|
|
else
|
|
Result := Result + dummychar;
|
|
end;
|
|
end;
|
|
|
|
function StripCR(s: AnsiString): AnsiString;
|
|
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(const Name: string): string;
|
|
{$ifdef DELPHI5OROLDER}
|
|
var
|
|
Len: DWORD;
|
|
{$endif}
|
|
begin
|
|
{$ifdef DELPHI5OROLDER}
|
|
SetLength(Result, 1024);
|
|
Len := Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), 1024);
|
|
SetLength(Result, Len);
|
|
if Len > 1024 then
|
|
if Windows.GetEnvironmentVariable(PChar(Name),PChar(Result), Len) <> Len then
|
|
Result := 'ERROR: Windows environment changes concurrently with this application';
|
|
{$endif}
|
|
{$ifndef DELPHI5OROLDER}
|
|
Result := SysUtils.GetEnvironmentVariable(Name);
|
|
{$endif}
|
|
end;
|
|
|
|
function StartsWith(const Text, StartText: string; CaseInsensitive: Boolean = False): Boolean;
|
|
var
|
|
Len, i: Integer;
|
|
begin
|
|
Result := False;
|
|
Len := Length(StartText);
|
|
if Len > Length(Text) then
|
|
Exit;
|
|
if CaseInsensitive then
|
|
begin
|
|
for i := 1 to Len do
|
|
if UpCase(Text[i]) <> UpCase(StartText[i]) then
|
|
Exit;
|
|
end
|
|
else
|
|
begin
|
|
for i := 1 to Len do
|
|
if Text[i] <> StartText[i] then
|
|
Exit;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
function EndsWith(const Text, EndText: string; CaseInsensitive: Boolean): Boolean;
|
|
var
|
|
Len, i, x: Integer;
|
|
begin
|
|
Result := False;
|
|
Len := Length(EndText);
|
|
x := Length(Text);
|
|
if Len > x then
|
|
Exit;
|
|
if CaseInsensitive then
|
|
begin
|
|
for i := Len downto 1 do
|
|
if UpCase(Text[x]) <> UpCase(EndText[i]) then
|
|
Exit
|
|
else
|
|
Dec(x);
|
|
end
|
|
else
|
|
begin
|
|
for i := Len downto 1 do
|
|
if Text[x] <> EndText[i] then
|
|
Exit
|
|
else
|
|
Dec(x);
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
function IsInDirStrOf(const Filename, Dir: string): Boolean;
|
|
begin
|
|
Result := StartsWith(Filename, Dir, {$ifdef MSWINDOWS}True{$else}False{$endif});
|
|
end;
|
|
|
|
function EndsWithFilename(const Path, Filename: string): Boolean;
|
|
begin
|
|
Result := EndsWith(Path, Filename, {$ifdef MSWINDOWS}True{$else}False{$endif});
|
|
end;
|
|
|
|
{$ifdef CLR}
|
|
function TrimCopy(const S: string; Index, Count: Integer): string; overload;
|
|
var
|
|
Len, StartIndex, EndIndex: Integer;
|
|
begin
|
|
Result := '';
|
|
|
|
Len := Length(S);
|
|
if Index <= 0 then
|
|
Index := 1;
|
|
if Count > Len then
|
|
Count := Len;
|
|
|
|
if (Count > 0) and (Len > 0) then
|
|
begin
|
|
StartIndex := Index;
|
|
while (StartIndex <= Len) and (S[StartIndex] <= #32) do
|
|
Inc(StartIndex);
|
|
Dec(Count, StartIndex - Index);
|
|
|
|
EndIndex := StartIndex + Count - 1;
|
|
if EndIndex > Len then
|
|
begin
|
|
Dec(Count, EndIndex - Len);
|
|
EndIndex := Len;
|
|
end;
|
|
|
|
while (EndIndex > 0) and (S[EndIndex] <= #32) do
|
|
begin
|
|
Dec(EndIndex);
|
|
Dec(Count);
|
|
end;
|
|
|
|
if EndIndex >= StartIndex then
|
|
Result := Copy(S, StartIndex, Count);
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
function TrimCopy(const S: AnsiString; Index, Count: Integer): AnsiString; overload;
|
|
var
|
|
Len, StartIndex, EndIndex: Integer;
|
|
begin
|
|
Result := '';
|
|
|
|
Len := Length(S);
|
|
if Index <= 0 then
|
|
Index := 1;
|
|
if Count > Len then
|
|
Count := Len;
|
|
|
|
if (Count > 0) and (Len > 0) then
|
|
begin
|
|
StartIndex := Index;
|
|
while (StartIndex <= Len) and (S[StartIndex] <= #32) do
|
|
Inc(StartIndex);
|
|
Dec(Count, StartIndex - Index);
|
|
|
|
EndIndex := StartIndex + Count - 1;
|
|
if EndIndex > Len then
|
|
begin
|
|
Dec(Count, EndIndex - Len);
|
|
EndIndex := Len;
|
|
end;
|
|
|
|
while (EndIndex > 0) and (S[EndIndex] <= #32) do
|
|
begin
|
|
Dec(EndIndex);
|
|
Dec(Count);
|
|
end;
|
|
|
|
if EndIndex >= StartIndex then
|
|
{$ifdef CLR}
|
|
Result := Copy(S, StartIndex, Count);
|
|
{$else}
|
|
SetString(Result, PChar(Pointer(S)) + StartIndex - 1, Count);
|
|
{$endif CLR}
|
|
end;
|
|
end;
|
|
|
|
function LF2LineBreakA(s: AnsiString): AnsiString;
|
|
{$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 (i > 1) and (s[i - 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
|
|
{$ifndef CLR}
|
|
Result := Assigned(Info) and (Info^.SetProc <> nil);
|
|
{$else}
|
|
Result := Assigned(Info) and CanWrite(Info);
|
|
{$endif}
|
|
end;
|
|
|
|
{ not used }
|
|
{
|
|
function string2csyntax(const s: AnsiString): AnsiString;
|
|
// Converts a string to the syntax that is used in .po files
|
|
var
|
|
i: Integer;
|
|
c: AnsiChar;
|
|
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 + '\0x' + IntToHex(Ord(c), 2);
|
|
end;
|
|
end;
|
|
Result := '"' + Result + '"';
|
|
end;
|
|
}
|
|
|
|
{$ifdef DELPHI5OROLDER}
|
|
function GetPropList(AObject: TObject; out PropList: PPropList): Integer;
|
|
var
|
|
Data: PTypeData;
|
|
begin
|
|
Result := 0;
|
|
PropList := nil;
|
|
if (AObject.ClassInfo <> nil) then
|
|
begin
|
|
Data := GetTypeData(AObject.ClassInfo);
|
|
Result := Data^.PropCount;
|
|
if Result > 0 then
|
|
begin
|
|
GetMem(PropList, Result * SizeOf(PPropInfo));
|
|
GetPropInfos(AObject.ClassInfo, PropList);
|
|
end;
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
function ResourceStringGettext(const MsgId: WideString): WideString;
|
|
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;
|
|
|
|
{$ifndef DELPHI5OROLDER}
|
|
function gettext(const szMsgId: AnsiString): WideString;
|
|
begin
|
|
Result := DefaultInstance.gettext(szMsgId);
|
|
end;
|
|
{$endif}
|
|
|
|
function gettext(const szMsgId: WideString): WideString;
|
|
begin
|
|
Result := DefaultInstance.gettext(szMsgId);
|
|
end;
|
|
|
|
{$ifndef DELPHI5OROLDER}
|
|
function _(const szMsgId: AnsiString): WideString;
|
|
begin
|
|
Result := DefaultInstance.gettext(szMsgId);
|
|
end;
|
|
{$endif}
|
|
|
|
function _(const szMsgId: WideString): WideString;
|
|
begin
|
|
Result := DefaultInstance.gettext(szMsgId);
|
|
end;
|
|
|
|
{$ifndef DELPHI5OROLDER}
|
|
function dgettext(const szDomain: string; const szMsgId: AnsiString): WideString;
|
|
begin
|
|
Result := DefaultInstance.dgettext(szDomain, szMsgId);
|
|
end;
|
|
{$endif}
|
|
|
|
function dgettext(const szDomain: string; const szMsgId: WideString): WideString;
|
|
begin
|
|
Result := DefaultInstance.dgettext(szDomain, szMsgId);
|
|
end;
|
|
|
|
{$ifndef DELPHI5OROLDER}
|
|
function dngettext(const szDomain: string; const singular, plural: AnsiString;
|
|
Number: Longint): WideString;
|
|
begin
|
|
Result := DefaultInstance.dngettext(szDomain, singular, plural, Number);
|
|
end;
|
|
{$endif}
|
|
|
|
function dngettext(const szDomain: string; const singular, plural: WideString;
|
|
Number: Longint): WideString;
|
|
begin
|
|
Result := DefaultInstance.dngettext(szDomain, singular, plural, Number);
|
|
end;
|
|
|
|
{$ifndef DELPHI5OROLDER}
|
|
function ngettext(const singular, plural: AnsiString; Number: Longint): WideString;
|
|
begin
|
|
Result := DefaultInstance.ngettext(singular, plural, Number);
|
|
end;
|
|
{$endif}
|
|
|
|
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;
|
|
|
|
{not used}
|
|
{
|
|
procedure SetGettextEnabled(Enabled: Boolean);
|
|
begin
|
|
DefaultInstance.Enabled := Enabled;
|
|
end;
|
|
}
|
|
|
|
function getcurrenttextdomain: string;
|
|
begin
|
|
Result := DefaultInstance.getcurrenttextdomain;
|
|
end;
|
|
|
|
procedure bindtextdomain(const szDomain, szDirectory: string);
|
|
begin
|
|
DefaultInstance.bindtextdomain(szDomain, szDirectory);
|
|
end;
|
|
|
|
procedure TP_Ignore(AnObject: TObject; const Name: AnsiString);
|
|
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: AnsiString);
|
|
begin
|
|
DefaultInstance.TP_IgnoreClassProperty(IgnClass, PropertyName);
|
|
end;
|
|
|
|
procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString);
|
|
begin
|
|
DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass, PropertyName);
|
|
end;
|
|
|
|
procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator);
|
|
begin
|
|
DefaultInstance.TP_GlobalHandleClass(HClass, Handler);
|
|
end;
|
|
|
|
{not used}
|
|
{
|
|
procedure TranslateProperties(AnObject: TObject; TextDomain: AnsiString = '');
|
|
begin
|
|
DefaultInstance.TranslateProperties(AnObject, TextDomain);
|
|
end;
|
|
}
|
|
|
|
procedure TranslateComponent(AnObject: TComponent; const TextDomain: string = '');
|
|
begin
|
|
DefaultInstance.TranslateComponent(AnObject, TextDomain);
|
|
end;
|
|
|
|
procedure RetranslateComponent(AnObject: TComponent; const TextDomain: string = '');
|
|
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 GetOSLanguage: AnsiString;
|
|
var
|
|
langid: Cardinal;
|
|
LangCode: AnsiString;
|
|
CountryName: array[0..4] of AnsiChar;
|
|
LanguageName: array[0..4] of AnsiChar;
|
|
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_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 := 'gr_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}
|
|
|
|
{$ifdef CLR}
|
|
function GetOSLanguage: string;
|
|
var
|
|
p: Integer;
|
|
begin
|
|
Result := CultureInfo.get_CurrentCulture.ToString;
|
|
p := Pos('-', Result);
|
|
if p <> 0 then
|
|
Result[p] := '_';
|
|
end;
|
|
{$endif}
|
|
|
|
{$ifdef LINUX}
|
|
function GetOSLanguage: AnsiString;
|
|
begin
|
|
Result := '';
|
|
end;
|
|
{$endif}
|
|
|
|
{$ifndef CLR}
|
|
function LoadResStringA(ResStringRec: PResStringRec): string;
|
|
begin
|
|
if DefaultInstance <> nil then
|
|
Result := DefaultInstance.LoadResString(ResStringRec)
|
|
else
|
|
Result := PChar(ResStringRec.Identifier);
|
|
end;
|
|
{$endif}
|
|
|
|
function GetTranslatorNameAndEmail: WideString;
|
|
begin
|
|
Result := DefaultInstance.GetTranslatorNameAndEmail;
|
|
end;
|
|
|
|
procedure UseLanguage(const LanguageCode: string);
|
|
begin
|
|
DefaultInstance.UseLanguage(LanguageCode);
|
|
end;
|
|
|
|
{$ifndef CLR}
|
|
type
|
|
PStrData = ^TStrData;
|
|
TStrData = record
|
|
Ident: Integer;
|
|
Str: AnsiString;
|
|
end;
|
|
|
|
function SysUtilsEnumStringModules(Instance: Longint; Data: Pointer): Boolean;
|
|
{$ifdef MSWINDOWS}
|
|
var
|
|
Buffer: array[0..1023] of AnsiChar;
|
|
begin
|
|
with PStrData(Data)^ do
|
|
begin
|
|
SetString(Str, Buffer,
|
|
LoadString(Instance, Ident, Buffer, 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): AnsiString;
|
|
var
|
|
StrData: TStrData;
|
|
begin
|
|
StrData.Ident := Ident;
|
|
StrData.Str := '';
|
|
EnumResourceModules(SysUtilsEnumStringModules, @StrData);
|
|
Result := StrData.Str;
|
|
end;
|
|
|
|
function SysUtilsLoadStr(Ident: Integer): AnsiString;
|
|
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): AnsiString;
|
|
begin
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DefaultInstance.DebugWriteln('SysUtils.FmtLoadRes(' + IntToStr(ident) + ', Args) called');
|
|
{$endif}
|
|
FmtStr(Result, SysUtilsFindStringResource(Ident), Args);
|
|
Result := ResourceStringGettext(Result);
|
|
end;
|
|
|
|
function LoadResString(ResStringRec: PResStringRec): WideString;
|
|
begin
|
|
Result := DefaultInstance.LoadResString(ResStringRec);
|
|
end;
|
|
|
|
function LoadResStringW(ResStringRec: PResStringRec): WideString;
|
|
begin
|
|
Result := DefaultInstance.LoadResString(ResStringRec);
|
|
end;
|
|
{$endif}
|
|
|
|
|
|
function GetCurrentLanguage: string;
|
|
begin
|
|
Result := DefaultInstance.GetCurrentLanguage;
|
|
end;
|
|
|
|
{ TDomain }
|
|
|
|
procedure TDomain.CloseMoFile;
|
|
begin
|
|
if moFile <> nil then
|
|
FileLocator.ReleaseMoFile(moFile);
|
|
OpenHasFailedBefore := False;
|
|
end;
|
|
|
|
destructor TDomain.Destroy;
|
|
begin
|
|
CloseMoFile;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{$ifdef MSWINDOWS}
|
|
{not used}
|
|
{
|
|
function GetLastWinError: AnsiString;
|
|
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;
|
|
const
|
|
ErrorMsg = 'The translation for the language code %s (in %s) does not have ' +
|
|
'charset=utf-8 in its Content-Type. Translations are turned off.';
|
|
var
|
|
Filename: string;
|
|
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
|
|
Filename := SpecificFilename
|
|
else
|
|
begin
|
|
Filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
|
|
if (not FileLocator.FileExists(Filename)) and (not FileExists(Filename)) then
|
|
Filename := Directory + Copy(curlang, 1, 2) + PathDelim +
|
|
'LC_MESSAGES' + PathDelim + domain + '.mo';
|
|
end;
|
|
if (not FileLocator.FileExists(Filename)) and (not FileExists(Filename)) then
|
|
begin
|
|
OpenHasFailedBefore := True;
|
|
Exit;
|
|
end;
|
|
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(Format(ErrorMsg, [curlang, Filename]));
|
|
{$endif}
|
|
{$ifdef MSWINDOWS}
|
|
MessageBox(0, PChar(Format(ErrorMsg, [curlang, Filename])),
|
|
'Localization problem', MB_OK);
|
|
{$endif}
|
|
{$ifdef CLR}
|
|
MessageBox.show(Format(ErrorMsg, [curlang, Filename]));
|
|
{$endif}
|
|
{$ifdef LINUX}
|
|
WriteLn(stderr, Format(ErrorMsg, [curlang, Filename]));
|
|
{$endif}
|
|
Enabled := False;
|
|
end;
|
|
end;
|
|
|
|
function TDomain.GetTranslationProperty(PropertyName: string): WideString;
|
|
var
|
|
sl: TStringList;
|
|
i, PropLen: Integer;
|
|
s: string;
|
|
begin
|
|
PropertyName := PropertyName + ': ';
|
|
PropLen := Length(PropertyName) + 1;
|
|
sl := TStringList.Create;
|
|
try
|
|
{$ifdef CLR}
|
|
s := gettext('');
|
|
if Pos(sLineBreak, s) = 0 then
|
|
sl.LineBreak := #10
|
|
else
|
|
sl.LineBreak := sLineBreak;
|
|
sl.Text := s;
|
|
{$else}
|
|
sl.Text := Utf8Encode(gettext(''));
|
|
{$endif}
|
|
for i := 0 to sl.Count - 1 do
|
|
begin
|
|
s := sl.Strings[i];
|
|
if StartsWith(s, PropertyName, True) then
|
|
begin
|
|
{$ifdef CLR}
|
|
Result := TrimCopy(s, PropLen, MaxInt);
|
|
{$else}
|
|
Result := Utf8Decode(TrimCopy(s, PropLen, MaxInt));
|
|
{$endif}
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DebugLogger('GetTranslationProperty(' + PropertyName + ') returns ''' + Result + '''.');
|
|
{$endif}
|
|
Exit;
|
|
end;
|
|
end;
|
|
finally
|
|
sl.Free;
|
|
end;
|
|
Result := '';
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DebugLogger('GetTranslationProperty(' + PropertyName +
|
|
') did not find any value. An empty string is returned.');
|
|
{$endif}
|
|
end;
|
|
|
|
procedure TDomain.SetDirectory(const Value: string);
|
|
begin
|
|
vDirectory := IncludeTrailingPathDelimiter(Value);
|
|
SpecificFilename := '';
|
|
CloseMoFile;
|
|
end;
|
|
|
|
procedure AddDomainForResourceString(const domain: string);
|
|
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: string);
|
|
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: 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;
|
|
|
|
procedure TDomain.GetListOfLanguages(List: TStrings);
|
|
var
|
|
sr: TSearchRec;
|
|
more: Boolean;
|
|
Filename, Path, LangCode: AnsiString;
|
|
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];
|
|
if IsInDirStrOf(Filename, Directory) then
|
|
begin
|
|
j := Length(Directory);
|
|
Path := PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
|
|
if EndsWithFilename(Filename, Path) then
|
|
begin
|
|
LangCode := LowerCase(Copy(Filename, j + 1, Length(Filename) - Length(Path) - j));
|
|
if List.IndexOf(LangCode) = -1 then
|
|
List.Add(LangCode);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDomain.SetFilename(const Filename: string);
|
|
begin
|
|
CloseMoFile;
|
|
vDirectory := '';
|
|
SpecificFilename := Filename;
|
|
end;
|
|
|
|
function TDomain.gettext(const msgid: AnsiString): AnsiString;
|
|
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, szDirectory: string);
|
|
var
|
|
dir: string;
|
|
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
|
|
inherited Create;
|
|
{$ifndef CLR}
|
|
CreatorThread := GetCurrentThreadId;
|
|
{ TODO : Do something about Thread handling if resourcestrings are enabled }
|
|
{$endif}
|
|
{$ifdef MSWINDOWS}
|
|
DesignTimeCodePage := CP_ACP;
|
|
{$endif}
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DebugLogCS := TMultiReadExclusiveWriteSynchronizer.Create;
|
|
DebugLog := TMemoryStream.Create;
|
|
DebugWriteln('Debug log started ' + DateTimeToStr(Now));
|
|
DebugWriteln('');
|
|
{$endif}
|
|
curGetPluralForm := GetPluralForm2EN;
|
|
Enabled := True;
|
|
curmsgdomain := DefaultTextDomain;
|
|
savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;
|
|
DomainList := TStringList.Create;
|
|
TP_IgnoreList := TStringList.Create;
|
|
TP_IgnoreList.Sorted := True;
|
|
TP_GlobalClassHandling := TObjectList.Create;
|
|
TP_ClassHandling := TObjectList.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;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if SaveMemory <> nil then
|
|
begin
|
|
savefileCS.BeginWrite;
|
|
try
|
|
CloseFile(savefile);
|
|
finally
|
|
savefileCS.EndWrite;
|
|
end;
|
|
FreeAndNil(SaveMemory);
|
|
end;
|
|
FreeAndNil(savefileCS);
|
|
FreeAndNil(TP_IgnoreList);
|
|
FreeAndNil(TP_GlobalClassHandling);
|
|
FreeAndNil(TP_ClassHandling);
|
|
for I := 0 to DomainList.Count - 1 do
|
|
DomainList.Objects[I].Free;
|
|
FreeAndNil(DomainList);
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
FreeAndNil(DebugLog);
|
|
FreeAndNil(DebugLogCS);
|
|
{$endif}
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{$ifndef DELPHI5OROLDER}
|
|
function TGnuGettextInstance.dgettext(const szDomain: string;
|
|
const szMsgId: AnsiString): WideString;
|
|
begin
|
|
Result := dgettext(szDomain, ansi2wide(szMsgId));
|
|
end;
|
|
{$endif}
|
|
|
|
function TGnuGettextInstance.dgettext(const szDomain: string;
|
|
const szMsgId: WideString): WideString;
|
|
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(LF2LineBreakA(getdomain(szDomain, DefaultDomainDirectory,
|
|
CurLang).gettext(StripCR(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.GetCurrentLanguage: string;
|
|
begin
|
|
Result := curlang;
|
|
end;
|
|
|
|
function TGnuGettextInstance.getcurrenttextdomain: string;
|
|
begin
|
|
Result := curmsgdomain;
|
|
end;
|
|
|
|
{$ifndef DELPHI5OROLDER}
|
|
function TGnuGettextInstance.gettext(const szMsgId: AnsiString): WideString;
|
|
begin
|
|
Result := dgettext(curmsgdomain, szMsgId);
|
|
end;
|
|
{$endif}
|
|
|
|
function TGnuGettextInstance.gettext(const szMsgId: WideString): WideString;
|
|
begin
|
|
Result := dgettext(curmsgdomain, szMsgId);
|
|
end;
|
|
|
|
procedure TGnuGettextInstance.textdomain(const szDomain: string);
|
|
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 := TClassMode(TP_GlobalClassHandling.Items[i]);
|
|
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 := TClassMode(TP_GlobalClassHandling.Items[i]);
|
|
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;
|
|
const PropertyName: AnsiString);
|
|
var
|
|
cm: TClassMode;
|
|
i, idx: Integer;
|
|
begin
|
|
for i := 0 to TP_GlobalClassHandling.Count - 1 do
|
|
begin
|
|
cm := TClassMode(TP_GlobalClassHandling.Items[i]);
|
|
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: AnsiString);
|
|
begin
|
|
TP_IgnoreList.Add(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: string);
|
|
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);
|
|
{$endif}
|
|
{$ifdef CLR}
|
|
MessageBox.show('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}
|
|
{$ifdef LINUX}
|
|
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;
|
|
|
|
{$ifndef CLR}
|
|
procedure TGnuGettextInstance.TranslateProperty(AnObject: TObject;
|
|
PropInfo: PPropInfo; TodoList: TStrings; const TextDomain: AnsiString);
|
|
var
|
|
{$ifdef DELPHI5OROLDER}
|
|
ws: AnsiString;
|
|
old: AnsiString;
|
|
{$endif}
|
|
{$ifndef DELPHI5OROLDER}
|
|
ppi: PPropInfo;
|
|
ws: WideString;
|
|
old: WideString;
|
|
{$endif}
|
|
obj: TObject;
|
|
Propname: AnsiString;
|
|
begin
|
|
PropName := PropInfo^.Name;
|
|
try
|
|
// Translate certain types of properties
|
|
case PropInfo^.PropType^.Kind of
|
|
tkString, tkLString, tkWString:
|
|
begin
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DebugWriteln('Translating ' + AnObject.ClassName + '.' + PropName);
|
|
{$endif}
|
|
{$ifdef DELPHI5OROLDER}
|
|
old := GetStrProp(AnObject, PropName);
|
|
{$endif}
|
|
{$ifndef DELPHI5OROLDER}
|
|
if PropInfo^.PropType^.Kind <> tkWString then
|
|
old := ansi2wide(GetStrProp(AnObject, PropName))
|
|
else
|
|
old := GetWideStrProp(AnObject, PropName);
|
|
{$endif}
|
|
{$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
|
|
TTP_Retranslator(TP_Retranslator).Remember(AnObject, PropName, old);
|
|
ws := dgettext(TextDomain, old);
|
|
if ws <> old then
|
|
begin
|
|
{$ifdef DELPHI5OROLDER}
|
|
SetStrProp(AnObject, PropName, ws);
|
|
{$endif}
|
|
{$ifndef DELPHI5OROLDER}
|
|
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;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
end { case item };
|
|
tkClass:
|
|
begin
|
|
obj := GetObjectProp(AnObject, PropName);
|
|
if obj <> nil then
|
|
TodoList.AddObject('', obj);
|
|
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;
|
|
{$endif}
|
|
|
|
procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject;
|
|
TextDomain: string = '');
|
|
{$ifndef CLR}
|
|
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: AnsiString;
|
|
PropInfo: PPropInfo;
|
|
Comp: TComponent;
|
|
cm, currentcm: TClassMode;
|
|
ObjectPropertyIgnoreList: TStringList;
|
|
objid, Name: AnsiString;
|
|
{$endif}
|
|
begin
|
|
{$ifndef CLR}
|
|
{$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
|
|
TTP_Retranslator(TP_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;
|
|
{$ifndef DELPHI5OROLDER}
|
|
ObjectPropertyIgnoreList.CaseSensitive := False;
|
|
DoneList.Duplicates := dupError;
|
|
DoneList.CaseSensitive := True;
|
|
{$endif}
|
|
|
|
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 := TClassMode(TP_ClassHandling.Items[j]);
|
|
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 := TClassMode(TP_GlobalClassHandling.Items[j]);
|
|
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];
|
|
UPropName := 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 (TStrings(AnObject).Count > 0) and (TP_Retranslator <> nil) then
|
|
TTP_Retranslator(TP_Retranslator).Remember(AnObject,
|
|
'Text', TStrings(AnObject).Text);
|
|
TranslateStrings(TStrings(AnObject), TextDomain);
|
|
end;
|
|
// Check for TCollection
|
|
if AnObject is TCollection then
|
|
begin
|
|
for i := 0 to TCollection(AnObject).Count - 1 do
|
|
TodoList.AddObject('', TCollection(AnObject).Items[i]);
|
|
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(Comp.Name, j)) then
|
|
begin
|
|
TodoList.AddObject(Comp.Name, Comp);
|
|
end;
|
|
end;
|
|
end;
|
|
end { if AnObject <> nil };
|
|
end { while TodoList.count <> 0 };
|
|
finally
|
|
TodoList.Free;
|
|
ObjectPropertyIgnoreList.Free;
|
|
DoneList.Free;
|
|
end;
|
|
TP_ClassHandling.Clear; // deletes the objects
|
|
TP_IgnoreList.Clear;
|
|
TP_Retranslator := nil;
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DebugWriteln('----------------------------------------------------------------------');
|
|
{$endif}
|
|
{$endif}
|
|
end;
|
|
|
|
procedure TGnuGettextInstance.UseLanguage(LanguageCode: string);
|
|
var
|
|
i, p: Integer;
|
|
dom: TDomain;
|
|
l2: string[2];
|
|
begin
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DebugWriteln('UseLanguage(''' + LanguageCode + '''); called');
|
|
{$endif}
|
|
|
|
if LanguageCode = '' then
|
|
begin
|
|
LanguageCode := GGGetEnvironmentVariable('LANG');
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DebugWriteln('LANG env variable is ''' + LanguageCode + '''.');
|
|
{$endif}
|
|
if LanguageCode = '' then
|
|
begin
|
|
LanguageCode := GetOSLanguage;
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DebugWriteln('Found OS language code to be ''' + LanguageCode + '''.');
|
|
{$endif}
|
|
end;
|
|
p := Pos('.', LanguageCode);
|
|
if p <> 0 then
|
|
Delete(LanguageCode, p, MaxInt);
|
|
{$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 := TDomain(DomainList.Objects[i]);
|
|
dom.SetLanguageCode(curlang);
|
|
end;
|
|
|
|
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
|
|
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: string);
|
|
var
|
|
Line: AnsiString;
|
|
i: Integer;
|
|
TempList: TStringList;
|
|
begin
|
|
if sl.Count > 0 then
|
|
begin
|
|
sl.BeginUpdate;
|
|
try
|
|
TempList := TStringList.Create;
|
|
try
|
|
TempList.Assign(sl);
|
|
for i := 0 to TempList.Count - 1 do
|
|
begin
|
|
Line := TempList.Strings[i];
|
|
if Line <> '' then
|
|
TempList.Strings[i] := dgettext(TextDomain, Line);
|
|
end;
|
|
sl.Assign(TempList);
|
|
finally
|
|
TempList.Free;
|
|
end;
|
|
{
|
|
for i := 0 to sl.Count - 1 do
|
|
begin
|
|
Line := sl.Strings[i];
|
|
if Line <> '' then
|
|
sl.Strings[i] := dgettext(TextDomain, Line);
|
|
end;
|
|
}
|
|
finally
|
|
sl.EndUpdate;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TGnuGettextInstance.GetTranslatorNameAndEmail: WideString;
|
|
begin
|
|
Result := GetTranslationProperty('LAST-TRANSLATOR');
|
|
end;
|
|
|
|
function TGnuGettextInstance.GetTranslationProperty(const PropertyName: AnsiString): WideString;
|
|
begin
|
|
Result := getdomain(curmsgdomain, DefaultDomainDirectory,
|
|
CurLang).GetTranslationProperty(PropertyName);
|
|
end;
|
|
|
|
function TGnuGettextInstance.dngettext(const szDomain: string;
|
|
singular, plural: WideString;
|
|
Number: Integer): WideString;
|
|
var
|
|
org, trans: WideString;
|
|
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, string(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 := Copy(trans, 1, p - 1);
|
|
Exit;
|
|
end;
|
|
Delete(trans, 1, p);
|
|
Dec(idx);
|
|
end;
|
|
end;
|
|
|
|
{$ifndef DELPHI5OROLDER}
|
|
function TGnuGettextInstance.ngettext(const singular, plural: AnsiString;
|
|
Number: Integer): WideString;
|
|
begin
|
|
Result := dngettext(curmsgdomain, singular, plural, Number);
|
|
end;
|
|
{$endif}
|
|
|
|
function TGnuGettextInstance.ngettext(const singular, plural: WideString;
|
|
Number: Integer): WideString;
|
|
begin
|
|
Result := dngettext(curmsgdomain, singular, plural, Number);
|
|
end;
|
|
|
|
procedure TGnuGettextInstance.WhenNewDomain(const TextDomain: string);
|
|
begin
|
|
// This is meant to be empty.
|
|
end;
|
|
|
|
procedure TGnuGettextInstance.WhenNewLanguage(const LanguageID: AnsiString);
|
|
begin
|
|
// This is meant to be empty.
|
|
end;
|
|
|
|
procedure TGnuGettextInstance.WhenNewDomainDirectory(const TextDomain,
|
|
Directory: string);
|
|
begin
|
|
// This is meant to be empty.
|
|
end;
|
|
|
|
procedure TGnuGettextInstance.GetListOfLanguages(const domain: string;
|
|
List: TStrings);
|
|
begin
|
|
getdomain(Domain, DefaultDomainDirectory, CurLang).GetListOfLanguages(List);
|
|
end;
|
|
|
|
procedure TGnuGettextInstance.bindtextdomainToFile(const szDomain, Filename: string);
|
|
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
|
|
DebugLogOutputPaused := PauseEnabled;
|
|
end;
|
|
|
|
procedure TGnuGettextInstance.DebugLogToFile(const Filename: string; append: Boolean = False);
|
|
var
|
|
fs: TFileStream;
|
|
marker: AnsiString;
|
|
begin
|
|
// 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;
|
|
|
|
if DebugLog <> nil then
|
|
begin
|
|
// Copy the memorystream contents to the file
|
|
DebugLog.Seek(0, soFromBeginning);
|
|
fs.CopyFrom(DebugLog, 0);
|
|
|
|
// Make DebugLog point to the filestream
|
|
FreeAndNil(DebugLog);
|
|
end;
|
|
DebugLog := fs;
|
|
end;
|
|
|
|
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;
|
|
|
|
function TGnuGettextInstance.Getdomain(const domain, DefaultDomainDirectory,
|
|
CurLang: string): 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;
|
|
Result.DebugLogger := DebugWriteln;
|
|
Result.Domain := Domain;
|
|
Result.Directory := DefaultDomainDirectory;
|
|
Result.SetLanguageCode(curlang);
|
|
DomainList.AddObject(Domain, Result);
|
|
end
|
|
else
|
|
begin
|
|
Result := TDomain(DomainList.Objects[idx]);
|
|
end;
|
|
end;
|
|
|
|
{$ifndef CLR}
|
|
function TGnuGettextInstance.LoadResString(ResStringRec: PResStringRec): WideString;
|
|
{$ifdef MSWINDOWS}
|
|
var
|
|
Len: Integer;
|
|
Buffer: array[0..1023] of AnsiChar;
|
|
{$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) or (Self = nil) then
|
|
Exit;
|
|
if ResStringRec.Identifier >= 64 * 1024 then
|
|
begin
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
DebugWriteln('LoadResString was given an invalid ResStringRec.Identifier');
|
|
{$endif}
|
|
Result := PChar(ResStringRec.Identifier);
|
|
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,
|
|
PChar(ResStringRec^.Identifier div ResStringTableLen), PChar(6)); // RT_STRING
|
|
Tab := Pointer(LoadResource(ResMod, Handle));
|
|
if Tab = nil then
|
|
Result := ''
|
|
else
|
|
Result := PWideChar(PChar(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 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}
|
|
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;
|
|
{$endif}
|
|
|
|
procedure TGnuGettextInstance.RetranslateComponent(AnObject: TComponent;
|
|
const TextDomain: string);
|
|
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 := TClassMode(TP_ClassHandling.Items[i]);
|
|
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;
|
|
const PropertyName: AnsiString);
|
|
var
|
|
cm: TClassMode;
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to TP_ClassHandling.Count - 1 do
|
|
begin
|
|
cm := TClassMode(TP_ClassHandling.Items[i]);
|
|
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;
|
|
|
|
function TGnuGettextInstance.ansi2wide(const s: AnsiString): WideString;
|
|
{$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, PChar(s), len,
|
|
PWideChar(Result), len);
|
|
if len = 0 then
|
|
raise EGGAnsi2WideConvError.Create('Cannot convert AnsiString to WideString:' +
|
|
sLineBreak + s);
|
|
SetLength(Result, len);
|
|
end;
|
|
end;
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifndef DELPHI5OROLDER}
|
|
function TGnuGettextInstance.dngettext(const szDomain: string; singular,
|
|
plural: AnsiString; Number: Integer): WideString;
|
|
begin
|
|
Result := dngettext(szDomain, ansi2wide(singular), ansi2wide(plural), Number);
|
|
end;
|
|
{$endif}
|
|
|
|
{ TClassMode }
|
|
|
|
constructor TClassMode.Create;
|
|
begin
|
|
inherited Create;
|
|
PropertiesToIgnore := TStringList.Create;
|
|
PropertiesToIgnore.Sorted := True;
|
|
PropertiesToIgnore.Duplicates := dupError;
|
|
{$ifndef DELPHI5OROLDER}
|
|
PropertiesToIgnore.CaseSensitive := False;
|
|
{$endif}
|
|
end;
|
|
|
|
destructor TClassMode.Destroy;
|
|
begin
|
|
PropertiesToIgnore.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TFileLocator }
|
|
|
|
procedure TFileLocator.Analyze;
|
|
var
|
|
s: AnsiString;
|
|
i: Integer;
|
|
Offset: Int64;
|
|
fs: TFileStream;
|
|
fi: TEmbeddedFileInfo;
|
|
AnsiFilename: AnsiString;
|
|
begin
|
|
s := '6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0; // this string is patched in the executable
|
|
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 := TEmbeddedFileInfo.Create;
|
|
try
|
|
fi.Offset := ReadInt64(fs);
|
|
fi.Size := ReadInt64(fs);
|
|
SetLength(AnsiFilename, Offset - fs.Position);
|
|
fs.ReadBuffer(AnsiFilename[1], Offset - fs.Position);
|
|
FileList.AddObject(Trim(AnsiFilename), fi);
|
|
except
|
|
fi.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
finally
|
|
fs.Free;
|
|
end;
|
|
except
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
raise;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
|
|
constructor TFileLocator.Create;
|
|
begin
|
|
inherited Create;
|
|
MoFilesCS := TMultiReadExclusiveWriteSynchronizer.Create;
|
|
MoFiles := TStringList.Create;
|
|
FileList := TStringList.Create;
|
|
{$ifdef LINUX}
|
|
FileList.Duplicates := dupError;
|
|
FileList.CaseSensitive := True;
|
|
{$endif}
|
|
MoFiles.Sorted := True;
|
|
{$ifndef DELPHI5OROLDER}
|
|
MoFiles.Duplicates := dupError;
|
|
MoFiles.CaseSensitive := False;
|
|
{$ifdef MSWINDOWS}
|
|
FileList.Duplicates := dupError;
|
|
FileList.CaseSensitive := False;
|
|
{$endif}
|
|
{$endif}
|
|
FileList.Sorted := True;
|
|
end;
|
|
|
|
destructor TFileLocator.Destroy;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to FileList.Count - 1 do
|
|
FileList.Objects[I].Free;
|
|
{ while FileList.Count <> 0 do
|
|
begin
|
|
FileList.Objects[0].Free;
|
|
FileList.Delete(0);
|
|
end;}
|
|
FileList.Free;
|
|
MoFiles.Free;
|
|
MoFilesCS.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TFileLocator.FileExists(Filename: string): Boolean;
|
|
var
|
|
idx: Integer;
|
|
begin
|
|
if IsInDirStrOf(Filename, BaseDirectory) then
|
|
Delete(Filename, 1, Length(BaseDirectory));
|
|
Result := FileList.Find(Filename, idx);
|
|
end;
|
|
|
|
function TFileLocator.GetMoFile(Filename: string; DebugLogger: TDebugLogger): TMoFile;
|
|
var
|
|
fi: TEmbeddedFileInfo;
|
|
idx: Integer;
|
|
idxName: string;
|
|
Offset, Size: Int64;
|
|
RealFilename: string;
|
|
begin
|
|
// Find real Filename
|
|
Offset := 0;
|
|
Size := 0;
|
|
RealFilename := Filename;
|
|
if IsInDirStrOf(Filename, BaseDirectory) then
|
|
begin
|
|
Delete(Filename, 1, Length(BaseDirectory));
|
|
idx := FileList.IndexOf(Filename);
|
|
if idx <> -1 then
|
|
begin
|
|
fi := TEmbeddedFileInfo(FileList.Objects[idx]);
|
|
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 + #0 + IntToStr(Offset);
|
|
if MoFiles.Find(idxName, idx) then
|
|
begin
|
|
Result := TMoFile(MoFiles.Objects[idx]);
|
|
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(var 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
|
|
inherited Create;
|
|
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;
|
|
List.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TTP_Retranslator.Execute;
|
|
var
|
|
i: Integer;
|
|
sl: TStrings;
|
|
Item: TTP_RetranslatorItem;
|
|
newvalue: WideString;
|
|
{$ifndef DELPHI5OROLDER}
|
|
ppi: PPropInfo;
|
|
{$endif}
|
|
begin
|
|
for i := 0 to List.Count - 1 do
|
|
begin
|
|
Item := TTP_RetranslatorItem(List.items[i]);
|
|
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);
|
|
TStrings(Item.obj).BeginUpdate;
|
|
try
|
|
TStrings(Item.obj).Assign(sl);
|
|
finally
|
|
TStrings(Item.obj).EndUpdate;
|
|
end;
|
|
finally
|
|
sl.Free;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
newValue := Instance.dgettext(TextDomain, Item.OldValue);
|
|
{$ifdef DELPHI5OROLDER}
|
|
SetStrProp(Item.obj, Item.PropName, newValue);
|
|
{$endif}
|
|
{$ifndef DELPHI5OROLDER}
|
|
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;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTP_Retranslator.Remember(obj: TObject; const PropName: AnsiString;
|
|
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
|
|
Retranslator.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{$ifndef CLR}
|
|
{ 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
|
|
inherited Create;
|
|
{$ifndef CPU386}
|
|
'This procedure only works on Intel i386 compatible processors.'
|
|
{$endif}
|
|
|
|
OldProc := OldProcedure;
|
|
NewProc := NewProcedure;
|
|
|
|
Reset(FollowJump);
|
|
end;
|
|
|
|
destructor THook.Destroy;
|
|
begin
|
|
Shutdown;
|
|
inherited Destroy;
|
|
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 := PChar(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;
|
|
{$endif}
|
|
|
|
{ TMoFile }
|
|
|
|
constructor TMoFile.Create(const Filename: string; Offset, Size: Int64);
|
|
var
|
|
i: Cardinal;
|
|
nn: Integer;
|
|
moFile: TFileStream;
|
|
begin
|
|
inherited Create;
|
|
|
|
if SizeOf(i) <> 4 then
|
|
raise EGGProgrammingError.Create(
|
|
'TDomain in gnugettext is written for an architecture that has 32 bit integers.');
|
|
|
|
// Read the whole file into memory
|
|
moFile := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone);
|
|
try
|
|
if Size = 0 then
|
|
Size := moFile.Size;
|
|
SetLength(moMemory, Size);
|
|
moFile.Seek(Offset, soFromBeginning);
|
|
{$ifdef CLR}
|
|
mofile.ReadBuffer(moMemory, Size);
|
|
{$else}
|
|
mofile.ReadBuffer(moMemory[0], Size);
|
|
{$endif}
|
|
finally
|
|
moFile.Free;
|
|
end;
|
|
|
|
// Check the magic number
|
|
doswap := False;
|
|
i := CardinalInMem(0);
|
|
if (i <> $950412DE) and (i <> $DE120495) then
|
|
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(4);
|
|
// Read the version number, but don't use it for anything.
|
|
N := CardinalInMem(8); // Get string count
|
|
O := CardinalInMem(12); // Get Offset of original strings
|
|
T := CardinalInMem(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;
|
|
|
|
function TMoFile.CardinalInMem (Offset: Cardinal): Cardinal;
|
|
begin
|
|
if doswap then
|
|
begin
|
|
Result:=
|
|
moMemory[Offset]+
|
|
(moMemory[Offset + 1] shl 8)+
|
|
(moMemory[Offset + 2] shl 16)+
|
|
(moMemory[Offset + 3] shl 24);
|
|
end
|
|
else
|
|
begin
|
|
Result:=
|
|
(momemory[Offset] shl 24)+
|
|
(momemory[Offset + 1] shl 16)+
|
|
(momemory[Offset + 2] shl 8)+
|
|
momemory[Offset + 3];
|
|
end;
|
|
end;
|
|
|
|
|
|
function TMoFile.gettext(const msgid: AnsiString; var Found: Boolean): AnsiString;
|
|
var
|
|
{$ifdef CLR}
|
|
j: Cardinal;
|
|
{$endif}
|
|
i, Step: Cardinal;
|
|
Offset, Pos: Cardinal;
|
|
CompareResult: Integer;
|
|
msgidptr, a, b: Integer;
|
|
abidx: Integer;
|
|
Size, msgidsize: Integer;
|
|
begin
|
|
Found := False;
|
|
msgidptr := 1;
|
|
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(Pos + 4);
|
|
Size := CardinalInMem(Pos);
|
|
a := msgidptr;
|
|
b := Offset;
|
|
abidx := Size;
|
|
if msgidsize < abidx then
|
|
abidx := msgidsize;
|
|
CompareResult := 0;
|
|
while abidx <> 0 do
|
|
begin
|
|
CompareResult := Integer(Byte(msgid[a])) - Integer(moMemory[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(Pos + 4);
|
|
Size := CardinalInMem(Pos);
|
|
{$ifdef CLR}
|
|
SetLength(Result, Size);
|
|
for j := 0 to Size - 1 do
|
|
Result[j + 1] := AnsiChar(moMemory[Offset + j]);
|
|
{$else}
|
|
SetString(Result, PChar(@moMemory[0]) + Offset, Size);
|
|
{$endif}
|
|
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;
|
|
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
const
|
|
DebuggingText = 'gnugettext.pas debugging is enabled. Turn it off before ' +
|
|
'releasing this piece of software.';
|
|
{$endif}
|
|
|
|
initialization
|
|
{$ifdef DXGETTEXTDEBUG}
|
|
{$ifdef CLR}
|
|
MessageBox.show(DebuggingText);
|
|
{$else}
|
|
{$ifdef MSWINDOWS}
|
|
MessageBox(0, PChar(DebuggingText), 'Information', MB_OK);
|
|
{$endif}
|
|
{$ifdef LINUX}
|
|
WriteLn(stderr, DebuggingText);
|
|
{$endif}
|
|
{$endif}
|
|
{$endif}
|
|
if IsLibrary then
|
|
begin
|
|
// Get DLL/shared object Filename
|
|
SetLength(ExecutableFilename, 300);
|
|
{$ifdef MSWINDOWS}
|
|
SetLength(ExecutableFilename, GetModuleFileName(HInstance,
|
|
PChar(ExecutableFilename), Length(ExecutableFilename)));
|
|
{$endif}
|
|
{$ifdef LINUX}
|
|
// This line has not been tested on Linux, yet, but should work.
|
|
SetLength(ExecutableFilename, GetModuleFileName(0, PChar(ExecutableFilename),
|
|
Length(ExecutableFilename)));
|
|
{$endif}
|
|
{$ifdef CLR}
|
|
ExecutableFilename := System.Diagnostics.Process.GetCurrentProcess.MainModule.FileName;
|
|
{$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}
|
|
|
|
{$ifndef CLR}
|
|
// replace Borlands LoadResString with gettext enabled version:
|
|
HookLoadResString := THook.Create(@System.LoadResString, @LoadResStringA);
|
|
HookLoadStr := THook.Create(@SysUtils.LoadStr, @SysUtilsLoadStr);
|
|
HookFmtLoadStr := THook.Create(@SysUtils.FmtLoadStr, @SysUtilsFmtLoadStr);
|
|
HookIntoResourceStrings(AutoCreateHooks, False);
|
|
{$endif}
|
|
|
|
finalization
|
|
FreeAndNil(DefaultInstance);
|
|
FreeAndNil(ResourceStringDomainListCS);
|
|
FreeAndNil(ResourceStringDomainList);
|
|
{$ifndef CLR}
|
|
FreeAndNil(HookFmtLoadStr);
|
|
FreeAndNil(HookLoadStr);
|
|
FreeAndNil(HookLoadResString);
|
|
{$endif}
|
|
FreeAndNil(FileLocator);
|
|
|
|
end.
|