jvgnugettext.pas

East make Tray Icon in delphi

unit JvGnugettext;
(**************************************************************)
(*                                                            *)
(*  (C) Copyright by Lars B. Dybdahl and others               *)
(*  E-mail: [e-mail], phone [phone]               *)
(*                                                            *)
(*  Contributors: Peter Thornqvist, Troy Wolbrink,            *)
(*                Frank Andreas de Groot, Igor Siticov,       *)
(*                Jacques Garcia Vazquez                      *)
(*                Andreas Hausladen                           *)
(*                                                            *)
(*  See http://dybdahl.dk/dxgettext/ for more information     *)
(*                                                            *)
(**************************************************************)

// Redistribution and use in source and binary forms, with or without
// modification, are permitted provided that the following conditions are met:
//
// The names of any contributor may not be used to endorse or promote
// products derived from this software without specific prior written permission.
//
// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
// ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
// LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

interface

// If the conditional define DXGETTEXTDEBUG is defined, debugging log is activated.
// Use DefaultInstance.DebugLogToFile() to write the log to a file.
{ $define DXGETTEXTDEBUG}

{$ifdef VER100}
  // Delphi 3
  {$DEFINE DELPHI5OROLDER}
  {$DEFINE DELPHI6OROLDER}
  {$DEFINE DELPHI7OROLDER}
{$endif}
{$ifdef VER110}
  // C++ Builder 3
  {$DEFINE DELPHI5OROLDER}
  {$DEFINE DELPHI6OROLDER}
  {$DEFINE DELPHI7OROLDER}
{$endif}
{$ifdef VER120}
  // Delphi 4
  {$DEFINE DELPHI5OROLDER}
  {$DEFINE DELPHI6OROLDER}
  {$DEFINE DELPHI7OROLDER}
{$endif}
{$ifdef VER125}
  // C++ Builder 4
  {$DEFINE DELPHI5OROLDER}
  {$DEFINE DELPHI6OROLDER}
  {$DEFINE DELPHI7OROLDER}
{$endif}
{$ifdef VER130}
  // Delphi 5
  {$DEFINE DELPHI5OROLDER}
  {$DEFINE DELPHI6OROLDER}
  {$DEFINE DELPHI7OROLDER}
  {$ifdef WIN32}
  {$DEFINE MSWINDOWS}
  {$endif}
{$endif}
{$ifdef VER135}
  // C++ Builder 5
  {$DEFINE DELPHI5OROLDER}
  {$DEFINE DELPHI6OROLDER}
  {$DEFINE DELPHI7OROLDER}
  {$ifdef WIN32}
  {$DEFINE MSWINDOWS}
  {$endif}
{$endif}
{$ifdef VER140}
  // Delphi 6
  {$DEFINE DELPHI6OROLDER}
  {$DEFINE DELPHI7OROLDER}
{$endif}
{$ifdef VER150}
  {$DEFINE DELPHI7OROLDER}
  // Delphi 7
{$endif}
{$ifdef VER160}
  // Delphi 8
{$endif}

uses
{$ifdef DELPHI5OROLDER}
  JvGnugettextD5,
{$endif}
{$ifdef MSWINDOWS}
  Windows,
{$endif}
{$ifdef LINUX}
  Libc,
{$endif}
  Classes, SysUtils, Contnrs, TypInfo;

(*****************************************************************************)
(*                                                                           *)
(*  MAIN API                                                                 *)
(*                                                                           *)
(*****************************************************************************)

// Main GNU gettext functions. See documentation for instructions on how to use them.
{$ifdef DELPHI5OROLDER}
function _(const szMsgId: WideString): WideString;
function gettext(const szMsgId: WideString): WideString;
function dgettext(const szDomain: string; const szMsgId: WideString): WideString;
function dngettext(const szDomain: string; const singular, plural: WideString; Number: Longint): WideString;
function ngettext(const singular, plural: WideString; Number: Longint): WideString;
{$endif}
{$ifndef DELPHI5OROLDER}
function _(const szMsgId: AnsiString): WideString; overload;
function _(const szMsgId: WideString): WideString; overload;
function gettext(const szMsgId: AnsiString): WideString; overload;
function gettext(const szMsgId: WideString): WideString; overload;
function dgettext(const szDomain: string; const szMsgId: AnsiString): WideString; overload;
function dgettext(const szDomain: string; const szMsgId: WideString): WideString; overload;
function dngettext(const szDomain: string; const singular, plural: AnsiString; Number: Longint): WideString; overload;
function dngettext(const szDomain: string; const singular, plural: WideString; Number: Longint): WideString; overload;
function ngettext(const singular, plural: AnsiString; Number: Longint): WideString; overload;
function ngettext(const singular, plural: WideString; Number: Longint): WideString; overload;
{$endif}
procedure textdomain(const szDomain: string);
function getcurrenttextdomain: string;
procedure bindtextdomain(const szDomain, szDirectory: string);

  // Set language to use
procedure UseLanguage(const LanguageCode: string);
function GetCurrentLanguage: string;

  // Translates a component (form, frame etc.) to the currently selected language.
  // Put TranslateComponent(self) in the OnCreate event of all your forms.
  // See the manual for documentation on these functions
type
  TTranslator = procedure(obj: TObject) of object;

procedure TP_Ignore(AnObject: TObject; const Name: AnsiString);
procedure TP_IgnoreClass(IgnClass: TClass);
procedure TP_IgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString);
procedure TP_GlobalIgnoreClass(IgnClass: TClass);
procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString);
procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator);
procedure TranslateComponent(AnObject: TComponent; const TextDomain: string = '');
procedure RetranslateComponent(AnObject: TComponent; const TextDomain: string = '');

  // Add more domains that resourcestrings can be extracted from. If a translation
  // is not found in the default domain, this domain will be searched, too.
  // This is useful for adding mo files for certain runtime libraries and 3rd
  // party component libraries
procedure AddDomainForResourceString(const domain: string);
procedure RemoveDomainForResourceString(const domain: string);

{$ifndef CLR}
  // Unicode-enabled way to get resourcestrings, automatically translated
  // Use like this: ws := LoadResStringW(@NameOfResourceString);
function LoadResString(ResStringRec: PResStringRec): WideString;
function LoadResStringA(ResStringRec: PResStringRec): AnsiString;
function LoadResStringW(ResStringRec: PResStringRec): WideString;
{$endif}

  // This returns an empty string if not translated or translator name is not specified.
function GetTranslatorNameAndEmail: WideString; 


(*****************************************************************************)
(*                                                                           *)
(*  ADVANCED FUNCTIONALITY                                                   *)
(*                                                                           *)
(*****************************************************************************)

const
  DefaultTextDomain = 'default'; 

var
  ExecutableFilename: string;
  // This is set to paramstr(0) or the name of the DLL you are creating.

type
  EGnuGettext = class(Exception); 
  EGGProgrammingError = class(EGnuGettext);
  EGGComponentError = class(EGnuGettext);
  EGGIOError = class(EGnuGettext); 
  EGGAnsi2WideConvError = class(EGnuGettext); 

{$ifndef CLR}
  // This function will turn resourcestring hooks on or off, eventually with BPL file support.
  // Please do not activate BPL file support when the package is in design mode.
const
  AutoCreateHooks = True;

procedure HookIntoResourceStrings(Enabled: Boolean = True;
  SupportPackages: Boolean = False);
{$endif}



(*****************************************************************************)
(*                                                                           *)
(*  CLASS based implementation.                                              *)
(*  Use TGnuGettextInstance to have more than one language                   *)
(*  in your application at the same time                                     *)
(*                                                                           *)
(*****************************************************************************)

{$ifdef MSWINDOWS}
{$ifndef DELPHI6OROLDER}
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CODE OFF}
{$WARN UNSAFE_CAST OFF}
{$endif}
{$endif}
{$ifndef DELPHI7OROLDER}
{$WARN SYMBOL_PLATFORM OFF}
{$WARN SYMBOL_DEPRECATED OFF}
{$endif}

type
  TOnDebugLine = procedure(Sender: TObject; const Line: AnsiString;
    var Discard: Boolean) of object;  // Set Discard to False if output should still go to ordinary debug log
  TGetPluralForm = function(Number: Longint): Integer;
  TDebugLogger = procedure(Line: AnsiString) of object;

  TMoFile = class // Don't use this class. It's for internal use.
      // Threadsafe. Only constructor and destructor are writing to memory
  private
    doswap: Boolean;
  public
    Users: Integer;
    // Reference count. If it reaches zero, this object should be destroyed.
    constructor Create(const Filename: string; Offset, Size: Int64);
    function gettext(const msgid: AnsiString; var Found: Boolean): AnsiString;
    // uses mo file
    property isSwappedArchitecture: Boolean read doswap;
  private
    N, O, T: Cardinal; // Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html
    StartIndex, StartStep: Integer;
    moMemory: array of byte;
    function CardinalInMem(Offset: Cardinal): Cardinal;
  end;

  TDomain = class // Don't use this class. It's for internal use.
  private
    Enabled: Boolean;
    vDirectory: string;
    procedure SetDirectory(const Value: string);
  public
    DebugLogger: TDebugLogger;
    Domain: string;
    property Directory: string read vDirectory write SetDirectory;
    constructor Create;
    destructor Destroy; override;
    // Set parameters
    procedure SetLanguageCode(const LangCode: string);
    procedure SetFilename(const Filename: string); // Bind this domain to a specific file
    // Get information
    procedure GetListOfLanguages(List: TStrings);
    function GetTranslationProperty(PropertyName: string): WideString;
    function gettext(const msgid: AnsiString): AnsiString; // uses mo file
  private
    moFile: TMoFile;
    SpecificFilename: string;
    curlang: string;
    OpenHasFailedBefore: Boolean;
    procedure OpenMoFile;
    procedure CloseMoFile;
  end;

  TExecutable = class
    procedure Execute; virtual; abstract;
  end;

  TGnuGettextInstance = class
  private
    fOnDebugLine: TOnDebugLine;
    {$ifndef CLR}
    CreatorThread: Cardinal;  // Only this thread can use LoadResString
    {$endif}
  public
    Enabled: Boolean;      // Set this to False to disable translations
    DesignTimeCodePage: Integer;
    // See MultiByteToWideChar() in Win32 API for documentation
    constructor Create;
    destructor Destroy; override;
    procedure UseLanguage(LanguageCode: string);
    procedure GetListOfLanguages(const domain: string; List: TStrings); // Puts List of language codes, for which there are translations in the specified domain, into List
    {$ifdef DELPHI5OROLDER}
    function gettext(const szMsgId: WideString): WideString;
    function ngettext(const singular, plural: WideString; Number: Longint): WideString;
    {$endif}
    {$ifndef DELPHI5OROLDER}
    function gettext(const szMsgId: AnsiString): WideString; overload;
    function gettext(const szMsgId: WideString): WideString; overload;
    function ngettext(const singular, plural: AnsiString; Number: Longint): WideString; overload;
    function ngettext(const singular, plural: WideString; Number: Longint): WideString; overload;
    {$endif}
    function GetCurrentLanguage: string;
    function GetTranslationProperty(const PropertyName: AnsiString): WideString;
    function GetTranslatorNameAndEmail: WideString;

    // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites()
    procedure TP_Ignore(AnObject: TObject; const Name: AnsiString);
    procedure TP_IgnoreClass(IgnClass: TClass);
    procedure TP_IgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString);
    procedure TP_GlobalIgnoreClass(IgnClass: TClass);
    procedure TP_GlobalIgnoreClassProperty(IgnClass: TClass; const PropertyName: AnsiString);
    procedure TP_GlobalHandleClass(HClass: TClass; Handler: TTranslator);
    procedure TranslateProperties(AnObject: TObject; TextDomain: string = '');
    procedure TranslateComponent(AnObject: TComponent; const TextDomain: string = '');
    procedure RetranslateComponent(AnObject: TComponent; const TextDomain: string = '');

    // Multi-domain functions
    {$ifdef DELPHI5OROLDER}
    function dgettext(const szDomain: string; const szMsgId: WideString): WideString;
    function dngettext(const szDomain: string; singular, plural: WideString; Number: Longint): WideString;
    {$endif}
    {$ifndef DELPHI5OROLDER}
    function dgettext(const szDomain: string; const szMsgId: AnsiString): WideString; overload;
    function dgettext(const szDomain: string; const szMsgId: WideString): WideString; overload;
    function dngettext(const szDomain: string; singular, plural: AnsiString; Number: Longint): WideString; overload;
    function dngettext(const szDomain: string; singular, plural: WideString; Number: Longint): WideString; overload;
    {$endif}
    procedure textdomain(const szDomain: string);
    function getcurrenttextdomain: string;
    procedure bindtextdomain(const szDomain, szDirectory: string);
    procedure bindtextdomainToFile(const szDomain, Filename: string);
    // Also works with files embedded in exe file

    {$ifndef CLR}
    // Windows API functions
    function LoadResString(ResStringRec: PResStringRec): WideString;
    {$endif}

    // Output all log info to this file. This may only be called once.
    procedure DebugLogToFile(const Filename: string; append: Boolean = False);
    procedure DebugLogPause(PauseEnabled: Boolean);
    property OnDebugLine: TOnDebugLine read fOnDebugLine write fOnDebugLine;
    // If set, all debug output goes here

    // Conversion according to design-time character set
    function ansi2wide(const s: AnsiString): WideString; 
  protected
    procedure TranslateStrings(sl: TStrings; const TextDomain: string);

    // Override these three, if you want to inherited from this class
    // to create a new class that handles other domain and language dependent
    // issues
    procedure WhenNewLanguage(const LanguageID: AnsiString); virtual;
      // Override to know when language changes
    procedure WhenNewDomain(const TextDomain: string); virtual;
      // Override to know when text domain changes. Directory is purely informational
    procedure WhenNewDomainDirectory(const TextDomain, Directory: string); virtual;
      // Override to know when any text domain's directory changes. It won't be called if a domain is fixed to a specific file.
  private
    curlang: string;
    curGetPluralForm: TGetPluralForm;
    curmsgdomain: string;
    savefileCS: TMultiReadExclusiveWriteSynchronizer;
    savefile: TextFile;
    SaveMemory: TStringList;
    DefaultDomainDirectory: string;
    DomainList: TStringList;     // List of domain names. Objects are TDomain.
    TP_IgnoreList: TStringList;
    // Temporary List, reset each time TranslateProperties is called
    TP_ClassHandling: TObjectList;
    // Items are TClassMode. If a is derived from b, a comes first
    TP_GlobalClassHandling: TObjectList;
    // Items are TClassMode. If a is derived from b, a comes first
    TP_Retranslator: TExecutable; // Cast this to TTP_Retranslator
    DebugLogCS: TMultiReadExclusiveWriteSynchronizer;
    DebugLog: TStream;
    DebugLogOutputPaused: Boolean;
    function TP_CreateRetranslator: TExecutable;  // Must be freed by caller!
    procedure DebugWriteln(Line: AnsiString);
    function Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain;
      // Translates a single property of an object
    {$ifndef CLR}
    procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;
      TodoList: TStrings; const TextDomain: string);
    {$endif}
  end;

var
  DefaultInstance: TGnuGettextInstance;

implementation

(**************************************************************************)
// Some comments on the implementation:
// This unit should be independent of other units where possible.
// It should have a small footprint in any way.
(**************************************************************************)
// TMultiReadExclusiveWriteSynchronizer is used instead of TCriticalSection
// because it makes this unit independent of the SyncObjs unit
(**************************************************************************)

{$ifdef CLR}
uses
  System.Globalization, System.Diagnostics, System.Windows.Forms;
{$endif}

type
  TTP_RetranslatorItem = class
    obj: TObject;
    Propname: AnsiString;
    OldValue: WideString;
  end;

  TTP_Retranslator = class(TExecutable)
    TextDomain: string;
    Instance: TGnuGettextInstance;
    constructor Create;
    destructor Destroy; override;
    procedure Remember(obj: TObject; const PropName: AnsiString; OldValue: WideString);
    procedure Execute; override;
  private
    List: TList;
  end;

  TEmbeddedFileInfo = class
    Offset, Size: Int64;
  end;