diff --git a/packages/delphiXE/heidisql.dpr b/packages/delphiXE/heidisql.dpr index 48ff8443..9a71e344 100644 --- a/packages/delphiXE/heidisql.dpr +++ b/packages/delphiXE/heidisql.dpr @@ -39,7 +39,8 @@ uses loginform in '..\..\source\loginform.pas' {frmLogin}, Cromis.DirectoryWatch in '..\..\source\Cromis.DirectoryWatch.pas', exportgrid in '..\..\source\exportgrid.pas' {frmExportGrid}, - syncdb in '..\..\source\syncdb.pas' {frmSyncDB}; + syncdb in '..\..\source\syncdb.pas' {frmSyncDB}, + gnugettext in '..\..\source\gnugettext.pas'; {$R ..\..\res\icon.RES} {$R ..\..\res\version.RES} diff --git a/packages/delphiXE/heidisql.dproj b/packages/delphiXE/heidisql.dproj index 7d2b3cc1..29115702 100644 --- a/packages/delphiXE/heidisql.dproj +++ b/packages/delphiXE/heidisql.dproj @@ -1,4 +1,4 @@ - + {53d02113-9bb2-4326-83eb-53734f07dae7} heidisql.dpr @@ -215,6 +215,7 @@
frmSyncDB
 +
updater.res
 diff --git a/source/about.pas b/source/about.pas index 83fbd7cc..1c160cd8 100644 --- a/source/about.pas +++ b/source/about.pas @@ -7,7 +7,7 @@ unit About; interface uses - Windows, Classes, Graphics, Forms, Controls, StdCtrls, ExtCtrls, SysUtils, ComCtrls, pngimage; + Windows, Classes, Graphics, Forms, Controls, StdCtrls, ExtCtrls, SysUtils, ComCtrls, pngimage, gnugettext; type TAboutBox = class(TForm) @@ -60,6 +60,8 @@ procedure TAboutBox.FormShow(Sender: TObject); begin Screen.Cursor := crHourGlass; + TranslateComponent(Self); + InheritFont(Font); InheritFont(lblAppName.Font); lblAppName.Font.Size := 14; diff --git a/source/bineditor.pas b/source/bineditor.pas index ff8d9889..da8e84e0 100644 --- a/source/bineditor.pas +++ b/source/bineditor.pas @@ -4,7 +4,7 @@ interface uses Windows, Classes, Graphics, Forms, Controls, StdCtrls, VirtualTrees, - ComCtrls, ToolWin, Dialogs, SysUtils; + ComCtrls, ToolWin, Dialogs, SysUtils, gnugettext; {$I const.inc} @@ -80,6 +80,7 @@ end; procedure TfrmBinEditor.FormCreate(Sender: TObject); begin InheritFont(Font); + TranslateComponent(Self); end; diff --git a/source/column_selection.pas b/source/column_selection.pas index a1359d47..c3e2880e 100644 --- a/source/column_selection.pas +++ b/source/column_selection.pas @@ -4,7 +4,7 @@ interface uses Windows, Classes, Controls, Forms, StdCtrls, CheckLst, ExtCtrls, - helpers; + helpers, gnugettext; type TColumnSelectionForm = class(TForm) @@ -44,6 +44,7 @@ uses main; procedure TColumnSelectionForm.FormCreate(Sender: TObject); begin InheritFont(Font); + TranslateComponent(Self); end; diff --git a/source/connections.pas b/source/connections.pas index 4373f875..46adb61d 100644 --- a/source/connections.pas +++ b/source/connections.pas @@ -11,7 +11,7 @@ interface uses Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls, VirtualTrees, Menus, Graphics, Generics.Collections, ActiveX, - dbconnection; + dbconnection, gnugettext; type Tconnform = class(TForm) @@ -174,6 +174,7 @@ var Params: TConnectionParameters; begin // Fix GUI stuff + TranslateComponent(Self); InheritFont(Font); SetWindowSizeGrip(Handle, True); Width := AppSettings.ReadInt(asSessionManagerWindowWidth); diff --git a/source/copytable.pas b/source/copytable.pas index 09d83631..143c7156 100644 --- a/source/copytable.pas +++ b/source/copytable.pas @@ -5,7 +5,7 @@ interface uses Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, - dbconnection, VirtualTrees, SynEdit, SynMemo, Menus; + dbconnection, VirtualTrees, SynEdit, SynMemo, Menus, gnugettext; type TCopyTableForm = class(TForm) @@ -66,6 +66,7 @@ const procedure TCopyTableForm.FormCreate(Sender: TObject); begin + TranslateComponent(Self); InheritFont(Font); Width := AppSettings.ReadInt(asCopyTableWindowWidth); Height := AppSettings.ReadInt(asCopyTableWindowHeight); diff --git a/source/createdatabase.pas b/source/createdatabase.pas index db78b799..ccbaf953 100644 --- a/source/createdatabase.pas +++ b/source/createdatabase.pas @@ -4,7 +4,7 @@ interface uses Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, SynEdit, SynMemo, - dbconnection; + dbconnection, gnugettext; type TCreateDatabaseForm = class(TForm) @@ -50,6 +50,7 @@ uses main, helpers; procedure TCreateDatabaseForm.FormCreate(Sender: TObject); begin InheritFont(Font); + TranslateComponent(Self); // Setup SynMemoPreview SynMemoPreview.Highlighter := Mainform.SynSQLSyn1; end; diff --git a/source/data_sorting.pas b/source/data_sorting.pas index 835e3764..a63a5135 100644 --- a/source/data_sorting.pas +++ b/source/data_sorting.pas @@ -5,7 +5,7 @@ interface uses Windows, SysUtils, Classes, Controls, Forms, StdCtrls, ExtCtrls, ComCtrls, Buttons, - helpers; + helpers, gnugettext; type @@ -54,6 +54,7 @@ uses main; procedure TDataSortingForm.FormCreate(Sender: TObject); begin InheritFont(Font); + TranslateComponent(Self); ColumnNames := TStringList.Create; end; diff --git a/source/editvar.pas b/source/editvar.pas index 16bac896..d8f57c1b 100644 --- a/source/editvar.pas +++ b/source/editvar.pas @@ -4,7 +4,7 @@ interface uses Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, - dbconnection, mysql_structures, ComCtrls; + dbconnection, mysql_structures, ComCtrls, gnugettext; type TVarType = (vtString, vtNumeric, vtBoolean, vtEnum); @@ -56,6 +56,7 @@ uses main, helpers; procedure TfrmEditVariable.FormCreate(Sender: TObject); begin InheritFont(Font); + TranslateComponent(Self); SetWindowSizeGrip(Handle, True); Width := AppSettings.ReadInt(asEditVarWindowWidth); Height := AppSettings.ReadInt(asEditVarWindowHeight); diff --git a/source/event_editor.pas b/source/event_editor.pas index c3d6374e..3360523b 100644 --- a/source/event_editor.pas +++ b/source/event_editor.pas @@ -5,7 +5,7 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, SynEdit, SynMemo, SynRegExpr, ComCtrls, ExtCtrls, WideStrUtils, - helpers, dbconnection; + helpers, dbconnection, gnugettext; type TFrame = TDBObjectEditor; @@ -74,6 +74,7 @@ uses main; constructor TfrmEventEditor.Create(AOwner: TComponent); begin inherited; + TranslateComponent(Self); Mainform.SynCompletionProposal.AddEditor(SynMemoBody); comboEveryInterval.Items := Explode('|', 'YEAR|QUARTER|MONTH|DAY|HOUR|MINUTE|WEEK|SECOND|YEAR_MONTH|'+ 'DAY_HOUR|DAY_MINUTE|DAY_SECOND|HOUR_MINUTE|HOUR_SECOND|MINUTE_SECOND'); diff --git a/source/exportgrid.pas b/source/exportgrid.pas index f65eff2f..08dd01f3 100644 --- a/source/exportgrid.pas +++ b/source/exportgrid.pas @@ -4,7 +4,7 @@ interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, ExtCtrls, Menus, ComCtrls, VirtualTrees, SynExportHTML; + Dialogs, StdCtrls, ExtCtrls, Menus, ComCtrls, VirtualTrees, SynExportHTML, gnugettext; type TGridExportFormat = (efExcel, efCSV, efHTML, efXML, efSQLInsert, efSQLReplace, efLaTeX, efWiki, efPHPArray); @@ -94,6 +94,7 @@ procedure TfrmExportGrid.FormCreate(Sender: TObject); var FormatDesc: String; begin + TranslateComponent(Self); InheritFont(Font); editFilename.Text := AppSettings.ReadString(asGridExportFilename); radioOutputCopyToClipboard.Checked := AppSettings.ReadBool(asGridExportOutputCopy); diff --git a/source/gnugettext.pas b/source/gnugettext.pas new file mode 100644 index 00000000..b3157557 --- /dev/null +++ b/source/gnugettext.pas @@ -0,0 +1,3382 @@ +{*------------------------------------------------------------------------------ + 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: 220 $ + @see http://dybdahl.dk/dxgettext/ +-------------------------------------------------------------------------------} +unit gnugettext; +(**************************************************************) +(* *) +(* (C) Copyright by Lars B. Dybdahl and others *) +(* E-mail: Lars@dybdahl.dk, phone +45 70201241 *) +(* *) +(* Contributors: Peter Thornqvist, Troy Wolbrink, *) +(* Frank Andreas de Groot, Igor Siticov, *) +(* Jacques Garcia Vazquez, Igor Gitman, *) +(* Arvid Winkelsdorf *) +(* *) +(* See http://dybdahl.dk/dxgettext/ for more information *) +(* *) +(**************************************************************) + +// Information about this file: +// $LastChangedDate: 2010-08-25 15:40:17 +0200 (on, 25 aug 2010) $ +// $LastChangedRevision: 220 $ +// $HeadURL: http://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} + +{$ifdef VER140} + // Delphi 6 + {$DEFINE DELPHI2007OROLDER} +{$ifdef MSWINDOWS} + {$DEFINE DELPHI6OROLDER} +{$endif} +{$endif} +{$ifdef VER150} + // Delphi 7 + {$DEFINE DELPHI2007OROLDER} +{$endif} +{$ifdef VER160} + // Delphi 8 + {$DEFINE DELPHI2007OROLDER} +{$endif} +{$ifdef VER170} + // Delphi 2005 + {$DEFINE DELPHI2007OROLDER} +{$endif} +{$ifdef VER180} + // Delphi 2006 + {$DEFINE DELPHI2007OROLDER} +{$endif} +{$ifdef VER190} + // Delphi 2007 + {$DEFINE DELPHI2007OROLDER} +{$endif} +{$ifdef VER200} + // Delphi 2009 with Unicode + {$DEFINE DELPHI2009OROLDER} +{$endif} +{$ifdef VER210} + // Delphi 2010 with Unicode + {$DEFINE DELPHI2010OROLDER} +{$endif} +{$ifdef VER220} + // Delphi 2011/XE with Unicode + {$DEFINE DELPHI2011OROLDER} +{$endif} +{$ifdef VER230} + // Delphi 2012/XE2 with Unicode + {$DEFINE DELPHI2012OROLDER} +{$endif} +{$ifdef VER240} + // Delphi 2013/XE3 with Unicode + {$DEFINE DELPHI2013OROLDER} +{$endif} + +{$ifdef DELPHI2007OROLDER} + {$DEFINE DELPHI2011OROLDER} +{$endif} +{$ifdef DELPHI2009OROLDER} + {$DEFINE DELPHI2011OROLDER} +{$endif} +{$ifdef DELPHI2010OROLDER} + {$DEFINE DELPHI2011OROLDER} +{$endif} + +uses +{$ifdef MSWINDOWS} + Windows, +{$else} + Libc, +{$ifdef FPC} + CWString, +{$endif} +{$endif} + Classes, StrUtils, SysUtils, TypInfo; + +(*****************************************************************************) +(* *) +(* MAIN API *) +(* *) +(*****************************************************************************) + +type + {$IFNDEF UNICODE} + UnicodeString=WideString; + RawUtf8String=AnsiString; + RawByteString=AnsiString; + {$ELSE} + RawUtf8String=RawByteString; + {$ENDIF} + DomainString=string; + LanguageString=string; + ComponentNameString=string; + FilenameString=string; + MsgIdString=UnicodeString; + TranslatedUnicodeString=UnicodeString; + +// Main GNU gettext functions. See documentation for instructions on how to use them. +function _(const szMsgId: MsgIdString): TranslatedUnicodeString; +function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString; +function gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString; +function gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString; +function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; +function dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; +function dngettext(const szDomain: DomainString; const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString; +function ngettext(const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString; +function ngettext_NoExtract(const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString; +procedure textdomain(const szDomain: DomainString); +function getcurrenttextdomain: DomainString; +procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString); + +// Set language to use +procedure UseLanguage(LanguageCode: LanguageString); +function GetCurrentLanguage:LanguageString; + +// Translates a component (form, frame etc.) to the currently selected language. +// Put TranslateComponent(self) in the OnCreate event of all your forms. +// See the manual for documentation on these functions +type + TTranslator=procedure (obj:TObject) of object; + +procedure TP_Ignore(AnObject:TObject; const name:ComponentNameString); +procedure TP_IgnoreClass (IgnClass:TClass); +procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:ComponentNameString); +procedure TP_GlobalIgnoreClass (IgnClass:TClass); +function TP_TryGlobalIgnoreClass (IgnClass:TClass): boolean; +procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:ComponentNameString); +procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator); +procedure TranslateComponent(AnObject: TComponent; const TextDomain:DomainString=''); +procedure RetranslateComponent(AnObject: TComponent; const TextDomain:DomainString=''); + +// Add more domains that resourcestrings can be extracted from. If a translation +// is not found in the default domain, this domain will be searched, too. +// This is useful for adding mo files for certain runtime libraries and 3rd +// party component libraries +procedure AddDomainForResourceString (const domain:DomainString); +procedure RemoveDomainForResourceString (const domain:DomainString); + +// Add more domains that component strings can be extracted from. If a translation +// is not found in the default domain, this domain will be searched, too. +// This is useful when an application inherits components from a 3rd +// party component libraries +procedure AddDomainForComponent (const domain:DomainString); +procedure RemoveDomainForComponent (const domain:DomainString); + +// Unicode-enabled way to get resourcestrings, automatically translated +// Use like this: ws:=LoadResStringW(@NameOfResourceString); +function LoadResString(ResStringRec: PResStringRec): widestring; +function LoadResStringW(ResStringRec: PResStringRec): UnicodeString; + +// This returns an empty string if not translated or translator name is not specified. +function GetTranslatorNameAndEmail:TranslatedUnicodeString; + + +(*****************************************************************************) +(* *) +(* ADVANCED FUNCTIONALITY *) +(* *) +(*****************************************************************************) + +const + DefaultTextDomain = 'default'; + +var + ExecutableFilename: FilenameString; // This is set to paramstr(0) or the name of the DLL you are creating. + +const + PreferExternal = False; // Set to true, to prefer external *.mo over embedded translation + UseMemoryMappedFiles = True; // Set to False, to use the mo-file as independent copy in memory (you can update the file while it is in use) + ReReadMoFileOnSameLanguage = False; // Set to True, to reread mo-file if the current language is selected again + +const + // Subversion source code version control version information + VCSVersion='$LastChangedRevision: 220 $'; + +type + EGnuGettext=class(Exception); + EGGProgrammingError=class(EGnuGettext); + EGGComponentError=class(EGnuGettext); + EGGIOError=class(EGnuGettext); + EGGAnsi2WideConvError=class(EGnuGettext); + +// This function will turn resourcestring hooks on or off, eventually with BPL file support. +// Please do not activate BPL file support when the package is in design mode. +const AutoCreateHooks=true; +procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false); + + + + +(*****************************************************************************) +(* *) +(* CLASS based implementation. *) +(* Use TGnuGettextInstance to have more than one language *) +(* in your application at the same time *) +(* *) +(*****************************************************************************) + +{$ifdef MSWINDOWS} +{$ifndef DELPHI6OROLDER} +{$WARN UNSAFE_TYPE OFF} +{$WARN UNSAFE_CODE OFF} +{$WARN UNSAFE_CAST OFF} +{$endif} +{$endif} + +type + TOnDebugLine = Procedure (Sender: TObject; const Line: String; var Discard: Boolean) of Object; // Set Discard to false if output should still go to ordinary debug log + TGetPluralForm=function (Number:Longint):Integer; + TDebugLogger=procedure (line: ansistring) of object; + +{*------------------------------------------------------------------------------ + Handles .mo files, in separate files or inside the exe file. + Don't use this class. It's for internal use. +-------------------------------------------------------------------------------} + TMoFile= + class /// Threadsafe. Only constructor and destructor are writing to memory + private + doswap: boolean; + public + Users:Integer; /// Reference count. If it reaches zero, this object should be destroyed. + constructor Create (const filename: FilenameString; + const Offset: int64; Size: int64; + const xUseMemoryMappedFiles: Boolean); + destructor Destroy; override; + function gettext(const msgid: RawUtf8String;var found:boolean): RawUtf8String; // uses mo file and utf-8 + property isSwappedArchitecture:boolean read doswap; + private + N, O, T: Cardinal; /// Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html + startindex,startstep:integer; + FUseMemoryMappedFiles: Boolean; + mo: THandle; + momapping: THandle; + momemoryHandle:PAnsiChar; + momemory: PAnsiChar; + function autoswap32(i: cardinal): cardinal; + function CardinalInMem(baseptr: PAnsiChar; Offset: Cardinal): Cardinal; + end; + +{*------------------------------------------------------------------------------ + Handles all issues regarding a specific domain. + Don't use this class. It's for internal use. +-------------------------------------------------------------------------------} + TDomain= + class + private + Enabled:boolean; + vDirectory: FilenameString; + procedure setDirectory(const dir: FilenameString); + public + DebugLogger:TDebugLogger; + Domain: DomainString; + property Directory: FilenameString read vDirectory write setDirectory; + constructor Create; + destructor Destroy; override; + // Set parameters + procedure SetLanguageCode (const langcode:LanguageString); + procedure SetFilename (const filename:FilenameString); // Bind this domain to a specific file + // Get information + procedure GetListOfLanguages(list:TStrings); + function GetTranslationProperty(Propertyname: ComponentNameString): TranslatedUnicodeString; + function gettext(const msgid: RawUtf8String): RawUtf8String; // uses mo file and utf-8 + private + mofile:TMoFile; + SpecificFilename:FilenameString; + curlang: LanguageString; + OpenHasFailedBefore: boolean; + procedure OpenMoFile; + procedure CloseMoFile; + end; + +{*------------------------------------------------------------------------------ + Helper class for invoking events. +-------------------------------------------------------------------------------} + TExecutable= + class + procedure Execute; virtual; abstract; + end; + +{*------------------------------------------------------------------------------ + Interface to implement if you want to register as a language change listener +-------------------------------------------------------------------------------} + IGnuGettextInstanceWhenNewLanguageListener = interface + procedure WhenNewLanguage (const LanguageID:LanguageString); + end; + +{*------------------------------------------------------------------------------ + The main translation engine. +-------------------------------------------------------------------------------} + TGnuGettextInstance= + class + private + fOnDebugLine:TOnDebugLine; + CreatorThread:Cardinal; /// Only this thread can use LoadResString + public + Enabled:Boolean; /// Set this to false to disable translations + DesignTimeCodePage:Integer; /// See MultiByteToWideChar() in Win32 API for documentation + constructor Create; + destructor Destroy; override; + procedure UseLanguage(LanguageCode: LanguageString); + procedure GetListOfLanguages (const domain:DomainString; list:TStrings); // Puts list of language codes, for which there are translations in the specified domain, into list + {$ifndef UNICODE} + function gettext(const szMsgId: ansistring): TranslatedUnicodeString; overload; virtual; + function ngettext(const singular,plural:ansistring;Number:longint):TranslatedUnicodeString; overload; virtual; + {$endif} + function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString; overload; virtual; + function gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString; + function gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString; + function ngettext(const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString; overload; virtual; + function ngettext_NoExtract(const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString; + function GetCurrentLanguage:LanguageString; + function GetTranslationProperty (const Propertyname:ComponentNameString):TranslatedUnicodeString; + function GetTranslatorNameAndEmail:TranslatedUnicodeString; + + // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites() + procedure TP_Ignore(AnObject:TObject; const name:ComponentNameString); + procedure TP_IgnoreClass (IgnClass:TClass); + procedure TP_IgnoreClassProperty (IgnClass:TClass;propertyname:ComponentNameString); + function TP_TryGlobalIgnoreClass (IgnClass:TClass): boolean; + procedure TP_GlobalIgnoreClass (IgnClass:TClass); + procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:ComponentNameString); + procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator); + procedure TranslateProperties(AnObject: TObject; textdomain:DomainString=''); + procedure TranslateComponent(AnObject: TComponent; const TextDomain:DomainString=''); + procedure RetranslateComponent(AnObject: TComponent; const TextDomain:DomainString=''); + + // Multi-domain functions + {$ifndef UNICODE} + function dgettext(const szDomain: DomainString; const szMsgId: ansistring): TranslatedUnicodeString; overload; virtual; + function dngettext(const szDomain: DomainString; const singular,plural:ansistring;Number:longint):TranslatedUnicodeString; overload; virtual; + {$endif} + function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; overload; virtual; + function dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; + function dngettext(const szDomain: DomainString; const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString; overload; virtual; + function dngettext_NoExtract(const szDomain: DomainString; const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString; + procedure textdomain(const szDomain: DomainString); + function getcurrenttextdomain: DomainString; + procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString); + procedure bindtextdomainToFile (const szDomain: DomainString; const filename: FilenameString); // Also works with files embedded in exe file + + // Windows API functions + function LoadResString(ResStringRec: PResStringRec): UnicodeString; + + // Output all log info to this file. This may only be called once. + procedure DebugLogToFile (const filename:FilenameString; append:boolean=false); + procedure DebugLogPause (PauseEnabled:boolean); + property OnDebugLine: TOnDebugLine read fOnDebugLine write fOnDebugLine; // If set, all debug output goes here + {$ifndef UNICODE} + // Conversion according to design-time character set + function ansi2wideDTCP (const s:AnsiString):MsgIdString; // Convert using Design Time Code Page + {$endif} + + procedure RegisterWhenNewLanguageListener(Listener: IGnuGettextInstanceWhenNewLanguageListener); + procedure UnregisterWhenNewLanguageListener(Listener: IGnuGettextInstanceWhenNewLanguageListener); + protected + procedure TranslateStrings (sl:TStrings;const TextDomain:DomainString); + + // Override these three, if you want to inherited from this class + // to create a new class that handles other domain and language dependent + // issues + procedure WhenNewLanguage (const LanguageID:LanguageString); virtual; // Override to know when language changes + procedure WhenNewDomain (const TextDomain:DomainString); virtual; // Override to know when text domain changes. Directory is purely informational + procedure WhenNewDomainDirectory (const TextDomain:DomainString;const Directory:FilenameString); virtual; // Override to know when any text domain's directory changes. It won't be called if a domain is fixed to a specific file. + private + curlang: LanguageString; + curGetPluralForm:TGetPluralForm; + curmsgdomain: DomainString; + savefileCS: TMultiReadExclusiveWriteSynchronizer; + savefile: TextFile; + savememory: TStringList; + DefaultDomainDirectory:FilenameString; + domainlist: TStringList; /// List of domain names. Objects are TDomain. + TP_IgnoreList:TStringList; /// Temporary list, reset each time TranslateProperties is called + TP_ClassHandling:TList; /// Items are TClassMode. If a is derived from b, a comes first + TP_GlobalClassHandling:TList; /// Items are TClassMode. If a is derived from b, a comes first + TP_Retranslator:TExecutable; /// Cast this to TTP_Retranslator + fWhenNewLanguageListeners: TInterfaceList; /// List of all registered WhenNewLanguage listeners + {$ifdef DXGETTEXTDEBUG} + DebugLogCS:TMultiReadExclusiveWriteSynchronizer; + DebugLog:TStream; + DebugLogOutputPaused:Boolean; + {$endif} + function TP_CreateRetranslator:TExecutable; // Must be freed by caller! + procedure FreeTP_ClassHandlingItems; + {$ifdef DXGETTEXTDEBUG} + procedure DebugWriteln(line: ansistring); + {$endif} + procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo; + TodoList: TStrings; const TextDomain:DomainString); + function Getdomain(const domain:DomainString; const DefaultDomainDirectory:FilenameString; const CurLang: LanguageString): TDomain; // Translates a single property of an object + end; + +const + LOCALE_SISO639LANGNAME = $59; // Used by Lazarus software development tool + LOCALE_SISO3166CTRYNAME = $5A; // Used by Lazarus software development tool + +var + DefaultInstance:TGnuGettextInstance; /// Default instance of the main API for singlethreaded applications. + +implementation + +{$ifndef MSWINDOWS} +{$ifndef LINUX} + 'This version of gnugettext.pas is only meant to be compiled with Kylix 3,' + 'Delphi 6, Delphi 7 and later versions. If you use other versions, please' + 'get the gnugettext.pas version from the Delphi 5 directory.' +{$endif} +{$endif} + +(**************************************************************************) +// Some comments on the implementation: +// This unit should be independent of other units where possible. +// It should have a small footprint in any way. +(**************************************************************************) +// TMultiReadExclusiveWriteSynchronizer is used instead of TCriticalSection +// because it makes this unit independent of the SyncObjs unit +(**************************************************************************) + +{$B-,R+,I+,Q+} + +type + TTP_RetranslatorItem= + class + obj:TObject; + Propname:ComponentNameString; + OldValue:TranslatedUnicodeString; + end; + TTP_Retranslator= + class (TExecutable) + TextDomain:DomainString; + Instance:TGnuGettextInstance; + constructor Create; + destructor Destroy; override; + procedure Remember (obj:TObject; PropName:ComponentNameString; OldValue:TranslatedUnicodeString); + procedure Execute; override; + private + list:TList; + end; + TEmbeddedFileInfo= + class + offset,size:int64; + end; + TFileLocator= + class // This class finds files even when embedded inside executable + constructor Create; + destructor Destroy; override; + function FindSignaturePos(const signature: RawByteString; str: TFileStream): Int64; + procedure Analyze; // List files embedded inside executable + function FileExists (filename:FilenameString):boolean; + function GetMoFile (filename:FilenameString;DebugLogger:TDebugLogger):TMoFile; + procedure ReleaseMoFile (mofile:TMoFile); + private + basedirectory:FilenameString; + filelist:TStringList; //Objects are TEmbeddedFileInfo. Filenames are relative to .exe file + MoFilesCS:TMultiReadExclusiveWriteSynchronizer; + MoFiles:TStringList; // Objects are filenames+offset, objects are TMoFile + function ReadInt64 (str:TStream):int64; + end; + TGnuGettextComponentMarker= + class (TComponent) + public + LastLanguage:LanguageString; + Retranslator:TExecutable; + destructor Destroy; override; + end; + TClassMode= + class + HClass:TClass; + SpecialHandler:TTranslator; + PropertiesToIgnore:TStringList; // This is ignored if Handler is set + constructor Create; + destructor Destroy; override; + end; + TRStrinfo = record + strlength, stroffset: cardinal; + end; + TStrInfoArr = array[0..10000000] of TRStrinfo; + PStrInfoArr = ^TStrInfoArr; + TCharArray5=array[0..4] of ansichar; + THook= // Replaces a runtime library procedure with a custom procedure + class + public + constructor Create (OldProcedure, NewProcedure: pointer; FollowJump:boolean=false); + destructor Destroy; override; // Restores unhooked state + procedure Reset (FollowJump:boolean=false); // Disables and picks up patch points again + procedure Disable; + procedure Enable; + private + oldproc,newproc:Pointer; + Patch:TCharArray5; + Original:TCharArray5; + PatchPosition:PAnsiChar; + procedure Shutdown; // Same as destroy, except that object is not destroyed + end; + +var + // System information + Win32PlatformIsUnicode:boolean=False; + + // Information about files embedded inside .exe file + FileLocator:TFileLocator; + + // Hooks into runtime library functions + ResourceStringDomainListCS:TMultiReadExclusiveWriteSynchronizer; + ResourceStringDomainList:TStringList; + ComponentDomainListCS:TMultiReadExclusiveWriteSynchronizer; + ComponentDomainList:TStringList; + HookLoadResString:THook; + HookLoadStr:THook; + HookFmtLoadStr:THook; + +function GGGetEnvironmentVariable(const Name:widestring):widestring; +var + Len: integer; + W : WideString; +begin + Result := ''; + SetLength(W,1); + Len := Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(W), 1); + if Len > 0 then begin + SetLength(Result, Len - 1); + Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(Result), Len); + end; +end; + +function StripCRRawMsgId (s:RawUtf8String):RawUtf8String; +var + i:integer; +begin + i:=1; + while i<=length(s) do begin + if s[i]=#13 then delete (s,i,1) else inc (i); + end; + Result:=s; +end; + +function EnsureLineBreakInTranslatedString (s:RawUtf8String):RawUtf8String; +{$ifdef MSWINDOWS} +var + i:integer; +{$endif} +begin + {$ifdef MSWINDOWS} + Assert (sLinebreak=ansistring(#13#10)); + i:=1; + while i<=length(s) do begin + if (s[i]=#10) and (MidStr(s,i-1,1)<>#13) then begin + insert (#13,s,i); + inc (i,2); + end else + inc (i); + end; + {$endif} + Result:=s; +end; + +function IsWriteProp(Info: PPropInfo): Boolean; +begin + Result := Assigned(Info) and (Info^.SetProc <> nil); +end; + +function ResourceStringGettext(MsgId: MsgIdString): TranslatedUnicodeString; +var + i:integer; +begin + if (MsgID='') or (ResourceStringDomainListCS=nil) then begin + // This only happens during very complicated program startups that fail, + // or when Msgid='' + Result:=MsgId; + exit; + end; + ResourceStringDomainListCS.BeginRead; + try + for i:=0 to ResourceStringDomainList.Count-1 do begin + Result:=dgettext(ResourceStringDomainList.Strings[i], MsgId); + if Result<>MsgId then + break; + end; + finally + ResourceStringDomainListCS.EndRead; + end; +end; + +function ComponentGettext(MsgId: MsgIdString; Instance: TGnuGettextInstance = nil): TranslatedUnicodeString; +var + i:integer; +begin + if (MsgID='') or (ComponentDomainListCS=nil) then begin + // This only happens during very complicated program startups that fail, + // or when Msgid='' + Result:=MsgId; + exit; + end; + ComponentDomainListCS.BeginRead; + try + for i:=0 to ComponentDomainList.Count-1 do begin + if Assigned(Instance) then + Result:=Instance.dgettext(ComponentDomainList.Strings[i], MsgId) + else + Result:=dgettext(ComponentDomainList.Strings[i], MsgId); + if Result<>MsgId then + break; + end; + finally + ComponentDomainListCS.EndRead; + end; +end; + +function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + Result := DefaultInstance.gettext(szMsgId); +end; + +function gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + // This one is very useful for translating text in variables. + // This can sometimes be necessary, and by using this function, + // the source code scanner will not trigger warnings. + Result := gettext(szMsgId); +end; + +function gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + //*** With this function Strings can be added to the po-file without beeing + // ResourceStrings (dxgettext will add the string and this function will + // return it without a change) + // see gettext manual + // 4.7 - Special Cases of Translatable Strings + // http://www.gnu.org/software/hello/manual/gettext/Special-cases.html#Special-cases + Result := DefaultInstance.gettext_NoOp(szMsgId); +end; + +{*------------------------------------------------------------------------------ + This is the main translation procedure used in programs. It takes a parameter, + looks it up in the translation dictionary, and returns the translation. + If no translation is found, the parameter is returned. + + @param szMsgId The text, that should be displayed if no translation is found. +-------------------------------------------------------------------------------} +function _(const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + Result:=DefaultInstance.gettext(szMsgId); +end; + +{*------------------------------------------------------------------------------ + Translates a text, using a specified translation domain. + If no translation is found, the parameter is returned. + + @param szDomain Which translation domain that should be searched for a translation. + @param szMsgId The text, that should be displayed if no translation is found. +-------------------------------------------------------------------------------} +function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + Result:=DefaultInstance.dgettext(szDomain, szMsgId); +end; + +function dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + // This one is very useful for translating text in variables. + // This can sometimes be necessary, and by using this function, + // the source code scanner will not trigger warnings. + Result := dgettext(szDomain, szMsgId); +end; + +function dngettext(const szDomain: DomainString; const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString; +begin + Result:=DefaultInstance.dngettext(szDomain,singular,plural,Number); +end; + +function ngettext(const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString; +begin + Result:=DefaultInstance.ngettext(singular,plural,Number); +end; + +function ngettext_NoExtract(const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString; +begin + // This one is very useful for translating text in variables. + // This can sometimes be necessary, and by using this function, + // the source code scanner will not trigger warnings. + Result := ngettext(singular, plural, Number); +end; + +procedure textdomain(const szDomain: Domainstring); +begin + DefaultInstance.textdomain(szDomain); +end; + +procedure SetGettextEnabled (enabled:boolean); +begin + DefaultInstance.Enabled:=enabled; +end; + +function getcurrenttextdomain: DomainString; +begin + Result:=DefaultInstance.getcurrenttextdomain; +end; + +procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString); +begin + DefaultInstance.bindtextdomain(szDomain, szDirectory); +end; + +procedure TP_Ignore(AnObject:TObject; const name:FilenameString); +begin + DefaultInstance.TP_Ignore(AnObject, name); +end; + +procedure TP_GlobalIgnoreClass (IgnClass:TClass); +begin + DefaultInstance.TP_GlobalIgnoreClass(IgnClass); +end; + +function TP_TryGlobalIgnoreClass (IgnClass:TClass): boolean; +begin + Result := DefaultInstance.TP_TryGlobalIgnoreClass (IgnClass); +end; + +procedure TP_IgnoreClass (IgnClass:TClass); +begin + DefaultInstance.TP_IgnoreClass(IgnClass); +end; + +procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:ComponentNameString); +begin + DefaultInstance.TP_IgnoreClassProperty(IgnClass,propertyname); +end; + +procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:ComponentNameString); +begin + DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass,propertyname); +end; + +procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator); +begin + DefaultInstance.TP_GlobalHandleClass (HClass, Handler); +end; + +procedure TranslateComponent(AnObject: TComponent; const TextDomain:DomainString=''); +begin + DefaultInstance.TranslateComponent(AnObject, TextDomain); +end; + +procedure RetranslateComponent(AnObject: TComponent; const TextDomain:DomainString=''); +begin + DefaultInstance.RetranslateComponent(AnObject, TextDomain); +end; + +{$ifdef MSWINDOWS} + +// These constants are only used in Windows 95 +// Thanks to Frank Andreas de Groot for this table +const + IDAfrikaans = $0436; IDAlbanian = $041C; + IDArabicAlgeria = $1401; IDArabicBahrain = $3C01; + IDArabicEgypt = $0C01; IDArabicIraq = $0801; + IDArabicJordan = $2C01; IDArabicKuwait = $3401; + IDArabicLebanon = $3001; IDArabicLibya = $1001; + IDArabicMorocco = $1801; IDArabicOman = $2001; + IDArabicQatar = $4001; IDArabic = $0401; + IDArabicSyria = $2801; IDArabicTunisia = $1C01; + IDArabicUAE = $3801; IDArabicYemen = $2401; + IDArmenian = $042B; IDAssamese = $044D; + IDAzeriCyrillic = $082C; IDAzeriLatin = $042C; + IDBasque = $042D; IDByelorussian = $0423; + IDBengali = $0445; IDBulgarian = $0402; + IDBurmese = $0455; IDCatalan = $0403; + IDChineseHongKong = $0C04; IDChineseMacao = $1404; + IDSimplifiedChinese = $0804; IDChineseSingapore = $1004; + IDTraditionalChinese = $0404; IDCroatian = $041A; + IDCzech = $0405; IDDanish = $0406; + IDBelgianDutch = $0813; IDDutch = $0413; + IDEnglishAUS = $0C09; IDEnglishBelize = $2809; + IDEnglishCanadian = $1009; IDEnglishCaribbean = $2409; + IDEnglishIreland = $1809; IDEnglishJamaica = $2009; + IDEnglishNewZealand = $1409; IDEnglishPhilippines = $3409; + IDEnglishSouthAfrica = $1C09; IDEnglishTrinidad = $2C09; + IDEnglishUK = $0809; IDEnglishUS = $0409; + IDEnglishZimbabwe = $3009; IDEstonian = $0425; + IDFaeroese = $0438; IDFarsi = $0429; + IDFinnish = $040B; IDBelgianFrench = $080C; + IDFrenchCameroon = $2C0C; IDFrenchCanadian = $0C0C; + IDFrenchCotedIvoire = $300C; IDFrench = $040C; + IDFrenchLuxembourg = $140C; IDFrenchMali = $340C; + IDFrenchMonaco = $180C; IDFrenchReunion = $200C; + IDFrenchSenegal = $280C; IDSwissFrench = $100C; + IDFrenchWestIndies = $1C0C; IDFrenchZaire = $240C; + IDFrisianNetherlands = $0462; IDGaelicIreland = $083C; + IDGaelicScotland = $043C; IDGalician = $0456; + IDGeorgian = $0437; IDGermanAustria = $0C07; + IDGerman = $0407; IDGermanLiechtenstein = $1407; + IDGermanLuxembourg = $1007; IDSwissGerman = $0807; + IDGreek = $0408; IDGujarati = $0447; + IDHebrew = $040D; IDHindi = $0439; + IDHungarian = $040E; IDIcelandic = $040F; + IDIndonesian = $0421; IDItalian = $0410; + IDSwissItalian = $0810; IDJapanese = $0411; + IDKannada = $044B; IDKashmiri = $0460; + IDKazakh = $043F; IDKhmer = $0453; + IDKirghiz = $0440; IDKonkani = $0457; + IDKorean = $0412; IDLao = $0454; + IDLatvian = $0426; IDLithuanian = $0427; + IDMacedonian = $042F; IDMalaysian = $043E; + IDMalayBruneiDarussalam = $083E; IDMalayalam = $044C; + IDMaltese = $043A; IDManipuri = $0458; + IDMarathi = $044E; IDMongolian = $0450; + IDNepali = $0461; IDNorwegianBokmol = $0414; + IDNorwegianNynorsk = $0814; IDOriya = $0448; + IDPolish = $0415; IDBrazilianPortuguese = $0416; + IDPortuguese = $0816; IDPunjabi = $0446; + IDRhaetoRomanic = $0417; IDRomanianMoldova = $0818; + IDRomanian = $0418; IDRussianMoldova = $0819; + IDRussian = $0419; IDSamiLappish = $043B; + IDSanskrit = $044F; IDSerbianCyrillic = $0C1A; + IDSerbianLatin = $081A; IDSesotho = $0430; + IDSindhi = $0459; IDSlovak = $041B; + IDSlovenian = $0424; IDSorbian = $042E; + IDSpanishArgentina = $2C0A; IDSpanishBolivia = $400A; + IDSpanishChile = $340A; IDSpanishColombia = $240A; + IDSpanishCostaRica = $140A; IDSpanishDominicanRepublic = $1C0A; + IDSpanishEcuador = $300A; IDSpanishElSalvador = $440A; + IDSpanishGuatemala = $100A; IDSpanishHonduras = $480A; + IDMexicanSpanish = $080A; IDSpanishNicaragua = $4C0A; + IDSpanishPanama = $180A; IDSpanishParaguay = $3C0A; + IDSpanishPeru = $280A; IDSpanishPuertoRico = $500A; + IDSpanishModernSort = $0C0A; IDSpanish = $040A; + IDSpanishUruguay = $380A; IDSpanishVenezuela = $200A; + IDSutu = $0430; IDSwahili = $0441; + IDSwedishFinland = $081D; IDSwedish = $041D; + IDTajik = $0428; IDTamil = $0449; + IDTatar = $0444; IDTelugu = $044A; + IDThai = $041E; IDTibetan = $0451; + IDTsonga = $0431; IDTswana = $0432; + IDTurkish = $041F; IDTurkmen = $0442; + IDUkrainian = $0422; IDUrdu = $0420; + IDUzbekCyrillic = $0843; IDUzbekLatin = $0443; + IDVenda = $0433; IDVietnamese = $042A; + IDWelsh = $0452; IDXhosa = $0434; + IDZulu = $0435; + +function GetWindowsLanguage: WideString; +var + langid: Cardinal; + langcode: WideString; + CountryName: array[0..4] of widechar; + LanguageName: array[0..4] of widechar; + works: boolean; +begin + // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero + works := 3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName)); + works := works and (3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName, SizeOf(CountryName))); + if works then begin + // Windows 98, Me, NT4, 2000, XP and newer + LangCode := PWideChar(@(LanguageName[0])); + if lowercase(LangCode)='no' then LangCode:='nb'; + LangCode:=LangCode + '_' + PWideChar(@CountryName[0]); + end else begin + // This part should only happen on Windows 95. + langid := GetThreadLocale; + case langid of + IDBelgianDutch: langcode := 'nl_BE'; + IDBelgianFrench: langcode := 'fr_BE'; + IDBrazilianPortuguese: langcode := 'pt_BR'; + IDDanish: langcode := 'da_DK'; + IDDutch: langcode := 'nl_NL'; + IDEnglishUK: langcode := 'en_GB'; + IDEnglishUS: langcode := 'en_US'; + IDFinnish: langcode := 'fi_FI'; + IDFrench: langcode := 'fr_FR'; + IDFrenchCanadian: langcode := 'fr_CA'; + IDGerman: langcode := 'de_DE'; + IDGermanLuxembourg: langcode := 'de_LU'; + IDGreek: langcode := 'el_GR'; + IDIcelandic: langcode := 'is_IS'; + IDItalian: langcode := 'it_IT'; + IDKorean: langcode := 'ko_KO'; + IDNorwegianBokmol: langcode := 'nb_NO'; + IDNorwegianNynorsk: langcode := 'nn_NO'; + IDPolish: langcode := 'pl_PL'; + IDPortuguese: langcode := 'pt_PT'; + IDRussian: langcode := 'ru_RU'; + IDSpanish, IDSpanishModernSort: langcode := 'es_ES'; + IDSwedish: langcode := 'sv_SE'; + IDSwedishFinland: langcode := 'sv_FI'; + else + langcode := 'C'; + end; + end; + Result := langcode; +end; +{$endif} + +{$ifndef UNICODE} +function LoadResStringA(ResStringRec: PResStringRec): ansistring; +begin + Result:=DefaultInstance.LoadResString(ResStringRec); +end; +{$endif} + +function GetTranslatorNameAndEmail:TranslatedUnicodeString; +begin + Result:=DefaultInstance.GetTranslatorNameAndEmail; +end; + +procedure UseLanguage(LanguageCode: LanguageString); +begin + DefaultInstance.UseLanguage(LanguageCode); +end; + +// Delphi6: use integer (does not know NativeInt) +// Delphi7: use integer (knows NativeInt, but it's not documented) +// Delphi2005: use integer (knows NativeInt, but it's not documented) +// Delphi2006: use integer (knows NativeInt, but it's not documented) +// Delphi2007: use integer (knows NativeInt, but it's not documented) +// Delphi2009: use integer (knows NativeInt, but it's not documented but mentioned where constants are documented) +// Delphi2010: use integer (knows NativeInt and it's documented) +// Delphi2011/XE: use integer (knows NativeInt and it's documented) +// Delphi2012/XE2: use nativeint +// DelphiX2013/XE3: use nativeint + +type +{$IFDEF DELPHI2011OROLDER} + THInstanceType = Integer; + TNativeInt = Integer; +{$ELSE} + THInstanceType = NativeInt; + TNativeInt= NativeInt; +{$ENDIF} + +type + PStrData = ^TStrData; + TStrData = record + Ident: TNativeInt; + Str: String; + end; + +function SysUtilsEnumStringModules(Instance: THInstanceType; Data: Pointer): Boolean; +{$IFDEF MSWINDOWS} +var + Buffer: array [0..1023] of Char; // WideChar in Delphi 2009, AnsiChar before that +begin + with PStrData(Data)^ do begin + SetString(Str, Buffer, + LoadString(Instance, Ident, @Buffer[0], sizeof(Buffer))); + Result := Str = ''; + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + rs:TResStringRec; + Module:HModule; +begin + Module:=Instance; + rs.Module:=@Module; + with PStrData(Data)^ do begin + rs.Identifier:=Ident; + Str:=System.LoadResString(@rs); + Result:=Str=''; + end; +end; +{$ENDIF} + +function SysUtilsFindStringResource(Ident: TNativeInt): string; +var + StrData: TStrData; +begin + StrData.Ident := Ident; + StrData.Str := ''; + EnumResourceModules(SysUtilsEnumStringModules, @StrData); + Result := StrData.Str; +end; + +function SysUtilsLoadStr(Ident: Integer): string; +begin + {$ifdef DXGETTEXTDEBUG} + DefaultInstance.DebugWriteln ('Sysutils.LoadRes('+IntToStr(ident)+') called'); + {$endif} + Result := ResourceStringGettext(SysUtilsFindStringResource(Ident)); +end; + +function SysUtilsFmtLoadStr(Ident: Integer; const Args: array of const): string; +begin + {$ifdef DXGETTEXTDEBUG} + DefaultInstance.DebugWriteln ('Sysutils.FmtLoadRes('+IntToStr(ident)+',Args) called'); + {$endif} + FmtStr(Result, ResourceStringGettext(SysUtilsFindStringResource(Ident)),Args); +end; + +function LoadResString(ResStringRec: PResStringRec): widestring; +begin + Result:=DefaultInstance.LoadResString(ResStringRec); +end; + +function LoadResStringW(ResStringRec: PResStringRec): UnicodeString; +begin + Result:=DefaultInstance.LoadResString(ResStringRec); +end; + + + +function GetCurrentLanguage:LanguageString; +begin + Result:=DefaultInstance.GetCurrentLanguage; +end; + +{ TDomain } + +procedure TDomain.CloseMoFile; +begin + if mofile<>nil then begin + FileLocator.ReleaseMoFile(mofile); + mofile:=nil; + end; + OpenHasFailedBefore:=False; +end; + +destructor TDomain.Destroy; +begin + CloseMoFile; + inherited; +end; + +{$ifdef mswindows} +function GetLastWinError:widestring; +var + errcode:Cardinal; +begin + SetLength (Result,2000); + errcode:=GetLastError(); + Windows.FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PWideChar(Result),2000,nil); + Result:=PWideChar(Result); +end; +{$endif} + +procedure TDomain.OpenMoFile; +var + filename: FilenameString; +begin + // Check if it is already open + if mofile<>nil then + exit; + + // Check if it has been attempted to open the file before + if OpenHasFailedBefore then + exit; + + if SpecificFilename<>'' then begin + filename:=SpecificFilename; + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('Domain '+domain+' is bound to specific file '+filename); + {$endif} + end else begin + filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; + if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('Domain '+domain+': File does not exist, neither embedded or in file system: '+filename); + {$endif} + filename := Directory + MidStr(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('Domain '+domain+' will attempt to use this file: '+filename); + {$endif} + end else begin + {$ifdef DXGETTEXTDEBUG} + if FileLocator.FileExists(filename) then + DebugLogger ('Domain '+domain+' will attempt to use this embedded file: '+filename) + else + DebugLogger ('Domain '+domain+' will attempt to use this file that was found on the file system: '+filename); + {$endif} + end; + end; + if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('Domain '+domain+' failed to locate the file: '+filename); + {$endif} + OpenHasFailedBefore:=True; + exit; + end; + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('Domain '+domain+' now accesses the file.'); + {$endif} + mofile:=FileLocator.GetMoFile(filename, DebugLogger); + + {$ifdef DXGETTEXTDEBUG} + if mofile.isSwappedArchitecture then + DebugLogger ('.mo file is swapped (comes from another CPU architecture)'); + {$endif} + + // Check, that the contents of the file is utf-8 + if pos('CHARSET=UTF-8',uppercase(GetTranslationProperty('Content-Type')))=0 then begin + CloseMoFile; + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.'); + {$endif} + {$ifdef MSWINDOWS} + MessageBoxW(0,PWideChar(widestring('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.')),'Localization problem',MB_OK); + {$else} + writeln (stderr,'The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.'); + {$endif} + Enabled:=False; + end; +end; + +{$IFDEF UNICODE} +function utf8decode (s:RawByteString):UnicodeString; inline; +begin + Result:=UTF8ToWideString(s); +end; +{$endif} + +function TDomain.GetTranslationProperty( + Propertyname: ComponentNameString): TranslatedUnicodeString; +var + sl:TStringList; + i:integer; + s:string; +begin + Propertyname:=uppercase(Propertyname)+': '; + sl:=TStringList.Create; + try + sl.Text:=utf8decode(gettext('')); + for i:=0 to sl.Count-1 do begin + s:=sl.Strings[i]; + if uppercase(MidStr(s,1,length(Propertyname)))=Propertyname then begin + Result:=trim(MidStr(s,length(PropertyName)+1,maxint)); + + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('GetTranslationProperty('+PropertyName+') returns '''+Result+'''.'); + {$endif} + exit; + end; + end; + finally + FreeAndNil (sl); + end; + Result:=''; + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('GetTranslationProperty('+PropertyName+') did not find any value. An empty string is returned.'); + {$endif} +end; + +procedure TDomain.setDirectory(const dir: FilenameString); +begin + vDirectory := IncludeTrailingPathDelimiter(dir); + SpecificFilename:=''; + CloseMoFile; +end; + +procedure AddDomainForResourceString (const domain:DomainString); +begin + {$ifdef DXGETTEXTDEBUG} + DefaultInstance.DebugWriteln ('Extra domain for resourcestring: '+domain); + {$endif} + ResourceStringDomainListCS.BeginWrite; + try + if ResourceStringDomainList.IndexOf(domain)=-1 then + ResourceStringDomainList.Add (domain); + finally + ResourceStringDomainListCS.EndWrite; + end; +end; + +procedure RemoveDomainForResourceString (const domain:DomainString); +var + i:integer; +begin + {$ifdef DXGETTEXTDEBUG} + DefaultInstance.DebugWriteln ('Remove domain for resourcestring: '+domain); + {$endif} + ResourceStringDomainListCS.BeginWrite; + try + i:=ResourceStringDomainList.IndexOf(domain); + if i<>-1 then + ResourceStringDomainList.Delete (i); + finally + ResourceStringDomainListCS.EndWrite; + end; +end; + +procedure AddDomainForComponent (const domain:DomainString); +begin + {$ifdef DXGETTEXTDEBUG} + DefaultInstance.DebugWriteln ('Extra domain for component: '+domain); + {$endif} + ComponentDomainListCS.BeginWrite; + try + if ComponentDomainList.IndexOf(domain)=-1 then + ComponentDomainList.Add (domain); + finally + ComponentDomainListCS.EndWrite; + end; +end; + +procedure RemoveDomainForComponent (const domain:DomainString); +var + i:integer; +begin + {$ifdef DXGETTEXTDEBUG} + DefaultInstance.DebugWriteln ('Remove domain for component: '+domain); + {$endif} + ComponentDomainListCS.BeginWrite; + try + i:=ComponentDomainList.IndexOf(domain); + if i<>-1 then + ComponentDomainList.Delete (i); + finally + ComponentDomainListCS.EndWrite; + end; +end; + +procedure TDomain.SetLanguageCode(const langcode: LanguageString); +begin + CloseMoFile; + curlang:=langcode; +end; + +function GetPluralForm2EN(Number: Integer): Integer; +begin + Number:=abs(Number); + if Number=1 then Result:=0 else Result:=1; +end; + +function GetPluralForm1(Number: Integer): Integer; +begin + Result:=0; +end; + +function GetPluralForm2FR(Number: Integer): Integer; +begin + Number:=abs(Number); + if (Number=1) or (Number=0) then Result:=0 else Result:=1; +end; + +function GetPluralForm3LV(Number: Integer): Integer; +begin + Number:=abs(Number); + if (Number mod 10=1) and (Number mod 100<>11) then + Result:=0 + else + if Number<>0 then Result:=1 + else Result:=2; +end; + +function GetPluralForm3GA(Number: Integer): Integer; +begin + Number:=abs(Number); + if Number=1 then Result:=0 + else if Number=2 then Result:=1 + else Result:=2; +end; + +function GetPluralForm3LT(Number: Integer): Integer; +var + n1,n2:byte; +begin + Number:=abs(Number); + n1:=Number mod 10; + n2:=Number mod 100; + if (n1=1) and (n2<>11) then + Result:=0 + else + if (n1>=2) and ((n2<10) or (n2>=20)) then Result:=1 + else Result:=2; +end; + +function GetPluralForm3PL(Number: Integer): Integer; +var + n1,n2:byte; +begin + Number:=abs(Number); + n1:=Number mod 10; + n2:=Number mod 100; + + if Number=1 then Result:=0 + else if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1 + else Result:=2; +end; + +function GetPluralForm3RU(Number: Integer): Integer; +var + n1,n2:byte; +begin + Number:=abs(Number); + n1:=Number mod 10; + n2:=Number mod 100; + if (n1=1) and (n2<>11) then + Result:=0 + else + if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1 + else Result:=2; +end; + +function GetPluralForm3SK(Number: Integer): Integer; +begin + Number:=abs(Number); + if number=1 then Result:=0 + else if (number<5) and (number<>0) then Result:=1 + else Result:=2; +end; + +function GetPluralForm4SL(Number: Integer): Integer; +var + n2:byte; +begin + Number:=abs(Number); + n2:=Number mod 100; + if n2=1 then Result:=0 + else + if n2=2 then Result:=1 + else + if (n2=3) or (n2=4) then Result:=2 + else + Result:=3; +end; + +procedure TDomain.GetListOfLanguages(list: TStrings); +var + sr:TSearchRec; + more:boolean; + filename, path:FilenameString; + langcode:LanguageString; + i, j:integer; +begin + list.Clear; + + // Iterate through filesystem + more:=FindFirst (Directory+'*',faAnyFile,sr)=0; + try + while more do begin + if (sr.Attr and faDirectory<>0) and (sr.name<>'.') and (sr.name<>'..') then begin + filename := Directory + sr.Name + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; + if fileexists(filename) then begin + langcode:=lowercase(sr.name); + if list.IndexOf(langcode)=-1 then + list.Add(langcode); + end; + end; + more:=FindNext (sr)=0; + end; + finally + FindClose (sr); + end; + + // Iterate through embedded files + for i:=0 to FileLocator.filelist.Count-1 do begin + filename:=FileLocator.basedirectory+FileLocator.filelist.Strings[i]; + path:=Directory; + {$ifdef MSWINDOWS} + path:=uppercase(path); + filename:=uppercase(filename); + {$endif} + j:=length(path); + if MidStr(filename,1,j)=path then begin + path:=PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo'; + {$ifdef MSWINDOWS} + path:=uppercase(path); + {$endif} + if MidStr(filename,length(filename)-length(path)+1,length(path))=path then begin + langcode:=lowercase(MidStr(filename,j+1,length(filename)-length(path)-j)); + langcode:=LeftStr(langcode,3)+uppercase(MidStr(langcode,4,maxint)); + if list.IndexOf(langcode)=-1 then + list.Add(langcode); + end; + end; + end; +end; + +procedure TDomain.SetFilename(const filename: FilenameString); +begin + CloseMoFile; + vDirectory := ''; + SpecificFilename:=filename; +end; + +function TDomain.gettext(const msgid: RawUtf8String): RawUtf8String; +var + found:boolean; +begin + if not Enabled then begin + Result:=msgid; + exit; + end; + if (mofile=nil) and (not OpenHasFailedBefore) then + OpenMoFile; + if mofile=nil then begin + {$ifdef DXGETTEXTDEBUG} + DebugLogger('.mo file is not open. Not translating "'+msgid+'"'); + {$endif} + Result := msgid; + end else begin + Result:=mofile.gettext(msgid,found); + {$ifdef DXGETTEXTDEBUG} + if found then + DebugLogger ('Found in .mo ('+Domain+'): "'+utf8encode(msgid)+'"->"'+utf8encode(Result)+'"') + else + DebugLogger ('Translation not found in .mo file ('+Domain+') : "'+utf8encode(msgid)+'"'); + {$endif} + end; +end; + +constructor TDomain.Create; +begin + inherited Create; + Enabled:=True; +end; + +{ TGnuGettextInstance } + +procedure TGnuGettextInstance.bindtextdomain(const szDomain:DomainString; + const szDirectory: FilenameString); +var + dir:FilenameString; +begin + dir:=IncludeTrailingPathDelimiter(szDirectory); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Text domain "'+szDomain+'" is now located at "'+dir+'"'); + {$endif} + getdomain(szDomain,DefaultDomainDirectory,CurLang).Directory := dir; + WhenNewDomainDirectory (szDomain, szDirectory); +end; + +constructor TGnuGettextInstance.Create; +begin + CreatorThread:=GetCurrentThreadId; + {$ifdef MSWindows} + DesignTimeCodePage:=CP_ACP; + {$endif} + {$ifdef DXGETTEXTDEBUG} + DebugLogCS:=TMultiReadExclusiveWriteSynchronizer.Create; + DebugLog:=TMemoryStream.Create; + DebugWriteln('Debug log started '+DateTimeToStr(Now)); + DebugWriteln('GNU gettext module version: '+VCSVersion); + DebugWriteln(''); + {$endif} + curGetPluralForm:=GetPluralForm2EN; + Enabled:=True; + curmsgdomain:=DefaultTextDomain; + savefileCS := TMultiReadExclusiveWriteSynchronizer.Create; + domainlist := TStringList.Create; + TP_IgnoreList:=TStringList.Create; + TP_IgnoreList.Sorted:=True; + TP_GlobalClassHandling:=TList.Create; + TP_ClassHandling:=TList.Create; + fWhenNewLanguageListeners := TInterfaceList.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); + fWhenNewLanguageListeners.Free; + {$ifdef DXGETTEXTDEBUG} + FreeAndNil (DebugLog); + FreeAndNil (DebugLogCS); + {$endif} + inherited; +end; + +{$ifndef UNICODE} +function TGnuGettextInstance.dgettext(const szDomain: DomainString; const szMsgId: ansistring): TranslatedUnicodeString; +begin + Result:=dgettext(szDomain, ansi2wideDTCP(szMsgId)); +end; +{$endif} + +function TGnuGettextInstance.dgettext(const szDomain: DomainString; + const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + if not Enabled then begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Translation has been disabled. Text is not being translated: '+szMsgid); + {$endif} + Result:=szMsgId; + end else begin + Result:=UTF8Decode(EnsureLineBreakInTranslatedString(getdomain(szDomain,DefaultDomainDirectory,CurLang).gettext(StripCRRawMsgId(utf8encode(szMsgId))))); + + {$ifdef DXGETTEXTDEBUG} + if (szMsgId<>'') and (Result='') then + DebugWriteln (Format('Error: Translation of %s was an empty string. This may never occur.',[szMsgId])); + {$endif} + end; +end; + +function TGnuGettextInstance.dgettext_NoExtract(const szDomain: DomainString; + const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + // This one is very useful for translating text in variables. + // This can sometimes be necessary, and by using this function, + // the source code scanner will not trigger warnings. + Result:=dgettext(szDomain,szMsgId); +end; + +function TGnuGettextInstance.GetCurrentLanguage: LanguageString; +begin + Result:=curlang; +end; + +function TGnuGettextInstance.getcurrenttextdomain: DomainString; +begin + Result := curmsgdomain; +end; + +{$ifndef UNICODE} +function TGnuGettextInstance.gettext( + const szMsgId: ansistring): TranslatedUnicodeString; +begin + Result := dgettext(curmsgdomain, szMsgId); +end; +{$endif} + +function TGnuGettextInstance.gettext( + const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + Result := dgettext(curmsgdomain, szMsgId); +end; + +function TGnuGettextInstance.gettext_NoExtract( + const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + // This one is very useful for translating text in variables. + // This can sometimes be necessary, and by using this function, + // the source code scanner will not trigger warnings. + Result:=gettext (szMsgId); +end; + +function TGnuGettextInstance.gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString; +begin + //*** With this function Strings can be added to the po-file without beeing + // ResourceStrings (dxgettext will add the string and this function will + // return it without a change) + // see gettext manual + // 4.7 - Special Cases of Translatable Strings + // http://www.gnu.org/software/hello/manual/gettext/Special-cases.html#Special-cases + Result := TranslatedUnicodeString(szMsgId); +end; + +procedure TGnuGettextInstance.textdomain(const szDomain: DomainString); +begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Changed text domain to "'+szDomain+'"'); + {$endif} + curmsgdomain := szDomain; + WhenNewDomain (szDomain); +end; + +function TGnuGettextInstance.TP_CreateRetranslator : TExecutable; +var + ttpr:TTP_Retranslator; +begin + ttpr:=TTP_Retranslator.Create; + ttpr.Instance:=self; + TP_Retranslator:=ttpr; + Result:=ttpr; + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('A retranslator was created.'); + {$endif} +end; + +procedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass; + Handler: TTranslator); +var + cm:TClassMode; + i:integer; +begin + for i:=0 to TP_GlobalClassHandling.Count-1 do begin + cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode; + if cm.HClass=HClass then + raise EGGProgrammingError.Create ('You cannot set a handler for a class that has already been assigned otherwise.'); + if HClass.InheritsFrom(cm.HClass) then begin + // This is the place to insert this class + cm:=TClassMode.Create; + cm.HClass:=HClass; + cm.SpecialHandler:=Handler; + TP_GlobalClassHandling.Insert(i,cm); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('A handler was set for class '+HClass.ClassName+'.'); + {$endif} + exit; + end; + end; + cm:=TClassMode.Create; + cm.HClass:=HClass; + cm.SpecialHandler:=Handler; + TP_GlobalClassHandling.Add(cm); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('A handler was set for class '+HClass.ClassName+'.'); + {$endif} +end; + +function TGnuGettextInstance.TP_TryGlobalIgnoreClass (IgnClass:TClass): boolean; +var + cm:TClassMode; + i:integer; +begin + Result := false; + for i:=0 to TP_GlobalClassHandling.Count-1 do begin + cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode; + if cm.HClass=IgnClass then + exit; // class already in ignore list + 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); + Result := true; + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.'); + {$endif} + exit; + end; + end; + cm:=TClassMode.Create; + cm.HClass:=IgnClass; + TP_GlobalClassHandling.Add(cm); + Result := true; + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.'); + {$endif} +end; + +procedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass); +begin + if not TP_TryGlobalIgnoreClass(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.'); +end; + +procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty( + IgnClass: TClass; propertyname: ComponentNameString); +var + cm:TClassMode; + i,idx:integer; +begin + propertyname:=uppercase(propertyname); + for i:=0 to TP_GlobalClassHandling.Count-1 do begin + cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode; + if cm.HClass=IgnClass then begin + if Assigned(cm.SpecialHandler) then + raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.'); + if not cm.PropertiesToIgnore.Find(propertyname,idx) then + cm.PropertiesToIgnore.Add(propertyname); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.'); + {$endif} + exit; + end; + if IgnClass.InheritsFrom(cm.HClass) then begin + // This is the place to insert this class + cm:=TClassMode.Create; + cm.HClass:=IgnClass; + cm.PropertiesToIgnore.Add(propertyname); + TP_GlobalClassHandling.Insert(i,cm); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.'); + {$endif} + exit; + end; + end; + cm:=TClassMode.Create; + cm.HClass:=IgnClass; + cm.PropertiesToIgnore.Add(propertyname); + TP_GlobalClassHandling.Add(cm); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.'); + {$endif} +end; + +procedure TGnuGettextInstance.TP_Ignore(AnObject: TObject; + const name: ComponentNameString); +begin + TP_IgnoreList.Add(uppercase(name)); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('On object with class name '+AnObject.ClassName+', ignore is set on '+name); + {$endif} +end; + +procedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent; + const TextDomain: DomainString); +var + comp:TGnuGettextComponentMarker; +begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('======================================================================'); + DebugWriteln ('TranslateComponent() was called for a component with name '+AnObject.Name+'.'); + {$endif} + comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker; + if comp=nil then begin + comp:=TGnuGettextComponentMarker.Create (nil); + comp.Name:='GNUgettextMarker'; + comp.Retranslator:=TP_CreateRetranslator; + TranslateProperties (AnObject, TextDomain); + AnObject.InsertComponent(comp); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('This is the first time, that this component has been translated. A retranslator component has been created for this component.'); + {$endif} + end else begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('This is not the first time, that this component has been translated.'); + {$endif} + if comp.LastLanguage<>curlang then begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('ERROR: TranslateComponent() was called twice with different languages. This indicates an attempt to switch language at runtime, but by using TranslateComponent every time. This API has changed - please use RetranslateComponent() instead.'); + {$endif} + {$ifdef mswindows} + MessageBox (0,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.','Error',MB_OK); + {$else} + writeln (stderr,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.'); + {$endif} + end else begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('ERROR: TranslateComponent has been called twice, but with the same language chosen. This is a mistake, but in order to prevent that the application breaks, no exception is raised.'); + {$endif} + end; + end; + comp.LastLanguage:=curlang; + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('======================================================================'); + {$endif} +end; + +procedure TGnuGettextInstance.TranslateProperty (AnObject:TObject; PropInfo:PPropInfo; TodoList:TStrings; const TextDomain:DomainString); +var + ppi:PPropInfo; + ws: TranslatedUnicodeString; + old: TranslatedUnicodeString; + compmarker:TComponent; + obj:TObject; + Propname:ComponentNameString; +begin + PropName:=string(PropInfo^.Name); + try + // Translate certain types of properties + case PropInfo^.PropType^.Kind of + {$IFDEF UNICODE} + // All dfm files returning tkUString + tkString, tkLString, tkWString, tkUString: + {$ELSE} + tkString, tkLString, tkWString: + {$ENDIF} + begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Translating '+AnObject.ClassName+'.'+PropName); + {$endif} + case PropInfo^.PropType^.Kind of + tkString, tkLString : + old := GetStrProp(AnObject, PropName); + tkWString : + old := GetWideStrProp(AnObject, PropName); + {$IFDEF UNICODE} + tkUString : + old := GetUnicodeStrProp(AnObject, PropName); + {$ENDIF} + else + raise Exception.Create ('Internal error: Illegal property type. This problem needs to be solved by a programmer, try to find a workaround.'); + end; + {$ifdef DXGETTEXTDEBUG} + if old='' then + DebugWriteln ('(Empty, not translated)') + else + DebugWriteln ('Old value: "'+old+'"'); + {$endif} + if (old <> '') and (IsWriteProp(PropInfo)) then begin + if TP_Retranslator<>nil then + (TP_Retranslator as TTP_Retranslator).Remember(AnObject, PropName, old); + if textdomain = '' then + ws := ComponentGettext(old) + else + ws := dgettext(textdomain,old); + if ws <> old then begin + ppi:=GetPropInfo(AnObject, Propname); + if ppi<>nil then begin + SetWideStrProp(AnObject, ppi, ws); + end else begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('ERROR: Property disappeared: '+Propname+' for object of type '+AnObject.ClassName); + {$endif} + end; + end; + end; + end { case item }; + tkClass: + begin + obj:=GetObjectProp(AnObject, PropName); + if obj<>nil then begin + if obj is TComponent then begin + compmarker := TComponent(obj).FindComponent('GNUgettextMarker'); + if Assigned(compmarker) then + exit; + end; + TodoList.AddObject ('',obj); + end; + end { case item }; + end { case }; + except + on E:Exception do + raise EGGComponentError.Create ('Property cannot be translated.'+sLineBreak+ + 'Add TP_GlobalIgnoreClassProperty('+AnObject.ClassName+','''+PropName+''') to your source code or use'+sLineBreak+ + 'TP_Ignore (self,''.'+PropName+''') to prevent this message.'+sLineBreak+ + 'Reason: '+e.Message); + end; +end; + +procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; textdomain:DomainString=''); +var + TodoList:TStringList; // List of Name/TObject's that is to be processed + DoneList:TStringList; // List of hex codes representing pointers to objects that have been done + i, j, Count: integer; + PropList: PPropList; + UPropName: ComponentNameString; + PropInfo: PPropInfo; + compmarker, + comp:TComponent; + cm, + currentcm:TClassMode; // currentcm is nil or contains special information about how to handle the current object + ObjectPropertyIgnoreList:TStringList; + objid:string; + Name:ComponentNameString; +begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('----------------------------------------------------------------------'); + DebugWriteln ('TranslateProperties() was called for an object of class '+AnObject.ClassName+' with domain "'+textdomain+'".'); + {$endif} + if TP_Retranslator<>nil then + if textdomain = '' then + (TP_Retranslator as TTP_Retranslator).TextDomain:=curmsgdomain + else + (TP_Retranslator as TTP_Retranslator).TextDomain:=textdomain; + {$ifdef FPC} + DoneList:=TCSStringList.Create; + TodoList:=TCSStringList.Create; + ObjectPropertyIgnoreList:=TCSStringList.Create; + {$else} + DoneList:=TStringList.Create; + TodoList:=TStringList.Create; + ObjectPropertyIgnoreList:=TStringList.Create; + {$endif} + try + TodoList.AddObject('', AnObject); + DoneList.Sorted:=True; + ObjectPropertyIgnoreList.Sorted:=True; + ObjectPropertyIgnoreList.Duplicates:=dupIgnore; + ObjectPropertyIgnoreList.CaseSensitive:=False; + DoneList.Duplicates:=dupError; + DoneList.CaseSensitive:=True; + + while TodoList.Count<>0 do begin + AnObject:=TodoList.Objects[0]; + Name:=TodoList.Strings[0]; + TodoList.Delete(0); + if (AnObject<>nil) and (AnObject is TPersistent) then begin + // Make sure each object is only translated once + Assert (sizeof({$IFDEF CPUx64}NativeInt{$ELSE}Integer{$ENDIF CPUx64})=sizeof(TObject)); + objid:=IntToHex({$IFDEF CPUx64}NativeInt{$ELSE}Integer{$ENDIF CPUx64}(AnObject),8); + if DoneList.Find(objid,i) then begin + continue; + end else begin + DoneList.Add(objid); + end; + + ObjectPropertyIgnoreList.Clear; + + // Find out if there is special handling of this object + currentcm:=nil; + // First check the local handling instructions + for j:=0 to TP_ClassHandling.Count-1 do begin + cm:=TObject(TP_ClassHandling.Items[j]) as TClassMode; + if AnObject.InheritsFrom(cm.HClass) then begin + if cm.PropertiesToIgnore.Count<>0 then begin + ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore); + end else begin + // Ignore the entire class + currentcm:=cm; + break; + end; + end; + end; + // Then check the global handling instructions + if currentcm=nil then + for j:=0 to TP_GlobalClassHandling.Count-1 do begin + cm:=TObject(TP_GlobalClassHandling.Items[j]) as TClassMode; + if AnObject.InheritsFrom(cm.HClass) then begin + if cm.PropertiesToIgnore.Count<>0 then begin + ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore); + end else begin + // Ignore the entire class + currentcm:=cm; + break; + end; + end; + end; + if currentcm<>nil then begin + ObjectPropertyIgnoreList.Clear; + // Ignore or use special handler + if Assigned(currentcm.SpecialHandler) then begin + currentcm.SpecialHandler (AnObject); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Special handler activated for '+AnObject.ClassName); + {$endif} + end else begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Ignoring object '+AnObject.ClassName); + {$endif} + end; + continue; + end; + + Count := GetPropList(AnObject, PropList); + try + for j := 0 to Count - 1 do begin + PropInfo := PropList[j]; + {$IFDEF UNICODE} + if not (PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString, tkClass, tkUString]) then + {$ELSE} + if not (PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString, tkClass]) then + {$ENDIF} + continue; + UPropName:=uppercase(string(PropInfo^.Name)); + // Ignore properties that are meant to be ignored + if ((currentcm=nil) or (not currentcm.PropertiesToIgnore.Find(UPropName,i))) and + (not TP_IgnoreList.Find(Name+'.'+UPropName,i)) and + (not ObjectPropertyIgnoreList.Find(UPropName,i)) then begin + TranslateProperty (AnObject,PropInfo,TodoList,TextDomain); + end; // if + end; // for + finally + if Count<>0 then + FreeMem (PropList); + end; + if AnObject is TStrings then begin + if ((AnObject as TStrings).Text<>'') and (TP_Retranslator<>nil) then + (TP_Retranslator as TTP_Retranslator).Remember(AnObject, 'Text', (AnObject as TStrings).Text); + TranslateStrings (AnObject as TStrings,TextDomain); + end; + // Check for TCollection + if AnObject is TCollection then begin + for i := 0 to (AnObject as TCollection).Count - 1 do begin + // Only add the object if it's not totally ignored already + if not Assigned(currentcm) or not AnObject.InheritsFrom(currentcm.HClass) then + TodoList.AddObject('',(AnObject as TCollection).Items[i]); + end; + end; + if AnObject is TComponent then begin + for i := 0 to TComponent(AnObject).ComponentCount - 1 do begin + comp:=TComponent(AnObject).Components[i]; + if (not TP_IgnoreList.Find(uppercase(comp.Name),j)) then begin + // Only add the object if it's not totally ignored or translated already + if not Assigned(currentcm) or not AnObject.InheritsFrom(currentcm.HClass) then begin + compmarker := comp.FindComponent('GNUgettextMarker'); + if not Assigned(compmarker) then + TodoList.AddObject(uppercase(comp.Name),comp); + end; + end; + end; + end; + end { if AnObject<>nil }; + end { while todolist.count<>0 }; + finally + FreeAndNil (todolist); + FreeAndNil (ObjectPropertyIgnoreList); + FreeAndNil (DoneList); + end; + FreeTP_ClassHandlingItems; + TP_IgnoreList.Clear; + TP_Retranslator:=nil; + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('----------------------------------------------------------------------'); + {$endif} +end; + +procedure TGnuGettextInstance.UnregisterWhenNewLanguageListener( + Listener: IGnuGettextInstanceWhenNewLanguageListener); +begin + fWhenNewLanguageListeners.Remove(Listener); +end; + +procedure TGnuGettextInstance.UseLanguage(LanguageCode: LanguageString); +var + i,p:integer; + dom:TDomain; + l2:string; +begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln('UseLanguage('''+LanguageCode+'''); called'); + {$endif} + + if LanguageCode='' then begin + LanguageCode:=GGGetEnvironmentVariable('LANG'); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('LANG env variable is '''+LanguageCode+'''.'); + {$endif} + {$ifdef MSWINDOWS} + if LanguageCode='' then begin + LanguageCode:=GetWindowsLanguage; + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Found Windows language code to be '''+LanguageCode+'''.'); + {$endif} + end; + {$endif} + p:=pos('.',LanguageCode); + if p<>0 then + LanguageCode:=LeftStr(LanguageCode,p-1); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Language code that will be set is '''+LanguageCode+'''.'); + {$endif} + end; + + curlang := LanguageCode; + for i:=0 to domainlist.Count-1 do begin + dom:=domainlist.Objects[i] as TDomain; + dom.SetLanguageCode (curlang); + end; + + l2:=lowercase(LeftStr(curlang,2)); + if (l2='en') or (l2='de') then curGetPluralForm:=GetPluralForm2EN else + if (l2='hu') or (l2='ko') or (l2='zh') or (l2='ja') or (l2='tr') then curGetPluralForm:=GetPluralForm1 else + if (l2='fr') or (l2='fa') or (lowercase(curlang)='pt_br') then curGetPluralForm:=GetPluralForm2FR else + if (l2='lv') then curGetPluralForm:=GetPluralForm3LV else + if (l2='ga') then curGetPluralForm:=GetPluralForm3GA else + if (l2='lt') then curGetPluralForm:=GetPluralForm3LT else + if (l2='ru') or (l2='uk') or (l2='hr') then curGetPluralForm:=GetPluralForm3RU else + if (l2='cs') or (l2='sk') then curGetPluralForm:=GetPluralForm3SK else + if (l2='pl') then curGetPluralForm:=GetPluralForm3PL else + if (l2='sl') then curGetPluralForm:=GetPluralForm4SL else begin + curGetPluralForm:=GetPluralForm2EN; + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Plural form for the language was not found. English plurality system assumed.'); + {$endif} + end; + + WhenNewLanguage (curlang); + + {$ifdef DXGETTEXTDEBUG} + DebugWriteln(''); + {$endif} +end; + +procedure TGnuGettextInstance.TranslateStrings(sl: TStrings;const TextDomain:DomainString); +var + line: string; + i: integer; + s:TStringList; + {$ifdef DELPHI2009OROLDER} + slAsTStringList:TStringList; + originalOwnsObjects: Boolean; + {$endif} +begin + if sl.Count > 0 then begin + // From D2009 onward, the TStringList class has a OwnsObjects property, just like + // TObjectList has. This means that when we will be calling Clear on the given + // list in the sl parameter, we could destroy the objects it contains. + // To avoid this we must disable OwnsObjects while we replace the strings, but + // only if sl is a TStringList instance and if using Delphi 2009 or upper. + {$ifdef DELPHI2009OROLDER} + originalOwnsObjects := False; // avoid warning + if sl is TStringList then + slAsTStringList := TStringList(sl) + else + slAsTStringList := nil; + {$endif} + + sl.BeginUpdate; + try + s:=TStringList.Create; + try + // don't use Assign here as it will propagate the Sorted property (among others) + // in versions of Delphi from Delphi XE ownard + s.AddStrings(sl); + + for i:=0 to s.Count-1 do begin + line:=s.Strings[i]; + if line<>'' then + if TextDomain = '' then + s.Strings[i]:=ComponentGettext(line) + else + s.Strings[i]:=dgettext(TextDomain,line); + end; + + {$ifdef DELPHI2009OROLDER} + if Assigned(slAsTStringList) then begin + originalOwnsObjects := slAsTStringList.OwnsObjects; + slAsTStringList.OwnsObjects := False; + end; + {$endif} + try + // same here, we don't want to modify the properties of the orignal string list + sl.Clear; + sl.AddStrings(s); + finally + {$ifdef DELPHI2009OROLDER} + if Assigned(slAsTStringList) then + slAsTStringList.OwnsObjects := originalOwnsObjects; + {$endif} + end; + finally + FreeAndNil (s); + end; + finally + sl.EndUpdate; + end; + end; +end; + +function TGnuGettextInstance.GetTranslatorNameAndEmail: TranslatedUnicodeString; +begin + Result:=GetTranslationProperty('LAST-TRANSLATOR'); +end; + +function TGnuGettextInstance.GetTranslationProperty( + const Propertyname: ComponentNameString): TranslatedUnicodeString; +begin + Result:=getdomain(curmsgdomain,DefaultDomainDirectory,CurLang).GetTranslationProperty (Propertyname); +end; + +function TGnuGettextInstance.dngettext(const szDomain: DomainString; const singular, plural: MsgIdString; + Number: Integer): TranslatedUnicodeString; +var + org:MsgIdString; + trans:TranslatedUnicodeString; + idx:integer; + p:integer; +begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('dngettext translation (domain '+szDomain+', number is '+IntTostr(Number)+') of '+singular+'/'+plural); + {$endif} + org:=singular+#0+plural; + trans:=dgettext(szDomain,org); + if org=trans then begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Translation was equal to english version. English plural forms assumed.'); + {$endif} + idx:=GetPluralForm2EN(Number) + end else + idx:=curGetPluralForm(Number); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Index '+IntToStr(idx)+' will be used'); + {$endif} + while true do begin + p:=pos(#0,trans); + if p=0 then begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Last translation used: '+utf8encode(trans)); + {$endif} + Result:=trans; + exit; + end; + if idx=0 then begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Translation found: '+utf8encode(trans)); + {$endif} + Result:=LeftStr(trans,p-1); + exit; + end; + delete (trans,1,p); + dec (idx); + end; +end; + +function TGnuGettextInstance.dngettext_NoExtract(const szDomain: DomainString; + const singular, plural: MsgIdString; + Number: Integer): TranslatedUnicodeString; +begin + // This one is very useful for translating text in variables. + // This can sometimes be necessary, and by using this function, + // the source code scanner will not trigger warnings. + Result:=dngettext(szDomain,singular,plural,Number); +end; + +{$ifndef UNICODE} +function TGnuGettextInstance.ngettext(const singular, plural: ansistring; + Number: Integer): TranslatedUnicodeString; +begin + Result := dngettext(curmsgdomain, singular, plural, Number); +end; +{$endif} + +function TGnuGettextInstance.ngettext(const singular, plural: MsgIdString; + Number: Integer): TranslatedUnicodeString; +begin + Result := dngettext(curmsgdomain, singular, plural, Number); +end; + +function TGnuGettextInstance.ngettext_NoExtract(const singular, + plural: MsgIdString; Number: Integer): TranslatedUnicodeString; +begin + // This one is very useful for translating text in variables. + // This can sometimes be necessary, and by using this function, + // the source code scanner will not trigger warnings. + Result:=ngettext(singular,plural,Number); +end; + +procedure TGnuGettextInstance.WhenNewDomain(const TextDomain: DomainString); +begin + // This is meant to be empty. +end; + +procedure TGnuGettextInstance.WhenNewLanguage(const LanguageID: LanguageString); +var + I: Integer; +begin + for I := 0 to fWhenNewLanguageListeners.Count - 1 do + IGnuGettextInstanceWhenNewLanguageListener(fWhenNewLanguageListeners[I]).WhenNewLanguage(LanguageID); +end; + +procedure TGnuGettextInstance.WhenNewDomainDirectory(const TextDomain:DomainString; const Directory: FilenameString); +begin + // This is meant to be empty. +end; + +procedure TGnuGettextInstance.GetListOfLanguages(const domain: DomainString; + list: TStrings); +begin + getdomain(Domain,DefaultDomainDirectory,CurLang).GetListOfLanguages(list); +end; + +procedure TGnuGettextInstance.bindtextdomainToFile(const szDomain:DomainString; const filename: FilenameString); +begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Text domain "'+szDomain+'" is now bound to file named "'+filename+'"'); + {$endif} + getdomain(szDomain,DefaultDomainDirectory,CurLang).SetFilename (filename); +end; + +procedure TGnuGettextInstance.DebugLogPause(PauseEnabled: boolean); +begin + {$ifdef DXGETTEXTDEBUG} + DebugLogOutputPaused:=PauseEnabled; + {$endif} +end; + +procedure TGnuGettextInstance.DebugLogToFile(const filename: FilenameString; append:boolean=false); +{$ifdef DXGETTEXTDEBUG} +var + fs:TFileStream; + marker:ansistring; +{$endif} +begin + {$ifdef DXGETTEXTDEBUG} + // Create the file if needed + if (not fileexists(filename)) or (not append) then + fileclose (filecreate (filename)); + + // Open file + fs:=TFileStream.Create (filename,fmOpenWrite or fmShareDenyWrite); + if append then + fs.Seek(0,soFromEnd); + + // Write header if appending + if fs.Position<>0 then begin + marker:=sLineBreak+'==========================================================================='+sLineBreak; + fs.WriteBuffer(marker[1],length(marker)); + end; + + // Copy the memorystream contents to the file + if DebugLog <> nil then + begin + DebugLog.Seek(0,soFromBeginning); + fs.CopyFrom(DebugLog,0); + end; + + // Make DebugLog point to the filestream + FreeAndNil (DebugLog); + DebugLog:=fs; + {$endif} +end; + +{$ifdef DXGETTEXTDEBUG} +procedure TGnuGettextInstance.DebugWriteln(line: ansistring); +Var + Discard: Boolean; +begin + Assert (DebugLogCS<>nil); + Assert (DebugLog<>nil); + + DebugLogCS.BeginWrite; + try + if DebugLogOutputPaused then + exit; + + if Assigned (fOnDebugLine) then begin + Discard := True; + fOnDebugLine (Self, Line, Discard); + If Discard then Exit; + end; + + line:=line+sLineBreak; + + // Ensure that memory usage doesn't get too big. + if (DebugLog is TMemoryStream) and (DebugLog.Position>1000000) then begin + line:=sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak+ + 'Debug log halted because memory usage grew too much.'+sLineBreak+ + 'Specify a filename to store the debug log in or disable debug loggin in gnugettext.pas.'+ + sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak; + DebugLogOutputPaused:=True; + end; + DebugLog.WriteBuffer(line[1],length(line)); + finally + DebugLogCS.EndWrite; + end; +end; +{$endif} + +function TGnuGettextInstance.Getdomain(const domain:DomainString; const DefaultDomainDirectory:FilenameString; const CurLang: LanguageString): TDomain; +// Retrieves the TDomain object for the specified domain. +// Creates one, if none there, yet. +var + idx: integer; +begin + idx := domainlist.IndexOf(Domain); + if idx = -1 then begin + Result := TDomain.Create; + {$ifdef DXGETTEXTDEBUG} + Result.DebugLogger:=DebugWriteln; + {$endif} + Result.Domain := Domain; + Result.Directory := DefaultDomainDirectory; + Result.SetLanguageCode(curlang); + domainlist.AddObject(Domain, Result); + end else begin + Result := domainlist.Objects[idx] as TDomain; + end; +end; + +function TGnuGettextInstance.LoadResString( + ResStringRec: PResStringRec): UnicodeString; +{$ifdef MSWINDOWS} +var + Len: Integer; + {$IFDEF UNICODE} + Buffer: array [0..1023] of widechar; + {$else} + Buffer: array [0..1023] of ansichar; + {$endif} +{$endif} +{$ifdef LINUX } +const + ResStringTableLen = 16; +type + ResStringTable = array [0..ResStringTableLen-1] of LongWord; +var + Handle: TResourceHandle; + Tab: ^ResStringTable; + ResMod: HMODULE; +{$endif } +begin + if ResStringRec=nil then + exit; + if ResStringRec.Identifier>=64*1024 then begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('LoadResString was given an invalid ResStringRec.Identifier'); + {$endif} + Result:='ERROR'; + exit; + end else begin + {$ifdef LINUX} + // This works with Unicode if the Linux has utf-8 character set + // Result:=System.LoadResString(ResStringRec); + ResMod:=FindResourceHInstance(ResStringRec^.Module^); + Handle:=FindResource(ResMod, + PAnsiChar(ResStringRec^.Identifier div ResStringTableLen), PAnsiChar(6)); // RT_STRING + Tab:=Pointer(LoadResource(ResMod, Handle)); + if Tab=nil then + Result:='' + else + Result:=PWideChar(PAnsiChar(Tab)+Tab[ResStringRec^.Identifier mod ResStringTableLen]); + {$endif} + {$ifdef MSWINDOWS} + if not Win32PlatformIsUnicode then begin + SetString(Result, Buffer, + LoadString(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, SizeOf(Buffer))) + end else begin + Result := ''; + Len := 0; + While Length(Result)<=Len+1 do begin + if Length(Result) = 0 then + SetLength(Result, 1024) + else + SetLength(Result, Length(Result) * 2); + Len := LoadStringW(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, PWideChar(Result), Length(Result)); + end; + SetLength(Result, Len); + end; + {$endif} + end; + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Loaded resourcestring: '+utf8encode(Result)); + {$endif} + if CreatorThread<>GetCurrentThreadId then begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('LoadResString was called from an invalid thread. Resourcestring was not translated.'); + {$endif} + end else + Result:=ResourceStringGettext(Result); +end; + +procedure TGnuGettextInstance.RegisterWhenNewLanguageListener( + Listener: IGnuGettextInstanceWhenNewLanguageListener); +begin + fWhenNewLanguageListeners.Add(Listener); +end; + +procedure TGnuGettextInstance.RetranslateComponent(AnObject: TComponent; + const TextDomain: DomainString); +var + comp:TGnuGettextComponentMarker; +begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('======================================================================'); + DebugWriteln ('RetranslateComponent() was called for a component with name '+AnObject.Name+'.'); + {$endif} + comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker; + if comp=nil then + begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Retranslate was called on an object that has not been translated before. An Exception is being raised.'); + {$endif} + raise EGGProgrammingError.Create ('Retranslate was called on an object that has not been translated before. Please use TranslateComponent() before RetranslateComponent().'); + end + else + begin + //*** if param ReReadMoFileOnSameLanguage is set, use the ReTranslate + // function nevertheless if the current language is the same like the + // new (-> reread the current .mo-file from the file system). + if ReReadMoFileOnSameLanguage or + (comp.LastLanguage <> curlang) then + begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('The retranslator is being executed.'); + {$endif} + comp.Retranslator.Execute; + end + else + begin + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('The language has not changed. The retranslator is not executed.'); + {$endif} + end; + end; + comp.LastLanguage:=curlang; + + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('======================================================================'); + {$endif} +end; + +procedure TGnuGettextInstance.TP_IgnoreClass(IgnClass: TClass); +var + cm:TClassMode; + i:integer; +begin + for i:=0 to TP_ClassHandling.Count-1 do begin + cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode; + if cm.HClass=IgnClass then + raise EGGProgrammingError.Create ('You cannot add a class to the ignore list that is already on that list: '+IgnClass.ClassName+'.'); + if IgnClass.InheritsFrom(cm.HClass) then begin + // This is the place to insert this class + cm:=TClassMode.Create; + cm.HClass:=IgnClass; + TP_ClassHandling.Insert(i,cm); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.'); + {$endif} + exit; + end; + end; + cm:=TClassMode.Create; + cm.HClass:=IgnClass; + TP_ClassHandling.Add(cm); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.'); + {$endif} +end; + +procedure TGnuGettextInstance.TP_IgnoreClassProperty(IgnClass: TClass; + propertyname: ComponentNameString); +var + cm:TClassMode; + i:integer; +begin + propertyname:=uppercase(propertyname); + for i:=0 to TP_ClassHandling.Count-1 do begin + cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode; + if cm.HClass=IgnClass then begin + if Assigned(cm.SpecialHandler) then + raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.'); + cm.PropertiesToIgnore.Add(propertyname); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.'); + {$endif} + exit; + end; + if IgnClass.InheritsFrom(cm.HClass) then begin + // This is the place to insert this class + cm:=TClassMode.Create; + cm.HClass:=IgnClass; + cm.PropertiesToIgnore.Add(propertyname); + TP_ClassHandling.Insert(i,cm); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.'); + {$endif} + exit; + end; + end; + cm:=TClassMode.Create; + cm.HClass:=IgnClass; + cm.PropertiesToIgnore.Add(propertyname); + TP_GlobalClassHandling.Add(cm); + {$ifdef DXGETTEXTDEBUG} + DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.'); + {$endif} +end; + +procedure TGnuGettextInstance.FreeTP_ClassHandlingItems; +begin + while TP_ClassHandling.Count<>0 do begin + TObject(TP_ClassHandling.Items[0]).Free; + TP_ClassHandling.Delete(0); + end; +end; + +{$ifndef UNICODE} +function TGnuGettextInstance.ansi2wideDTCP(const s: ansistring): MsgIdString; +{$ifdef MSWindows} +var + len:integer; +{$endif} +begin +{$ifdef MSWindows} + if DesignTimeCodePage=CP_ACP then begin + // No design-time codepage specified. Using runtime codepage instead. +{$endif} + Result:=s; +{$ifdef MSWindows} + end else begin + len:=length(s); + if len=0 then + Result:='' + else begin + SetLength (Result,len); + len:=MultiByteToWideChar(DesignTimeCodePage,0,pansichar(s),len,pwidechar(Result),len); + if len=0 then + raise EGGAnsi2WideConvError.Create ('Cannot convert string to widestring:'+sLineBreak+s); + SetLength (Result,len); + end; + end; +{$endif} +end; +{$endif} + +{$ifndef UNICODE} +function TGnuGettextInstance.dngettext(const szDomain: DomainString; const singular, + plural: ansistring; Number: Integer): TranslatedUnicodeString; +begin + Result:=dngettext (szDomain, ansi2wideDTCP(singular), ansi2wideDTCP(plural), Number); +end; +{$endif} + +{ TClassMode } + +constructor TClassMode.Create; +begin + PropertiesToIgnore:=TStringList.Create; + PropertiesToIgnore.Sorted:=True; + PropertiesToIgnore.Duplicates:=dupError; + PropertiesToIgnore.CaseSensitive:=False; +end; + +destructor TClassMode.Destroy; +begin + FreeAndNil (PropertiesToIgnore); + inherited; +end; + +{ TFileLocator } + +function TFileLocator.FindSignaturePos(const signature: RawByteString; + str: TFileStream): Int64; +// Finds the position of signature in the file. +const + bufsize=100000; +var + a:RawByteString; + b:RawByteString; + offset:integer; + rd,p:Integer; +begin + if signature='' then + begin + Result := 0; + Exit; + end; + + offset:=0; + str.Seek(0, soFromBeginning); + + SetLength (a, bufsize); + SetLength (b, bufsize); + str.Read(a[1],bufsize); + + while true do begin + rd:=str.Read(b[1],bufsize); + p:=pos(signature,a+b); + if (p<>0) then begin // do not check p < bufsize+100 here! + Result:=offset+p-1; + exit; + end; + if rd<>bufsize then begin + // Prematurely ended without finding anything + Result:=0; + exit; + end; + a:=b; + offset:=offset+bufsize; + end; + Result:=0; +end; + +procedure TFileLocator.Analyze; +var + HeaderSize, + PrefixSize: Integer; + dummysig, + headerpre, + headerbeg, + headerend:RawByteString; + i:integer; + headerbeginpos, + headerendpos:integer; + offset, + tableoffset:int64; + fs:TFileStream; + fi:TEmbeddedFileInfo; + filename:FilenameString; + filename8bit:RawByteString; +const + // DetectionSignature: used solely to detect gnugettext usage by assemble + DetectionSignature: array[0..35] of AnsiChar='2E23E563-31FA-4C24-B7B3-90BE720C6B1A'; + // Embedded Header Begin Signature (without dynamic prefix written by assemble) + BeginHeaderSignature: array[0..35] of AnsiChar='BD7F1BE4-9FCF-4E3A-ABA7-3443D11AB362'; + // Embedded Header End Signature (without dynamic prefix written by assemble) + EndHeaderSignature: array[0..35] of AnsiChar='1C58841C-D8A0-4457-BF54-D8315D4CF49D'; + // Assemble Prefix (do not put before the Header Signatures!) + SignaturePrefix: array[0..2] of AnsiChar='DXG'; // written from assemble +begin + // Attn: Ensure all Signatures have the same size! + HeaderSize := High(BeginHeaderSignature) - Low(BeginHeaderSignature) + 1; + PrefixSize := High(SignaturePrefix) - Low(SignaturePrefix) + 1; + + // dummy usage of DetectionSignature (otherwise not compiled into exe) + SetLength(dummysig, HeaderSize); + for i := 0 to HeaderSize-1 do + dummysig[i+1] := DetectionSignature[i]; + + // copy byte by byte (D2009+ compatible) + SetLength(headerpre, PrefixSize); + for i:= 0 to PrefixSize-1 do + headerpre[i+1] := SignaturePrefix[i]; + + SetLength(headerbeg, HeaderSize); + for i:= 0 to HeaderSize-1 do + headerbeg[i+1] := BeginHeaderSignature[i]; + + SetLength(headerend, HeaderSize); + for i:= 0 to HeaderSize-1 do + headerend[i+1] := EndHeaderSignature[i]; + + BaseDirectory:=ExtractFilePath(ExecutableFilename); + try + fs:=TFileStream.Create(ExecutableFilename,fmOpenRead or fmShareDenyNone); + try + // try to find new header begin and end signatures + headerbeginpos := FindSignaturePos(headerpre+headerbeg, fs); + headerendpos := FindSignaturePos(headerpre+headerend, fs); + + if (headerbeginpos > 0) and (headerendpos > 0) then + begin + // adjust positions (to the end of each signature) + headerbeginpos := headerbeginpos + HeaderSize + PrefixSize; + + // get file table offset (8 byte, stored directly before the end header) + fs.Seek(headerendpos - 8, soFromBeginning); + // get relative offset and convert to absolute offset during runtime + tableoffset := headerbeginpos + ReadInt64(fs); + + // go to beginning of embedded block + fs.Seek(headerbeginpos, soFromBeginning); + + offset := tableoffset; + Assert(sizeof(offset)=8); + while (true) and (fs.Position0 do begin + filelist.Objects[0].Free; + filelist.Delete (0); + end; + FreeAndNil (filelist); + FreeAndNil (MoFiles); + FreeAndNil (MoFilesCS); + inherited; +end; + +function TFileLocator.FileExists(filename: FilenameString): boolean; +var + idx:integer; +begin + if LeftStr(filename,length(basedirectory))=basedirectory then begin + // Cut off basedirectory if the file is located beneath that base directory + filename:=MidStr(filename,length(basedirectory)+1,maxint); + end; + Result:=filelist.Find(filename,idx); +end; + +function TFileLocator.GetMoFile(filename: FilenameString; DebugLogger:TDebugLogger): TMoFile; +var + fi:TEmbeddedFileInfo; + idx:integer; + idxname:FilenameString; + Offset, Size: Int64; + realfilename:FilenameString; +begin + // Find real filename + offset:=0; + size:=0; + realfilename:=filename; + if LeftStr(filename,length(basedirectory))=basedirectory then begin + filename:=MidStr(filename,length(basedirectory)+1,maxint); + idx:=filelist.IndexOf(filename); + if idx<>-1 then begin + fi:=filelist.Objects[idx] as TEmbeddedFileInfo; + realfilename:=ExecutableFilename; + offset:=fi.offset; + size:=fi.size; + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('Instead of '+filename+', using '+realfilename+' from offset '+IntTostr(offset)+', size '+IntToStr(size)); + {$endif} + end; + end; + + + {$ifdef DXGETTEXTDEBUG} + DebugLogger ('Reading .mo data from file '''+filename+''''); + {$endif} + + // Find TMoFile object + MoFilesCS.BeginWrite; + try + idxname:=realfilename+' //\\ '+IntToStr(offset); + if MoFiles.Find(idxname, idx) then begin + Result:=MoFiles.Objects[idx] as TMoFile; + end else begin + Result:=TMoFile.Create (realfilename, Offset, Size, UseMemoryMappedFiles); + MoFiles.AddObject(idxname, Result); + end; + Inc (Result.Users); + finally + MoFilesCS.EndWrite; + end; +end; + +function TFileLocator.ReadInt64(str: TStream): int64; +begin + Assert (sizeof(Result)=8); + str.ReadBuffer(Result,8); +end; + +procedure TFileLocator.ReleaseMoFile(mofile: TMoFile); +var + i:integer; +begin + Assert (mofile<>nil); + + MoFilesCS.BeginWrite; + try + dec (mofile.Users); + if mofile.Users<=0 then begin + i:=MoFiles.Count-1; + while i>=0 do begin + if MoFiles.Objects[i]=mofile then begin + MoFiles.Delete(i); + FreeAndNil (mofile); + break; + end; + dec (i); + end; + end; + finally + MoFilesCS.EndWrite; + end; +end; + +{ TTP_Retranslator } + +constructor TTP_Retranslator.Create; +begin + list:=TList.Create; +end; + +destructor TTP_Retranslator.Destroy; +var + i:integer; +begin + for i:=0 to list.Count-1 do + TObject(list.Items[i]).Free; + FreeAndNil (list); + inherited; +end; + +procedure TTP_Retranslator.Execute; +var + i:integer; + sl:TStrings; + item:TTP_RetranslatorItem; + newvalue:TranslatedUnicodeString; + comp:TGnuGettextComponentMarker; + ppi:PPropInfo; +begin + for i:=0 to list.Count-1 do begin + item:=TObject(list.items[i]) as TTP_RetranslatorItem; + if item.obj is TComponent then begin + comp:=TComponent(item.obj).FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker; + if Assigned(comp) and (self<>comp.Retranslator) then begin + comp.Retranslator.Execute; + Continue; + end; + end; + if item.obj is TStrings then begin + // Since we don't know the order of items in sl, and don't have + // the original .Objects[] anywhere, we cannot anticipate anything + // about the current sl.Strings[] and sl.Objects[] values. We therefore + // have to discard both values. We can, however, set the original .Strings[] + // value into the list and retranslate that. + sl:=TStringList.Create; + try + sl.Text:=item.OldValue; + Instance.TranslateStrings(sl,textdomain); + (item.obj as TStrings).BeginUpdate; + try + (item.obj as TStrings).Text:=sl.Text; + finally + (item.obj as TStrings).EndUpdate; + end; + finally + FreeAndNil (sl); + end; + end else begin + if (textdomain = '') or (textdomain = DefaultTextDomain) then + newValue := ComponentGettext(item.OldValue, instance) + else + newValue := instance.dgettext(textdomain,item.OldValue); + ppi:=GetPropInfo(item.obj, item.Propname); + if ppi<>nil then begin + SetWideStrProp(item.obj, ppi, newValue); + end else begin + {$ifdef DXGETTEXTDEBUG} + Instance.DebugWriteln ('ERROR: On retranslation, property disappeared: '+item.Propname+' for object of type '+item.obj.ClassName); + {$endif} + end; + end; + end; +end; + +procedure TTP_Retranslator.Remember(obj: TObject; PropName: ComponentNameString; + OldValue: TranslatedUnicodeString); +var + item:TTP_RetranslatorItem; +begin + item:=TTP_RetranslatorItem.Create; + item.obj:=obj; + item.Propname:=Propname; + item.OldValue:=OldValue; + list.Add(item); +end; + +{ TGnuGettextComponentMarker } + +destructor TGnuGettextComponentMarker.Destroy; +begin + FreeAndNil (Retranslator); + inherited; +end; + +{ THook } + +constructor THook.Create(OldProcedure, NewProcedure: pointer; FollowJump:boolean=false); +{ Idea and original code from Igor Siticov } +{ Modified by Jacques Garcia Vazquez and Lars Dybdahl } +begin + {$ifndef CPU386} + {$ifndef CPUx64} + raise Exception.Create ('This procedure only works on Intel i386 or x64 compatible processors.'); + {$endif} + {$endif} + + oldproc:=OldProcedure; + newproc:=NewProcedure; + + Reset (FollowJump); +end; + +destructor THook.Destroy; +begin + Shutdown; + inherited; +end; + +procedure THook.Disable; +begin + Assert (PatchPosition<>nil,'Patch position in THook was nil when Disable was called'); + PatchPosition[0]:=Original[0]; + PatchPosition[1]:=Original[1]; + PatchPosition[2]:=Original[2]; + PatchPosition[3]:=Original[3]; + PatchPosition[4]:=Original[4]; +end; + +procedure THook.Enable; +begin + Assert (PatchPosition<>nil,'Patch position in THook was nil when Enable was called'); + PatchPosition[0]:=Patch[0]; + PatchPosition[1]:=Patch[1]; + PatchPosition[2]:=Patch[2]; + PatchPosition[3]:=Patch[3]; + PatchPosition[4]:=Patch[4]; +end; + +procedure THook.Reset(FollowJump: boolean); +var + offset:integer; + {$ifdef LINUX} + p:pointer; + pagesize:integer; + {$endif} + {$ifdef MSWindows} + ov: cardinal; + {$endif} +begin + if PatchPosition<>nil then + Shutdown; + + patchPosition := OldProc; + if FollowJump and (Word(OldProc^) = $25FF) then begin + // This finds the correct procedure if a virtual jump has been inserted + // at the procedure address + Inc(patchPosition, 2); // skip the jump + patchPosition := pansiChar(Pointer(pointer(patchPosition)^)^); + end; + offset:=integer(NewProc)-integer(pointer(patchPosition))-5; + + Patch[0] := ansichar($E9); + Patch[1] := ansichar(offset and 255); + Patch[2] := ansichar((offset shr 8) and 255); + Patch[3] := ansichar((offset shr 16) and 255); + Patch[4] := ansichar((offset shr 24) and 255); + + Original[0]:=PatchPosition[0]; + Original[1]:=PatchPosition[1]; + Original[2]:=PatchPosition[2]; + Original[3]:=PatchPosition[3]; + Original[4]:=PatchPosition[4]; + + {$ifdef MSWINDOWS} + if not VirtualProtect(Pointer(PatchPosition), 5, PAGE_EXECUTE_READWRITE, @ov) then + RaiseLastOSError; + {$endif} + {$ifdef LINUX} + pageSize:=sysconf (_SC_PAGE_SIZE); + p:=pointer(PatchPosition); + p:=pointer((integer(p) + PAGESIZE-1) and not (PAGESIZE-1) - pageSize); + if mprotect (p, pageSize, PROT_READ + PROT_WRITE + PROT_EXEC) <> 0 then + RaiseLastOSError; + {$endif} +end; + +procedure THook.Shutdown; +begin + Disable; + PatchPosition:=nil; +end; + +procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false); +begin + HookLoadResString.Reset (SupportPackages); + HookLoadStr.Reset (SupportPackages); + HookFmtLoadStr.Reset (SupportPackages); + if enabled then begin + HookLoadResString.Enable; + HookLoadStr.Enable; + HookFmtLoadStr.Enable; + end; +end; + +{ TMoFile } + +function TMoFile.autoswap32(i: cardinal): cardinal; +var + cnv1, cnv2: + record + case integer of + 0: (arr: array[0..3] of byte); + 1: (int: cardinal); + end; +begin + if doswap then begin + cnv1.int := i; + cnv2.arr[0] := cnv1.arr[3]; + cnv2.arr[1] := cnv1.arr[2]; + cnv2.arr[2] := cnv1.arr[1]; + cnv2.arr[3] := cnv1.arr[0]; + Result := cnv2.int; + end else + Result := i; +end; + +function TMoFile.CardinalInMem(baseptr: PansiChar; Offset: Cardinal): Cardinal; +var pc:^Cardinal; +begin + inc (baseptr,offset); + pc:=Pointer(baseptr); + Result:=pc^; + if doswap then + autoswap32(Result); +end; + +constructor TMoFile.Create(const filename: FilenameString; + const Offset: int64; Size: int64; + const xUseMemoryMappedFiles: Boolean); +var + i:cardinal; + nn:integer; + mofile:TFileStream; +begin + if sizeof(i) <> 4 then + raise EGGProgrammingError.Create('TDomain in gnugettext is written for an architecture that has 32 bit integers.'); + + {$ifdef mswindows} + FUseMemoryMappedFiles := xUseMemoryMappedFiles; + {$endif} + + {$ifdef linux} + FUseMemoryMappedFiles := False; + {$endif} + + if FUseMemoryMappedFiles then + begin + // Map the mo file into memory and let the operating system decide how to cache + mo:=createfile (PChar(filename),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0); + if mo=INVALID_HANDLE_VALUE then + raise EGGIOError.Create ('Cannot open file '+filename); + momapping:=CreateFileMapping (mo, nil, PAGE_READONLY, 0, 0, nil); + if momapping=0 then + raise EGGIOError.Create ('Cannot create memory map on file '+filename); + momemoryHandle:=MapViewOfFile (momapping,FILE_MAP_READ,0,0,0); + if momemoryHandle=nil then begin + raise EGGIOError.Create ('Cannot map file '+filename+' into memory. Reason: '+GetLastWinError); + end; + momemory:=momemoryHandle+offset; + end + else + begin + // Read the whole file into memory + mofile:=TFileStream.Create (filename, fmOpenRead or fmShareDenyNone); + try + if (size = 0) then + size := mofile.Size; + Getmem (momemoryHandle, size); + momemory := momemoryHandle; + mofile.Seek(offset, soFromBeginning); + mofile.ReadBuffer(momemory^, size); + finally + FreeAndNil(mofile); + end; + end; + + // Check the magic number + doswap:=False; + i:=CardinalInMem(momemory,0); + if (i <> $950412DE) and (i <> $DE120495) then + raise EGGIOError.Create('This file is not a valid GNU gettext mo file: ' + filename); + doswap := (i = $DE120495); + + + // Find the positions in the file according to the file format spec + CardinalInMem(momemory,4); // Read the version number, but don't use it for anything. + N:=CardinalInMem(momemory,8); // Get string count + O:=CardinalInMem(momemory,12); // Get offset of original strings + T:=CardinalInMem(momemory,16); // Get offset of translated strings + + // Calculate start conditions for a binary search + nn := N; + startindex := 1; + while nn <> 0 do begin + nn := nn shr 1; + startindex := startindex shl 1; + end; + startindex := startindex shr 1; + startstep := startindex shr 1; +end; + +destructor TMoFile.Destroy; +begin + if FUseMemoryMappedFiles then + begin + UnMapViewOfFile (momemoryHandle); + CloseHandle (momapping); + CloseHandle (mo); + end + else + begin + FreeMem (momemoryHandle); + end; + + inherited; +end; + +function TMoFile.gettext(const msgid: RawUtf8String;var found:boolean): RawUtf8String; +var + i, step: cardinal; + offset, pos: cardinal; + CompareResult:integer; + msgidptr,a,b:PAnsiChar; + abidx:integer; + size, msgidsize:integer; +begin + found:=false; + msgidptr:=PAnsiChar(msgid); + msgidsize:=length(msgid); + + // Do binary search + i:=startindex; + step:=startstep; + while true do begin + // Get string for index i + pos:=O+8*(i-1); + offset:=CardinalInMem (momemory,pos+4); + size:=CardinalInMem (momemory,pos); + a:=msgidptr; + b:=momemory+offset; + abidx:=size; + if msgidsize0 do begin + CompareResult:=integer(byte(a^))-integer(byte(b^)); + if CompareResult<>0 then + break; + dec (abidx); + inc (a); + inc (b); + end; + if CompareResult=0 then + CompareResult:=msgidsize-size; + if CompareResult=0 then begin // msgid=s + // Found the msgid + pos:=T+8*(i-1); + offset:=CardinalInMem (momemory,pos+4); + size:=CardinalInMem (momemory,pos); + SetString (Result,momemory+offset,size); + found:=True; + break; + end; + if step=0 then begin + // Not found + Result:=msgid; + break; + end; + if CompareResult<0 then begin // msgids + i := i + step; + if i > N then + i := N; + step := step shr 1; + end; + end; +end; + +var + param0:string; + +initialization + {$ifdef DXGETTEXTDEBUG} + {$ifdef MSWINDOWS} + MessageBox (0,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.','Information',MB_OK); + {$endif} + {$ifdef LINUX} + writeln (stderr,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.'); + {$endif} + {$endif} + {$ifdef FPC} + {$ifdef LINUX} + SetLocale(LC_ALL, ''); + SetCWidestringManager; + {$endif LINUX} + {$endif FPC} + // Get DLL/shared object filename + SetLength(ExecutableFilename, 300); // MAX_PATH ? + {$ifdef MSWINDOWS} + SetLength(ExecutableFilename, GetModuleFileName(HInstance, + PChar(ExecutableFilename), Length(ExecutableFilename))); + {$endif} + {$ifdef LINUX} + if ModuleIsLib or ModuleIsPackage then + begin + // This line has not been tested on Linux, yet, but should work. + SetLength(ExecutableFilename, GetModuleFileName(0, PChar(ExecutableFilename), + Length(ExecutableFilename))); + end else + ExecutableFilename:=Paramstr(0); + {$endif} + FileLocator:=TFileLocator.Create; + FileLocator.Analyze; + ResourceStringDomainList:=TStringList.Create; + ResourceStringDomainList.Add(DefaultTextDomain); + ResourceStringDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create; + ComponentDomainList:=TStringList.Create; + ComponentDomainList.Add(DefaultTextDomain); + ComponentDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create; + DefaultInstance:=TGnuGettextInstance.Create; + {$ifdef MSWINDOWS} + Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT); + {$endif} + + // replace Borlands LoadResString with gettext enabled version: + {$ifdef UNICODE} + HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringW); + {$else} + HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringA); + {$endif} + HookLoadStr:=THook.Create (@sysutils.LoadStr, @SysUtilsLoadStr); + HookFmtLoadStr:=THook.Create (@sysutils.FmtLoadStr, @SysUtilsFmtLoadStr); + param0:=lowercase(extractfilename(paramstr(0))); + if (param0<>'delphi32.exe') and (param0<>'kylix') and (param0<>'bds.exe') then + HookIntoResourceStrings (AutoCreateHooks,false); + param0:=''; + +finalization + FreeAndNil (DefaultInstance); + FreeAndNil (ResourceStringDomainListCS); + FreeAndNil (ResourceStringDomainList); + FreeAndNil (ComponentDomainListCS); + FreeAndNil (ComponentDomainList); + FreeAndNil (HookFmtLoadStr); + FreeAndNil (HookLoadStr); + FreeAndNil (HookLoadResString); + FreeAndNil (FileLocator); + +end. + diff --git a/source/insertfiles.pas b/source/insertfiles.pas index 5de3e3b5..8699ec25 100644 --- a/source/insertfiles.pas +++ b/source/insertfiles.pas @@ -5,7 +5,7 @@ interface uses Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ImgList, ShellApi, Math, Graphics, ComCtrls, ToolWin, - dbconnection, mysql_structures, VirtualTrees, grideditlinks, SynRegExpr; + dbconnection, mysql_structures, VirtualTrees, grideditlinks, SynRegExpr, gnugettext; type TColInfo = class @@ -120,6 +120,7 @@ var SysIL : uint; SFI : TSHFileInfo; begin + TranslateComponent(Self); FSmallImages := TImageList.Create(Self); SysIL := SHGetFileInfo('', 0, SFI, SizeOf(SFI), SHGFI_SYSICONINDEX or SHGFI_SMALLICON); if SysIL <> 0 then begin diff --git a/source/loaddata.pas b/source/loaddata.pas index 29957878..56c435b3 100644 --- a/source/loaddata.pas +++ b/source/loaddata.pas @@ -11,7 +11,7 @@ interface uses Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ComCtrls, CheckLst, SynRegExpr, Buttons, ExtCtrls, ToolWin, ExtDlgs, Math, - dbconnection, mysql_structures; + dbconnection, mysql_structures, gnugettext; type Tloaddataform = class(TForm) @@ -92,6 +92,7 @@ const procedure Tloaddataform.FormCreate(Sender: TObject); begin + TranslateComponent(Self); InheritFont(Font); SetWindowSizeGrip(Handle, True); // Restore settings diff --git a/source/loginform.pas b/source/loginform.pas index 613ec207..2f4ae38e 100644 --- a/source/loginform.pas +++ b/source/loginform.pas @@ -4,7 +4,7 @@ interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, ExtCtrls; + Dialogs, StdCtrls, ExtCtrls, gnugettext; type TfrmLogin = class(TForm) @@ -36,6 +36,7 @@ uses helpers, main; procedure TfrmLogin.FormCreate(Sender: TObject); begin + TranslateComponent(Self); InheritFont(Font); Caption := APPNAME + ' - Login'; MainForm.ImageListMain.GetBitmap(144, imgIcon.Picture.Bitmap); diff --git a/source/main.pas b/source/main.pas index 79cdf642..3360dbe3 100644 --- a/source/main.pas +++ b/source/main.pas @@ -18,7 +18,7 @@ uses CommCtrl, Contnrs, Generics.Collections, Generics.Defaults, SynEditExport, SynExportHTML, Math, ExtDlgs, Registry, AppEvnts, routine_editor, trigger_editor, event_editor, options, EditVar, helpers, createdatabase, table_editor, TableTools, View, Usermanager, SelectDBObject, connections, sqlhelp, dbconnection, - insertfiles, searchreplace, loaddata, copytable, VTHeaderPopup, Cromis.DirectoryWatch, SyncDB; + insertfiles, searchreplace, loaddata, copytable, VTHeaderPopup, Cromis.DirectoryWatch, SyncDB, gnugettext; type @@ -1317,6 +1317,8 @@ var begin caption := APPNAME; + TranslateComponent(Self); + // Detect version dwInfoSize := GetFileVersionInfoSize(PChar(Application.ExeName), dwWnd); GetMem(ptrVerBuf, dwInfoSize); diff --git a/source/options.pas b/source/options.pas index 8936ba5c..ed57e814 100644 --- a/source/options.pas +++ b/source/options.pas @@ -12,7 +12,7 @@ uses Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, ExtCtrls, SynEditHighlighter, SynHighlighterSQL, SynEdit, SynMemo, VirtualTrees, SynEditKeyCmds, ActnList, SynEditMiscClasses, StdActns, Menus, - mysql_structures; + mysql_structures, gnugettext; type TShortcutItemData = record @@ -342,6 +342,7 @@ var (TStrings(Data)).Add(String(lpelf^.elfLogFont.lfFaceName)); end; begin + TranslateComponent(Self); InheritFont(Font); // Misecllaneous diff --git a/source/printlist.pas b/source/printlist.pas index dafe0e06..ca05ed78 100644 --- a/source/printlist.pas +++ b/source/printlist.pas @@ -9,7 +9,7 @@ unit printlist; interface uses - Windows, Classes, Controls, Forms, Dialogs, StdCtrls, Printers, VirtualTrees; + Windows, Classes, Controls, Forms, Dialogs, StdCtrls, Printers, VirtualTrees, gnugettext; type TprintlistForm = class(TForm) @@ -42,6 +42,7 @@ uses main, helpers, table_editor, dbconnection; procedure TprintlistForm.FormCreate(Sender: TObject); begin InheritFont(Font); + TranslateComponent(Self); end; procedure TprintlistForm.FormShow(Sender: TObject); diff --git a/source/routine_editor.pas b/source/routine_editor.pas index c0fe46fc..2e03c580 100644 --- a/source/routine_editor.pas +++ b/source/routine_editor.pas @@ -5,7 +5,7 @@ interface uses Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, SynEdit, SynMemo, StdCtrls, ComCtrls, ToolWin, VirtualTrees, - dbconnection, helpers; + dbconnection, helpers, gnugettext; type TFrame = TDBObjectEditor; @@ -102,6 +102,7 @@ uses main, mysql_structures, grideditlinks; constructor TfrmRoutineEditor.Create(AOwner: TComponent); begin inherited; + TranslateComponent(Self); ScaleControls(Screen.PixelsPerInch, FORMS_DPI); // Combo items in a .dfm are sporadically lost after an IDE restart, // so we set them here to avoid developer annoyance diff --git a/source/runsqlfile.pas b/source/runsqlfile.pas index 5e1a01f0..7402fcae 100644 --- a/source/runsqlfile.pas +++ b/source/runsqlfile.pas @@ -3,7 +3,7 @@ unit runsqlfile; interface uses - Windows, SysUtils, Classes, Controls, Forms, Dialogs, ComCtrls, StdCtrls; + Windows, SysUtils, Classes, Controls, Forms, Dialogs, ComCtrls, StdCtrls, gnugettext; type TRunSQLFileForm = class(TForm) @@ -148,6 +148,7 @@ end; procedure TRunSQLFileForm.FormCreate(Sender: TObject); begin InheritFont(Font); + TranslateComponent(Self); end; end. diff --git a/source/searchreplace.pas b/source/searchreplace.pas index 8d465ddc..2794520f 100644 --- a/source/searchreplace.pas +++ b/source/searchreplace.pas @@ -4,7 +4,7 @@ interface uses Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, - ExtCtrls, SynMemo, SynEditTypes; + ExtCtrls, SynMemo, SynEditTypes, gnugettext; type TfrmSearchReplace = class(TForm) @@ -49,6 +49,7 @@ uses helpers; procedure TfrmSearchReplace.FormCreate(Sender: TObject); begin + TranslateComponent(Self); comboSearch.Items.Text := AppSettings.ReadString(asFindDialogSearchHistory); comboReplace.Items.Text := AppSettings.ReadString(asFindDialogReplaceHistory); comboSearch.Text := ''; diff --git a/source/selectdbobject.pas b/source/selectdbobject.pas index b232e624..0d8048c7 100644 --- a/source/selectdbobject.pas +++ b/source/selectdbobject.pas @@ -4,7 +4,7 @@ interface uses Windows, Classes, Controls, Forms, StdCtrls, VirtualTrees, Graphics, - dbconnection; + dbconnection, gnugettext; type TfrmSelectDBObject = class(TForm) @@ -62,6 +62,7 @@ end; procedure TfrmSelectDBObject.FormCreate(Sender: TObject); begin + TranslateComponent(Self); Width := AppSettings.ReadInt(asSelectDBOWindowWidth); Height := AppSettings.ReadInt(asSelectDBOWindowHeight); SetWindowSizeGrip( Self.Handle, True ); diff --git a/source/sqlhelp.pas b/source/sqlhelp.pas index 0fc50ac0..5a2cfc60 100644 --- a/source/sqlhelp.pas +++ b/source/sqlhelp.pas @@ -6,7 +6,7 @@ uses Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ComCtrls, ExtCtrls, Buttons, SynMemo, SynEditHighlighter, SynHighlighterURI, SynURIOpener, SynEdit, VirtualTrees, Graphics, - dbconnection; + dbconnection, gnugettext; type TfrmSQLhelp = class(TForm) @@ -91,6 +91,7 @@ begin Caption := DEFAULT_WINDOW_CAPTION; MainForm.SetupSynEditors; FixVT(treeTopics); + TranslateComponent(Self); treeTopics.Clear; FreeAndNil(FRootTopics); diff --git a/source/syncdb.pas b/source/syncdb.pas index 07c6afe0..2979eb8c 100644 --- a/source/syncdb.pas +++ b/source/syncdb.pas @@ -5,7 +5,7 @@ interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Generics.Collections, VirtualTrees, - dbconnection; + dbconnection, gnugettext; type TfrmSyncDB = class(TForm) @@ -107,6 +107,7 @@ var SessionPaths: TStringList; begin Caption := MainForm.actSynchronizeDatabase.Caption; + TranslateComponent(Self); InheritFont(Font); SetWindowSizeGrip(Self.Handle, True); FixVT(treeSource); diff --git a/source/table_editor.pas b/source/table_editor.pas index 2f4201b0..2e238e5e 100644 --- a/source/table_editor.pas +++ b/source/table_editor.pas @@ -6,7 +6,7 @@ uses Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, ToolWin, VirtualTrees, SynRegExpr, ActiveX, ExtCtrls, SynEdit, SynMemo, Menus, Clipbrd, Math, - grideditlinks, mysql_structures, dbconnection, helpers; + grideditlinks, mysql_structures, dbconnection, helpers, gnugettext; type TFrame = TDBObjectEditor; @@ -210,6 +210,7 @@ uses main; constructor TfrmTableEditor.Create(AOwner: TComponent); begin inherited; + TranslateComponent(Self); PageControlMain.Height := AppSettings.ReadInt(asTableEditorTabsHeight); FixVT(listColumns); FixVT(treeIndexes); diff --git a/source/tabletools.pas b/source/tabletools.pas index 14591019..72fddc23 100644 --- a/source/tabletools.pas +++ b/source/tabletools.pas @@ -11,7 +11,7 @@ interface uses Windows, SysUtils, Classes, Controls, Forms, StdCtrls, ComCtrls, Buttons, Dialogs, StdActns, VirtualTrees, ExtCtrls, Graphics, SynRegExpr, Math, Generics.Collections, - dbconnection, helpers, Menus; + dbconnection, helpers, Menus, gnugettext; type TToolMode = (tmMaintenance, tmFind, tmSQLExport, tmBulkTableEdit); @@ -179,6 +179,8 @@ var dt: TListNodeType; Obj: TDBObject; begin + TranslateComponent(Self); + // Restore GUI setup InheritFont(Font); Width := AppSettings.ReadInt(asTableToolsWindowWidth); diff --git a/source/texteditor.pas b/source/texteditor.pas index 1f119342..8130d66e 100644 --- a/source/texteditor.pas +++ b/source/texteditor.pas @@ -5,7 +5,7 @@ interface uses Windows, Classes, Graphics, Forms, Controls, StdCtrls, VirtualTrees, ComCtrls, ToolWin, Dialogs, SysUtils, Menus, ExtDlgs, - helpers; + helpers, gnugettext; {$I const.inc} @@ -163,6 +163,7 @@ end; procedure TfrmTextEditor.FormCreate(Sender: TObject); begin InheritFont(Font); + TranslateComponent(Self); end; diff --git a/source/trigger_editor.pas b/source/trigger_editor.pas index 055604e6..4f288b3c 100644 --- a/source/trigger_editor.pas +++ b/source/trigger_editor.pas @@ -5,7 +5,7 @@ interface uses Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, SynEdit, SynMemo, SynCompletionProposal, - dbconnection, mysql_structures, helpers; + dbconnection, mysql_structures, helpers, gnugettext; type TFrame = TDBObjectEditor; @@ -57,6 +57,7 @@ var i: Integer; begin inherited; + TranslateComponent(Self); SynMemoBody.Highlighter := Mainform.SynSQLSyn1; editName.MaxLength := NAME_LEN; comboTiming.Items.Text := 'BEFORE'+CRLF+'AFTER'; diff --git a/source/updatecheck.pas b/source/updatecheck.pas index 6eb8a0fb..f62eb6e7 100644 --- a/source/updatecheck.pas +++ b/source/updatecheck.pas @@ -4,7 +4,7 @@ interface uses Windows, Messages, SysUtils, Classes, Forms, StdCtrls, IniFiles, Controls, Graphics, - helpers; + helpers, gnugettext; type TfrmUpdateCheck = class(TForm) @@ -55,6 +55,7 @@ begin // Should be false by default. Callers can set this to True after Create() AutoClose := False; InheritFont(Font); + TranslateComponent(Self); end; {** diff --git a/source/usermanager.pas b/source/usermanager.pas index 4eb61084..11beafde 100644 --- a/source/usermanager.pas +++ b/source/usermanager.pas @@ -6,7 +6,7 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls, ExtCtrls, ToolWin, ClipBrd, Generics.Collections, Generics.Defaults, SynRegExpr, - dbconnection, helpers, VirtualTrees, Menus; + dbconnection, helpers, VirtualTrees, Menus, gnugettext; {$I const.inc} @@ -214,6 +214,7 @@ begin FixVT(listUsers); FixVT(treePrivs); Mainform.RestoreListSetup(listUsers); + TranslateComponent(Self); PrivsRead := Explode(',', 'SELECT,SHOW VIEW,SHOW DATABASES,PROCESS,EXECUTE'); PrivsWrite := Explode(',', 'ALTER,CREATE,DROP,DELETE,UPDATE,INSERT,ALTER ROUTINE,CREATE ROUTINE,CREATE TEMPORARY TABLES,CREATE VIEW,INDEX,TRIGGER,EVENT,REFERENCES,CREATE TABLESPACE'); PrivsAdmin := Explode(',', 'RELOAD,SHUTDOWN,REPLICATION CLIENT,REPLICATION SLAVE,SUPER,LOCK TABLES,GRANT,FILE,CREATE USER'); diff --git a/source/view.pas b/source/view.pas index 126e3da6..07a214b7 100644 --- a/source/view.pas +++ b/source/view.pas @@ -5,7 +5,7 @@ interface uses Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, SynEdit, SynMemo, ExtCtrls, - dbconnection, mysql_structures, helpers; + dbconnection, mysql_structures, helpers, gnugettext; type TFrame = TDBObjectEditor; @@ -50,6 +50,7 @@ uses main; constructor TfrmView.Create(AOwner: TComponent); begin inherited; + TranslateComponent(Self); SynMemoBody.Highlighter := Mainform.SynSQLSyn1; Mainform.SynCompletionProposal.AddEditor(SynMemoBody); editName.MaxLength := NAME_LEN;