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

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

type
      TSaveTables=array[1..15] of TMemDataset;    
    var
      //Global variable that holds tables for saving/restoring session
      vSaveTables:TSaveTables;                  
      //Suppress events flag variables. Used during data loading from files.
      vSuppressEvents:Boolean;

const
      //Constant cSaveRestore determines the way for saving and restoring of MemDatasets to persistent files
      cSaveRestore=0; //0=MemDataset native way, 1=saving and restoring from CSV

procedure TMainForm.FormCreate(Sender: TObject);
    begin
      //List of tables to be saved/restored for a session
      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;
      //Restore session
      RestoreSession;
      GetAutoincrementPrimaryFields;
    end;

procedure TMainForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
    begin
     //Save memdatasets to files (to save current session)
     SaveSession;
    end;

procedure RestoreSession;
    var
      I:Integer;
    begin
      try
        MemoMessages.Append(TimeToStr(Now())+' Starting restoration of previously saved session.');
        vSuppressEvents:=True; //Supress events used for referential integrity enforcing
        //Disable controls and refresh all datasets
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].DisableControls;
          vSaveTables[I].Refresh; //Important if dataset was filtered
        end;
        //Load memdatasets from files (to restore previous session)
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].First;
          MemoMessages.Append(TimeToStr(Now())+' Starting restoration of table: '+vSaveTables[I].Name);
          try
            //If data is loaded from a csv file, then table must be deleted first.
            if cSaveRestore=1 then begin
              MemoMessages.Append(TimeToStr(Now())+' Starting delete of all records in table: '+vSaveTables[I].Name);
              //This way of deleting all records is incredibly slow.
              {while not vSaveTables[I].EOF do begin
                vSaveTables[I].Delete;
              end;}
              //This method for deleting of all records is much faster
              EmptyMemDataSet(vSaveTables[I]);
              MemoMessages.Append(TimeToStr(Now())+' All records from table: '+vSaveTables[I].Name+' deleted.');
            end;
          except
            on E:Exception do begin
              MemoMessages.Append(TimeToStr(Now())+' Error while deleteing records from table: '+vSaveTables[I].Name +'. '+E.Message);
            end;
          end;
          try
            try
              MemoMessages.Append(TimeToStr(Now())+' Restoring table: '+vSaveTables[I].Name);
              //Check constant for way of saving/restoring data and load saved session
              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())+' Error while restoring table: '+vSaveTables[I].Name +'. '+E.Message);
              end;
            end;
          finally
            vSaveTables[I].Active:=True;//Needed because of LoadFromFile method....
          end;
          MemoMessages.Append(TimeToStr(Now())+' Table: '+vSaveTables[I].Name+' restored.');
        end;
      finally
        vSuppressEvents:=False;
        //Refresh all datasets  and enable controls
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].Refresh; //Needed for tables that are filtered.
          vSaveTables[I].EnableControls;
        end;
         MemoMessages.Append(TimeToStr(Now())+' All tables restored from saved files.');
      end;
    end;

procedure SaveSession;
    var
      I:Integer;
    begin
      try
        MemoMessages.Append(TimeToStr(Now())+' Starting saving session to persistent files.');
        vSuppressEvents:=True;
        //Disable controls and refresh all datasets
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].DisableControls;
          vSaveTables[I].Refresh; //Important if dataset was filtered
        end;
        //Save session to file
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].First;
          MemoMessages.Append(TimeToStr(Now())+' Saving table: '+vSaveTables[I].Name);
          try
            //Check constant for way of saving/restoring data and save session
            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())+' Error while saving table: '+vSaveTables[I].Name +'. '+E.Message);
            end;
          end;
          MemoMessages.Append(TimeToStr(Now())+' Table: '+vSaveTables[I].Name+' saved.');
        end;
      finally
        vSuppressEvents:=False;
        //Refresh all datasets  and enable controls
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].Refresh; //Needed for tables that are filtered
          vSaveTables[I].EnableControls;
        end;
         MemoMessages.Append(TimeToStr(Now())+' All tables saved to files.');
      end;
    end;

procedure EmptyMemDataSet(DataSet:TMemDataSet);
    var
      vTemporaryMemDataSet:TMemDataSet;
      vFieldDef:TFieldDef;
      I:Integer;
    begin
      try
        //Create temporary MemDataSet
        vTemporaryMemDataSet:=TMemDataSet.Create(nil);
        //Store FieldDefs to Temporary 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;
        //Clear existing fielddefs
        DataSet.Clear;
        //Restore 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
        //Assign SdfDataSetTemporary
        with SdfDataSetTemporary do begin
          Active:=False;
          ClearFields;
          FileName:=DataSet.Name+'.txt';
          FirstLineAsSchema:=True;
          Active:=True;
          //Determine number of fields
          vFieldCount:=FieldDefs.Count;
        end;
        //Iterate through SdfDataSetTemporary and insert records into MemDataSet
        SdfDataSetTemporary.First;
        while not SdfDataSetTemporary.EOF do begin
          DataSet.Append;
          //Iterate through 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())+' Error while setting value for field: '
                 +DataSet.Name+'.'+DataSet.Fields[I].Name +'. '+E.Message);
              end;
            end;
          end;
          try
            DataSet.Post;
          except
            on E:Exception do begin
              MemoMessages.Append(TimeToStr(Now())+' Error while posting record to table: '
               +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';
      //create a new file
      AssignFile(myTextFile, myFileName);
      Rewrite(myTextFile);
      s := ''; //initialize empty string
      try
        //write field names (as column headers)
        for i := 0 to DataSet.Fields.Count - 1 do
          begin
            s := s + Format('%s,', [DataSet.Fields[i].FieldName]);
          end;
        Writeln(myTextFile, s);
        DataSet.First;
        //write field values
        while not DataSet.Eof do
          begin
            s := '';
            for i := 0 to DataSet.FieldCount - 1 do
              begin
                //Numerical fields without quotes, string fields with quotes
                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
      //Global variables used for calculation of autoincrement primary key fields of 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())+' Getting information about autoincrement fields');
        vSuppressEvents:=True;
        //Disable controls and refresh all datasets
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].DisableControls;
          vSaveTables[I].Refresh; //Important if dataset was filtered
        end;
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          with vSaveTables[I] do begin
            //Use appropriate global variable
            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
              //Find last value of Id and save it to global variable
              Last;
              vCurrentId:=FieldByName(Name+'Id').AsInteger;
              if (vCurrentId>vId^) then vId^:=vCurrentId;
            finally
              //Remove reference;
              vId:=nil;
            end;
          end;
        end;
      finally
        vSuppressEvents:=False;
        //Refresh all datasets  and enable controls
        for I:=Low(vSaveTables) to High(vSaveTables) do begin
          vSaveTables[I].Refresh;
          vSaveTables[I].EnableControls;
        end;
         MemoMessages.Lines.Append(TimeToStr(Now())+' Autoincrement fields - done.');
      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=True then Exit;
      //Set new autoincrement value
      vOrdersId:=vOrdersId+1;
      DataSet.FieldByName('OrdersId').AsInteger:=vOrdersId;
    end;

procedure TMainForm.MasterTableBeforeDelete(DataSet: TDataSet);
    begin
      if vSuppressEvents=True then Exit;
      try
        DetailTable.DisableControls;
        // Enforce referential delete ("cascade delete") for table "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;
      // Enforce referential insert/update for table "DetailTable" with
      // foreign key "MasterTableID" linking to
      // the MasterTable ID primary key field
      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;
      // Show only child fields whose foreign key points to current
      // master table record
      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 invalid field name, exit.
      if Field = nil then Exit;
      //if invalid field type, exit.
      if {(Field is TObjectField) or} (Field is TBlobField) or
        {(Field is TAggregateField) or} (Field is TVariantField)
         or (Field is TBinaryField) then Exit;
      //Get IndexDefs and IndexName using 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;
      //Ensure IndexDefs is up-to-date
      IndexDefs.Updated:=false; {<<<<---This line is critical as IndexDefs.Update will do nothing on the next sort if it's already true}
      IndexDefs.Update;
      //If an ascending index is already in use,
      //switch to a descending index
      if IndexName = FieldName + '__IdxA'
      then
        begin
          IndexName := FieldName + '__IdxD';
          IndexOptions := [ixDescending];
        end
      else
        begin
          IndexName := FieldName + '__IdxA';
          IndexOptions := [];
        end;
      //Look for existing index
      for i := 0 to Pred(IndexDefs.Count) do
      begin
        if IndexDefs[i].Name = IndexName then
          begin
            Result := True;
            Break
          end;  //if
      end; // for
      //If existing index not found, create one
      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
      //Set the index
      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 Internal_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.Internal_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';
    
        //If shift is presed then add field to field list
        if ssShift in GetKeyShiftState then
        begin
          Fields.Values[FieldName] := Dir;
          //We do not add to sor any more field if total field count exids 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;