1 files changed, 643 insertions, 0 deletions
diff --git a/extras/contributed/ats/ats_main.pas b/extras/contributed/ats/ats_main.pas
new file mode 100644
index 00000000..e8efb251
--- /dev/null
+++ b/extras/contributed/ats/ats_main.pas
@@ -0,0 +1,643 @@
+unit ats_main;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+type
+  TatsFormat = (atsPureText, atsPascalSource, atsCSV);
+
+  TatsTextItem = record
+    LangId : string;
+    Text   : string;
+  end;
+
+  { TatsTextRow }
+
+  TatsTextRow = class
+  protected
+    FTextId : string;
+    FTexts : array of TatsTextItem;
+  public
+    constructor Create(const atextid : string);
+    destructor Destroy; override;
+
+    procedure SetText(const alangid, atext : string);
+    procedure DeleteText(const alangid : string);
+
+    function GetText(const alangid : string; var afound : boolean) : string;
+    
+    property TextId : string read FTextId;
+  end;
+  
+  { TatsTextTable }
+
+  TatsTextTable = class
+  private
+    FLangIds : TStringList;
+
+    FTable : TStringList;
+
+    FCurrentLangId : string;
+
+  protected
+    function FindRow(const atextid : string) : TatsTextRow;
+
+    function AddRow(const atextid : string) : TatsTextRow;
+
+  public
+    constructor Create;
+    destructor Destroy; override;
+    
+    procedure Clear;
+
+    procedure AddLang(const alangid : string);
+
+    procedure SetText(const atextid, alangid, atext : string);
+    function GetText(const atextid, alangid : string; var found : boolean) : string; overload;
+    function GetText(const atextid : string) : string; overload;
+
+    // later this can prepare a fast search table too:
+    procedure SelectLang(const alangid : string);
+
+    //procedure SetFallbackOrder(const alangids : string);
+
+    property CurrentLang : string read FCurrentLangId;
+    
+  public
+
+    function LoadFromFile(const afilename : string) : boolean;
+    
+    function LoadFromPascalFile(const afilename : string) : boolean;
+    
+    function LoadFromArray(const aarr : array of string) : boolean;
+    
+    procedure LoadPureText(const fdata : string);
+    
+    procedure SaveToFile(const afilename : string; aformat : TatsFormat);
+    
+    // utility functions
+    function RowCount : integer;
+    function GetRow(arow : integer) : TatsTextRow;
+
+    property LangList : TStringList read FLangIds;
+  end;
+
+var
+  atsTexts : TatsTextTable;
+
+function atsGetText(const atextid : string) : string;
+function atsText(const atextid : string) : string;
+
+implementation
+
+uses
+  ptrparsefunc;
+
+function atsGetText(const atextid : string) : string;
+begin
+  result := atsTexts.GetText(atextid);
+end;
+
+function atsText(const atextid : string) : string;
+begin
+  result := atsTexts.GetText(atextid);
+end;
+
+{ TatsTextRow }
+
+constructor TatsTextRow.Create(const atextid : string);
+begin
+  FTextId := atextid;
+  SetLength(FTexts,0);
+end;
+
+destructor TatsTextRow.Destroy;
+var
+  n : integer;
+begin
+  // good to be sure about freeing ansi string
+  for n := 0 to length(FTexts)-1 do
+  begin
+    FTexts[n].LangId := '';
+    FTexts[n].Text   := '';
+  end;
+  SetLength(FTexts,0);
+end;
+
+procedure TatsTextRow.SetText(const alangid, atext: string);
+var
+  n : integer;
+begin
+  // search for an existing
+  for n := 0 to length(FTexts)-1 do
+  begin
+    if FTexts[n].LangId = alangid then
+    begin
+      FTexts[n].Text := atext;
+      Exit; //==>
+    end;
+  end;
+  // add as new
+  n := length(FTexts);
+  SetLength(FTexts,n+1);
+  FTexts[n].LangId := alangid;
+  FTexts[n].Text := atext;
+end;
+
+procedure TatsTextRow.DeleteText(const alangid: string);
+var
+  n : integer;
+begin
+  // search for an existing
+  n := 0;
+  while (n < length(FTexts)) and (FTexts[n].LangId <> alangid) do
+  begin
+    inc(n);
+  end;
+
+  // for ansi string safety
+  if n < length(FTexts) then
+  begin
+    FTexts[n].LangId := '';
+    FTexts[n].Text := '';
+    inc(n);
+  end;
+
+  while (n < length(FTexts))  do
+  begin
+    FTexts[n-1] := FTexts[n];
+    inc(n);
+  end;
+
+  SetLength(FTexts,length(FTexts)-1);
+end;
+
+function TatsTextRow.GetText(const alangid: string; var afound : boolean) : string;
+var
+  n : integer;
+begin
+  // search for an existing
+  for n := 0 to length(FTexts)-1 do
+  begin
+    if FTexts[n].LangId = alangid then
+    begin
+      result := FTexts[n].Text;
+      afound := true;
+      Exit; //==>
+    end;
+  end;
+  result := '';
+  afound := false;
+end;
+
+{ TatsTextTable }
+
+function TatsTextTable.FindRow(const atextid: string) : TatsTextRow;
+var
+  i : integer;
+begin
+  i := FTable.IndexOf(atextid);
+
+  if i >= 0 then result := TatsTextRow(FTable.Objects[i])
+            else result := nil;
+end;
+
+function TatsTextTable.AddRow(const atextid: string) : TatsTextRow;
+begin
+  result := FindRow(atextid);
+  if result = nil then
+  begin
+    result := TatsTextRow.Create(atextid);
+    FTable.AddObject(atextid, result);
+  end;
+end;
+
+constructor TatsTextTable.Create;
+begin
+  FTable := TStringList.Create;
+  FLangIds := TStringList.Create;
+  FCurrentLangId := '';
+end;
+
+destructor TatsTextTable.Destroy;
+begin
+  Clear;
+  FTable.Free;
+  FLangIds.Free;
+end;
+
+procedure TatsTextTable.Clear;
+var
+  n : integer;
+begin
+  for n := 0 to FTable.Count - 1 do
+  begin
+    TatsTextRow(FTable.Objects[n]).Free;
+  end;
+  FTable.Clear;
+  FLangIds.Clear;
+end;
+
+procedure TatsTextTable.AddLang(const alangid: string);
+var
+  i : integer;
+begin
+  i := FLangIds.IndexOf(alangid);
+  if i < 0 then FLangIds.Add(alangid);
+  if FCurrentLangId = '' then FCurrentLangId := alangid;
+end;
+
+procedure TatsTextTable.SetText(const atextid, alangid, atext: string);
+var
+  tr : TatsTextRow;
+begin
+  AddLang(alangid);
+  tr := AddRow(atextid);
+  tr.SetText(alangid, atext);
+end;
+
+function TatsTextTable.GetText(const atextid, alangid: string; var found: boolean): string;
+var
+  tr : TatsTextRow;
+begin
+  tr := FindRow(atextid);
+  if tr <> nil then result := tr.GetText(alangid, found)
+  else
+  begin
+    result := '';
+    found := false;
+  end;
+end;
+
+function TatsTextTable.GetText(const atextid: string): string;
+var
+  found : boolean;
+begin
+  result := GetText(atextid, FCurrentLangId, found);
+  if not found then
+  begin
+    // some fallback mechanism
+    result := '#'+atextid+'@'+FCurrentLangId;
+  end;
+end;
+
+procedure TatsTextTable.SelectLang(const alangid: string);
+var
+  i : integer;
+begin
+  i := FLangIds.indexof(alangid);
+  if i >= 0 then
+  begin
+    FCurrentLangId := alangid;
+  end;
+end;
+
+function GetFileContent(const afilename : string) : string;
+var
+  f : file;
+  toread, rcnt, brres : integer;
+begin
+  try
+    AssignFile(f,afilename);
+    Reset(f,1);
+    
+    toread := FileSize(f);
+    rcnt := 0;
+    
+    SetLength(result, toread);
+    
+    repeat
+      BlockRead(f, result[1+rcnt], toread, brres);
+
+      if brres > 0 then
+      begin
+        inc(rcnt,brres);
+        dec(toread,brres);
+      end;
+    until toread <= 0;
+
+  finally
+    CloseFile(f);
+  end;
+end;
+
+procedure PutFileContent(const afilename : string; const adata : string);
+var
+  f : file;
+  towrite, wcnt, wrres : integer;
+begin
+  try
+    AssignFile(f,afilename);
+    Rewrite(f,1);
+
+    towrite := length(adata);
+    wcnt := 0;
+
+    repeat
+      BlockWrite(f, adata[1+wcnt], towrite, wrres);
+
+      if wrres > 0 then
+      begin
+        inc(wcnt,wrres);
+        dec(towrite,wrres);
+      end;
+    until towrite <= 0;
+
+  finally
+    CloseFile(f);
+  end;
+end;
+
+
+function TatsTextTable.LoadFromFile(const afilename: string): boolean;
+var
+  fdata : string;
+begin
+  fdata := GetFileContent(afilename);
+  //writeln('File content:');
+  //writeln(fdata);
+  LoadPureText(fdata);
+  
+  result := true;
+end;
+
+function TatsTextTable.LoadFromPascalFile(const afilename : string) : boolean;
+var
+  fdata, data : string;
+  rp,sp,ep : PChar; // read ptr, start ptr, end ptr
+  len : integer;
+  tid, lid, txt : string;
+  inquote : boolean;
+begin
+  result := false;
+  
+  fdata := GetFileContent(afilename);
+  
+  if fdata = '' then Exit;
+
+  sp := @fdata[1];
+  ep := sp + length(fdata);
+
+  rp := sp;
+
+  // skipping UTF8 marker first
+  ppCheckSymbol(rp, ep, #$EF#$BB#$BF);
+  
+  ppSkipSpaces(rp, ep);
+  
+  if not ppCheckSymbolCI(rp, ep, 'array') then EXIT;
+  
+  ppSkipSpaces(rp, ep);
+  if not ppCheckSymbol(rp, ep, '[') then EXIT;
+
+  if not ppSearchPattern(rp, ep, ']', len) then EXIT;
+  
+  ppSkipSpaces(rp, ep);
+  if not ppCheckSymbolCI(rp, ep, 'of') then EXIT;
+  ppSkipSpaces(rp, ep);
+  if not ppCheckSymbolCI(rp, ep, 'string') then EXIT;
+  ppSkipSpaces(rp, ep);
+  if not ppCheckSymbol(rp, ep, '=') then EXIT;
+  ppSkipSpaces(rp, ep);
+  if not ppCheckSymbol(rp, ep, '(') then EXIT;
+
+  ppSkipSpaces(rp, ep);
+  
+  data := '';
+  
+  inquote := false;
+
+  while rp < ep do
+  begin
+    if not inquote then
+    begin
+      ppSkipSpaces(rp, ep);
+      if ppCheckSymbol(rp, ep, '''') then
+      begin
+        inquote := true;
+        sp := rp;
+      end
+      else if ppCheckSymbol(rp, ep, ',') then
+      begin
+        // just skip ip
+        ppSkipSpaces(rp, ep);
+      end
+      else if ppCheckSymbol(rp, ep, ')') then
+      begin
+        // closing char
+        break;
+      end
+      else
+      begin
+        // invalid char
+        break;
+      end;
+    end;
+    
+    if inquote then
+    begin
+      if ppReadTo(rp, ep, '''', len) then
+      begin
+        // closing quote or double quote
+        if len > 0 then data := data + ppMakeString(sp, len);
+        inc(rp);
+        if (rp < ep) and (rp^ = '''') then
+        begin
+          data := data + '''';
+          inc(rp);
+          sp := rp;
+        end
+        else
+        begin
+          data := data + #10;
+          inquote := false;
+        end;
+      end;
+    end;
+  end; // while
+  
+  //writeln('Pure content:');
+  //writeln(data);
+  
+  LoadPureText(data);
+
+  result := true;
+end;
+
+function TatsTextTable.LoadFromArray(const aarr: array of string): boolean;
+var
+  fdata : string;
+  n : integer;
+begin
+  fdata := '';
+  for n := low(aarr) to high(aarr) do
+  begin
+    fdata := fdata + aarr[n] + #10;
+  end;
+  LoadPureText(fdata);
+end;
+
+procedure TatsTextTable.LoadPureText(const fdata: string);
+var
+  rp,sp,ep : PChar; // read ptr, start ptr, end ptr
+  len : integer;
+  tid, lid, txt : string;
+begin
+  if fdata = '' then Exit;
+
+  sp := @fdata[1];
+  ep := sp + length(fdata);
+
+  rp := sp;
+
+  // skipping UTF8 marker first
+  ppCheckSymbol(rp, ep, #$EF#$BB#$BF);
+
+  ppSkipSpaces(rp, ep);
+
+  tid := '???';
+
+  while rp < ep do
+  begin
+    sp := rp;
+    // reading identifier (txt or lang)
+    if ppReadTo(rp, ep, '=:', len) then
+    begin
+      if rp^ = ':' then
+      begin
+        // text id is this
+        tid := trim(ppMakeString(sp, len));
+        inc(rp); // skip ':'
+      end
+      else if rp^ = '=' then
+      begin
+        // lang id is this
+        lid := trim(ppMakeString(sp,len));
+        inc(rp); // skip '='
+
+        ppSkipSpaces(rp, ep);
+
+        if not ppCheckSymbol(rp,ep,'"') then
+        begin
+          // starting quote is missing
+        end;
+
+        txt := '';
+        sp := rp;
+        if ppReadTo(rp, ep, '"', len) then
+        begin
+          txt := ppMakeString(sp,len);
+          inc(rp);
+        end
+        else
+        begin
+          // end quote is missing
+        end;
+
+        if txt <> '' then
+        begin
+          atsTexts.SetText(tid, lid, txt);
+        end;
+      end;
+
+      ppSkipSpaces(rp, ep);
+    end; // reading identifier
+  end;
+end;
+
+procedure TatsTextTable.SaveToFile(const afilename: string; aformat: TatsFormat);
+var
+  sl : TStringList;
+  tr : TatsTextRow;
+  n,i : integer;
+  s : string;
+  b : boolean;
+  fdata : string;
+begin
+  sl := TStringList.Create;
+  
+  for n:=0 to FTable.Count-1 do
+  begin
+    tr := TatsTextRow(FTable.Objects[n]);
+    if aformat = atsCSV then
+    begin
+      s := '"'+tr.TextId+'"';
+      for i := 0 to FLangIds.Count-1 do
+      begin
+        s := s + ',"' + tr.GetText(FLangIds[i],b) + '"';
+      end;
+      sl.Add(s);
+    end
+    else
+    begin
+      sl.Add(tr.TextID+':');
+      for i := 0 to FLangIds.Count-1 do
+      begin
+        s := tr.GetText(FLangIds[i],b);
+        if b then sl.Add('  '+FLangIds[i]+'="'+s+'"');
+      end;
+    end;
+  end;
+  
+  // assembly the final buffer
+  
+  if aformat = atsCSV then
+  begin
+    fdata := '"ATSF1"';
+    for i := 0 to FLangIds.Count-1 do
+    begin
+      fdata := fdata + ',"' + FLangIds[i] + '"';
+    end;
+    for n := 0 to sl.Count-1 do
+    begin
+      fdata := fdata + #13#10 + sl[n];
+    end;
+  end
+  else if aformat = atsPascalSource then
+  begin
+    fdata := 'array[1..'+IntToStr(sl.Count)+'] of string = ('+#13#10;
+    s := ' ';
+    for n := 0 to sl.Count-1 do
+    begin
+      fdata := fdata + '  ' + s + QuotedStr(sl[n]) + #13#10;
+      s := ',';
+    end;
+    fdata := fdata + #13#10 + ');' + #13#10;
+  end
+  else
+  begin
+    // pure text...
+    fdata := ''; // no header
+    for n := 0 to sl.Count-1 do
+    begin
+      fdata := fdata + sl[n] + #13#10;
+    end;
+  end;
+  
+  sl.Free;
+  
+  PutFileContent(afilename, fdata);
+end;
+
+function TatsTextTable.RowCount: integer;
+begin
+  result := FTable.Count;
+end;
+
+function TatsTextTable.GetRow(arow: integer): TatsTextRow;
+begin
+  result := TatsTextRow(FTable.Objects[arow]);
+end;
+
+
+initialization
+begin
+  atsTexts := TatsTextTable.Create;
+end;
+
+end.
+