jvgnugettext.pas

East make Tray Icon in delphi

  if not Enabled then
  begin
    Result := msgid; 
    Exit; 
  end; 
  if (moFile = nil) and (not OpenHasFailedBefore) then
    OpenMoFile; 
  if moFile = nil then 
  begin
    {$ifdef DXGETTEXTDEBUG}
    DebugLogger('.mo file is not open. Not translating "' + msgid + '"'); 
    {$endif}
    Result := msgid; 
  end 
  else 
  begin
    Result := moFile.gettext(msgid, found); 
    {$ifdef DXGETTEXTDEBUG}
    if found then
      DebugLogger('Found in .mo (' + Domain + '): "' + Utf8Encode(msgid) +
        '"->"' + Utf8Encode(Result) + '"')
    else
      DebugLogger('Translation not found in .mo file (' + Domain +
        ') : "' + Utf8Encode(msgid) + '"'); 
    {$endif}
  end; 
end; 

constructor TDomain.Create;
begin
  inherited Create;
  Enabled := True;
end;

{ TGnuGettextInstance }

procedure TGnuGettextInstance.bindtextdomain(const szDomain, szDirectory: string);
var
  dir: string;
begin
  dir := IncludeTrailingPathDelimiter(szDirectory);
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln('Text domain "' + szDomain + '" is now located at "' + dir + '"'); 
  {$endif}
  getdomain(szDomain, DefaultDomainDirectory, CurLang).Directory := dir; 
  WhenNewDomainDirectory(szDomain, szDirectory); 
end;

constructor TGnuGettextInstance.Create;
begin
  inherited Create;
  {$ifndef CLR}
  CreatorThread := GetCurrentThreadId;
  { TODO : Do something about Thread handling if resourcestrings are enabled }
  {$endif}
  {$ifdef MSWINDOWS}
  DesignTimeCodePage := CP_ACP;
  {$endif}
  {$ifdef DXGETTEXTDEBUG}
  DebugLogCS := TMultiReadExclusiveWriteSynchronizer.Create;
  DebugLog := TMemoryStream.Create;
  DebugWriteln('Debug log started ' + DateTimeToStr(Now));
  DebugWriteln('');
  {$endif}
  curGetPluralForm := GetPluralForm2EN;
  Enabled := True;
  curmsgdomain := DefaultTextDomain;
  savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;
  DomainList := TStringList.Create;
  TP_IgnoreList := TStringList.Create;
  TP_IgnoreList.Sorted := True;
  TP_GlobalClassHandling := TObjectList.Create;
  TP_ClassHandling := TObjectList.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;
var
  I: Integer;
begin
  if SaveMemory <> nil then
  begin
    savefileCS.BeginWrite;
    try
      CloseFile(savefile);
    finally
      savefileCS.EndWrite;
    end;
    FreeAndNil(SaveMemory);
  end;
  FreeAndNil(savefileCS);
  FreeAndNil(TP_IgnoreList);
  FreeAndNil(TP_GlobalClassHandling);
  FreeAndNil(TP_ClassHandling);
  for I := 0 to DomainList.Count - 1 do
    DomainList.Objects[I].Free;
  FreeAndNil(DomainList);
  {$ifdef DXGETTEXTDEBUG}
  FreeAndNil(DebugLog);
  FreeAndNil(DebugLogCS);
  {$endif}
  inherited Destroy;
end; 

{$ifndef DELPHI5OROLDER}
function TGnuGettextInstance.dgettext(const szDomain: string;
  const szMsgId: AnsiString): WideString;
begin
  Result := dgettext(szDomain, ansi2wide(szMsgId));
end;
{$endif}

function TGnuGettextInstance.dgettext(const szDomain: string;
  const szMsgId: WideString): WideString;
begin
  if not Enabled then 
  begin
    {$ifdef DXGETTEXTDEBUG}
    DebugWriteln('Translation has been disabled. Text is not being translated: ' + szMsgid); 
    {$endif}
    Result := szMsgId; 
  end 
  else 
  begin
    Result := Utf8Decode(LF2LineBreakA(getdomain(szDomain, DefaultDomainDirectory,
      CurLang).gettext(StripCR(Utf8Encode(szMsgId))))); 
    {$ifdef DXGETTEXTDEBUG}
    if (szMsgId <> '') and (Result = '') then
      DebugWriteln(Format('Error: Translation of %s was an empty string. This may never occur.',
        [szMsgId])); 
    {$endif}
  end; 
end; 

function TGnuGettextInstance.GetCurrentLanguage: string;
begin
  Result := curlang;
end;

function TGnuGettextInstance.getcurrenttextdomain: string;
begin
  Result := curmsgdomain; 
end; 

{$ifndef DELPHI5OROLDER}
function TGnuGettextInstance.gettext(const szMsgId: AnsiString): WideString;
begin
  Result := dgettext(curmsgdomain, szMsgId);
end;
{$endif} 

function TGnuGettextInstance.gettext(const szMsgId: WideString): WideString; 
begin
  Result := dgettext(curmsgdomain, szMsgId); 
end; 

procedure TGnuGettextInstance.textdomain(const szDomain: string);
begin
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln('Changed text domain to "' + szDomain + '"'); 
  {$endif}
  curmsgdomain := szDomain; 
  WhenNewDomain(szDomain); 
end; 

function TGnuGettextInstance.TP_CreateRetranslator: TExecutable;
var
  ttpr: TTP_Retranslator; 
begin
  ttpr := TTP_Retranslator.Create; 
  ttpr.Instance := self; 
  TP_Retranslator := ttpr; 
  Result := ttpr; 
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln('A retranslator was created.'); 
  {$endif}
end; 

procedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass; 
  Handler: TTranslator); 
var
  cm: TClassMode; 
  i: Integer; 
begin
  for i := 0 to TP_GlobalClassHandling.Count - 1 do
  begin
    cm := TClassMode(TP_GlobalClassHandling.Items[i]);
    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; 

procedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass); 
var
  cm: TClassMode; 
  i: Integer; 
begin
  for i := 0 to TP_GlobalClassHandling.Count - 1 do
  begin
    cm := TClassMode(TP_GlobalClassHandling.Items[i]); 
    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 + '. You should keep all TP_Global functions in one place in your source code.'); 
    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); 
      {$ifdef DXGETTEXTDEBUG}
      DebugWriteln('Globally, class ' + IgnClass.ClassName + ' is being ignored.'); 
      {$endif}
      Exit; 
    end; 
  end; 
  cm := TClassMode.Create; 
  cm.HClass := IgnClass; 
  TP_GlobalClassHandling.Add(cm); 
  {$ifdef DXGETTEXTDEBUG}
  DebugWriteln('Globally, class ' + IgnClass.ClassName + ' is being ignored.'); 
  {$endif}
end; 

procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(IgnClass: TClass;
  const PropertyName: AnsiString);
var
  cm: TClassMode;
  i, idx: Integer;
begin
  for i := 0 to TP_GlobalClassHandling.Count - 1 do
  begin
    cm := TClassMode(TP_GlobalClassHandling.Items[i]);
    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: AnsiString); 
begin
  TP_IgnoreList.Add(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: string);
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);
      {$endif}
      {$ifdef CLR}
      MessageBox.show('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}
      {$ifdef LINUX}
      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; 

{$ifndef CLR}
procedure TGnuGettextInstance.TranslateProperty(AnObject: TObject;
  PropInfo: PPropInfo; TodoList: TStrings; const TextDomain: AnsiString); 
var
  {$ifdef DELPHI5OROLDER}
  ws: AnsiString;
  old: AnsiString;
  {$endif}
  {$ifndef DELPHI5OROLDER}
  ppi: PPropInfo;
  ws: WideString; 
  old: WideString;
  {$endif} 
  obj: TObject; 
  Propname: AnsiString; 
begin
  PropName := PropInfo^.Name; 
  try
    // Translate certain types of properties
    case PropInfo^.PropType^.Kind of
      tkString, tkLString, tkWString:
        begin
          {$ifdef DXGETTEXTDEBUG}
          DebugWriteln('Translating ' + AnObject.ClassName + '.' + PropName); 
          {$endif}
          {$ifdef DELPHI5OROLDER}
          old := GetStrProp(AnObject, PropName);
          {$endif}
          {$ifndef DELPHI5OROLDER}
          if PropInfo^.PropType^.Kind <> tkWString then
            old := ansi2wide(GetStrProp(AnObject, PropName))
          else
            old := GetWideStrProp(AnObject, PropName);
          {$endif}
          {$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
              TTP_Retranslator(TP_Retranslator).Remember(AnObject, PropName, old);
            ws := dgettext(TextDomain, old);
            if ws <> old then
            begin
              {$ifdef DELPHI5OROLDER}
              SetStrProp(AnObject, PropName, ws);
              {$endif}
              {$ifndef DELPHI5OROLDER}
              ppi := GetPropInfo(AnObject, Propname);
              if ppi <> nil then
              begin
                SetWideStrProp(AnObject, ppi, ws);