udbprovider.pas

千年源代码,只缺少控件,可以做二次开发用,好不容易得来的

unit uDBProvider;

interface

uses
   Windows, Classes, SysUtils, StdCtrls, ComCtrls, mmSystem, uRecordDef,
   uUtil, DefType;

type

   TIndexData = record
      Name : String [32];
      RecordNo : Integer;
   end;
   PTIndexData = ^TIndexData;
   TBlankData = record
      RecordNo : Integer;
   end;
   PTBlankData = ^TBlankData;

   TIndexClass = class
   private
      Header : TIndexHeader;
      RecordBuffer : TIndexData;
      
      DataList : TList;
      LastErrorStr : String;

      function GetCount : Integer;
   public
      constructor Create;
      destructor Destroy; override;

      procedure Clear;
      procedure Sort;

      function LoadFromFile (aFileName : String; var aBlankList : TList) : Boolean;
      function SaveToFile (aFileName : String; var aBlankList : TList) : Boolean;

      function Add (aName : String; aRecordNo : Integer) : Byte;
      function Delete (aName : String) : Byte;
      function Select (aName : String) : Integer;
      function SelectByIndex (aIndex : Integer) : Integer;

      function Insert (aName : String; aRecordNo : Integer) : Byte;
      function GetInsertPos (aName : String) : Integer;

      procedure Print (aControl : TMemo);

      property GetLastErrorStr : String read LastErrorStr;
      property Count : Integer read GetCount;
   end;

   TDBProvider = class
   private
      FileName : String;
      DBStream : TFileStream;
      Header : TDBHeader;
      RecordBuffer : TDBRecord;

      IndexClass : TIndexClass;
      BlankList : TList;

      PrintControl : TMemo;

      LastErrorStr : String;

      function GetTotalRecordCount : Integer;
      function GetUsedRecordCount : Integer;
      function GetUnusedRecordCount : Integer;
   public
      constructor Create (aFileName : String);
      destructor Destroy; override;

      function CreateDB : Boolean;
      function OpenDB : Boolean;
      function CloseDB : Boolean;

      function AddBlankRecord (aCount : Integer) : Boolean;

      procedure Clear;

      function SelectDisk (aIndexName : String; aDBRecord : PTDBRecord) : Byte;
      function UpdateDisk (aIndexName : String; aDBRecord : PTDBRecord) : Byte;

      function Select (aIndexName : String; aDBRecord : PTDBRecord) : Byte;
      function Insert (aIndexName : String; aDBRecord : PTDBRecord) : Byte;
      function Delete (aIndexName : String) : Byte;
      function Update (aIndexName : String; aDBRecord : PTDBRecord) : Byte;

      function ChangeDataToStr (aDBRecord : PTDBRecord) : String;
      procedure ChangeStrToData (aStr : String; var DBRecord : TDBRecord);

      procedure SetPrintControl (aMemo : TMemo);
      procedure ShowInfo (aStr : String);

      procedure BackupHeader (aStream : TFileStream);
      function BackupRecord (aStream : TFileStream; aIndex : Integer) : Boolean;

      property TotalRecordCount : Integer read GetTotalRecordCount;
      property UsedRecordCount : Integer read GetUsedRecordCount;
      property UnusedRecordCount : Integer read GetUnusedRecordCount;
   end;

   function IndexSortCompare (Item1, Item2: Pointer): Integer;

var
   DBProvider : TDBProvider = nil;

implementation

uses
   FMain;

function IndexSortCompare (Item1, Item2: Pointer): Integer;
var
   pd1, pd2 : PTIndexData;
begin
   Result := 0;
   
   pd1 := PTIndexData (Item1);
   pd2 := PTIndexData (Item2);

   if pd1^.Name > pd2^.Name then begin
      Result := 1;
   end else if pd1^.Name < pd2^.Name then begin
      Result := -1;
   end;
end;

// TIndexClass

constructor TIndexClass.Create;
begin
   LastErrorStr := '';

   FillChar (Header, SizeOf (TIndexHeader), 0);
   FillChar (RecordBuffer, SizeOf (TIndexData), 0);
   DataList := TList.Create;
end;

destructor TIndexClass.Destroy;
begin
   Clear;
   DataList.Free;

   inherited Destroy;
end;

procedure TIndexClass.Clear;
var
   i : Integer;
   pd : PTIndexData;
begin
   for i := 0 to DataList.Count - 1 do begin
      pd := DataList.Items [i];
      if pd <> nil then Dispose (pd);
   end;
   DataList.Clear;
end;

function TIndexClass.GetCount : Integer;
begin
   Result := DataList.Count;
end;

procedure TIndexClass.Sort;
begin
   DataList.Sort (IndexSortCompare);
end;

function TIndexClass.LoadFromFile (aFileName : String; var aBlankList : TList) : Boolean;
var
   i : Integer;
   nCode : byte;
   nCount : Integer;
   Stream : TFileStream;

   IndexData : TIndexData;
   BlankData : TBlankData;
   pd : PTBlankData;
begin
   Result := false;

   if not FileExists (aFileName) then exit;

   Stream := nil;
   try
      Stream := TFileStream.Create (aFileName, fmOpenReadWrite);
      Stream.ReadBuffer (Header, SizeOf (TIndexHeader));
   except
      if Stream <> nil then Stream.Free;
      exit;
   end;

   Header.ID[3] := 0;
   if StrPas (@Header.ID) <> IndexID then begin
      Stream.Free;
      exit;
   end;

   try
      nCount := 0;
      for i := 0 to Header.IndexRecordCount - 1 do begin
         Stream.ReadBuffer (IndexData, SizeOf (TIndexData));
         nCode := Add (IndexData.Name, IndexData.RecordNo);
         if nCode <> DB_OK then break;
         nCount := nCount + 1;
      end;
      Header.IndexRecordCount := nCount;

      nCount := 0;
      for i := 0 to Header.BlankRecordCount - 1 do begin
         Stream.ReadBuffer (BlankData, SizeOf (TBlankData));
         New (pd);
         pd^.RecordNo := i;
         aBlankList.Add (pd);
         nCount := nCount + 1;
      end;
      Header.BlankRecordCount := nCount;
   except
      if Stream <> nil then Stream.Free;
      exit;
   end;
   Stream.Free;

   Result := true;
end;

function TIndexClass.SaveToFile (aFileName : String; var aBlankList : TList) : Boolean;
var
   i : Integer;
   Stream : TFileStream;

   pid : PTIndexData;
   pbd : PTBlankData;
begin
   Result := false;

   if FileExists (aFileName) then DeleteFile (aFileName);

   StrPCopy (@Header.ID, IndexID);
   Header.IndexRecordCount := DataList.Count;
   Header.BlankRecordCount := aBlankList.Count;

   Stream := nil;
   try
      Stream := TFileStream.Create (aFileName, fmCreate);
      Stream.WriteBuffer (Header, SizeOf (TIndexHeader));
   except
      if Stream <> nil then Stream.Free;
      exit;
   end;
   
   try
      for i := 0 to Header.IndexRecordCount - 1 do begin
         pid := DataList.Items [i];
         Stream.WriteBuffer (pid^, SizeOf (TIndexData));
      end;
      for i := 0 to Header.BlankRecordCount - 1 do begin
         pbd := aBlankList.Items [i];
         Stream.WriteBuffer (pbd^, SizeOf (TBlankData));
      end;
   except
      if Stream <> nil then Stream.Free;
      exit;
   end;

   Stream.Free;
   Result := true;

end;

procedure TIndexClass.Print (aControl : TMemo);
var
   i : Integer;
   pd : PTIndexData;
begin
   for i := 0 to DataList.Count - 1 do begin
      pd := DataList.Items [i];
      aControl.Lines.Add (pd^.Name);
   end;
end;

function TIndexClass.Add (aName : String; aRecordNo : Integer) : Byte;
var
   nPos : Integer;
   pd : PTIndexData;
begin
   Result := DB_OK;

   if aName = '' then begin
      LastErrorStr := 'Invalid Name';
      Result := DB_ERR_INVALIDDATA;
      exit;
   end;

   nPos := Select (aName);
   if nPos >= 0 then begin
      LastErrorStr := 'Invalid Key (same key is already being)';
      Result := DB_ERR_DUPLICATE;
      exit;
   end;

   New (pd);
   pd^.Name := aName;
   pd^.RecordNo := aRecordNo;
   DataList.Add (pd);
end;

function TIndexClass.Insert (aName : String; aRecordNo : Integer) : Byte;
var
   nPos : Integer;
   pd : PTIndexData;
   i : Integer;
begin
   Result := DB_OK;

   if aName = '' then begin
      LastErrorStr := 'Invalid Name';
      Result := DB_ERR_INVALIDDATA;
      exit;
   end;

   nPos := Select (aName);
   if nPos >= 0 then begin
      LastErrorStr := 'Invalid Key (same key is already being)';
      Result := DB_ERR_DUPLICATE;
      exit;
   end;

   New (pd);
   pd^.Name := aName;
   pd^.RecordNo := aRecordNo;

   nPos := GetInsertPos (aName);
   if nPos < 0 then begin
      Result := DB_ERR_DUPLICATE;
      exit;
   end;

   DataList.Insert (nPos, pd);

   {
   for i := 0 to DataList.Count - 1 do begin
      pd := DataList.Items[i];
      frmMain.AddLog (pd^.Name);
   end;
   }
end;

function TIndexClass.Delete (aName : String) : Byte;
var
   nPos : Integer;
   pd : PTIndexData;
begin
   Result := DB_OK;

   nPos := Select (aName);
   if nPos < 0 then begin
      Result := DB_ERR_NOTFOUND;
      exit;
   end;

   pd := DataList.Items [nPos];
   Dispose (pd);

   DataList.Delete (nPos);
end;

function TIndexClass.Select (aName : String) : Integer;
var
   HighPos, LowPos, MidPos : Integer;
   pd : PTIndexData;
begin
   Result := -1;

   LowPos := 0;
   HighPos := DataList.Count - 1;
   MidPos := (LowPos + HighPos) div 2;

   while LowPos <= HighPos do begin
      pd := DataList.Items [MidPos];
      if pd^.Name = aName then begin
         Result := pd^.RecordNo;
         exit;
      end else if pd^.Name > aName then begin
         HighPos := MidPos - 1;
      end else begin
         LowPos := MidPos + 1;
      end;
      MidPos := (LowPos + HighPos) div 2;
   end;
end;

function TIndexClass.SelectByIndex (aIndex : Integer) : Integer;
var
   pd : PTIndexData;
begin
   Result := -1;
   if aIndex >= DataList.Count then exit;

   pd := DataList.Items [aIndex];
   
   Result := pd^.RecordNo;
end;

function TIndexClass.GetInsertPos (aName : String) : Integer;
var
   HighPos, LowPos, MidPos : Integer;
   pd : PTIndexData;
begin
   Result := -1;

   LowPos := 0;
   HighPos := DataList.Count - 1;
   MidPos := (LowPos + HighPos) div 2;

   while LowPos <= HighPos do begin
      pd := DataList.Items [MidPos];
      if pd^.Name = aName then begin
         exit;
      end else if pd^.Name > aName then begin
         HighPos := MidPos - 1;
      end else begin
         LowPos := MidPos + 1;
      end;
      MidPos := (LowPos + HighPos) div 2;
   end;

   if HighPos >= 0 then MidPos := MidPos + 1;
   
   Result := MidPos;
end;

// TDBProvider
constructor TDBProvider.Create (aFileName : String);
begin
   FileName := aFileName;
   DBStream := nil;
   FillChar (Header, sizeof (TDBHeader), 0);
   IndexClass := nil;
   BlankList := nil;
   LastErrorStr := '';

   PrintControl := nil;
end;

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

function TDBProvider.GetTotalRecordCount : Integer;
begin
   Result := Header.RecordCount;
end;

function TDBProvider.GetUsedRecordCount : Integer;
begin
   Result := IndexClass.Count;
end;

function TDBProvider.GetUnusedRecordCount : Integer;
begin
   Result := BlankList.Count;
end;

function TDBProvider.CreateDB : Boolean;
begin
   Result := false;

   Clear;

   if FileExists (FileName) then exit;

   ShowInfo (format ('%s creating...', [FileName]));

   try
      FillChar (Header, SizeOf (TDBHeader), 0);
      StrPCopy (@Header.ID, 'DBID');
      Header.RecordCount := 0;
      Header.RecordDataSize := SizeOf (TDBRecord) - 1;
      Header.RecordFullSize := SizeOf (TDBRecord);
      Header.boSavedIndex := FALSE;
      DBStream := TFileStream.Create (FileName, fmCreate);
      DBStream.WriteBuffer (Header, sizeof (TDBHeader));
      DBStream.Free;
      DBStream := nil;
   except
      exit;
   end;
   
   ShowInfo ('completed');
   Result := true;
end;

function TDBProvider.AddBlankRecord (aCount : Integer) : Boolean;
var
   i : Integer;
   pd : PTBlankData;
begin
   Result := false;
   if DBStream = nil then exit;

   try
      DBStream.Seek (SizeOf (TDBHeader) + Header.RecordCount * Header.RecordFullSize, soFromBeginning);
      
      FillChar (RecordBuffer, SizeOf (TDBRecord), 0);