How to write in-memory database applications in Lazarus/FPC/ru

[[Advantage Database Server|Advantage]] \- [[MySQLDatabases|MySQL]] \- [[mssqlconn|MSSQL]] \- [[postgres|Postgres]] \- [[Firebird|Interbase]] \- [[Firebird]] \- [[Oracle]] \- [[ODBCConn|ODBC]] \- [[TParadox|Paradox]] \- [[SQLite]] \- [[Lazarus Tdbf Tutorial|dBASE]] \- [[MS Access]] \- [[Zeos tutorial|Zeos]]

type
      TSaveTables=array[1..15] of TMemDataset;    
    var
      //Глобальная переменная, которая хранит таблицы для сохранения/восстановления сеанса работы
      vSaveTables:TSaveTables;                  
      //Переменная-флаг подавления событий датасета. Используется при загрузке данных из файлов.
      vSuppressEvents:Boolean;

const
      //Константа cSaveRestore определяет способ сохранения и восстановления MemDataset в постоянные файлы.
      cSaveRestore=0; //0=собственный формат MemDataset, 1=сохранение и восстановление из CSV

procedure TMainForm.FormCreate(Sender: TObject);
    begin
      //Список таблиц, которые будут сохранены/восстановлены для сеанса работы
      vSaveTables[1]:=Products;
      vSaveTables[2]:=Boms;
      vSaveTables[3]:=Stocks;
      vSaveTables[4]:=Orders;
      vSaveTables[5]:=BomCalculationProducts;
      vSaveTables[6]:=BomCalculationComponents;
      vSaveTables[7]:=BomCalculationFooter;
      vSaveTables[8]:=BomCalculationProductsMultiple;
      vSaveTables[9]:=BomCalculationComponentsMultiple;
      vSaveTables[10]:=BomCalculationFooterMultiple;
      vSaveTables[11]:=ImportVariants;
      vSaveTables[12]:=ImportToTables;
      vSaveTables[13]:=ImportToFields;
      vSaveTables[14]:=ImportFromTables;
      vSaveTables[15]:=ImportFromFields;
      //Восстанавливаем сеанс работы
      RestoreSession;
      GetAutoincrementPrimaryFields;
    end;

procedure TMainForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
    begin
     //Сохраняем наборы данных в файлы (чтобы сохранить текущий сеанс)
     SaveSession;
    end;

procedure RestoreSession;
    var
      I:Integer;
    begin
      try
        MemoMessages.Append(TimeToStr(Now())+' Начало восстановления ранее сохраненного сеанса.');
        vSuppressEvents:=True; //Подавляем события, используемые для обеспечения ссылочной целостности
        //Отключаем элементы управления и обновляем все наборы данных
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].DisableControls;
          vSaveTables[I].Refresh; //Важный момент, если набор данных был отфильтрован
        end;
        //Загружаем memdataset'ы из файлов (для восстановления предыдущего сеанса)
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].First;
          MemoMessages.Append(TimeToStr(Now())+' Начинаем восстановление таблицы: '+vSaveTables[I].Name);
          try
            //Если данные загружаются из CSV-файла, то сначала необходимо удалить таблицу.
            if cSaveRestore=1 then begin
              MemoMessages.Append(TimeToStr(Now())+' Начинаем удаление всех записей в таблице: '+vSaveTables[I].Name);
              //Этот способ удаления всех записей невероятно медленный.
              {while not vSaveTables[I].EOF do begin
                vSaveTables[I].Delete;
              end;}
              //Этот метод для удаления всех записей намного быстрее
              EmptyMemDataSet(vSaveTables[I]);
              MemoMessages.Append(TimeToStr(Now())+' Все записи из таблицы: '+vSaveTables[I].Name+' удалены.');
            end;
          except
            on E:Exception do begin
              MemoMessages.Append(TimeToStr(Now())+' Ошибка при удалении записей из таблицы: '+vSaveTables[I].Name +'. '+E.Message);
            end;
          end;
          try
            try
              MemoMessages.Append(TimeToStr(Now())+' Восстановление таблицы: '+vSaveTables[I].Name);
              //Проверяем константу для выбора способа сохранения/восстановления данных и загрузки сохраненного сеанса
              case cSaveRestore of
                0:vSaveTables[I].LoadFromFile(vSaveTables[I].Name);
                1:LoadFromCsv(vSaveTables[I]);
              end;
            except
              on E:Exception do begin
                MemoMessages.Append(TimeToStr(Now())+' Ошибка при восстановлении таблицы: '+vSaveTables[I].Name +'. '+E.Message);
              end;
            end;
          finally
            vSaveTables[I].Active:=True;//Требуется из-за метода LoadFromFile....
          end;
          MemoMessages.Append(TimeToStr(Now())+' Таблица: '+vSaveTables[I].Name+' восстановлена.');
        end;
      finally
        vSuppressEvents:=False;
        //Обновляем все наборы данных и включаем элементы управления
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].Refresh; //Необходимо для таблиц, которые фильтруются.
          vSaveTables[I].EnableControls;
        end;
         MemoMessages.Append(TimeToStr(Now())+' Все таблицы восстановлены из сохраненных файлов.');
      end;
    end;

procedure SaveSession;
    var
      I:Integer;
    begin
      try
        MemoMessages.Append(TimeToStr(Now())+' Начало сохранения сеанса в постоянные файлы.');
        vSuppressEvents:=True;
        //Отключаем элементы управления и обновляем все наборы данных
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].DisableControls;
          vSaveTables[I].Refresh; //Важный момент, если набор данных был отфильтрован
        end;
        //Сохраняем сеанс работы в файл
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].First;
          MemoMessages.Append(TimeToStr(Now())+' Сохранение таблицы: '+vSaveTables[I].Name);
          try
            //Проверяем константу для выбора способа сохранения/восстановления данных и загрузки сохраненного сеанса
            case cSaveRestore of
              0:vSaveTables[I].SaveToFile(vSaveTables[I].Name);
              1:SaveToCsv(vSaveTables[I]);
            end;
          except
            on E:Exception do begin
              MemoMessages.Append(TimeToStr(Now())+' Ошибка при сохранении таблицы: '+vSaveTables[I].Name +'. '+E.Message);
            end;
          end;
          MemoMessages.Append(TimeToStr(Now())+' Таблица: '+vSaveTables[I].Name+' сохранена.');
        end;
      finally
        vSuppressEvents:=False;
        //Обновляем все наборы данных и включаем элементы управления
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].Refresh; //Необходимо для таблиц, которые фильтруются
          vSaveTables[I].EnableControls;
        end;
         MemoMessages.Append(TimeToStr(Now())+' Все таблицы сохранены в файлы.');
      end;
    end;

procedure EmptyMemDataSet(DataSet:TMemDataSet);
    var
      vTemporaryMemDataSet:TMemDataSet;
      vFieldDef:TFieldDef;
      I:Integer;
    begin
      try
        //Создаем временный MemDataSet
        vTemporaryMemDataSet:=TMemDataSet.Create(nil);
        //Сохраняем FieldDefs во временном MemDataSet
        for I:=0 to DataSet.FieldDefs.Count-1 do begin
          vFieldDef:=vTemporaryMemDataSet.FieldDefs.AddFieldDef;
          with DataSet.FieldDefs[I] do begin
            vFieldDef.Name:=Name;
            vFieldDef.DataType:=DataType;
            vFieldDef.Size:=Size;
            vFieldDef.Required:=Required;
          end;
        end;
        //Очищаем существующие fielddefs
        DataSet.Clear;
        //Восстанавливаем fielddefs
        DataSet.FieldDefs:=vTemporaryMemDataSet.FieldDefs;
        DataSet.Active:=True;
      finally
      vTemporaryMemDataSet.Clear;
      vTemporaryMemDataSet.Free;
      end;
    end;

procedure LoadFromCsv(DataSet:TDataSet);
    var
      vFieldCount:Integer;
      I:Integer;
    begin
      try
        //Назначаем SdfDataSetTemporary
        with SdfDataSetTemporary do begin
          Active:=False;
          ClearFields;
          FileName:=DataSet.Name+'.txt';
          FirstLineAsSchema:=True;
          Active:=True;
          //Определяем количество полей
          vFieldCount:=FieldDefs.Count;
        end;
        //Выполняем итерацию по SdfDataSetTeditional и вставляем записи в MemDataSet.
        SdfDataSetTemporary.First;
        while not SdfDataSetTemporary.EOF do begin
          DataSet.Append;
          //Итерация по FieldDefs
          for I:=0 to vFieldCount-1 do begin
            try
              DataSet.Fields[I].Value:=SdfDataSetTemporary.Fields[I].Value;
            except
              on E:Exception do begin
                MemoMessages.Append(TimeToStr(Now())+' Ошибка при установке значения для поля: '
                 +DataSet.Name+'.'+DataSet.Fields[I].Name +'. '+E.Message);
              end;
            end;
          end;
          try
            DataSet.Post;
          except
            on E:Exception do begin
              MemoMessages.Append(TimeToStr(Now())+' Ошибка при сохранении записи в таблицу: '
               +DataSet.Name+'.'+E.Message);
            end;
          end;
          SdfDataSetTemporary.Next;
        end;
      finally
        SdfDataSetTemporary.Active:=False;
        SdfDataSetTemporary.ClearFields;
      end;
    end;

procedure SaveToCsv(DataSet:TDataSet);
    var
      myFileName:string;
      myTextFile: TextFile;
      i: integer;
      s: string;
    begin
      myFileName:=DataSet.Name+'.txt';
      //создаем новый файл
      AssignFile(myTextFile, myFileName);
      Rewrite(myTextFile);
      s := ''; //инициализируем пустую строку
      try
        //записываем имена полей (как заголовки столбцов)
        for i := 0 to DataSet.Fields.Count - 1 do
          begin
            s := s + Format('%s,', [DataSet.Fields[i].FieldName]);
          end;
        Writeln(myTextFile, s);
        DataSet.First;
        //записываем значения полей
        while not DataSet.Eof do
          begin
            s := '';
            for i := 0 to DataSet.FieldCount - 1 do
              begin
                //Числовые поля без кавычек, строковые поля с кавычками
                if ((DataSet.FieldDefs[i].DataType=ftInteger)
                 or (DataSet.FieldDefs[i].DataType=ftFloat)) then
                  s := s + Format('%s,', [DataSet.Fields[i].AsString])
                else
                  s := s + Format('"%s",', [DataSet.Fields[i].AsString]);
              end;
            Writeln(myTextfile, s);
            DataSet.Next;
          end;
      finally
        CloseFile(myTextFile);
      end;
    end;

var
      //Глобальные переменные, используемые для вычисления полей автогенератора первичного ключа MemDatasets
      vCurrentId:Integer=0;
      vProductsId:Integer=0;
      vBomsId:Integer=0;
      vBomCalculationProductsId:Integer=0;
      vBomCalculationComponentsId:Integer=0;
      vBomCalculationFooterId:Integer=0;
      vBomCalculationProductsMultipleId:Integer=0;
      vBomCalculationComponentsMultipleId:Integer=0;
      vBomCalculationFooterMultipleId:Integer=0;
      vStocksId:Integer=0;
      vOrdersId:Integer=0;
      vImportVariantsId:Integer=0;
      vImportToTablesId:Integer=0;
      vImportToFieldsId:Integer=0;
      vImportFromTablesId:Integer=0;
      vImportFromFieldsId:Integer=0;

procedure GetAutoincrementPrimaryFields;
    var
      I:Integer;
      vId:^Integer;
    begin
      try
        MemoMessages.Lines.Append(TimeToStr(Now())+' Получение информации о полях автогенератора');
        vSuppressEvents:=True;
        //Отключаем элементы управления и обновляем все наборы данных
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].DisableControls;
          vSaveTables[I].Refresh; //Важный момент, если набор данных был отфильтрован
        end;
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          with vSaveTables[I] do begin
            //Используем соответствующую глобальную переменную
            case StringToCaseSelect(Name,
              ['Products','Boms','Stocks','Orders',
                'BomCalculationProducts','BomCalculationComponents','BomCalculationFooter',
                'BomCalculationProductsMultiple','BomCalculationComponentsMultiple','BomCalculationFooterMultiple',
                'ImportVariants','ImportToTables','ImportToFields','ImportFromTables','ImportFromFields']) of
              0:vId:=@vProductsId;
              1:vId:=@vBomsId;
              2:vId:=@vStocksId;
              3:vId:=@vOrdersId;
              4:vId:=@vBomCalculationProductsId;
              5:vId:=@vBomCalculationComponentsId;
              6:vId:=@vBomCalculationFooterId;
              7:vId:=@vBomCalculationProductsMultipleId;
              8:vId:=@vBomCalculationComponentsMultipleId;
              9:vId:=@vBomCalculationFooterMultipleId;
              10:vId:=@vImportVariantsId;
              11:vId:=@vImportToTablesId;
              12:vId:=@vImportToFieldsId;
              13:vId:=@vImportFromTablesId;
              14:vId:=@vImportFromFieldsId;
            end;
            try
              //Находим последнее значение ID и сохраняем его в глобальной переменной
              Last;
              vCurrentId:=FieldByName(Name+'Id').AsInteger;
              if (vCurrentId>vId^) then vId^:=vCurrentId;
            finally
              //Удаляем ссылку
              vId:=nil;
            end;
          end;
        end;
      finally
        vSuppressEvents:=False;
        //Обновляем все наборы данных и включаем элементы управления
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].Refresh;
          vSaveTables[I].EnableControls;
        end;
         MemoMessages.Lines.Append(TimeToStr(Now())+' Автоинкрементные поля - готовы.');
      end;
    end;

function StringToCaseSelect(Selector:string;CaseList:array of string):Integer;
    var 
      cnt: integer;
    begin
      Result:=-1;
      for cnt:=0 to Length(CaseList)-1 do
      begin
        if CompareText(Selector, CaseList[cnt]) = 0 then
        begin
          Result:=cnt;
          Break;
        end;
      end;
    end;

procedure TMainForm.OrdersNewRecord(DataSet: TDataSet);
    begin
      if vSuppressEvents then Exit;
      //Устанавливаем новое значение автогенератора
      vOrdersId:=vOrdersId+1;
      DataSet.FieldByName('OrdersId').AsInteger:=vOrdersId;
    end;

procedure TMainForm.MasterTableBeforeDelete(DataSet: TDataSet);
    begin
      if vSuppressEvents then Exit;
      try
        DetailTable.DisableControls;
        // Принудительное удаление ссылок («каскадное удаление») для таблицы «MasterTable»
        while not DetailTable.EOF do begin
          DetailTable.Delete;
        end;
        DetailTable.Refresh;
      finally
        DetailTable.EnableControls;
      end;
    end;

procedure TMainForm.DetailTableBeforePost(DataSet: TDataSet);
    begin
      if vSuppressEvents=True then Exit;
      // Принудительное использование ссылочной вставки/обновления для таблицы «DetailTable» с 
      // внешним ключом «MasterTableID», ссылающимся на 
      // поле первичного ключа идентификатора MasterTable ID
      DataSet.FieldByName('MasterTableId').AsInteger:=
        MasterTable.FieldByName('ID').AsInteger;
    end;

procedure TMainForm.MasterTableAfterScroll(DataSet: TDataSet);
    begin
      if vSuppressEvents=True then Exit;
      DetailTable.Refresh;
    end;

procedure TMainForm.DetailTableFilterRecord(DataSet: TDataSet;
      var Accept: Boolean);
    begin
      if vSuppressEvents=True then Exit;
      // Показывем только дочерние поля, внешний ключ которых указывает на текущую 
      // запись master таблицы
      Accept:=DataSet.FieldByName('MasterTableId').AsInteger=
        MasterTable.FieldByName('ID').AsInteger;
    end;

Uses
      BufDataset, typinfo;
    
    function SortBufDataSet(DataSet: TBufDataSet;const FieldName: String): Boolean;
    var
      i: Integer;
      IndexDefs: TIndexDefs;
      IndexName: String;
      IndexOptions: TIndexOptions;
      Field: TField;
    begin
      Result := False;
      Field := DataSet.Fields.FindField(FieldName);
      //Если неверное имя поля, выйдем.
      if Field = nil then Exit;
      //Если неверный тип поля, выйдем.
      if {(Field is TObjectField) or} (Field is TBlobField) or
        {(Field is TAggregateField) or} (Field is TVariantField)
         or (Field is TBinaryField) then Exit;
      //Получаем IndexDefs и IndexName, используя RTTI
      if IsPublishedProp(DataSet, 'IndexDefs') then
        IndexDefs := GetObjectProp(DataSet, 'IndexDefs') as TIndexDefs
      else
        Exit;
      if IsPublishedProp(DataSet, 'IndexName') then
        IndexName := GetStrProp(DataSet, 'IndexName')
      else
        Exit;
      //Убедитесь, что IndexDefs об-нов-лен
      IndexDefs.Updated:=false; {<<<<---Эта строка имеет решающее значение, так как IndexDefs.Update ничего не будет делать при следующей сортировке, если она уже верна}
      IndexDefs.Update;
      //Если восходящий индекс уже используется, 
      //переключаемся на нисходящий индекс
      if IndexName = FieldName + '__IdxA'
      then
        begin
          IndexName := FieldName + '__IdxD';
          IndexOptions := [ixDescending];
        end
      else
        begin
          IndexName := FieldName + '__IdxA';
          IndexOptions := [];
        end;
      //ищем существующий индекс
      for i := 0 to Pred(IndexDefs.Count) do
      begin
        if IndexDefs[i].Name = IndexName then
          begin
            Result := True;
            Break
          end;  //if
      end; // for
      //Если существующий индекс не найден, создаем его
      if not Result then
          begin
            if IndexName=FieldName + '__IdxD' then
              DataSet.AddIndex(IndexName, FieldName, IndexOptions, FieldName)
            else
              DataSet.AddIndex(IndexName, FieldName, IndexOptions);
            Result := True;
          end; // if not
      //Устанавливаем индекс
      SetStrProp(DataSet, 'IndexName', IndexName);
    end;

procedure TFormMain.DBGridProductsTitleClick(Column: TColumn);
    begin
      SortBufDataSet(Products, Column.FieldName);
    end;

{ TDBGridHelper }
    
      TDBGridHelper = class helper for TDBGrid
      public const
        cMaxColCOunt = 3;
      private
        procedure Interbal_MakeNames(Fields: TStrings; out FieldsList, DescFields: String);
        procedure Internal_SetColumnsIcons(Fields: TStrings; AscIdx, DescIdx: Integer);
        function Internal_IndexNameExists(IndexDefs: TIndexDefs; IndexName: String): Boolean;
      public
        procedure Sort(const FieldName: String; AscIdx: Integer = -1; DescIdx: Integer = -1);
        procedure ClearSort;
      end;  
    
    { TDBGridHelper }
    
    procedure TDBGridHelper.Interbal_MakeNames(Fields: TStrings; out FieldsList, DescFields: String);
    var
      FldList: TStringList;
      DscList: TStringList;
      FldDesc, FldName: String;
      i: Integer;
    begin
      if Fields.Count = 0 then
      begin
        FieldsList := '';
        DescFields := '';
        Exit;
      end;
    
      FldList := TStringList.Create;
      DscList := TStringList.Create;
      try
        FldList.Delimiter := ';';
        DscList.Delimiter := ';';
    
        for i := 0 to Fields.Count - 1 do
        begin
          Fields.GetNameValue(i, FldName, FldDesc);
          FldList.Add(FldName);
    
          if FldDesc = 'D' then
            DscList.Add(FldName);
        end;
    
        FieldsList := FldList.DelimitedText;
        DescFields := DscList.DelimitedText;
      finally
        FldList.Free;
        DscList.Free;
      end;
    end;
    
    procedure TDBGridHelper.Internal_SetColumnsIcons(Fields: TStrings; AscIdx, DescIdx: Integer);
    var
      i: Integer;
      FldDesc: String;
    begin
      for i := 0 to Self.Columns.Count - 1 do
      begin
        FldDesc := Fields.Values[Self.Columns[i].Field.FieldName];
    
        if FldDesc = 'A' then
          Self.Columns[i].Title.ImageIndex := AscIdx
        else
        if FldDesc = 'D' then
          Self.Columns[i].Title.ImageIndex := DescIdx
        else
          Self.Columns[i].Title.ImageIndex := -1
      end;
    end;
    
    function TDBGridHelper.Internal_IndexNameExists(IndexDefs: TIndexDefs; IndexName: String): Boolean;
    var
      i: Integer;
    begin
      for i := 0 to IndexDefs.Count - 1 do
      begin
        if IndexDefs[i].Name = IndexName then
          Exit(True)
      end;
    
      Result := False
    end;
    
    procedure TDBGridHelper.Sort(const FieldName: String; AscIdx: Integer;
      DescIdx: Integer);
    var
      Field: TField;
      DataSet: TBufDataset;
      IndexDefs: TIndexDefs;
      IndexName, Dir, DescFields, FieldsList: String;
      Fields: TStringList;
    begin
      if not Assigned(DataSource.DataSet) or
         not DataSource.DataSet.Active or
         not (DataSource.DataSet is TBufDataset) then
        Exit;
      DataSet := DataSource.DataSet as TBufDataset;
    
      Field := DataSet.FieldByName(FieldName);
      if (Field is TBlobField) or (Field is TVariantField) or (Field is TBinaryField) then
        Exit;
    
      IndexDefs := DataSet.IndexDefs;
      IndexName := DataSet.IndexName;
    
      if not IndexDefs.Updated then
        IndexDefs.Update;
    
      Fields := TStringList.Create;
      try
        Fields.DelimitedText := IndexName;
        Dir := Fields.Values[FieldName];
    
        if Dir = 'A' then
          Dir := 'D'
        else
        if Dir = 'D' then
          Dir := 'A'
        else
          Dir := 'A';
    
        //Если нажата клавиша Shift, добавляем поле в список полей.
        if ssShift in GetKeyShiftState then
        begin
          Fields.Values[FieldName] := Dir;
          //Мы не добавляем в сортировку больше полей, если общее количество полей превышает cMaxColCOunt
          if Fields.Count > cMaxColCOunt then
            Exit;
        end
        else
        begin
          Fields.Clear;
          Fields.Values[FieldName] := Dir;
        end;
    
        IndexName := Fields.DelimitedText;
        if not Internal_IndexNameExists(IndexDefs, IndexName) then
        begin
          Interbal_MakeNames(Fields, FieldsList, DescFields);
          TBufDataset(DataSet).AddIndex(IndexName, FieldsList, [], DescFields, '');
        end;
    
        DataSet.IndexName := IndexName;
        Internal_SetColumnsIcons(Fields, AscIdx, DescIdx)
      finally
        Fields.Free;
      end;
    end;
    
    procedure TDBGridHelper.ClearSort;
    var
      DataSet: TBufDataset;
      Fields: TStringList;
    begin
      if not Assigned(DataSource.DataSet) or
         not DataSource.DataSet.Active or
         not (DataSource.DataSet is TBufDataset) then
        Exit;
      DataSet := DataSource.DataSet as TBufDataset;
    
      DataSet.IndexName := '';
    
      Fields := TStringList.Create;
      try
        Internal_SetColumnsIcons(Fields, -1, -1)
      finally
        Fields.Free
      end
    end;

procedure TForm1.grdCountriesCellClick(Column: TColumn);
    begin
      if not Assigned(Column) then
        grdCountries.ClearSort
    end;
    
    procedure TForm1.grdCountriesTitleClick(Column: TColumn);
    begin
      grdCountries.Sort(Column.Field.FieldName, 0, 1);
    end;