unit Filedata;
interface
uses Windows, Db, Classes;
type
// Bookmark information record to support TDataset bookmarks:
PDDGBookmarkInfo = ^TDDGBookmarkInfo;
TDDGBookmarkInfo = record
BookmarkData: Integer;
BookmarkFlag: TBookmarkFlag;
end;
// List used to maintain access to file of record:
TIndexList = class(TList)
public
procedure LoadFromFile(const FileName: string); virtual;
procedure LoadFromStream(Stream: TStream); virtual;
procedure SaveToFile(const FileName: string); virtual;
procedure SaveToStream(Stream: TStream); virtual;
end;
// Specialized DDG TDataset descendant for our "table" data:
TFiledata = class(TDataSet)
private
function GetDataFileSize: Integer;
//获取指定字段大小
function fdGetFieldSize(FieldNo:integer):integer;
//获取字段偏移量
function fdGetFieldOffset(FieldNo:integer):integer;
public
FDataFile: File;
FIdxName: string;
FIndexList: TIndexList;
FTableName: string;
FRecordPos: Integer;
FRecordSize: Integer;
FBufferSize: Integer;
procedure SetTableName(const Value: string);
protected
{ Mandatory overrides }
// Record buffer methods:
function AllocRecordBuffer: PChar; override;
procedure FreeRecordBuffer(var Buffer: PChar); override;
procedure InternalInitRecord(Buffer: PChar); override;
function GetRecord(Buffer: PChar; GetMode: TGetMode;
DoCheck: Boolean): TGetResult; override;
function GetRecordSize: Word; override;
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
// Bookmark methods:
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
procedure InternalGotoBookmark(Bookmark: Pointer); override;
procedure InternalSetToRecord(Buffer: PChar); override;
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
// Navigational methods:
procedure InternalFirst; override;
procedure InternalLast; override;
// Editing methods:
procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
procedure InternalDelete; override;
procedure InternalPost; override;
// Misc methods:
procedure InternalClose; override;
procedure InternalHandleException; override;
procedure InternalInitFieldDefs; override;
procedure InternalOpen; override;
function IsCursorOpen: Boolean; override;
{ Optional overrides }
function GetRecordCount: Integer; override;
function GetRecNo: Integer; override;
procedure SetRecNo(Value: Integer); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
// Additional procedures
procedure EmptyTable;
published
property Active;
property TableName: string read FTableName write SetTableName;
property BeforeOpen;
property AfterOpen;
property BeforeClose;
property AfterClose;
property BeforeInsert;
property AfterInsert;
property BeforeEdit;
property AfterEdit;
property BeforePost;
property AfterPost;
property BeforeCancel;
property AfterCancel;
property BeforeDelete;
property AfterDelete;
property BeforeScroll;
property AfterScroll;
property OnDeleteError;
property OnEditError;
// Additional Properties
property DataFileSize: Integer read GetDataFileSize;
end;
//procedure Register;
implementation
uses BDE, DBTables, SysUtils, DBConsts, Forms, Controls, Dialogs;
const
feDDGTable = '.ddg';
feDDGIndex = '.ddx';
// note that file is not being locked!
{ TIndexList }
procedure TIndexList.LoadFromFile(const FileName: string);
var
F: TFileStream;
begin
F := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(F);
finally
F.Free;
end;
end;
procedure TIndexList.LoadFromStream(Stream: TStream);
var
Value: Integer;
begin
while Stream.Position < Stream.Size do
begin
Stream.Read(Value, SizeOf(Value));
Add(Pointer(Value));
end;
// ShowMessage(IntToStr(Count));
end;
procedure TIndexList.SaveToFile(const FileName: string);
var
F: TFileStream;
begin
F := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
try
SaveToStream(F);
finally
F.Free;
end;
end;
procedure TIndexList.SaveToStream(Stream: TStream);
var
i: Integer;
Value: Integer;
begin
for i := 0 to Count - 1 do
begin
Value := Integer(Items);
Stream.Write(Value, SizeOf(Value));
end;
end;
{ TDDGDataSet }
constructor TFiledata.Create(AOwner: TComponent);
begin
FIndexList := TIndexList.Create;
FRecordSize := 0;
FBufferSize := 0;
inherited Create(AOwner);
end;
destructor TFiledata.Destroy;
begin
inherited Destroy;
FIndexList.Free;
end;
function TFiledata.AllocRecordBuffer: PChar;
begin
Result := AllocMem(FBufferSize);
end;
procedure TFiledata.FreeRecordBuffer(var Buffer: PChar);
begin
FreeMem(Buffer);
end;
procedure TFiledata.InternalInitRecord(Buffer: PChar);
begin
FillChar(Buffer^, FBufferSize, 0);
end;
function TFiledata.GetRecord(Buffer: PChar; GetMode: TGetMode;
DoCheck: Boolean): TGetResult;
var
IndexPos: Integer;
begin
if FIndexList.Count < 1 then
Result := grEOF
else begin
Result := grOk;
case GetMode of
gmPrior:
if FRecordPos <= 0 then
begin
Result := grBOF;
FRecordPos := -1;
end
else
Dec(FRecordPos);
gmCurrent:
if (FRecordPos < 0) or (FRecordPos >= RecordCount) then
Result := grError;
gmNext:
if FRecordPos >= RecordCount-1 then
Result := grEOF
else
Inc(FRecordPos);
end;
if Result = grOk then
begin
IndexPos := Integer(FIndexList[FRecordPos]);
Seek(FDataFile, IndexPos * FRecordSize);
BlockRead(FDataFile, (Buffer)^, FRecordsize);
with PDDGBookmarkInfo(Buffer + FRecordSize)^ do
begin
BookmarkData := FRecordPos;
BookmarkFlag := bfCurrent;
end;
end
else if (Result = grError) and DoCheck then
DatabaseError('No records');
end;
end;
function TFiledata.GetRecordSize: Word;
begin
Result := FRecordSize;
end;
function TFiledata.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
begin
Result := True;
Move((ActiveBuffer+fdGetFieldOffset(Field.FieldNo-1))^,Buffer^,fdGetFieldSize(Field.FieldNo-1));
end;
procedure TFiledata.SetFieldData(Field: TField; Buffer: Pointer);
begin
Move(Buffer^,(ActiveBuffer+fdGetFieldOffset(Field.FieldNo-1))^,fdGetFieldSize(Field.FieldNo-1));
DataEvent(deFieldChange, Longint(Field));
end;
procedure TFiledata.GetBookmarkData(Buffer: PChar; Data: Pointer);
begin
PInteger(Data)^ := PDDGBookmarkInfo(Buffer + FRecordSize)^.BookmarkData;
end;
function TFiledata.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
begin
Result := PDDGBookmarkInfo(Buffer + FRecordSize)^.BookmarkFlag;
end;
procedure TFiledata.InternalGotoBookmark(Bookmark: Pointer);
begin
FRecordPos := Integer(Bookmark);
end;
procedure TFiledata.InternalSetToRecord(Buffer: PChar);
begin
// bookmark value is the same as an offset into the file
FRecordPos := PDDGBookmarkInfo(Buffer + FRecordSize)^.Bookmarkdata;
end;
procedure TFiledata.SetBookmarkData(Buffer: PChar; Data: Pointer);
begin
PDDGBookmarkInfo(Buffer + FRecordSize)^.BookmarkData := PInteger(Data)^;
end;
procedure TFiledata.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
begin
PDDGBookmarkInfo(Buffer + FRecordSize)^.BookmarkFlag := Value;
end;
procedure TFiledata.InternalFirst;
begin
FRecordPos := -1;
end;
procedure TFiledata.InternalInitFieldDefs;
var
x,recsize:integer;
begin
// create FieldDefs which map to each field in the data record
recsize:=0;
if FieldDefs.count>0 then
begin
for x:=0 to FieldDefs.count-1 do
recsize:=recsize+fdGetFieldSize(x);
FRecordSize:=recsize;
FBufferSize:=recsize+sizeof(TDDGBookmarkInfo);
end;
end;
procedure TFiledata.InternalLast;
begin
FRecordPos := FIndexList.Count;
end;
procedure TFiledata.InternalClose;
begin
if TFileRec(FDataFile).Mode <> 0 then
CloseFile(FDataFile);
FIndexList.SaveToFile(FIdxName);
FIndexList.Clear;
if DefaultFields then
DestroyFields;
FRecordPos := -1;
FillChar(FDataFile, SizeOf(FDataFile), 0);
end;
procedure TFiledata.InternalHandleException;
begin
// standard implementation for this method:
Application.HandleException(Self);
end;
procedure TFiledata.InternalDelete;
begin
FIndexList.Delete(FRecordPos);
if FRecordPos >= FIndexList.Count then Dec(FRecordPos);
end;
procedure TFiledata.InternalAddRecord(Buffer: Pointer; Append: Boolean);
var
RecPos: Integer;
begin
Seek(FDataFile, FileSize(FDataFile));
BlockWrite(FDataFile, (Buffer)^, FRecordSize);
if Append then
begin
FIndexList.Add(Pointer(FileSize(FDataFile) div FRecordSize - 1));
InternalLast;
end
else begin
if FRecordPos = -1 then RecPos := 0
else RecPos := FRecordPos;
FIndexList.Insert(RecPos, Pointer(FileSize(FDataFile) div FRecordSize - 1));
end;
FIndexList.SaveToFile(FIdxName);
end;
procedure TFiledata.InternalOpen;
var
HFile: THandle;
begin
// make sure table and index files exist
FIdxName := ChangeFileExt(FTableName, feDDGIndex);
if not (FileExists(FTableName) and FileExists(FIdxName)) then
begin
HFile := FileCreate(FTableName);
if HFile = INVALID_HANDLE_VALUE then
DatabaseError('Error creating table file');
FileClose(HFile);
HFile := FileCreate(FIdxName);
if HFile = INVALID_HANDLE_VALUE then
DatabaseError('Error creating index file');
FileClose(HFile);
end;
// open data file
FileMode := fmShareDenyNone or fmOpenReadWrite;
AssignFile(FDataFile, FTableName);
Reset(FDataFile,1);
try
FIndexList.LoadFromFile(FIdxName); // initialize index TList from file
FRecordPos := -1; // initial record pos before BOF
BookmarkSize := SizeOf(Integer); // initialize bookmark size for VCL
InternalInitFieldDefs; // initialize FieldDef objects
// Create TField components when no persistent fields have been created
if DefaultFields then CreateFields;
BindFields(True); // bind FieldDefs to actual data
except
CloseFile(FDataFile);
FillChar(FDataFile, SizeOf(FDataFile), 0);
raise;
end;
end;
procedure TFiledata.InternalPost;
var
RecPos, InsPos: Integer;
begin
if FRecordPos = -1 then
RecPos := 0
else begin
if State = dsEdit then RecPos := Integer(FIndexList[FRecordPos])
else RecPos := FileSize(FDataFile) div FRecordSize;
end;
Seek(FDataFile, RecPos * FRecordSize);
BlockWrite(FDataFile, (ActiveBuffer)^, FRecordSize);
if State <> dsEdit then
begin
if FRecordPos = -1 then InsPos := 0
else InsPos := FRecordPos;
FIndexList.Insert(InsPos, Pointer(RecPos));
end;
FIndexList.SaveToFile(FIdxName);
end;
function TFiledata.IsCursorOpen: Boolean;
begin
// "Cursor" is open if data file is open. File is open if FDataFile's
// Mode includes the FileMode in which the file was open.
Result := TFileRec(FDataFile).Mode <> 0;
end;
function TFiledata.GetRecordCount: Integer;
begin
Result := FIndexList.Count;
end;
function TFiledata.GetRecNo: Integer;
begin
UpdateCursorPos;
if (FRecordPos = -1) and (RecordCount > 0) then
Result := 1
else
Result := FRecordPos + 1;
end;
procedure TFiledata.SetRecNo(Value: Integer);
begin
if (Value >= 0) and (Value <= FIndexList.Count-1) then
begin
FRecordPos := Value - 1;
Resync([]);
end;
end;
procedure TFiledata.SetTableName(const Value: string);
begin
CheckInactive;
FTableName := Value;
if ExtractFileExt(FTableName) = '' then
FTableName := FTableName + feDDGTable;
FIdxName := ChangeFileExt(FTableName, feDDGIndex);
end;
//procedure Register;
//begin
// RegisterComponents('DDG', [TFiledata]);
//end;
function TFiledata.GetDataFileSize: Integer;
begin
Result := FileSize(FDataFile);
end;
procedure TFiledata.EmptyTable;
var
HFile: THandle;
begin
Close;
DeleteFile(FTableName);
HFile := FileCreate(FTableName);
FileClose(HFile);
DeleteFile(FIdxName);
HFile := FileCreate(FIdxName);
FileClose(HFile);
Open;
end;
function TFiledata.fdGetFieldSize(FieldNo:integer):integer;
begin
case FieldDefs.items[Fieldno].DataType of
ftString: result:=FieldDefs.Items[Fieldno].size+1;
ftBoolean: result:=2;
ftFloat: result:=10;
ftSmallInt: result:=2;
ftInteger: result:=4;
ftDate: result:=10;
ftTime: result:=10;
else begin
raise Exception.create('Field type error or not support');
end;
end;
end;
function TFiledata.fdGetFieldOffset(FieldNo:integer):integer;
var
x:integer;
offs:integer;
begin
offs:=0;
if FieldNo>0 then
begin
for x:=0 to FieldNo-1 do
begin
offs:=offs+fdGetFieldSize(x);
end;
end;
result:=offs;
end;
end.
