gnugettext.pas

Last change: 2008-02-03 This is the source code of KCeasy。

unit gnugettext;
(**************************************************************)
(*                                                            *)
(*  (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                      *)
(*                                                            *)
(*  See http://dybdahl.dk/dxgettext/ for more information     *)
(*                                                            *)
(**************************************************************)

// Information about this file:
// $LastChangedDate: 2005-07-07 19:09:15 +0200 (to, 07 jul 2005) $
// $LastChangedRevision: 118 $
// $HeadURL: svn://svn.berlios.de/dxgettext/trunk/dxgettext/sample/gnugettext.pas $

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

interface

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


uses
{$ifdef MSWINDOWS}
  Windows,
{$else}
  Libc,
{$endif}
  Classes, SysUtils, TypInfo;

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

// Main GNU gettext functions. See documentation for instructions on how to use them.

// KCeasy modification: _() is impletented in Brand.cpp and does some
// preprocessing before calling gettext() to do the actual translating.
//function _(const szMsgId: widestring): widestring;

function gettext(const szMsgId: widestring): widestring;
function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
function ngettext(const singular,plural: widestring; Number:longint): widestring;
procedure textdomain(const szDomain: string);
function getcurrenttextdomain: string;
procedure bindtextdomain(const szDomain: string; const szDirectory: string);

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

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

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

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

// Unicode-enabled way to get resourcestrings, automatically translated
// Use like this: ws:=LoadResStringW(@NameOfResourceString);
function LoadResString(ResStringRec: PResStringRec): widestring;
function LoadResStringA(ResStringRec: PResStringRec): ansistring;
function LoadResStringW(ResStringRec: PResStringRec): widestring;

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


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

const
  DefaultTextDomain = 'default';

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

const
  PreferExternal=false;       // Set to true, to prefer external *.mo over embedded translation

const
  // Subversion source code version control version information
  VCSVersion='$LastChangedRevision: 118 $';

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.

// KCeasy modification: don't hook resource functions
const AutoCreateHooks=false;
procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);




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

{$ifdef MSWINDOWS}
{$ifndef VER140}
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CODE OFF}
{$WARN UNSAFE_CAST OFF}
{$endif}
{$endif}

type
  TOnDebugLine = Procedure (Sender: TObject; const Line: String; var Discard: Boolean) of Object;  // Set Discard to false if output should still go to ordinary debug log
  TGetPluralForm=function (Number:Longint):Integer;
  TDebugLogger=procedure (line: ansistring) of object;
  TMoFile= // Don't use this class. It's for internal use.
    class // Threadsafe. Only constructor and destructor are writing to memory
    private
      doswap: boolean;
    public
      Users:Integer; // Reference count. If it reaches zero, this object should be destroyed.
      constructor Create (filename:string;Offset,Size:int64);
      destructor Destroy; override;
      function gettext(const msgid: ansistring;var found:boolean): ansistring; // uses mo file
      property isSwappedArchitecture:boolean read doswap;
    private
      N, O, T: Cardinal; // Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html
      startindex,startstep:integer;
      {$ifdef mswindows}
      mo: THandle;
      momapping: THandle;
      {$endif}
      momemoryHandle:PChar;
      momemory: PChar;
      function autoswap32(i: cardinal): cardinal;
      function CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;
    end;
  TDomain= // Don't use this class. It's for internal use.
    class
    private
      Enabled:boolean;
      vDirectory: string;
      procedure setDirectory(const dir: string);
    public
      DebugLogger:TDebugLogger;
      Domain: string;
      property Directory: string read vDirectory write setDirectory;
      constructor Create;
      destructor Destroy; override;
      // Set parameters
      procedure SetLanguageCode (const langcode:string);
      procedure SetFilename (const filename:string); // Bind this domain to a specific file
      // Get information
      procedure GetListOfLanguages(list:TStrings);
      function GetTranslationProperty(Propertyname: string): WideString;
      function gettext(const msgid: ansistring): ansistring; // uses mo file
    private
      mofile:TMoFile;
      SpecificFilename:string;
      curlang: string;
      OpenHasFailedBefore: boolean;
      procedure OpenMoFile;
      procedure CloseMoFile;
    end;
  TExecutable=
    class
      procedure Execute; virtual; abstract;
    end;
  TGnuGettextInstance=
    class
    private
      fOnDebugLine:TOnDebugLine;
      CreatorThread:Cardinal;  // Only this thread can use LoadResString
    public
      Enabled:Boolean;      // Set this to false to disable translations
      DesignTimeCodePage:Integer;  // See MultiByteToWideChar() in Win32 API for documentation
      constructor Create;
      destructor Destroy; override;
      procedure UseLanguage(LanguageCode: string);
      procedure GetListOfLanguages (const domain:string; list:TStrings); // Puts list of language codes, for which there are translations in the specified domain, into list
      function gettext(const szMsgId: ansistring): widestring; overload; virtual;
      function gettext(const szMsgId: widestring): widestring; overload; virtual;
      function ngettext(const singular,plural:ansistring;Number:longint):widestring; overload; virtual;
      function ngettext(const singular,plural:widestring;Number:longint):widestring; overload; virtual;
      function GetCurrentLanguage:string;
      function GetTranslationProperty (const Propertyname:string):WideString;
      function GetTranslatorNameAndEmail:widestring;

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

      // Multi-domain functions
      function dgettext(const szDomain: string; const szMsgId: ansistring): widestring; overload; virtual;
      function dgettext(const szDomain: string; const szMsgId: widestring): widestring; overload; virtual;
      function dngettext(const szDomain: string; const singular,plural:ansistring;Number:longint):widestring; overload; virtual;
      function dngettext(const szDomain: string; const singular,plural:widestring;Number:longint):widestring; overload; virtual;
      procedure textdomain(const szDomain: string);
      function getcurrenttextdomain: string;
      procedure bindtextdomain(const szDomain: string; const szDirectory: string);
      procedure bindtextdomainToFile (const szDomain: string; const filename: string); // Also works with files embedded in exe file

      // Windows API functions
      function LoadResString(ResStringRec: PResStringRec): widestring;

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

      // Conversion according to design-time character set
      function ansi2wideDTCP (const s:ansistring):widestring;  // Convert using Design Time Code Page
    protected
      procedure TranslateStrings (sl:TStrings;const TextDomain:string);

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

var
  DefaultInstance:TGnuGettextInstance;

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
(**************************************************************************)


type
  TTP_RetranslatorItem=
    class
      obj:TObject;
      Propname:string;
      OldValue:WideString;
    end;
  TTP_Retranslator=
    class (TExecutable)
      TextDomain:string;
      Instance:TGnuGettextInstance;
      constructor Create;
      destructor Destroy; override;
      procedure Remember (obj:TObject; PropName:String; OldValue:WideString);
      procedure Execute; override;
    private
      list:TList;
    end;
  TEmbeddedFileInfo=
    class
      offset,size:int64;
    end;
  TFileLocator=
    class // This class finds files even when embedded inside executable
      constructor Create;
      destructor Destroy; override;