unit u_parser;

interface

uses Classes, SysUtils;

 {$B+}
 {$H+}

const
  // БАЗОВЫЕ ТИПЫ ДАННЫХ
  dBoolean       = 0;                  // TRUE, FALSE
  dInteger       = 1;                  // Целое число
  dFloat         = 2;                  // Число с плавающей точкой (Single)
  dString        = 3;                  // Строка
  // БАЗОВЫЕ СОСТАВНЫЕ
  dVector        = 4;                  // Вектор (с целочисленными осями)
  dFloatVector   = 5;                  // Вектор (c осями с плавающей точкой)

type
  TClassType = (ct_basic, ct_record);
  TCallFuction = Function (Data: Pointer) : Pointer;
  PPointer = ^Pointer;

  PVector = ^TVector;
  TVector = record
    X, Y: ^integer;
  end;
  TTVector = record
    X, Y: integer;
  end;
  PFloatVector = ^TFloatVector;
  TFloatVector = record
    X, Y: ^Single;
  end;

  TFilesParser = class;
  TDataType = class;

  PDataValue = ^TDataValue;
  TDataValue = record
    Name, Value, SysName, LinkName: AnsiString;
    Level: Byte;
  end;
  TParseNode = class
    Data: PDataValue;
    Child: TList;
    destructor Destroy; override;
  end;
  TDataVariable = class
    public
      Name: AnsiString;
      DataType: TDataType;
      isArray: Boolean;
  end;
  TDataObject = class
    public
      DataVar: TDataVariable;
      Name: AnsiString;
      DataId: Word;
      Data: Pointer;
  end;
  TDataObjectRecord = class (TList)
    public
      lvl: byte;
      FP: TFilesParser;
      DataType: TDataType;
      Obj: pointer;
      procedure GetData(Name_: AnsiString; Data_: PPointer; Warning: Boolean = false);
      function AddData(Name_: AnsiString; Data_: Pointer; CallF: boolean): TDataObject;
      constructor Create (Fp_: TFilesParser; DataId: Word; lvl_: byte);
      destructor Destroy; override;
  end;
  TDataType = class
    public
      Name: AnsiString;
      DataId: Word;
      DefaultValue: Pointer;
      ClassType: TClassType;
      CallFunction: TCallFuction;
      FP: TFilesParser;
      function RegisterVariable(Name_: AnsiString; DataType_: Word; isArray_: Boolean = false): TDataVariable;
      destructor Destroy; override;
    private
      Variables: TList;
      function FindVar(Name_: AnsiString) : TDataVariable;
  end;
  TDataFunction = class
    public
      Name: AnsiString;
      DataType: TDataType;
      ClassType: Byte;
      CallFunction: TCallFuction;
  end;
  TNamedObject = class
    public
      SysName: AnsiString;
      DataType: TDataType;
      Data: TDataObjectRecord;
  end;
  TFilesParser = class
    private
      Log: TStringList;
      DataTypes, DataFunctions, NamedObjects, Dors: TList;
      function ParseItems(Node: TParseNode; DataId: Word; lvl: integer) : TDataObjectRecord;
    public
      function FindTypeById(DataId : Word) : TDataType;
      function FindTypeByName(Name_: AnsiString) : TDataType;
      procedure LogInfo(data: AnsiString; level: byte);
      constructor Create;
      destructor Destroy; override;
      procedure LoadFromFile(dir: AnsiString; lvl: Byte = 0);
      procedure LoadData(dir: AnsiString);
      function RegisterType(Name_: AnsiString; DataId_: Word; DefaultValue_: Pointer; ClassType_: TClassType; CallFunction_: TCallFuction) : TDataType;
      function RegisterFunction(Name_: AnsiString; DataId_: Word; CallFunction_: TCallFuction) : TDataFunction;
  end;

var
  FileParser: TFilesParser;

  cfBooleanNull: Boolean = false;
  cfIntegerNull: Integer = 0;
  cfFloatNull: Single = 0;
  cfStringNull: AnsiString = '';
  cfVectorNull: TVector = (X: @cfIntegerNull; Y: @cfIntegerNull);
  cfFloatVectorNull: TFloatVector = (X: @cfFloatNull; Y: @cfFloatNull);

  function cfBoolean(Data: Pointer): Pointer;
  function cfInteger(Data: Pointer): Pointer;
  function cfFloat(Data: Pointer): Pointer;
  function cfString(Data: Pointer): Pointer;
  function cfVector(Data: TDataObjectRecord): Pointer;
  function cfFloatVector(Data: TDataObjectRecord): Pointer;

  function GetFilePath(Name: AnsiString): AnsiString;

implementation

function u_StrDown( const str : AnsiString ) : AnsiString;
  var
    i, l : Integer;
begin
  l := length( Str );
  SetLength( Result, l );
  for i := 1 to l do
    if ( Byte( Str[ i ] ) >= 65 ) and ( Byte( Str[ i ] ) <= 90 ) Then
      Result[ i ] := AnsiChar( Byte( Str[ i ] ) + 32 )
    else
      Result[ i ] := Str[ i ];
end;

function u_StrToBool( const Value : AnsiString ) : Boolean;
begin
  if Value = '1' Then
    Result := TRUE
  else
    if u_StrDown( Value ) = 'true' Then
      Result := TRUE
    else
      Result := FALSE;
end;

function cfBoolean(Data: Pointer): Pointer;
begin
  New(PBoolean(Result));
  Boolean(Result^) := u_StrToBool(AnsiString(Data^));
end;

function cfInteger(Data: Pointer): Pointer;
begin
  New(PInteger(Result));
  Integer(Result^) := StrToInt(string(AnsiString(Data^)));
end;

function cfFloat(Data: Pointer): Pointer;
begin
  New(PSingle(Result));
  Single(Result^) := StrToFloat(string(AnsiString(Data^)));
end;

function cfString(Data: Pointer): Pointer;
begin
  New(PAnsiString(Result));
  AnsiString(Result^) := AnsiString(Data^);
end;

function cfVector(Data: TDataObjectRecord): Pointer;
var p: PVector;
begin
  New(p);
  data.GetData('X', @p^.X, true);
  data.GetData('Y', @p^.Y, true);
  result := p;
end;

function cfFloatVector(Data: TDataObjectRecord): Pointer;
var p: PFloatVector;
begin
  New(p);
  data.GetData('X', @p^.X, true);
  data.GetData('Y', @p^.Y, true);
  result := p;
end;

destructor TParseNode.Destroy;
var i: integer;
    pn: TParseNode;
begin
  //Dispose(Data);
  for i := 0 to Child.Count - 1 do begin
    pn := Child.Items[i];
    pn.Free;
  end;
  Child.Free;
  inherited;
end;

constructor TDataObjectRecord.Create;
begin
  inherited Create;
  FP := Fp_;
  lvl := lvl_ + 1;
  DataType := Fp.FindTypeById(DataId);
  FP.Dors.Add(Self);
  Obj := nil;
end;

destructor TDataObjectRecord.Destroy;
var i: integer;
begin
  for i := 0 to Count - 1 do begin
    TDataObject(Items[i]).Free;
  end;
  inherited;
end;

function TDataObjectRecord.AddData;
var d: TDataVariable;
    dtp: TDataType;
    dt: Pointer;
    dobj: TDataObject;
    i: integer;
begin
  d := DataType.FindVar(Name_);
  Result := nil;
  if Assigned(d) then begin
    dtp := d.DataType;
    for i := 0 to Count -1 do begin
      dobj := Items[i];
      if dobj.Name = u_StrDown(Name_) then begin
        dobj.DataVar := d;
        dt := Data_;
        if CallF then
          dt := dtp.CallFunction(Data_);
        if dobj.DataVar.isArray then begin
          TList(dobj.Data).Add(dt);
        end else begin
          dobj.Data := dt;
        end;
        Result := dobj;
        Exit;
      end;
    end;
    Result := TDataObject.Create;
    Result.Name := u_StrDown(Name_);
    Result.DataVar := d;
    dt := Data_;
    if CallF then
      dt := dtp.CallFunction(Data_);
    if Result.DataVar.isArray then begin
      Result.Data := TList.Create;
      TList(Result.Data).Capacity := 16;
      TList(Result.Data).Add(dt);
    end else begin
      Result.Data := dt;
    end;
    Add(Result);
  end;
end;


procedure TDataObjectRecord.GetData;
var d: TDataObject;
    i: integer;
begin
  Name_ := u_StrDown(Name_);
  //if (Data_^ = nil) then
  Data_^ := DataType.FindVar(Name_).DataType.DefaultValue;
  for i := 0 to Count -1 do begin
    d := Items[i];
    if d.Name = Name_ then begin
      Data_^ := d.Data;
      exit;
    end;
  end;
  if Warning then
    FP.LogInfo('Внимание: свойство "' + Name_ + '" не задано!', lvl + 1);
end;

function TDataType.RegisterVariable;
begin
  Result := TDataVariable.Create;
  Result.isArray := isArray_;
  Result.Name := u_StrDown(Name_);
  Result.DataType := Fp.FindTypeById(DataType_);
  Variables.Add(Result);
end;

destructor TDataType.Destroy;
var i: integer;
    d: TDataVariable;
begin
  case ClassType of
    ct_record: begin
      for i := 0 to Variables.Count - 1 do begin
        d := Variables.Items[i];
        d.Free;
      end;
      Variables.Free;
    end;
  end;
  inherited;
end;

function TDataType.FindVar;
var dt: TDataVariable;
    i: integer;
begin
  Result := nil;
  for i := 0 to Variables.count - 1 do begin
    dt := Variables.Items[i];
    if dt.Name = Name_ then begin
      result := dt;
      break;
    end;
  end;
end;

function TFilesParser.FindTypeById;
var i: integer;
    d: TDataType;
begin
  result := nil;
  for i := 0 to DataTypes.Count -1 do begin
    d := DataTypes.Items[i];
    if d.DataId = DataId then begin
      Result := d;
      Exit;
    end;
  end;
end;

function TFilesParser.FindTypeByName;
var i: integer;
    d: TDataType;
begin
  result := nil;
  for i := 0 to DataTypes.Count -1 do begin
    d := DataTypes.Items[i];
    if d.Name = Name_ then begin
      Result := d;
      Exit;
    end;
  end;
end;

function TFilesParser.RegisterType;
var dt: TDataType;
begin
  dt := FindTypeById(DataId_);
  if dt = nil then begin
    Result := TDataType.Create;
    Result.Name := Name_;
    Result.DataId := DataId_;
    Result.ClassType := ClassType_;
    Result.CallFunction := CallFunction_;
    Result.DefaultValue := DefaultValue_;
    Result.FP := Self;
    case ClassType_ of
      ct_record: begin
        Result.Variables := TList.Create;
      end;
    end;

    DataTypes.Add(Result);
  end else begin
    Result := nil;
    LogInfo('Ошибка: Ячейка #' + AnsiString(IntToStr(DataId_)) +
      ' для типа "' + Name_ + '" уже была зарезервирована типом "' + dt.Name + '"!', 0);
  end;
end;

function TFilesParser.RegisterFunction;
begin
  Result := TDataFunction.Create;
  Result.Name := u_StrDown(Name_);
  Result.DataType := FindTypeById(DataId_);
  Result.CallFunction := CallFunction_;

  DataFunctions.Add(Result);
end;

function TFilesParser.ParseItems;
var i, j: integer;
    dt: TDataVariable;
    p: TNamedObject;
    no, n_o: TNamedObject;
    dor: TDataObjectRecord;
    tmp: TParseNode;
begin
  if Node.Data.LinkName <> '' then begin
    n_o := nil;
    for j := 0 to NamedObjects.Count -1 do begin
      no := NamedObjects.Items[j];
      if no.SysName = Node.Data.LinkName then begin
        n_o := no;
      end;
    end;
    if n_o <> nil then begin
      if node.Data.Value = n_o.DataType.Name then begin
        dor := n_o.Data;
      end else begin
        LogInfo('Ошибка Линковки: тип источника (' + Node.Data.LinkName + ' с типом ' + n_o.DataType.Name + ') и тип приёмника отличаются (нужен ' + Node.Data.Value + ')!', lvl + 2);
      end;
    end else begin
      LogInfo('Ошибка Линковки: объект ' + Node.Data.LinkName + ' не найден!', lvl + 2);
    end;
  end else begin
    dor := TDataObjectRecord.Create(Self, DataId, lvl);
    if Node.Data.SysName <> '' then begin
      p := TNamedObject.Create;
      p.SysName := Node.Data.SysName;
      p.DataType := dor.DataType;
      p.Data := dor;
      NamedObjects.Add(p);
    end;
  end;
  if Node.Data.LinkName <> '' then
    LogInfo('Объект ' + Node.Data^.Value + '::' + Node.Data^.Name + '(@' + Node.Data^.LinkName + ')', lvl + 1)
  else
    LogInfo('Объект ' + Node.Data^.Value + '::' + Node.Data^.Name + '(' + Node.Data^.SysName + ')', lvl + 1);
  for i := 0 to node.Child.Count -1 do begin
    tmp := Node.Child.Items[i];
    if u_StrDown(tmp.Data^.Name) = 'copyof' then begin
      n_o := nil;
      for j := 0 to NamedObjects.Count -1 do begin
        no := NamedObjects.Items[j];
        if no.SysName = tmp.Data^.Value then begin
          n_o := no;
        end;
      end;
      if n_o <> nil then begin
        if node.Data.Value = n_o.DataType.Name then begin
          for j := 0 to n_o.Data.Count - 1 do begin
            dor.Add(n_o.Data.Items[j]);
          end;
          LogInfo('@' + tmp.Data^.Value + ' -> копия!', lvl + 2);
        end else begin
          LogInfo('Ошибка Копирования: тип источника (' + tmp.Data^.Value + ' с типом ' + n_o.DataType.Name + ') и тип приёмника отличаются (нужен ' + Node.Data^.Value + ')!', lvl + 2);
        end;
      end else begin
        LogInfo('Ошибка Копирования: объект ' + tmp.Data^.Value + ' не найден!', lvl + 2);
      end;
    end else begin
      if tmp.Data.LinkName <> '' then begin
        n_o := nil;
        for j := 0 to NamedObjects.Count -1 do begin
          no := NamedObjects.Items[j];
          if no.SysName = tmp.Data.LinkName then begin
            n_o := no;
          end;
        end;
        if n_o <> nil then begin
          if tmp.Data.Value = n_o.DataType.Name then begin
            dor.AddData(tmp.Data^.Name,
              n_o.Data.Obj, false)
          end else begin
            LogInfo('Ошибка Линковки: тип источника (' + tmp.Data.LinkName + ' с типом ' + n_o.DataType.Name + ') и тип приёмника отличаются (нужен ' + tmp.Data.Value + ')!', lvl + 2);
          end;
        end else begin
          LogInfo('Ошибка Линковки: объект ' + tmp.Data.LinkName + ' не найден!', lvl + 2);
        end;
      end else begin
        dt := dor.DataType.FindVar(tmp.Data^.Name);
        if dt <> nil then begin
          if dt.DataType.ClassType = ct_basic then begin
            dor.AddData(tmp.Data^.Name, @tmp.Data.Value, true);
          end else begin
            if dt.DataType.Name = tmp.Data.Value then begin
              dor.AddData(tmp.Data^.Name,
                ParseItems(tmp, dt.DataType.DataId, lvl + 1).Obj, false);
            end else begin
              LogInfo('Ошибка Типов: тип значения ' + tmp.Data^.Value + ' не подходит для свойства ' + dt.Name + ' (нужен ' + dt.DataType.Name + ')!', lvl + 2);
            end;
          end;
        end else begin
          LogInfo('Ошибка: свойство ' + tmp.Data^.Name + ' неизвестно в типе ' + dor.DataType.Name + '!', lvl + 2);
        end;
      end;
    end;
  end;
  dor.Obj := dor.DataType.CallFunction(dor);
  result := dor;
end;

constructor TFilesParser.Create;
begin

  Log := TStringList.Create;
  LogInfo('-----------------------------------', 0);
  LogInfo('Универсальный Парсер INI-файлов', 1);
  LogInfo('-----------------------------------', 0);


  DataTypes := TList.Create;
  DataTypes.Capacity := 20;
  DataFunctions := TList.Create;
  DataFunctions.Capacity := 20;
  NamedObjects := TList.Create;
  NamedObjects.Capacity := 20;
  Dors := TList.Create;
  Dors.Capacity := 20;

  RegisterType('Boolean', dBoolean, @cfBooleanNull, ct_basic, @cfBoolean);
  RegisterType('Integer', dInteger, @cfIntegerNull, ct_basic, @cfInteger);
  RegisterType('Float', dFloat, @cfFloatNull, ct_basic, @cfFloat);
  RegisterType('AnsiString', dString, @cfStringNull, ct_basic, @cfString);

  with RegisterType('Vector', dVector, @cfVectorNull, ct_record, @cfVector) do begin
    RegisterVariable('X', dInteger);
    RegisterVariable('Y', dInteger);
  end;

  with RegisterType('FVector', dFloatVector, @cfFloatVectorNull, ct_record, @cfFloatVector) do begin
    RegisterVariable('X', dFloat);
    RegisterVariable('Y', dFloat);
  end;

end;

procedure TFilesParser.LogInfo;
var s: AnsiString;
begin
  SetLength(s, level); FillChar(s[1], level, #9);
  Log.Add(string(s + data));
  //Log.SaveToFile('parser_log.txt');
end;

function TrimStr(s: AnsiString; strDown: boolean = true): AnsiString;
var
  I, L: Integer;
begin
  if strDown then
    s := u_StrDown(s);
  L := Length(s);
  I := 1;
  while (I <= L) and (s[I] in [#0 .. ' ', '''', '"']) do Inc(I);
  if I > L then Result := '' else begin
    while s[L] in [#0 .. ' ', '''', '"'] do Dec(L);
    Result := AnsiString(Copy(s, I, L - I + 1));
  end;
end;

procedure TFilesParser.LoadData;
var sr: TSearchRec;
begin
  if FindFirst(string(dir + '/*.init'), faDirectory, sr) = 0 then begin
    repeat
      LoadFromFile(dir + '/' + AnsiString(sr.Name));
    until FindNext(sr) <> 0;
  end;
end;

destructor TFilesParser.Destroy;
var i: integer;
    d: TDataType;
    f: TDataFunction;
    n: TNamedObject;
    dor: TDataObjectRecord;
begin
  for i := 0 to DataTypes.Count - 1 do begin
    d := DataTypes.Items[i];
    d.Free;
  end;
  for i := 0 to DataFunctions.Count - 1 do begin
    f := DataFunctions.Items[i];
    f.Free;
  end;
  for i := 0 to NamedObjects.Count - 1 do begin
    n := NamedObjects.Items[i];
    n.Free;
  end;
  for i := 0 to Dors.Count - 1 do begin
    dor := Dors.Items[i];
    dor.Free;
  end;
  Log.Free;
  DataTypes.Free;
  DataFunctions.Free;
  NamedObjects.Free;
  Dors.Free;
  inherited;
end;

Function String_Reverse(S : AnsiString): AnsiString;
 Var
    i : Integer;
 Begin
    Result := '';
    For i := Length(S) DownTo 1 Do
    Begin
      Result := Result + Copy(S, i, 1) ;
    End;
 End;

function RPos(SubStr: AnsiString; S: AnsiString): integer;
var
  I: integer;
begin
  SubStr := String_Reverse(SubStr);
  S := String_Reverse(S);
  I := pos(SubStr, S);
  if I <> 0 then
    I := (Length(S) + 1) - (I + Length(SubStr) - 1);
  Result := I;
end;

function GetFilePath(Name: AnsiString): AnsiString;
var p: Integer;
begin
  for p := 1 to Length(Name) do
    if Name[p] = '\' then
      Name[p] := '/';
  p := RPos('/', Name);
  if p <> 0 then begin
    Result := Copy(Name, 1, p);
  end else Result := Name;
end;

procedure TFilesParser.LoadFromFile;
var fstr: TStringList;
    f_dir, str, val: AnsiString;
    i, j: integer;
    parseNodes: TList;
    pn: TParseNode;
    data: Pointer;
    df, d_f: TDataFunction;
    dor: TDataObjectRecord;
    dataValues: array of TDataValue;
    procedure ParseNode(pos, level: Integer; Parent: TList);
    var pn: TParseNode;
    begin
      while (pos < fstr.Count) and (dataValues[pos].Level >= level) do begin
        if dataValues[pos].Level = level then begin
          pn := TParseNode.Create;
          pn.Data := @dataValues[pos];
          pn.Child := TList.Create;
          Parent.Add(pn);
          ParseNode(Pos + 1, level + 1, pn.Child);
        end;
        Inc(pos);
      end;
    end;
begin
  fstr := TStringList.Create;
  f_dir := GetFilePath(dir);
  LogInfo('Файл (' + dir + ') {', lvl);
  if FileExists(string(dir)) then begin
    fstr.LoadFromFile(string(dir));
    if fstr.Count > 0 then begin
      SetLength(dataValues, fstr.Count);
      for i := 0 to fstr.Count - 1 do begin
        dataValues[i].Level := 0;
        str := AnsiString(fstr.Names[i]);
        if str <> '' then begin
          while (dataValues[i].Level <= length(str)) and
             (str[ dataValues[i].Level + 1 ] = #9) do
            inc(dataValues[i].Level);
        end;
        dataValues[i].Name := TrimStr(AnsiString(fstr.Names[i]), true);
        val := TrimStr(AnsiString(fstr.ValueFromIndex[i]), false);
        j := Pos('@', string(val));
        if j <> 0 then begin
          dataValues[i].Value := TrimStr(Copy(val, 1, j - 1), false);
          dataValues[i].SysName := TrimStr(Copy(val, j + 1, Length(val)));
          dataValues[i].LinkName := '';
        end else begin
          j := Pos('->', string(val));
          if j <> 0 then begin
            dataValues[i].Value := TrimStr(Copy(val, 1, j - 1), false);
            dataValues[i].SysName := '';
            dataValues[i].LinkName := TrimStr(Copy(val, j + 2, Length(val)));
          end else begin
            dataValues[i].Value := val;
            dataValues[i].SysName := '';
            dataValues[i].LinkName := '';
          end;
        end;
      end;
      parseNodes := TList.Create;
      parseNodes.Capacity := 64;
      ParseNode(0, 0, parseNodes);
      for i := 0 to parseNodes.Count -1 do begin
        pn := parseNodes.Items[i];
        str := pn.Data^.Name;
        if str = 'include' then begin
          LoadFromFile(f_dir + pn.Data^.Value, lvl + 1);
        end else begin
          d_f := nil;
          for j := 0 to DataFunctions.Count -1 do begin
            df := DataFunctions.Items[j];
            if df.Name = str then begin
              d_f := df;
              break;
            end;
          end;
          if assigned(d_f) then begin
            if d_f.DataType.ClassType = ct_basic then begin
              data := d_f.DataType.CallFunction(@pn.Data^.Value);
              if Assigned(d_f.CallFunction) then
                d_f.CallFunction(data);
            end else begin
              if d_f.DataType.Name = pn.Data^.Value then begin
                if Assigned(d_f.DataType.CallFunction) then begin
                  dor := ParseItems(pn, d_f.DataType.DataId, lvl);
                  if Assigned(d_f.CallFunction) then
                    d_f.CallFunction(dor.Obj);
                end;
              end else begin
                LogInfo('Ошибка типов: тип ' + pn.Data^.Value + ' не подходит для функции ' + d_f.Name + ' (нужен ' + d_f.DataType.Name + ')!', lvl + 1);
              end;
            end;
          end else begin
            LogInfo('Ошибка: фунция ' + pn.Data^.Name + ' не существует!', lvl + 1);
          end;
        end;

      end;
      for i := 0 to parseNodes.Count - 1 do begin
        pn := parseNodes.Items[i];
        pn.Free;
      end;
      parseNodes.Free;
      dataValues := nil;
    end;
  end else begin
    LogInfo('Ошибка: файл ' + dir + ' не существует!', lvl + 1);
  end;
  LogInfo('}', lvl);
  fstr.Free;
  Log.SaveToFile('parser_log.txt');
end;

end.

