{
 ***************************************************************************
 *                                                                         *
 *   This source is free software; you can redistribute it and/or modify   *
 *   it under the terms of the GNU General Public License as published by  *
 *   the Free Software Foundation; either version 2 of the License, or     *
 *   (at your option) any later version.                                   *
 *                                                                         *
 *   This code is distributed in the hope that it will be useful, but      *
 *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
 *   General Public License for more details.                              *
 *                                                                         *
 *   A copy of the GNU General Public License is available on the World    *
 *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
 *   obtain it by writing to the Free Software Foundation,                 *
 *   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
 *                                                                         *
 ***************************************************************************

  Author: Mattias Gaertner

  Abstract:
    Methods and classes for loading the IDE translations/localizations.
}
unit IDETranslations;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, GetText, LCLProc, Translations,
  IDEProcs, FileUtil,
  avl_tree, LazarusIDEStrConsts;
  { IDE Language (Human, not computer) }

type
  { TLazarusTranslation }

  TLazarusTranslation = class
  private
    FID: string;
  public
    property ID: string read FID;
  end;
  PLazarusTranslation = ^TLazarusTranslation;
  
  
  { TLazarusTranslations }
  
  TLazarusTranslations = class
  private
    FCount: integer;
    FItems: PLazarusTranslation;
    function GetItems(Index: integer): TLazarusTranslation;
  public
    destructor Destroy; override;
    procedure Add(const ID: string);
    function IndexOf(const ID: string): integer;
    procedure Clear;
  public
    property Count: integer read FCount;
    property Items[Index: integer]: TLazarusTranslation read GetItems; default;
  end;
  
// translate all resource strings
procedure TranslateResourceStrings(const BaseDirectory, CustomLang: string);

// get language name for ID
function GetLazarusLanguageLocalizedName(const ID: string): String;

// collect all available translations
procedure CollectTranslations(const LazarusDir: string);

function ConvertRSTFiles(RSTDirectory, PODirectory: string): Boolean;
function ConvertRSTFile(const RSTFilename, OutputFilename: string;
             CheckContentChange: Boolean; var ContentChanged: Boolean): Boolean;

var
  LazarusTranslations: TLazarusTranslations = nil;
  SystemLanguageID1, SystemLanguageID2: string;

implementation

function GetLazarusLanguageLocalizedName(const ID: string): String;
begin
  if ID='' then
    Result:=rsLanguageAutomatic
  else if CompareText(ID,'en')=0 then
    Result:=rsLanguageEnglish
  else if CompareText(ID,'de')=0 then
    Result:=rsLanguageGerman
  else if CompareText(ID,'ca')=0 then
    Result:=rsLanguageCatalan
  else if CompareText(ID,'fr')=0 then
    Result:=rsLanguageFrench
  else if CompareText(ID,'it')=0 then
    Result:=rsLanguageItalian
  else if CompareText(ID,'pl')=0 then
    Result:=rsLanguagePolish
  else if CompareText(ID,'pliso')=0 then
    Result:=rsLanguagePolishISO
  else if CompareText(ID,'plwin')=0 then
    Result:=rsLanguagePolishWin
  else if CompareText(ID,'ru')=0 then
    Result:=rsLanguageRussian
  else if CompareText(ID,'es')=0 then
    Result:=rsLanguageSpanish
  else if CompareText(ID,'fi')=0 then
    Result:=rsLanguageFinnish
  else if CompareText(ID,'he')=0 then
    Result:=rsLanguageHebrew
  else if CompareText(ID,'ar')=0 then
    Result:=rsLanguageArabic
  else if CompareText(ID,'pb')=0 then
    Result:=rsLanguagePortugues
  else if CompareText(ID,'ua')=0 then
    Result:=rsLanguageUkrainian
  else if CompareText(ID,'nl')=0 then
    Result:=rsLanguageDutch
  else if CompareText(ID,'ja')=0 then
    Result:=rsLanguageJapanese
  else if CompareText(ID,'zh_CN')=0 then
    Result:=rsLanguageChinese
  else if CompareText(ID,'id')=0 then
    Result:=rsLanguageIndonesian
  else if CompareText(ID,'af_ZA')=0 then
    Result:=rsLanguageAfrikaans
  else if CompareText(ID,'lt')=0 then
    Result:=rsLanguageLithuanian
  else if CompareText(ID,'sk')=0 then
    Result:=rsLanguageSlovak
  else
    Result:=ID;
end;

procedure CollectTranslations(const LazarusDir: string);
var
  FileInfo: TSearchRec;
  ID: String;
  SearchMask: String;
begin
  // search for all languages/lazarusidestrconsts.xxx.po files
  if LazarusTranslations=nil then
    LazarusTranslations:=TLazarusTranslations.Create
  else
    LazarusTranslations.Clear;
  // add automatic and english translation
  LazarusTranslations.Add('');
  LazarusTranslations.Add('en');
  // search existing translations
  SearchMask:=AppendPathDelim(LazarusDir)+'languages'+PathDelim+'lazaruside.*.po';
  //writeln('CollectTranslations ',SearchMask);
  if SysUtils.FindFirst(SearchMask,faAnyFile,FileInfo)=0
  then begin
    repeat
      if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
      then continue;
      ID:=copy(FileInfo.Name,length('lazaruside.')+1,
               length(FileInfo.Name)-length('lazaruside..po'));
      //writeln('CollectTranslations A ',FileInfo.Name,' ID=',ID);
      if (ID<>'') and (Pos('.',ID)<1) and (LazarusTranslations.IndexOf(ID)<0)
      then begin
        //writeln('CollectTranslations ID=',ID);
        LazarusTranslations.Add(ID);
      end;
    until SysUtils.FindNext(FileInfo)<>0;
  end;
  SysUtils.FindClose(FileInfo);
end;

type
  TConstItem = class
  public
    ModuleName, ConstName, Value: String;
  end;
  
function CompareConstItems(Data1, Data2: Pointer): integer;
begin
  Result:=CompareText(TConstItem(Data1).Value,TConstItem(Data2).Value);
end;

function CompareValueWithConstItems(ValuePAnsiString, ConstItem: Pointer): integer;
begin
  Result:=CompareText(PAnsiString(ValuePAnsiString)^,
                      TConstItem(ConstItem).Value);
end;

function ReadRSTFile(const InFilename: string;
  TreeOfConstItems: TAVLTree): Boolean;
var
  s: string;
  NextLineStartPos: integer;

  procedure ReadLine(out Line: string);
  var
    p: LongInt;
  begin
    p:=NextLineStartPos;
    while (p<=length(s)) and (not (s[p] in [#10,#13])) do inc(p);
    Line:=copy(s,NextLineStartPos,p-NextLineStartPos);
    inc(p);
    if (p<=length(s)) and (s[p] in [#10,#13]) and (s[p]<>s[p-1]) then inc(p);
    NextLineStartPos:=p;
  end;

var
  Line: String;
  item: TConstItem;
  DotPos, EqPos, i, j: Integer;
  ModuleName: String;
  ConstName: String;
  Value: String;
  fs: TFileStream;
  Node: TAVLTreeNode;
begin
  Result:=false;
  try
    fs:=TFileStream.Create(InFilename,fmOpenRead);
    try
      SetLength(s,fs.Size);
      if s='' then exit;
      fs.Read(s[1],length(s));
    finally
      fs.Free;
    end;
    NextLineStartPos:=1;

    while NextLineStartPos<=length(s) do begin
      ReadLine(Line);
      If (Length(Line)=0) or (Line[1]='#') then
        continue;

      DotPos := Pos('.', Line);
      EqPos := Pos('=', Line);
      if DotPos > EqPos then // paranoia checking.
        DotPos := 0;
      ModuleName := Copy(Line, 1, DotPos - 1);
      ConstName := Copy(Line, DotPos + 1, EqPos - DotPos - 1);

      Value := '';
      i := EqPos + 1;
      while i <= Length(Line) do begin
        if Line[i] = '''' then begin
          Inc(i);
          j := i;
          while (i <= Length(Line)) and (Line[i] <> '''') do
            Inc(i);
          Value := Value + Copy(Line, j, i - j);
          Inc(i);
        end else if Line[i] = '#' then begin
          Inc(i);
          j := i;
          while (i <= Length(Line)) and (Line[i] in ['0'..'9']) do
            Inc(i);
          Value := Value + Chr(StrToInt(Copy(Line, j, i - j)));
        end else if Line[i] = '+' then begin
          ReadLine(Line);
          i := 1;
        end else
          Inc(i);
      end;
      Node:=TreeOfConstItems.FindKey(@Value,@CompareValueWithConstItems);
      if Node=nil then begin
        Item:=TConstItem.Create;
        Item.ModuleName:=ModuleName;
        Item.ConstName:=ConstName;
        Item.Value:=Value;
        TreeOfConstItems.Add(Item);
      end else begin
        //DebugLn(['ReadRSTFile Double ignored: ModuleName=',ModuleName,' ConstName=',ConstName,' Value="',DbgStr(Value),'"']);
      end;
    end;

    Result:=true;
  except
    on E: Exception do begin
      DebugLn(['ReadRSTFile InFilename="',InFilename,'" Error=',E.Message]);
    end;
  end;
end;

function ConvertToGettextPO(TreeOfConstItems: TAVLTree;
  const OutFilename: string; CheckContentChange: Boolean;
  var ContentChanged: Boolean): Boolean;
var
  j: Integer;
  item: TConstItem;
  s: String;
  c: Char;
  Node: TAVLTreeNode;
  NewContent: TMemoryStream;
  e: string;
  OldContent: TMemoryStream;
  
  procedure WriteStr(const s: string);
  begin
    if s<>'' then NewContent.Write(s[1],length(s));
  end;
  
  procedure WriteLine(const s: string);
  begin
    if s<>'' then NewContent.Write(s[1],length(s));
    NewContent.Write(e[1],length(e));
  end;
  
begin
  Result:=false;
  ContentChanged:=false;
  NewContent:=nil;
  OldContent:=nil;
  try
    try
      e:=LineEnding;
      NewContent:=TMemoryStream.Create;

      // write header - needed by editors like poedit so they know what encoding
      //                to create
      WriteLine('msgid ""');
      WriteLine('msgstr ""');
      WriteLine('"MIME-Version: 1.0\n"');
      WriteLine('"Content-Type: text/plain; charset=UTF-8\n"');
      WriteLine('"Content-Transfer-Encoding: 8bit\n"');
      WriteStr(e);

      Node:=TreeOfConstItems.FindLowest;
      while Node<>nil do begin
        item := TConstItem(Node.Data);

        // Convert string to C-style syntax
        s := '';
        for j := 1 to Length(item.Value) do begin
          c := item.Value[j];
          case c of
            #9:  s := s + '\t';
            #10: s := s + '\n';
            #0..#8,#11..#31,#128..#255:
              s := s + '\' +
                Chr(Ord(c) shr 6 + 48) +
                Chr((Ord(c) shr 3) and 7 + 48) +
                Chr(Ord(c) and 7 + 48);
            '\': s := s + '\\';
            '"': s := s + '\"';
          else s := s + c;
          end;
        end;

        // Write msg entry
        WriteStr('#: ');
        WriteStr(item.ModuleName);
        WriteStr(':');
        WriteStr(item.ConstName);
        WriteStr(e);
        WriteStr('msgid "');
        WriteStr(s);
        WriteStr('"');
        WriteStr(e);
        WriteStr('msgstr ""');
        WriteStr(e);
        WriteStr(e);

        Node:=TreeOfConstItems.FindSuccessor(Node);
      end;

      NewContent.Position:=0;
      if CheckContentChange and FileExists(OutFilename) then begin
        OldContent:=TMemoryStream.Create;
        OldContent.LoadFromFile(OutFilename);
        ContentChanged:=not CompareMemStreamText(NewContent,OldContent);
        FreeAndNil(OldContent);
      end else begin
        ContentChanged:=true;
      end;
      if ContentChanged then begin
        ForceDirectories(ExtractFileDir(OutFileName));
        NewContent.SaveToFile(OutFilename);
      end;
      Result:=true;
    finally
      NewContent.Free;
      OldContent.Free;
    end;
  except
    on E: Exception do begin
      DebugLn(['ConvertToGettextPO ',E.Message]);
      DumpExceptionBackTrace;
    end;
  end;
end;

function ConvertRSTFile(const RSTFilename, OutputFilename: string;
  CheckContentChange: Boolean; var ContentChanged: Boolean): Boolean;
var
  TreeOfConstItems: TAVLTree;
begin
  Result:=false;
  //DebugLn(['ConvertRSTFile RSTFilename=',RSTFilename,' OutputFilename=',OutputFilename]);
  TreeOfConstItems:=TAVLTree.Create(@CompareConstItems);
  try
    // read .rst file
    if not ReadRSTFile(RSTFilename,TreeOfConstItems) then begin
      DebugLn(['ConvertRSTFile reading failed: RSTFilename=',RSTFilename]);
      exit;
    end;
    // write .po file
    if not ConvertToGettextPO(TreeOfConstItems,OutputFilename,
      CheckContentChange,ContentChanged)
    then begin
      DebugLn(['ConvertRSTFile writing failed: OutputFilename=',OutputFilename]);
      exit;
    end;
  finally
    if TreeOfConstItems<>nil then begin
      TreeOfConstItems.FreeAndClear;
      TreeOfConstItems.Free;
    end;
  end;
  Result:=true;
end;

function ConvertRSTFiles(RSTDirectory, PODirectory: string): Boolean;
var
  FileInfo: TSearchRec;
  RSTFilename: String;
  OutputFilename: String;
  ContentChanged: Boolean;
begin
  Result:=true;
  if (RSTDirectory='') then exit;// nothing to do
  RSTDirectory:=AppendPathDelim(RSTDirectory);
  if not DirectoryIsWritableCached(RSTDirectory) then begin
    // only update writable directories
    DebugLn(['ConvertRSTFiles skipping read only directory ',RSTDirectory]);
    exit(true);
  end;

  // find all .rst files in package output directory
  PODirectory:=AppendPathDelim(PODirectory);
  //DebugLn(['ConvertPackageRSTFiles PODirectory=',PODirectory]);
  if SysUtils.FindFirst(RSTDirectory+'*.rst',faAnyFile,FileInfo)=0
  then begin
    repeat
      // check if special file
      if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') then
        continue;
      RSTFilename:=RSTDirectory+FileInfo.Name;
      OutputFilename:=PODirectory+ChangeFileExt(FileInfo.Name,'.po');
      //DebugLn(['ConvertPackageRSTFiles RSTFilename=',RSTFilename,' OutputFilename=',OutputFilename]);
      if (not FileExists(OutputFilename))
      or (FileAge(RSTFilename)>FileAge(OutputFilename)) then begin
        ContentChanged:=false;
        if not ConvertRSTFile(RSTFilename,OutputFilename,true,ContentChanged)
        then begin
          DebugLn(['ConvertPackageRSTFiles FAILED: RSTFilename=',RSTFilename,' OutputFilename=',OutputFilename]);
          exit(false);
        end;
        if ContentChanged then begin
          // ToDo: update translations
        end;
      end;
    until SysUtils.FindNext(FileInfo)<>0;
  end;
  SysUtils.FindClose(FileInfo);
  Result:=true;
end;

{-------------------------------------------------------------------------------
  TranslateResourceStrings

  Params: none
  Result: none

  Translates all resourcestrings of the resource string files:
    - lclstrconsts.pas
    - codetoolsstrconsts.pas
    - lazarusidestrconsts.pas
-------------------------------------------------------------------------------}
procedure TranslateResourceStrings(const BaseDirectory, CustomLang: string);
const
  Ext = '.%s.po';
var
  Lang, FallbackLang: String;
  Dir: String;
begin
  //debugln('TranslateResourceStrings A CustomLang=',CustomLang);
  if LazarusTranslations=nil then CollectTranslations(BaseDirectory);
  if CustomLang='' then begin
    Lang:=SystemLanguageID1;
    FallbackLang:=SystemLanguageID2;
  end else begin
    Lang:=CustomLang;
    FallbackLang:='';
  end;
  //debugln('TranslateResourceStrings A Lang=',Lang,' FallbackLang=',FallbackLang);
  Dir:=AppendPathDelim(BaseDirectory);
  // IDE
  TranslateUnitResourceStrings('LazarusIDEStrConsts',
    Dir+'languages/lazaruside'+Ext,Lang,FallbackLang);
  // LCL
  TranslateUnitResourceStrings('LclStrConsts',
    Dir+'lcl/languages/lclstrconsts'+Ext,Lang,FallbackLang);
  // IDEIntf
  TranslateUnitResourceStrings('ObjInspStrConsts',
    Dir+'ideintf/languages/objinspstrconsts'+Ext,Lang,FallbackLang);
  // CodeTools
  TranslateUnitResourceStrings('CodeToolsStrConsts',
    Dir+'components/codetools/languages/codetoolsstrconsts'+Ext,Lang,FallbackLang);
  // SynEdit
  TranslateUnitResourceStrings('SynEditStrConst',
    Dir+'components/synedit/languages/synedit'+Ext,Lang,FallbackLang);
  // SynMacroRecorder
  TranslateUnitResourceStrings('SynMacroRecorder',
    Dir+'components/synedit/languages/synmacrorecorder'+Ext,Lang,FallbackLang);
end;

{ TLazarusTranslations }

function TLazarusTranslations.GetItems(Index: integer): TLazarusTranslation;
begin
  Result:=FItems[Index];
end;

destructor TLazarusTranslations.Destroy;
begin
  Clear;
  inherited Destroy;
end;

procedure TLazarusTranslations.Add(const ID: string);
var
  NewTranslation: TLazarusTranslation;
begin
  if IndexOf(ID)>=0 then
    raise Exception.Create('TLazarusTranslations.Add '
                          +'ID="'+ID+'" already exists.');
  NewTranslation:=TLazarusTranslation.Create;
  NewTranslation.FID:=ID;
  inc(FCount);
  ReallocMem(FItems,SizeOf(Pointer)*FCount);
  FItems[FCount-1]:=NewTranslation;
end;

function TLazarusTranslations.IndexOf(const ID: string): integer;
begin
  Result:=FCount-1;
  while (Result>=0) and (CompareText(ID,FItems[Result].ID)<>0) do
    dec(Result);
end;

procedure TLazarusTranslations.Clear;
var
  i: Integer;
begin
  for i:=0 to FCount-1 do FItems[i].Free;
  FCount:=0;
  ReallocMem(FItems,0);
end;

initialization
  LazarusTranslations:=nil;
  GetLanguageIDs(SystemLanguageID1,SystemLanguageID2);

finalization
  LazarusTranslations.Free;
  LazarusTranslations:=nil;

end.