[tuxdroid-svn] r5204 - software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_br
Status: Beta
Brought to you by:
ks156
Menu
▾
▴
[tuxdroid-svn] r5204 - software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser
|
From: jerome <c2m...@c2...> - 2009-07-28 12:38:43
|
Author: jerome
Date: 2009-07-28 14:38:23 +0200 (Tue, 28 Jul 2009)
New Revision: 5204
Added:
software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/gnugettext.dcu
software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/gnugettext.pas
Modified:
software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/TuxUtils.dcu
software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.dcu
software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.dfm
software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.pas
Log:
* Added full support of gnu gettext based translations for TuxBox 2.0
Modified: software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/TuxUtils.dcu
===================================================================
(Binary files differ)
Modified: software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.dcu
===================================================================
(Binary files differ)
Modified: software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.dfm
===================================================================
--- software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.dfm 2009-07-28 12:02:19 UTC (rev 5203)
+++ software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.dfm 2009-07-28 12:38:23 UTC (rev 5204)
@@ -60,7 +60,6 @@
Width = 955
Height = 619
TabOrder = 0
- Silent = False
RegisterAsBrowser = True
RegisterAsDropTarget = False
OnDocumentComplete = EmbeddedWB1DocumentComplete
Modified: software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.pas
===================================================================
--- software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.pas 2009-07-28 12:02:19 UTC (rev 5203)
+++ software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/Unit1.pas 2009-07-28 12:38:23 UTC (rev 5204)
@@ -29,7 +29,7 @@
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, OleCtrls, SHDocVw_EWB, EwbCore, EmbeddedWB, Menus, ImgList, IEDownload,
ExtCtrls, EwbControlComponent, AppEvnts, StdCtrls, ComCtrls, ShellAPI, TuxUtils,
- Registry;
+ Registry, gnugettext;
const
@@ -87,7 +87,25 @@
const wm_AppelMessage = wm_user + 1;
+resourcestring
+ //Contains all used strings.
+ SERVER_INITIALIZATION = 'TuxDroid server initialization...';
+ SERVER_READY = 'TuxBox 2.0 is ready to use.';
+ SERVER_STOP_ERROR_0 = 'Can not stop the Tux Droid server';
+ SERVER_STOP_ERROR_1 = 'Please, go to start menu to manually stop it.';
+ TUX_BOX_HIDDEN_0 = 'TuxBox 2.0 is now hidden in the tray icon';
+ TUX_BOX_HIDDEN_1 = 'To open it again, please double-click the tray icon.';
+ TUX_BOX_HIDDEN_2 = 'Click here to make this message disappear';
+ TUX_BOX_SHOW_HIDE = 'TuxBox 2.0 Show / Hide';
+ TUX_BOX_WARNING_MSG = 'TuxBox 2.0 Warning';
+
+ POPUP_CAPTION_SHOW_HIDE = 'Show / Hide';
+ POPUP_CAPTION_MUTE = 'Mute';
+ POPUP_CAPTION_HELP = 'Help';
+ POPUP_CAPTION_QUIT = 'Quit';
+
+
type
TForm1 = class(TForm)
EmbeddedWB1: TEmbeddedWB;
@@ -117,6 +135,7 @@
procedure DeleteSysTrayIcon();
procedure HideBalloonTips();
procedure setBalloonCanShow(showable : boolean);
+ procedure updateCaptions();
function isBalloonCanShow() : boolean;
function GetAllUsersDir() : string;
@@ -155,6 +174,10 @@
//Form initialization.
procedure TForm1.FormCreate(Sender: TObject);
begin
+
+ Form1.updateCaptions;
+ application.ProcessMessages;
+
url := 'http://127.0.0.1:270/user/';
started := false;
@@ -173,17 +196,33 @@
//Starting status pooling.
EmbeddedWB1.Go('about:blank');
+ //Initialization of GnuGetText object and updating language.
+ gnugettext.UseLanguage('en');
+ TP_GlobalIgnoreClassProperty(TEmbeddedWB, 'StatusText');
+ TP_Ignore(self, '.StatusText');
+ TranslateComponent (self);
+
//Starting server if not started yet.
if not TuxUtils.isTuxDroidServerStarted() then
begin
- Form1.ShowBalloonTips('TuxDroid server initialization...');
+ Form1.ShowBalloonTips(gettext(SERVER_INITIALIZATION));
TuxUtils.startServer();
- Form1.ShowBalloonTips('TuxBox 2.0 is ready to use.');
+ Form1.ShowBalloonTips(gettext(SERVER_READY));
end;
end;
+{#### Update captions according gnu gettext. ####}
+procedure TForm1.updateCaptions();
+begin
+ ShowHide1.Caption := gettext(POPUP_CAPTION_SHOW_HIDE);
+ Mute1.Caption := gettext(POPUP_CAPTION_MUTE);
+ Help1.Caption := gettext(POPUP_CAPTION_HELP);
+ Quit1.Caption := gettext(POPUP_CAPTION_QUIT);
+end;
+
+
//Avoiding close action.
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
@@ -191,9 +230,9 @@
begin
if Form1.isBalloonCanShow() then
begin
- Form1.ShowBalloonTips('TuxBox 2.0 is now hidden in the tray icon' + slinebreak +
- 'To open it again, please double-click the tray icon.' +
- slinebreak + 'Click here to make this message disappear.');
+ Form1.ShowBalloonTips(gettext(TUX_BOX_HIDDEN_0) + slinebreak +
+ gettext(TUX_BOX_HIDDEN_1) + slinebreak +
+ gettext(TUX_BOX_HIDDEN_2));
end;
CanClose := False;
Form1.Hide;
@@ -297,8 +336,8 @@
end
else if TuxUtils.isTuxDroidServerStarted() then
begin
- dialogs.ShowMessage('Can not stop the Tux Droid server' + slinebreak +
- 'Please, go to start menu to manually stop it.');
+ Form1.ShowBalloonTips(gettext(SERVER_STOP_ERROR_0) + slinebreak +
+ gettext(SERVER_STOP_ERROR_1));
end;
end;
@@ -514,6 +553,8 @@
{AddSysTrayIcon procedure add an icon to notification area}
procedure TForm1.AddSysTrayIcon();
+var
+ value : string;
begin
balloonShowed := false;
IconData.cbSize := SizeOf(IconData);
@@ -523,7 +564,11 @@
IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
IconData.uCallbackMessage := TRAY_CALLBACK;
IconData.hIcon := Application.Icon.Handle; //an Icon's Handle
- IconData.szTip := 'TuxBox 2.0 Show / Hide';
+
+ value := gettext(TUX_BOX_SHOW_HIDE);
+
+ StrLCopy(IconData.szTip, PAnsiChar(String(value)), SizeOf(IconData.szTip) -1 );
+
if not Shell_NotifyIcon(NIM_ADD, @IconData) then
Application.Terminate;
end;
@@ -540,7 +585,7 @@
TipInfo := mess;
strPLCopy(IconData.szInfo, TipInfo, SizeOf(IconData.szInfo) - 1);
IconData.DUMMYUNIONNAME.uTimeout := 2000;
- TipTitle := 'TuxBox 2.0 Warning';
+ TipTitle := gettext(TUX_BOX_WARNING_MSG);
strPLCopy(IconData.szInfoTitle, TipTitle, SizeOf(IconData.szInfoTitle) - 1);
IconData.dwInfoFlags := NIIF_INFO; //NIIF_ERROR; //NIIF_WARNING;
Shell_NotifyIcon(NIM_MODIFY, @IconData);
@@ -552,11 +597,14 @@
{Hide the balloon}
Procedure TForm1.HideBalloonTips();
+var
+ value : string;
begin
balloonShowed := false;
IconData.cbSize := SizeOf(IconData);
IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
- IconData.szTip := 'TuxBox 2.0 Show / Hide';
+ value := gettext(TUX_BOX_SHOW_HIDE);
+ StrLCopy(IconData.szTip, PAnsiChar(String(value)), SizeOf(IconData.szTip) -1 );
Shell_NotifyIcon(NIM_MODIFY, @IconData)
end;
@@ -565,8 +613,7 @@
procedure TForm1.DeleteSysTrayIcon;
begin
DeallocateHWnd(IconData.Wnd);
- if not Shell_NotifyIcon(NIM_DELETE, @IconData) then
- ShowMessage('Tray icon deletion failed');
+ Shell_NotifyIcon(NIM_DELETE, @IconData)
end;
Added: software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/gnugettext.dcu
===================================================================
(Binary files differ)
Property changes on: software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/gnugettext.dcu
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/gnugettext.pas
===================================================================
--- software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/gnugettext.pas (rev 0)
+++ software_suite_v3/software/tool/tux_droid_browser/windows/trunk/tux_droid_browser/gnugettext.pas 2009-07-28 12:38:23 UTC (rev 5204)
@@ -0,0 +1,2875 @@
+{*------------------------------------------------------------------------------
+ GNU gettext translation system for Delphi, Kylix, C++ Builder and others.
+ All parts of the translation system are kept in this unit.
+
+ @author Lars B. Dybdahl and others
+ @version $LastChangedRevision: 153 $
+ @see http://dybdahl.dk/dxgettext/
+-------------------------------------------------------------------------------}
+unit gnugettext;
+(**************************************************************)
+(* *)
+(* (C) Copyright by Lars B. Dybdahl and others *)
+(* E-mail: La...@dy..., phone +45 70201241 *)
+(* *)
+(* Contributors: Peter Thornqvist, Troy Wolbrink, *)
+(* Frank Andreas de Groot, Igor Siticov, *)
+(* Jacques Garcia Vazquez *)
+(* *)
+(* See http://dybdahl.dk/dxgettext/ for more information *)
+(* *)
+(**************************************************************)
+
+// Information about this file:
+// $LastChangedDate: 2008-03-10 10:29:54 +0100 (ma, 10 mar 2008) $
+// $LastChangedRevision: 153 $
+// $HeadURL: https://dybdahl@svn.berlios.de/svnroot/repos/dxgettext/trunk/dxgettext/sample/gnugettext.pas $
+
+// Redistribution and use in source and binary forms, with or without
+// modification, are permitted provided that the following conditions are met:
+//
+// The names of any contributor may not be used to endorse or promote
+// products derived from this software without specific prior written permission.
+//
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+// ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+// LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+interface
+
+// If the conditional define DXGETTEXTDEBUG is defined, debugging log is activated.
+// Use DefaultInstance.DebugLogToFile() to write the log to a file.
+{ $define DXGETTEXTDEBUG}
+
+
+uses
+{$ifdef MSWINDOWS}
+ Windows,
+{$else}
+ Libc,
+{$ifdef FPC}
+ CWString,
+{$endif}
+{$endif}
+ Classes, SysUtils, TypInfo;
+
+(*****************************************************************************)
+(* *)
+(* MAIN API *)
+(* *)
+(*****************************************************************************)
+
+// Main GNU gettext functions. See documentation for instructions on how to use them.
+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;
+procedure textdomain(const szDomain: string);
+function getcurrenttextdomain: string;
+procedure bindtextdomain(const szDomain: string; const szDirectory: string);
+
+// Set language to use
+procedure UseLanguage(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:string);
+procedure TP_IgnoreClass (IgnClass:TClass);
+procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:string);
+procedure TP_GlobalIgnoreClass (IgnClass:TClass);
+procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:string);
+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);
+
+// Unicode-enabled way to get resourcestrings, automatically translated
+// Use like this: ws:=LoadResStringW(@NameOfResourceString);
+function LoadResString(ResStringRec: PResStringRec): widestring;
+function LoadResStringA(ResStringRec: PResStringRec): ansistring;
+function LoadResStringW(ResStringRec: PResStringRec): widestring;
+
+// This returns an empty string if not translated or translator name is not specified.
+function GetTranslatorNameAndEmail:widestring;
+
+
+(*****************************************************************************)
+(* *)
+(* ADVANCED FUNCTIONALITY *)
+(* *)
+(*****************************************************************************)
+
+const
+ DefaultTextDomain = 'default';
+
+var
+ ExecutableFilename:string; // This is set to paramstr(0) or the name of the DLL you are creating.
+
+const
+ PreferExternal=false; // Set to true, to prefer external *.mo over embedded translation
+
+const
+ // Subversion source code version control version information
+ VCSVersion='$LastChangedRevision: 153 $';
+
+type
+ EGnuGettext=class(Exception);
+ EGGProgrammingError=class(EGnuGettext);
+ EGGComponentError=class(EGnuGettext);
+ EGGIOError=class(EGnuGettext);
+ EGGAnsi2WideConvError=class(EGnuGettext);
+
+// This function will turn resourcestring hooks on or off, eventually with BPL file support.
+// Please do not activate BPL file support when the package is in design mode.
+const AutoCreateHooks=true;
+procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);
+
+
+
+
+(*****************************************************************************)
+(* *)
+(* CLASS based implementation. *)
+(* Use TGnuGettextInstance to have more than one language *)
+(* in your application at the same time *)
+(* *)
+(*****************************************************************************)
+
+{$ifdef MSWINDOWS}
+{$ifndef VER140}
+{$WARN UNSAFE_TYPE OFF}
+{$WARN UNSAFE_CODE OFF}
+{$WARN UNSAFE_CAST OFF}
+{$endif}
+{$endif}
+
+type
+ TOnDebugLine = Procedure (Sender: TObject; const Line: String; var Discard: Boolean) of Object; // Set Discard to false if output should still go to ordinary debug log
+ TGetPluralForm=function (Number:Longint):Integer;
+ TDebugLogger=procedure (line: ansistring) of object;
+
+{*------------------------------------------------------------------------------
+ Handles .mo files, in separate files or inside the exe file.
+ Don't use this class. It's for internal use.
+-------------------------------------------------------------------------------}
+ TMoFile=
+ class /// Threadsafe. Only constructor and destructor are writing to memory
+ private
+ doswap: boolean;
+ public
+ Users:Integer; /// Reference count. If it reaches zero, this object should be destroyed.
+ constructor Create (filename:string;Offset,Size:int64);
+ destructor Destroy; override;
+ 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;
+ {$ifdef mswindows}
+ mo: THandle;
+ momapping: THandle;
+ {$endif}
+ momemoryHandle:PChar;
+ momemory: PChar;
+ function autoswap32(i: cardinal): cardinal;
+ function CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;
+ end;
+
+{*------------------------------------------------------------------------------
+ Handles all issues regarding a specific domain.
+ Don't use this class. It's for internal use.
+-------------------------------------------------------------------------------}
+ TDomain=
+ class
+ private
+ Enabled:boolean;
+ vDirectory: string;
+ procedure setDirectory(const dir: 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;
+
+{*------------------------------------------------------------------------------
+ Helper class for invoking events.
+-------------------------------------------------------------------------------}
+ TExecutable=
+ class
+ procedure Execute; virtual; abstract;
+ end;
+
+{*------------------------------------------------------------------------------
+ The main translation engine.
+-------------------------------------------------------------------------------}
+ TGnuGettextInstance=
+ class
+ private
+ fOnDebugLine:TOnDebugLine;
+ CreatorThread:Cardinal; /// Only this thread can use LoadResString
+ public
+ Enabled:Boolean; /// Set this to false to disable translations
+ DesignTimeCodePage:Integer; /// See MultiByteToWideChar() in Win32 API for documentation
+ constructor Create;
+ destructor Destroy; override;
+ procedure UseLanguage(LanguageCode: string);
+ procedure GetListOfLanguages (const domain:string; list:TStrings); // Puts list of language codes, for which there are translations in the specified domain, into list
+ function gettext(const szMsgId: ansistring): widestring; overload; virtual;
+ function gettext(const szMsgId: widestring): widestring; overload; virtual;
+ function ngettext(const singular,plural:ansistring;Number:longint):widestring; overload; virtual;
+ function ngettext(const singular,plural:widestring;Number:longint):widestring; overload; virtual;
+ function GetCurrentLanguage:string;
+ function GetTranslationProperty (const Propertyname:string):WideString;
+ function GetTranslatorNameAndEmail:widestring;
+
+ // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites()
+ procedure TP_Ignore(AnObject:TObject; const name:string);
+ procedure TP_IgnoreClass (IgnClass:TClass);
+ procedure TP_IgnoreClassProperty (IgnClass:TClass;propertyname:string);
+ procedure TP_GlobalIgnoreClass (IgnClass:TClass);
+ procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
+ 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
+ function dgettext(const szDomain: string; const szMsgId: ansistring): widestring; overload; virtual;
+ function dgettext(const szDomain: string; const szMsgId: widestring): widestring; overload; virtual;
+ function dngettext(const szDomain: string; const singular,plural:ansistring;Number:longint):widestring; overload; virtual;
+ function dngettext(const szDomain: string; const singular,plural:widestring;Number:longint):widestring; overload; virtual;
+ procedure textdomain(const szDomain: string);
+ function getcurrenttextdomain: string;
+ procedure bindtextdomain(const szDomain: string; const szDirectory: string);
+ procedure bindtextdomainToFile (const szDomain: string; const filename: string); // Also works with files embedded in exe file
+
+ // Windows API functions
+ function LoadResString(ResStringRec: PResStringRec): widestring;
+
+ // 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 ansi2wideDTCP (const s:ansistring):widestring; // Convert using Design Time Code Page
+ 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:string); 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:TList; /// Items are TClassMode. If a is derived from b, a comes first
+ TP_GlobalClassHandling:TList; /// Items are TClassMode. If a is derived from b, a comes first
+ TP_Retranslator:TExecutable; /// Cast this to TTP_Retranslator
+ DebugLogCS:TMultiReadExclusiveWriteSynchronizer;
+ DebugLog:TStream;
+ DebugLogOutputPaused:Boolean;
+ function TP_CreateRetranslator:TExecutable; // Must be freed by caller!
+ procedure FreeTP_ClassHandlingItems;
+ procedure DebugWriteln(line: ansistring);
+ procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;
+ TodoList: TStrings; const TextDomain:string);
+ function Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain; // Translates a single property of an object
+ end;
+
+const
+ LOCALE_SISO639LANGNAME = $59; // Used by Lazarus software development tool
+ LOCALE_SISO3166CTRYNAME = $5A; // Used by Lazarus software development tool
+
+var
+ DefaultInstance:TGnuGettextInstance; /// Default instance of the main API for singlethreaded applications.
+
+implementation
+
+{$ifndef MSWINDOWS}
+{$ifndef LINUX}
+ 'This version of gnugettext.pas is only meant to be compiled with Kylix 3,'
+ 'Delphi 6, Delphi 7 and later versions. If you use other versions, please'
+ 'get the gnugettext.pas version from the Delphi 5 directory.'
+{$endif}
+{$endif}
+
+(**************************************************************************)
+// Some comments on the implementation:
+// This unit should be independent of other units where possible.
+// It should have a small footprint in any way.
+(**************************************************************************)
+// TMultiReadExclusiveWriteSynchronizer is used instead of TCriticalSection
+// because it makes this unit independent of the SyncObjs unit
+(**************************************************************************)
+
+{$B-,R+,I+,Q+}
+
+type
+ TTP_RetranslatorItem=
+ class
+ obj:TObject;
+ Propname:string;
+ OldValue:WideString;
+ end;
+ TTP_Retranslator=
+ class (TExecutable)
+ TextDomain:string;
+ Instance:TGnuGettextInstance;
+ constructor Create;
+ destructor Destroy; override;
+ procedure Remember (obj:TObject; PropName:String; OldValue:WideString);
+ procedure Execute; override;
+ private
+ list:TList;
+ end;
+ 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 (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:string;
+ Retranslator:TExecutable;
+ destructor Destroy; override;
+ end;
+ TClassMode=
+ class
+ HClass:TClass;
+ SpecialHandler:TTranslator;
+ PropertiesToIgnore:TStringList; // This is ignored if Handler is set
+ constructor Create;
+ destructor Destroy; override;
+ end;
+ TRStrinfo = record
+ strlength, stroffset: cardinal;
+ end;
+ TStrInfoArr = array[0..10000000] of TRStrinfo;
+ PStrInfoArr = ^TStrInfoArr;
+ TCharArray5=array[0..4] of ansichar;
+ THook= // Replaces a runtime library procedure with a custom procedure
+ class
+ public
+ constructor Create (OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);
+ destructor Destroy; override; // Restores unhooked state
+ procedure Reset (FollowJump:boolean=false); // Disables and picks up patch points again
+ procedure Disable;
+ procedure Enable;
+ private
+ oldproc,newproc:Pointer;
+ Patch:TCharArray5;
+ Original:TCharArray5;
+ PatchPosition:PChar;
+ procedure Shutdown; // Same as destroy, except that object is not destroyed
+ end;
+
+var
+ // System information
+ Win32PlatformIsUnicode:boolean=False;
+
+ // Information about files embedded inside .exe file
+ FileLocator:TFileLocator;
+
+ // Hooks into runtime library functions
+ ResourceStringDomainListCS:TMultiReadExclusiveWriteSynchronizer;
+ ResourceStringDomainList:TStringList;
+ HookLoadResString:THook;
+ HookLoadStr:THook;
+ HookFmtLoadStr:THook;
+
+function GGGetEnvironmentVariable(const Name:string):string;
+var
+ Len: integer;
+ W : String;
+begin
+ Result := '';
+ SetLength(W,1);
+ Len := Windows.GetEnvironmentVariable(PChar(Name), PChar(W), 1);
+ if Len > 0 then begin
+ SetLength(Result, Len - 1);
+ Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), Len);
+ end;
+end;
+
+function StripCR (s:string):string;
+var
+ i:integer;
+begin
+ i:=1;
+ while i<=length(s) do begin
+ if s[i]=#13 then delete (s,i,1) else inc (i);
+ end;
+ Result:=s;
+end;
+
+function LF2LineBreakA (s:string):string;
+{$ifdef MSWINDOWS}
+var
+ i:integer;
+{$endif}
+begin
+ {$ifdef MSWINDOWS}
+ Assert (sLinebreak=#13#10);
+ i:=1;
+ while i<=length(s) do begin
+ if (s[i]=#10) and (copy(s,i-1,1)<>#13) then begin
+ insert (#13,s,i);
+ inc (i,2);
+ end else
+ inc (i);
+ end;
+ {$endif}
+ Result:=s;
+end;
+
+function IsWriteProp(Info: PPropInfo): Boolean;
+begin
+ Result := Assigned(Info) and (Info^.SetProc <> nil);
+end;
+
+function string2csyntax(s: string): string;
+// Converts a string to the syntax that is used in .po files
+var
+ i: integer;
+ c: char;
+begin
+ Result := '';
+ for i := 1 to length(s) do begin
+ c := s[i];
+ case c of
+ #32..#33, #35..#255: Result := Result + c;
+ #13: Result := Result + '\r';
+ #10: Result := Result + '\n"'#13#10'"';
+ #34: Result := Result + '\"';
+ else
+ Result := Result + '\0x' + IntToHex(ord(c), 2);
+ end;
+ end;
+ Result := '"' + Result + '"';
+end;
+
+function ResourceStringGettext(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;
+
+function gettext(const szMsgId: widestring): widestring;
+begin
+ Result:=DefaultInstance.gettext(szMsgId);
+end;
+
+{*------------------------------------------------------------------------------
+ This is the main translation procedure used in programs. It takes a parameter,
+ looks it up in the translation dictionary, and returns the translation.
+ If no translation is found, the parameter is returned.
+
+ @param szMsgId The text, that should be displayed if no translation is found.
+-------------------------------------------------------------------------------}
+function _(const szMsgId: widestring): widestring;
+begin
+ Result:=DefaultInstance.gettext(szMsgId);
+end;
+
+{*------------------------------------------------------------------------------
+ Translates a text, using a specified translation domain.
+ If no translation is found, the parameter is returned.
+
+ @param szDomain Which translation domain that should be searched for a translation.
+ @param szMsgId The text, that should be displayed if no translation is found.
+-------------------------------------------------------------------------------}
+function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
+begin
+ Result:=DefaultInstance.dgettext(szDomain, szMsgId);
+end;
+
+function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
+begin
+ Result:=DefaultInstance.dngettext(szDomain,singular,plural,Number);
+end;
+
+function ngettext(const singular,plural: widestring; Number:longint): widestring;
+begin
+ Result:=DefaultInstance.ngettext(singular,plural,Number);
+end;
+
+procedure textdomain(const szDomain: string);
+begin
+ DefaultInstance.textdomain(szDomain);
+end;
+
+procedure SetGettextEnabled (enabled:boolean);
+begin
+ DefaultInstance.Enabled:=enabled;
+end;
+
+function getcurrenttextdomain: string;
+begin
+ Result:=DefaultInstance.getcurrenttextdomain;
+end;
+
+procedure bindtextdomain(const szDomain: string; const szDirectory: string);
+begin
+ DefaultInstance.bindtextdomain(szDomain, szDirectory);
+end;
+
+procedure TP_Ignore(AnObject:TObject; const name:string);
+begin
+ DefaultInstance.TP_Ignore(AnObject, name);
+end;
+
+procedure TP_GlobalIgnoreClass (IgnClass:TClass);
+begin
+ DefaultInstance.TP_GlobalIgnoreClass(IgnClass);
+end;
+
+procedure TP_IgnoreClass (IgnClass:TClass);
+begin
+ DefaultInstance.TP_IgnoreClass(IgnClass);
+end;
+
+procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:string);
+begin
+ DefaultInstance.TP_IgnoreClassProperty(IgnClass,propertyname);
+end;
+
+procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:string);
+begin
+ DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass,propertyname);
+end;
+
+procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
+begin
+ DefaultInstance.TP_GlobalHandleClass (HClass, Handler);
+end;
+
+procedure TranslateComponent(AnObject: TComponent; const TextDomain: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 GetWindowsLanguage: string;
+var
+ langid: Cardinal;
+ langcode: string;
+ CountryName: array[0..4] of char;
+ LanguageName: array[0..4] of char;
+ works: boolean;
+begin
+ // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero
+ works := 3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName));
+ works := works and (3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName,
+ SizeOf(CountryName)));
+ if works then begin
+ // Windows 98, Me, NT4, 2000, XP and newer
+ LangCode := PChar(@LanguageName[0]);
+ if lowercase(LangCode)='no' then LangCode:='nb';
+ LangCode:=LangCode + '_' + 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 := 'el_GR';
+ IDIcelandic: langcode := 'is_IS';
+ IDItalian: langcode := 'it_IT';
+ IDKorean: langcode := 'ko_KO';
+ IDNorwegianBokmol: langcode := 'nb_NO';
+ IDNorwegianNynorsk: langcode := 'nn_NO';
+ IDPolish: langcode := 'pl_PL';
+ IDPortuguese: langcode := 'pt_PT';
+ IDRussian: langcode := 'ru_RU';
+ IDSpanish, IDSpanishModernSort: langcode := 'es_ES';
+ IDSwedish: langcode := 'sv_SE';
+ IDSwedishFinland: langcode := 'sv_FI';
+ else
+ langcode := 'C';
+ end;
+ end;
+ Result := langcode;
+end;
+{$endif}
+
+function LoadResStringA(ResStringRec: PResStringRec): string;
+begin
+ Result:=DefaultInstance.LoadResString(ResStringRec);
+end;
+
+function GetTranslatorNameAndEmail:widestring;
+begin
+ Result:=DefaultInstance.GetTranslatorNameAndEmail;
+end;
+
+procedure UseLanguage(LanguageCode: string);
+begin
+ DefaultInstance.UseLanguage(LanguageCode);
+end;
+
+type
+ PStrData = ^TStrData;
+ TStrData = record
+ Ident: Integer;
+ Str: string;
+ end;
+
+function SysUtilsEnumStringModules(Instance: Longint; Data: Pointer): Boolean;
+{$IFDEF MSWINDOWS}
+var
+ Buffer: array [0..1023] of char;
+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): string;
+var
+ StrData: TStrData;
+begin
+ StrData.Ident := Ident;
+ StrData.Str := '';
+ EnumResourceModules(SysUtilsEnumStringModules, @StrData);
+ Result := StrData.Str;
+end;
+
+function SysUtilsLoadStr(Ident: Integer): string;
+begin
+ {$ifdef DXGETTEXTDEBUG}
+ DefaultInstance.DebugWriteln ('Sysutils.LoadRes('+IntToStr(ident)+') called');
+ {$endif}
+ Result := ResourceStringGettext(SysUtilsFindStringResource(Ident));
+end;
+
+function SysUtilsFmtLoadStr(Ident: Integer; const Args: array of const): string;
+begin
+ {$ifdef DXGETTEXTDEBUG}
+ DefaultInstance.DebugWriteln ('Sysutils.FmtLoadRes('+IntToStr(ident)+',Args) called');
+ {$endif}
+ FmtStr(Result, 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;
+
+
+
+function GetCurrentLanguage:string;
+begin
+ Result:=DefaultInstance.GetCurrentLanguage;
+end;
+
+{ TDomain }
+
+procedure TDomain.CloseMoFile;
+begin
+ if mofile<>nil then begin
+ FileLocator.ReleaseMoFile(mofile);
+ mofile:=nil;
+ end;
+ OpenHasFailedBefore:=False;
+end;
+
+destructor TDomain.Destroy;
+begin
+ CloseMoFile;
+ inherited;
+end;
+
+{$ifdef mswindows}
+function GetLastWinError:string;
+var
+ errcode:Cardinal;
+begin
+ SetLength (Result,2000);
+ errcode:=GetLastError();
+ Windows.FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PChar(Result),2000,nil);
+ Result:=StrPas(PChar(Result));
+end;
+{$endif}
+
+procedure TDomain.OpenMoFile;
+var
+ 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 begin
+ filename:=SpecificFilename;
+ {$ifdef DXGETTEXTDEBUG}
+ DebugLogger ('Domain '+domain+' is bound to specific file '+filename);
+ {$endif}
+ end else begin
+ filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
+ if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin
+ {$ifdef DXGETTEXTDEBUG}
+ DebugLogger ('Domain '+domain+': File does not exist, neither embedded or in file system: '+filename);
+ {$endif}
+ filename := Directory + copy(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
+ {$ifdef DXGETTEXTDEBUG}
+ DebugLogger ('Domain '+domain+' will attempt to use this file: '+filename);
+ {$endif}
+ end else begin
+ {$ifdef DXGETTEXTDEBUG}
+ if FileLocator.FileExists(filename) then
+ DebugLogger ('Domain '+domain+' will attempt to use this embedded file: '+filename)
+ else
+ DebugLogger ('Domain '+domain+' will attempt to use this file that was found on the file system: '+filename);
+ {$endif}
+ end;
+ end;
+ if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin
+ {$ifdef DXGETTEXTDEBUG}
+ DebugLogger ('Domain '+domain+' failed to locate the file: '+filename);
+ {$endif}
+ OpenHasFailedBefore:=True;
+ exit;
+ end;
+ {$ifdef DXGETTEXTDEBUG}
+ DebugLogger ('Domain '+domain+' now accesses the file.');
+ {$endif}
+ mofile:=FileLocator.GetMoFile(filename, DebugLogger);
+
+ {$ifdef DXGETTEXTDEBUG}
+ if mofile.isSwappedArchitecture then
+ DebugLogger ('.mo file is swapped (comes from another CPU architecture)');
+ {$endif}
+
+ // Check, that the contents of the file is utf-8
+ if pos('CHARSET=UTF-8',uppercase(GetTranslationProperty('Content-Type')))=0 then begin
+ CloseMoFile;
+ {$ifdef DXGETTEXTDEBUG}
+ DebugLogger ('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.');
+ {$endif}
+ {$ifdef MSWINDOWS}
+ MessageBox(0,PChar('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.'),'Localization problem',MB_OK);
+ {$else}
+ writeln (stderr,'The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.');
+ {$endif}
+ Enabled:=False;
+ end;
+end;
+
+function TDomain.GetTranslationProperty(
+ Propertyname: string): WideString;
+var
+ sl:TStringList;
+ i:integer;
+ s:string;
+begin
+ Propertyname:=uppercase(Propertyname)+': ';
+ sl:=TStringList.Create;
+ try
+ sl.Text:=gettext(''); // Everything is UTF-8
+ for i:=0 to sl.Count-1 do begin
+ s:=sl.Strings[i];
+ if uppercase(copy(s,1,length(Propertyname)))=Propertyname then begin
+ Result:=utf8decode(trim(copy(s,length(PropertyName)+1,maxint)));
+ {$ifdef DXGETTEXTDEBUG}
+ DebugLogger ('GetTranslationProperty('+PropertyName+') returns '''+Result+'''.');
+ {$endif}
+ exit;
+ end;
+ end;
+ finally
+ FreeAndNil (sl);
+ end;
+ Result:='';
+ {$ifdef DXGETTEXTDEBUG}
+ DebugLogger ('GetTranslationProperty('+PropertyName+') did not find any value. An empty string is returned.');
+ {$endif}
+end;
+
+procedure TDomain.setDirectory(const dir: string);
+begin
+ vDirectory := IncludeTrailingPathDelimiter(dir);
+ 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 Number=1 then Result:=0
+ else if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
+ else Result:=2;
+end;
+
+function GetPluralForm3RU(Number: Integer): Integer;
+var
+ n1,n2:byte;
+begin
+ Number:=abs(Number);
+ n1:=Number mod 10;
+ n2:=Number mod 100;
+ if (n1=1) and (n2<>11) then
+ Result:=0
+ else
+ if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
+ else Result:=2;
+end;
+
+function GetPluralForm3SK(Number: Integer): Integer;
+begin
+ Number:=abs(Number);
+ if number=1 then Result:=0
+ else if (number<5) and (number<>0) then Result:=1
+ else Result:=2;
+end;
+
+function GetPluralForm4SL(Number: Integer): Integer;
+var
+ n2:byte;
+begin
+ Number:=abs(Number);
+ n2:=Number mod 100;
+ if n2=1 then Result:=0
+ else
+ if n2=2 then Result:=1
+ else
+ if (n2=3) or (n2=4) then Result:=2
+ else
+ Result:=3;
+end;
+
+procedure TDomain.GetListOfLanguages(list: TStrings);
+var
+ sr:TSearchRec;
+ more:boolean;
+ filename, path, langcode:string;
+ i, j:integer;
+begin
+ list.Clear;
+
+ // Iterate through filesystem
+ more:=FindFirst (Directory+'*',faAnyFile,sr)=0;
+ try
+ while more do begin
+ if (sr.Attr and faDirectory<>0) and (sr.name<>'.') and (sr.name<>'..') then begin
+ filename := Directory + sr.Name + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
+ if fileexists(filename) then begin
+ langcode:=lowercase(sr.name);
+ if list.IndexOf(langcode)=-1 then
+ list.Add(langcode);
+ end;
+ end;
+ more:=FindNext (sr)=0;
+ end;
+ finally
+ FindClose (sr);
+ end;
+
+ // Iterate through embedded files
+ for i:=0 to FileLocator.filelist.Count-1 do begin
+ filename:=FileLocator.basedirectory+FileLocator.filelist.Strings[i];
+ path:=Directory;
+ {$ifdef MSWINDOWS}
+ path:=uppercase(path);
+ filename:=uppercase(filename);
+ {$endif}
+ j:=length(path);
+ if copy(filename,1,j)=path then begin
+ path:=PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
+ {$ifdef MSWINDOWS}
+ path:=uppercase(path);
+ {$endif}
+ if copy(filename,length(filename)-length(path)+1,length(path))=path then begin
+ langcode:=lowercase(copy(filename,j+1,length(filename)-length(path)-j));
+ langcode:=copy(langcode,1,3)+uppercase(copy(langcode,4,maxint));
+ 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
+ CreatorThread:=GetCurrentThreadId;
+ {$ifdef MSWindows}
+ DesignTimeCodePage:=CP_ACP;
+ {$endif}
+ {$ifdef DXGETTEXTDEBUG}
+ DebugLogCS:=TMultiReadExclusiveWriteSynchronizer.Create;
+ DebugLog:=TMemoryStream.Create;
+ DebugWriteln('Debug log started '+DateTimeToStr(Now));
+ DebugWriteln('GNU gettext module version: '+VCSVersion);
+ DebugWriteln('');
+ {$endif}
+ curGetPluralForm:=GetPluralForm2EN;
+ Enabled:=True;
+ curmsgdomain:=DefaultTextDomain;
+ savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;
+ domainlist := TStringList.Create;
+ TP_IgnoreList:=TStringList.Create;
+ TP_IgnoreList.Sorted:=True;
+ TP_GlobalClassHandling:=TList.Create;
+ TP_ClassHandling:=TList.Create;
+
+ // Set some settings
+ DefaultDomainDirectory := IncludeTrailingPathDelimiter(extractfilepath(ExecutableFilename))+'locale';
+
+ UseLanguage('');
+
+ bindtextdomain(DefaultTextDomain, DefaultDomainDirectory);
+ textdomain(DefaultTextDomain);
+
+ // Add default properties to ignore
+ TP_GlobalIgnoreClassProperty(TComponent,'Name');
+ TP_GlobalIgnoreClassProperty(TCollection,'PropName');
+end;
+
+destructor TGnuGettextInstance.Destroy;
+begin
+ if savememory <> nil then begin
+ savefileCS.BeginWrite;
+ try
+ CloseFile(savefile);
+ finally
+ savefileCS.EndWrite;
+ end;
+ FreeAndNil(savememory);
+ end;
+ FreeAndNil (savefileCS);
+ FreeAndNil (TP_IgnoreList);
+ while TP_GlobalClassHandling.Count<>0 do begin
+ TObject(TP_GlobalClassHandling.Items[0]).Free;
+ TP_GlobalClassHandling.Delete(0);
+ end;
+ FreeAndNil (TP_GlobalClassHandling);
+ FreeTP_ClassHandlingItems;
+ FreeAndNil (TP_ClassHandling);
+ while domainlist.Count <> 0 do begin
+ domainlist.Objects[0].Free;
+ domainlist.Delete(0);
+ end;
+ FreeAndNil(domainlist);
+ {$ifdef DXGETTEXTDEBUG}
+ FreeAndNil (DebugLog);
+ FreeAndNil (DebugLogCS);
+ {$endif}
+ inherited;
+end;
+
+function TGnuGettextInstance.dgettext(const szDomain: string; const szMsgId: ansistring): widestring;
+begin
+ Result:=dgettext(szDomain, ansi2wideDTCP(szMsgId));
+end;
+
+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;
+
+function TGnuGettextInstance.gettext(
+ const szMsgId: ansistring): widestring;
+begin
+ Result := dgettext(curmsgdomain, szMsgId);
+end;
+
+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:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
+ if cm.HClass=HClass then
+ raise EGGProgrammingError.Create ('You cannot set a handler for a class that has already been assigned otherwise.');
+ if HClass.InheritsFrom(cm.HClass) then begin
+ // This is the place to insert this class
+ cm:=TClassMode.Create;
+ cm.HClass:=HClass;
+ cm.SpecialHandler:=Handler;
+ TP_GlobalClassHandling.Insert(i,cm);
+ {$ifdef DXGETTEXTDEBUG}
+ DebugWriteln ('A handler was set for class '+HClass.ClassName+'.');
+ {$endif}
+ exit;
+ end;
+ end;
+ cm:=TClassMo...
[truncated message content] |
