gnugettext.pas

delphi下的COMPORT修正版： 主要修改： 1、支持终端中文显示 2、支持终端hex显示 3、去掉了抛出的部分异常 这里有很多原版的

unit gnugettext;
(**************************************************************)
(*                                                            *)
(*  (C) Copyright by Lars B. Dybdahl and others               *)
(*  E-mail: [e-mail], phone [phone]               *)
(*  You may distribute and modify this file as you wish       *)
(*  for free                                                  *)
(*                                                            *)
(*  Contributors: Peter Thornqvist, Troy Wolbrink,            *) 
(*                Frank Andreas de Groot                      *)
(*                                                            *)
(*  See http://dybdahl.dk/dxgettext/ for more information     *)
(*                                                            *)
(**************************************************************)

interface


uses
  Classes, SysUtils, TypInfo;

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

// All these identical functions translate a text
function _(const szMsgId: widestring): widestring;
function gettext(const szMsgId: widestring): widestring;

// Translates a component (form, frame etc.) to the currently selected language.
// Put TranslateComponent(self) in the OnCreate event of all your forms.
// See the FAQ on the homepage if your application takes a long time to start.
procedure TranslateComponent(AnObject: TComponent; 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 (domain:string);

// Set language to use
procedure UseLanguage(LanguageCode: 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';
  RuntimePackageSupportEnabled=false; // This is experimental code. Don't set this to true unless you know what you do.

var
  ExecutableFilename:string;    // This is set to paramstr(0). Modify it for dll-files to point to the full dll path filename.

(*
 Make sure that the next TranslateProperties(self) will ignore
 the string property specified, e.g.:
 TP_Ignore (self,'ButtonOK.Caption');   // Ignores caption on ButtonOK
 TP_Ignore (self,'MyDBGrid');           // Ignores all properties on component MyDBGrid
 TP_Ignore (self,'.Caption');           // Ignores self's caption
 Only use this function just before calling TranslateProperties(self).
 If this function is being used, please only call TP_Ignore and TranslateProperties
 From the main thread.
*)
procedure TP_Ignore(AnObject:TObject; const name:string);

// Make TranslateProperties() not translate any objects descending from IgnClass
procedure TP_GlobalIgnoreClass (IgnClass:TClass);

// Make TranslateProperties() not translate a named property in all objects
// descending from IgnClass
procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);

type
  TTranslator=procedure (obj:TObject) of object;

// Make TranslateProperties() not translate any objects descending from HClass
// but instead call the specified Handler on each of these objects. The Name
// property of TComponent is already added and doesn't have to be added.
procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);

// Translate a component's properties and all subcomponents
// Use this on a Delphi TForm or a CLX program's QForm.
// It will only translate string properties, but see TP_ functions
// below if there are things you don't want to have translated.
procedure TranslateProperties(AnObject: TObject; TextDomain:string='');

// Load an external GNU gettext dll to be used instead of the internal
// implementation. Returns true if the dll is loaded. If the dll was already
// loaded, this function can be used to query whether it was loaded.
// On Linux, this function enables the Libc version of GNU gettext
// After calling this function, you must set all settings again
function LoadDLLifPossible (dllname:string='gnu_gettext.dll'):boolean;

function GetCurrentLanguage:string;

// These functions are also from the orginal GNU gettext implementation.
// Only use these, if you need to split up your translation into several
// .mo files.
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);




(*****************************************************************************)
(*                                                                           *)
(*  CLASS based implementation. Use this to have more than one language      *)
(*  in your application at the same time                                     *)
(*  Do not exploit this feature if you plan to use LoadDLLifPossible()       *)
(*                                                                           *)
(*****************************************************************************)

type
  TExecutable=
    class
      procedure Execute; virtual; abstract;
    end;
  TGetPluralForm=function (Number:Longint):Integer;
  TGnuGettextInstance=
    class   // Do not create multiple instances on Linux!
    public
      Enabled:Boolean;      // Set this to false to disable translations
      constructor Create;
      destructor Destroy; override;
      procedure UseLanguage(LanguageCode: string);
      function gettext(const szMsgId: widestring): widestring;
      function ngettext(const singular,plural:widestring;Number:longint):widestring;
      function GetCurrentLanguage:string;
      function GetTranslationProperty (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_GlobalIgnoreClass (IgnClass:TClass);
      procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
      procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
      function TP_CreateRetranslator:TExecutable;  // Must be freed by caller!
      procedure TranslateProperties(AnObject: TObject; textdomain:string='');
      procedure TranslateComponent(AnObject: TComponent; TextDomain:string='');

      // Multi-domain functions
      function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
      function dngettext(const szDomain,singular,plural:widestring;Number:longint):widestring;
      procedure textdomain(const szDomain: string);
      function getcurrenttextdomain: string;
      procedure bindtextdomain(const szDomain: string; const szDirectory: string);

      // Debugging and advanced tools
      procedure SaveUntranslatedMsgids(filename: string);
    protected
      procedure TranslateStrings (sl:TStrings;TextDomain:string);
    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_Retranslator:TExecutable; // Cast this to TTP_Retranslator
      procedure SaveCheck(szMsgId: widestring);
      procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;
        TodoList: TStrings; TextDomain:string);  // 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}

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

uses
  {$ifdef MSWINDOWS}
  Windows;
  {$endif}
  {$ifdef LINUX}
  Libc;
  {$endif}

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;
  TAssemblyFileInfo=
    class
      offset,size:int64;
    end;
  TAssemblyAnalyzer=
    class
      constructor Create;
      destructor Destroy; override;
      procedure Analyze;
      function FileExists (filename:string):boolean;
      procedure GetFileInfo (filename:string; var realfilename:string; var offset, size:int64);
    private
      basedirectory:string;
      filelist:TStringList; //Objects are TAssemblyFileInfo. Filenames are relative to .exe file
      function ReadInt64 (str:TStream):int64;
    end;
  TGnuGettextComponentMarker=
    class (TComponent)
    public
      LastLanguage:string;
      Retranslator:TExecutable;
      destructor Destroy; override;
    end;
  TDomain =
    class
    private
      vDirectory: string;
      procedure setDirectory(dir: string);
    public                    
      Domain: string;
      property Directory: string read vDirectory write setDirectory;
      constructor Create;
      destructor Destroy; override;
      procedure SetLanguageCode (langcode:string);
      function gettext(msgid: ansistring): ansistring; // uses mo file
    private
      moCS: TMultiReadExclusiveWriteSynchronizer; // Covers next three lines
      doswap: boolean;
      N, O, T: Cardinal; // Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html
      FileOffset:int64;
      {$ifdef mswindows}
      mo: THandle;
      momapping: THandle;
      {$endif}
      momemoryHandle:PChar;
      momemory: PChar;
      curlang: string;
      isopen, moexists: boolean;
      procedure OpenMoFile;
      procedure CloseMoFile;
      function gettextbyid(id: cardinal): ansistring;
      function getdsttextbyid(id: cardinal): ansistring;
      function autoswap32(i: cardinal): cardinal;
      function CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;
    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;
  {$ifdef MSWindows}
  tpgettext = function(const szMsgId: PChar): PChar; cdecl;
  tpdgettext = function(const szDomain: PChar; const szMsgId: PChar): PChar; cdecl;
  tpdcgettext = function(const szDomain: PChar; const szMsgId: PChar; iCategory: integer): PChar; cdecl;
  tptextdomain = function(const szDomain: PChar): PChar; cdecl;
  tpbindtextdomain = function(const szDomain: PChar; const szDirectory: PChar): PChar; cdecl;
  tpgettext_putenv = function(const envstring: PChar): integer; cdecl;
  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 Disable;
      procedure Enable;
    private
      ov: cardinal;
      Patch:TCharArray5;
      Original:TCharArray5;
      PatchPosition:PChar;
    end;
  {$endif}

var
  Win32PlatformIsUnicode:boolean=False;
  AssemblyAnalyzer:TAssemblyAnalyzer;
  TPDomainListCS:TMultiReadExclusiveWriteSynchronizer;
  TPDomainList:TStringList;
  DLLisLoaded: boolean=false;
  {$ifdef MSWINDOWS}
  pgettext: tpgettext;
  pdgettext: tpdgettext;
  ptextdomain: tptextdomain;
  pbindtextdomain: tpbindtextdomain;
  pgettext_putenv: tpgettext_putenv;
  dllmodule: THandle;
  HookLoadResString:THook;
  {$endif}

function StripCR (s:string):string;
var
  i:integer;
begin
  i:=1;
  while i<=length(s) do begin
    if s[i]=#13 then delete (s,i,1) else inc (i);
  end;
  Result:=s;
end;

function GGGetEnvironmentVariable (name:string):string;
begin
  Result:=SysUtils.GetEnvironmentVariable(name);
end;

function LF2LineBreakA (s:string):string;
{$ifdef MSWINDOWS}
var
  i:integer;
{$endif}
begin
  {$ifdef MSWINDOWS}
  Assert (sLinebreak=#13#10);
  i:=1;
  while i<=length(s) do begin
    if (s[i]=#10) and (copy(s,i-1,1)<>#13) then begin
      insert (#13,s,i);
      inc (i,2);
    end else
      inc (i);
  end;
  {$endif}
  Result:=s;
end;

function IsWriteProp(Info: PPropInfo): Boolean;
begin
  Result := Assigned(Info) and (Info^.SetProc <> nil);
end;

procedure SaveUntranslatedMsgids(filename: string);
begin
  DefaultInstance.SaveUntranslatedMsgids(filename);
end;

function string2csyntax(s: string): string;
// Converts a string to the syntax that is used in .po files
var
  i: integer;
  c: char;