[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]
{-----------------------------------------------------------------------------}
{ A dynamic variable length record and array class for Delphi 2.0 }
{ Copyright 1996,97 NFI Experimental Programming. All Rights Reserved. }
{ This component can be freely used and distributed in commercial and private }
{ environments, provided this notice is not modified in any way and there is }
{ no charge for it other than nomial handling fees. Contact NFI directly for }
{ modifications to this agreement. }
{-----------------------------------------------------------------------------}
{ All correspondance concerning this file should be directed to }
{ NFI Experimental Programming, E-Mail }
{ nfi@post1.com }
{-----------------------------------------------------------------------------}
{ Date last modified: March 4, 1997 }
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
{ SORRY FOR THE LACK OF COMMENTING, but as this file was initially designed }
{ and documented "in-house" minimal commenting was deemed necessary. It was }
{ only after this file was requested by several individuals that we decided }
{ on releasing in to the general public. Thus commenting has escaped the }
{ grasp of this source. }
{-----------------------------------------------------------------------------}
{ ----------------------------------------------------------------------------}
{ TNFIRecordList v2.1 }
{ ----------------------------------------------------------------------------}
{ Description: }
{ The TNFIRecordList class operates similarly to the traditional Pascal }
{ TCollection object. It creates a list consisting of TNFIRecordItem }
{ objects capable of storing whatever information you require. }
{-----------------------------------------------------------------------------}
{ ----------------------------------------------------------------------------}
{ TNFIVarRec v2.1 }
{ ----------------------------------------------------------------------------}
{ Description: }
{ NOT TO BE CONFUSED WITH BORLANDS TVARREC type for variants!!! TNFIVarRec }
{ is a variable record class that allows easy data access. It does not }
{ store the internal makeup of information you have stored, so if you store }
{ an integer and two strings then you must remember that! }
{ }
{ Storing and retrieving this information from TNFIVarRec is relatively }
{ easy, take for example: }
{ }
{ I want to store an integer and two strings. How do I do this? }
{ STORING: }
{ NFIVarRec.vInteger := AnInteger; }
{ NFIVarRec.vString := AString1; }
{ NFIVarRec.vString := AString2; }
{ RETRIEVAL:
{ NFIVarRec.ResetPointer; // Point to the start of the record. Do NOT }
{ // call "Reset" as this will remove all data }
{ // contained within TNFIVarRec! }
{ AnInteger := NFIVarRec.vInteger; }
{ AString1 := NFIVarRec.vString; }
{ AString2 := NFIVarRec.vString; }
{ }
{ Note that you must read this information in exactly the same order as you }
{ stored it! }
{-----------------------------------------------------------------------------}
{ ----------------------------------------------------------------------------}
{ TLongArray 2.1 }
{ ----------------------------------------------------------------------------}
{ Description: }
{ TLongArray is a dynamic LongInt array object. Information can be accessed }
{ in the same manner as an array, for example LongArray[x] but supports }
{ item-index removal. If you remove the first item then all other items are }
{ brought down one index automatically. }
{ }
{ The biggest problem associated with this object is the fact that it }
{ ONE based, not Zero as is traditional with C/C++ or Delphi. This is }
{ because all in-house work using TLongArray is one based. If someone would }
{ like to post a fix, feel free to contact us and let us know! }
{ ----------------------------------------------------------------------------}
unit NFILists;
interface
uses SysUtils, Classes, Windows;
{=======================================================================}
{ RECORD OBJECT TYPES }
{=======================================================================}
{ TNFIRecordList }
{ This object is the generic record storage object. It maintains a }
{ maximum list of "MaxInt" records of type TNFIRecordItem. }
type
TNFIVarRec = class;
TNFIRecordItem = class(TObject)
private
Buffer: Pointer;
RecordSize: Integer;
public
constructor Create(ARecord: Pointer; ASize: Integer);
destructor Destroy; override;
published
property Data: Pointer read Buffer;
property Size: Integer read RecordSize;
end;
TNFIRecordList = class(TObject)
private
FItems: TList;
RecordCount: Integer;
public
constructor Create;
destructor Destroy; override;
procedure AddRecord(ARecord: Pointer; Size: Integer);
procedure AddTNFIVarRec(ARecord: TNFIVarRec);
procedure InsertRecord(ARecord: Pointer; AtPos, Size: Integer);
procedure RemoveRecord(ARecNum: Integer);
function GetRecord(ARecNum: Integer): Pointer;
function GetTNFIVarRec(ARecNum: Integer; var ARecord: TNFIVarRec): Boolean;
function GetRecordSize(ARecNum: Integer): Integer;
procedure Clear;
published
property Items: TList read FItems;
{property Size: Integer read RecordSize;}
property Count: Integer read RecordCount;
end;
TNFIVarRec = class(TObject)
private
Memory: TMemoryStream;
MemorySize: LongInt;
Ident: Integer;
{ Ident is used as a "Contents Information" identifier }
{ -- As in "What in the heck did I store in this record ?" }
procedure SetMemorySize(ASize: LongInt);
function GetMemory: Pointer;
function GetSize: LongInt;
procedure SetByte(AByte: Byte);
procedure SetShortInt(AShortInt: ShortInt);
procedure SetInteger(AInteger: Integer);
procedure SetWord(AWord: Word);
procedure SetLongInt(ALongInt: LongInt);
procedure SetString(AString: String);
procedure SetTimeStamp(ATime: TDateTime);
function GetByte: Byte;
function GetShortInt: ShortInt;
function GetInteger: Integer;
function GetWord: Word;
function GetLongInt: LongInt;
function GetString: String;
function GetTimeStamp: TDateTime;
public
constructor Create;
destructor Destroy; override;
procedure ResetPointer;
procedure Reset;
procedure Move(Source: Pointer; ASize: LongInt);
{ MOVE: Move converts the buffer to SOURCE, and over-writes existing information }
procedure MoveItem(AnItem: TNFIRecordItem);
{ As with the move above, but uses a TNFIRecordItem object as the source. }
function Append(Source: Pointer; ASize: LongInt): Boolean;
{ APPEND: Appends SOURCE to the end of the current information }
{ THESE BLOBS ARE NOT TRADITIONAL DELPHI DATABASE BLOB OBJECTS. BLOB REFERS TO ANY GENERIC }
{ BINARY OBJECT THAT CAN ONLY BE READ AND WRITTEN FROM MEMORY! IF YOU NEED TO STORE A }
{ BITMAP (FOR INSTANCE), YOU CAN READ AND WRITE IT USING APPENDBLOB AND READBLOBEX! NOTE }
{ THAT TNFIVARREC AUTOMATICALLY STORES THE BLOB SIZE SO WHEN READ THE EQUIVALENT AMOUNT }
{ OF MEMORY IS ALLOCATED. MAXIMUM BLOB SIZE IS 2 GB. }
function AppendBlob(Source: Pointer; ASize: LongInt): Boolean;
{ APPENDBLOB: Appends SOURCE to the end of the current information storing the size of the BLOB}
function ReadBlob(var Buffer: Pointer): LongInt;
{ READBLOB: Reads a BLOB record from the current position within the file. }
{ Buffer SHOULD NOT be assigned as ReadBlob will change it's location !!! }
{ Buffer is in fact set to point to the internal storage area, so prior }
{ to making any changes make sure that you have copied this information }
{ out! }
function ReadBlobEx(var Buffer: Pointer): LongInt;
{ READBLOBEX: Creates a new memory buffer of the appropriate size and copies the }
{ contents of the BLOB into this new buffer. This allows the programmer }
{ to directly perform read/write operations on the buffer, unlike READBLOB }
function AppendPChar(Source: PChar): Boolean;
procedure ReadPChar(Buffer: PChar);
function LoadFromFile(AFileName: String): Boolean;
{ Clears out all information prior to loading and points to START! }
procedure LoadFromStream(AStream: TStream);
procedure SaveToFile(AFileName: String);
procedure SaveToStream(var AStream: TStream);
property vByte: Byte read GetByte write SetByte;
property vShortInt: ShortInt read GetShortInt write SetShortInt;
property vInteger: Integer read GetInteger write SetInteger;
property vWord: Word read GetWord write SetWord;
property vLongInt: LongInt read GetLongInt write SetLongInt;
property vLong: LongInt read GetLongInt write SetLongInt;
property vString: String read GetString write SetString;
property vTime: TDateTime read GetTimeStamp write SetTimeStamp;
property Data: Pointer read GetMemory;
property Size: LongInt read GetSize;
property Capacity: LongInt read MemorySize write SetMemorySize;
property ID: Integer read Ident write Ident default 0; // Set to zero anyway,
end; // but hey...
// TLongArray is one based!
TLongArray = class
private
Buffer: Pointer;
BufferSize, DataSize: LongInt;
procedure Grow; // Conducts a 4k increment
procedure Truncate; // Truncates the buffer at datasize
function GetCount: LongInt;
function GetAtPos(Index: Integer): LongInt;
procedure ReplacePos(Index: Integer; AValue: LongInt);
public
constructor Create;
destructor Destroy; override;
procedure Reset;
procedure Add(ALongInt: LongInt);
procedure Remove(AtPos: LongInt);
procedure Insert(AtPos: LongInt; ALongInt: LongInt);
procedure Replace(AtPos: LongInt; ALongInt: LongInt);
procedure Inc(AtPos, ANum: LongInt);
procedure Dec(AtPos, ANum: LongInt);
property At[Index: Integer]: LongInt read GetAtPos write ReplacePos; default;
property Size: LongInt read DataSize;
property Data: Pointer read Buffer;
property Count: LongInt read GetCount;
end;
implementation
{=======================================================================}
{ ** TNFIRECORDITEM CODE }
{=======================================================================}
constructor TNFIRecordItem.Create(ARecord: Pointer; ASize: Integer);
begin
RecordSize := ASize;
GetMem(Buffer, ASize);
Move(ARecord^, Buffer^, RecordSize);
end;
destructor TNFIRecordItem.Destroy;
begin
FreeMem(Buffer, RecordSize);
end;
{=======================================================================}
{ ** TNFIRECORDLIST CODE }
{=======================================================================}
constructor TNFIRecordList.Create;
begin
RecordCount := 0;
FItems := TList.Create;
end;
destructor TNFIRecordList.Destroy;
begin
if FItems <> nil then Clear;
FItems.Free;
end;
procedure TNFIRecordList.AddRecord(ARecord: Pointer; Size: Integer);
var NewRecord: TNFIRecordItem;
P: Pointer;
begin
NewRecord := TNFIRecordItem.Create(ARecord, Size);
FItems.Add(NewRecord);
Inc(RecordCount);
end;
procedure TNFIRecordList.AddTNFIVarRec(ARecord: TNFIVarRec);
begin
If Assigned(ARecord) Then
AddRecord(ARecord.Data, ARecord.Size);
end;
// Returns a pointer to the data held by a TNFIRecordItem, not a pointer to the
// object itself.
{ The procedure itself uses "ARecord" because without it, the compiler gave }
{ me an error it informs me I shouldn't have. Anyway, it works now so... }
function TNFIRecordList.GetRecord(ARecNum: Integer): Pointer;
var ARecord: TNFIRecordItem;
begin
If (RecordCount = 0) or (ARecNum < 1) or (ARecNum > RecordCount) Then ARecord := nil
Else ARecord := FItems[ARecNum - 1];
If ARecord <> nil Then GetRecord := ARecord.Data Else GetRecord := nil;
end;
function TNFIRecordList.GetTNFIVarRec(ARecNum: Integer; var ARecord: TNFIVarRec): Boolean;
var P: Pointer;
begin
GetTNFIVarRec := False;
If Assigned(ARecord) Then
begin
P := GetRecord(ARecNum);
ARecord.Move(P, GetRecordSize(ARecNum));
GetTNFIVarRec := True;
end;
end;
function TNFIRecordList.GetRecordSize(ARecNum: Integer): Integer;
begin
If (RecordCount = 0) or (ARecNum < 1) or (ARecNum > RecordCount) Then GetRecordSize := -1
Else GetRecordSize := TNFIRecordItem(FItems[ARecNum - 1]).Size;
end;
procedure TNFIRecordList.InsertRecord(ARecord: Pointer; AtPos, Size: Integer);
var NewRecord: TNFIRecordItem;
begin
NewRecord := TNFIRecordItem.Create(ARecord, Size);
FItems.Insert(AtPos - 1, NewRecord); // As this is a 1 based array, subtract
Inc(RecordCount); // one from it as TList is zero-based.
end;
procedure TNFIRecordList.RemoveRecord(ARecNum: Integer);
var ARecord: TNFIRecordItem;
begin
If (RecordCount > 0) and (ARecNum > 0) and (ARecNum <= RecordCount) Then
begin
ARecord := FItems[ARecNum - 1];
FItems.Delete(ARecNum - 1);
ARecord.Free;
Dec(RecordCount);
end;
end;
procedure TNFIRecordList.Clear;
var i: Integer;
begin
If RecordCount > 0 Then
For i := RecordCount downto 1 Do
RemoveRecord(i);
end;
{=======================================================================}
{ ** TNFIVarRec CODE }
{=======================================================================}
constructor TNFIVarRec.Create;
begin
MemorySize := 8192;
try
Memory := TMemoryStream.Create;
except
Abort;
end;
end;
destructor TNFIVarRec.Destroy;
begin
If Assigned(Memory) Then Memory.Free;
end;
procedure TNFIVarRec.ResetPointer;
begin
Memory.Position := 0;
end;
procedure TNFIVarRec.Reset;
begin
ResetPointer;
Memory.Clear;
end;
procedure TNFIVarRec.SetMemorySize(ASize: LongInt);
begin
If Assigned(Memory) Then Memory.SetSize(ASize);
end;
procedure TNFIVarRec.Move(Source: Pointer; ASize: LongInt);
begin
Reset;
Memory.WriteBuffer(Source^, ASize);
end;
procedure TNFIVarRec.MoveItem(AnItem: TNFIRecordItem);
begin
If Assigned(AnItem) Then
Move(AnItem.Data, AnItem.Size);
end;
function TNFIVarRec.Append(Source: Pointer; ASize: LongInt): Boolean;
begin
try
Memory.WriteBuffer(Source^, ASize);
Append := True;
except
Append := False;
end;
end;
{ THESE BLOBS ARE NOT TRADITIONAL DELPHI DATABASE BLOB OBJECTS. BLOB REFERS TO ANY GENERIC }
{ BINARY OBJECT THAT CAN ONLY BE READ AND WRITTEN FROM MEMORY! IF YOU NEED TO STORE A }
{ BITMAP (FOR INSTANCE), YOU CAN READ AND WRITE IT USING APPENDBLOB AND READBLOB! NOTE }
{ THAT TNFIVARREC AUTOMATICALLY STORES THE BLOB SIZE SO WHEN READ THE EQUIVALENT AMOUNT }
{ OF MEMORY IS ALLOCATED. MAXIMUM BLOB SIZE IS 2 GB. }
function TNFIVarRec.AppendBlob(Source: Pointer; ASize: LongInt): Boolean;
begin
try
Memory.WriteBuffer(ASize, 4);
Memory.WriteBuffer(Source^, ASize);
AppendBlob := True;
except
AppendBlob := False;
end;
end;
{ Please read the associated notes located at the class definition }
function TNFIVarRec.ReadBlob(var Buffer: Pointer): LongInt;
var BlobSize: LongInt;
begin
try
Memory.ReadBuffer(BlobSize, 4);
Buffer := Pointer(LongInt(Memory.Memory) + Memory.Position);
Memory.Position := Memory.Position + BlobSize;
ReadBlob := BlobSize;
except
Buffer := nil;
ReadBlob := -1;
end;
end;
{ Please read the associated notes located at the class definition }
function TNFIVarRec.ReadBlobEx(var Buffer: Pointer): LongInt;
var BlobSize: LongInt;
P: Pointer;
begin
try
Memory.ReadBuffer(BlobSize, 4);
P := Pointer(LongInt(Memory.Memory) + Memory.Position);
Buffer := AllocMem(BlobSize);
System.Move(P^, Buffer^, BlobSize);
Memory.Position := Memory.Position + BlobSize;
ReadBlobEx := BlobSize;
except
Buffer := nil;
ReadBlobEx := -1;
end;
end;
function TNFIVarRec.LoadFromFile(AFileName: String): Boolean;
var FileStream: TFileStream;
begin
LoadFromFile := False;
try
FileStream := TFileStream.Create(AFilename, fmOpenRead);
Reset;
Memory.CopyFrom(FileStream, FileStream.Size);
Memory.Position := 0;
LoadFromFile := True;
finally
If Assigned(FileStream) Then FileStream.Free;
end;
end;
procedure TNFIVarRec.LoadFromStream(AStream: TStream);
begin
Reset;
Memory.CopyFrom(AStream, AStream.Size);
Memory.Position := 0;
end;
procedure TNFIVarRec.SaveToFile(AFileName: String);
var FileStream: TFileStream;
begin
try
FileStream := TFileStream.Create(AFilename, fmCreate);
ResetPointer; // NOT RESET! We want to keep all information!
FileStream.CopyFrom(Memory, Memory.Size);
finally
If Assigned(FileStream) Then FileStream.Free;
end;
end;
procedure TNFIVarRec.SaveToStream(var AStream: TStream);
begin
ResetPointer;
AStream.CopyFrom(Memory, Memory.Size);
end;
function TNFIVarRec.GetMemory: Pointer;
begin
GetMemory := Memory.Memory;
end;
function TNFIVarRec.GetSize: LongInt;
begin
GetSize := Memory.Size;
end;
procedure TNFIVarRec.SetByte(AByte: Byte);
begin
Memory.WriteBuffer(AByte, 1);
end;
function TNFIVarRec.GetByte: Byte;
var AResult: Byte;
begin
Memory.ReadBuffer(AResult, 1);
GetByte := AResult;
end;
procedure TNFIVarRec.SetShortInt(AShortInt: ShortInt);
begin
SetByte(AShortInt);
end;
function TNFIVarRec.GetShortInt: ShortInt;
begin
GetShortInt := GetByte;
end;
procedure TNFIVarRec.SetWord(AWord: Word);
begin
Memory.WriteBuffer(AWord, 2);
end;
procedure TNFIVarRec.SetInteger(AInteger: Integer);
begin
SetWord(AInteger);
end;
function TNFIVarRec.GetInteger: Integer;
var AResult: Integer;
begin
Memory.ReadBuffer(AResult, 2);
GetInteger := AResult;
end;
function TNFIVarRec.GetWord: Word;
begin
GetWord := GetInteger;
end;
procedure TNFIVarRec.SetLongInt(ALongInt: LongInt);
begin
Memory.WriteBuffer(ALongInt, 4);
end;
function TNFIVarRec.GetLongInt: LongInt;
var AResult: LongInt;
begin
Memory.ReadBuffer(AResult, 4);
GetLongInt := AResult;
end;
procedure TNFIVarRec.SetString(AString: String);
var P: Pointer;
begin
GetMem(P, Length(AString) + 1);
StrPCopy(P, AString);
Memory.WriteBuffer(P^, Length(AString) + 1);
FreeMem(P);
end;
function TNFIVarRec.GetString: String;
var S: String;
C: Char;
begin
S := '';
Repeat
Memory.ReadBuffer(C, 1);
If C <> #0 Then S := S + C;
Until C = #0;
GetString := S;
end;
procedure TNFIVarRec.SetTimeStamp(ATime: TDateTime);
begin
Memory.WriteBuffer(ATime, SizeOf(TDateTime));
end;
function TNFIVarRec.GetTimeStamp: TDateTime;
var AResult: TDateTime;
begin
Memory.ReadBuffer(AResult, SizeOf(TDateTime));
GetTimeStamp := AResult;
end;
function TNFIVarRec.AppendPChar(Source: PChar): Boolean;
begin
try
Memory.WriteBuffer(Source^, StrLen(Source) + 1); { Include the terminating #0 }
AppendPChar := True;
except
AppendPChar := False;
end;
end;
procedure TNFIVarRec.ReadPChar(Buffer: PChar);
begin
try
StrCopy(Buffer, Pointer(LongInt(Memory.Memory) + Memory.Position));
except
Buffer := nil;
end;
end;
{=======================================================================}
{ ** TLONGARRAY CODE }
{=======================================================================}
constructor TLongArray.Create;
begin
Reset;
end;
destructor TLongArray.Destroy;
begin
If Assigned(Buffer) Then FreeMem(Buffer);
end;
procedure TLongArray.Reset;
begin
If Assigned(Buffer) Then FreeMem(Buffer);
BufferSize := 8192;
Buffer := AllocMem(BufferSize);
DataSize := 0;
end;
procedure TLongArray.Grow; { Add 4 extra kb to the end of the buffer }
begin
System.Inc(BufferSize, 4096);
ReAllocMem(Buffer, BufferSize);
end;
procedure TLongArray.Truncate;
begin
ReAllocMem(Buffer, DataSize);
BufferSize := DataSize;
end;
procedure TLongArray.Add(ALongInt: LongInt);
var P: ^LongInt;
begin
If DataSize = BufferSize Then Grow;
P := Buffer;
System.Inc(LongInt(P), DataSize);
P^ := ALongInt;
System.Inc(DataSize, 4);
end;
procedure TLongArray.Remove(AtPos: LongInt);
var P, Q: Pointer;
CopyAmount: LongInt;
begin
If (DataSize > 0) and (AtPos <= (DataSize div 4)) Then
begin
P := Buffer;
System.Inc(LongInt(P), AtPos * 4); // Point it past the record we are deleting
Q := Buffer;
System.Inc(Longint(Q), (AtPos - 1) * 4); // Point it to the one we are deleting
CopyAmount := DataSize - (AtPos * 4);
If CopyAmount > 0 Then
System.Move(P^, Q^, CopyAmount);
System.Dec(DataSize, 4);
If DataSize > 8192 Then Truncate;
end;
end;
procedure TLongArray.Insert(AtPos: LongInt; ALongInt: LongInt);
var P, TempBuffer: Pointer;
Q: ^LongInt;
CopyAmount: LongInt;
begin
If (AtPos > 0) and ((AtPos - 1 ) * 4 <= DataSize) Then
begin
If BufferSize = DataSize Then Grow;
P := Buffer;
System.Inc(LongInt(P), (AtPos - 1) * 4);
Q := P;
CopyAmount := DataSize - ((AtPos - 1) * 4);
If CopyAmount > 0 Then
begin
GetMem(TempBuffer, CopyAmount);
System.Move(P^, TempBuffer^, CopyAmount);
System.Inc(LongInt(P), 4);
System.Move(TempBuffer^, P^, CopyAmount);
FreeMem(TempBuffer);
end;
Q^ := ALongInt;
System.Inc(DataSize, 4);
end;
end;
function TLongArray.GetAtPos(Index: Integer): LongInt;
var P: ^LongInt;
begin
GetAtPos := 0;
If (Index > 0) and ((Index - 1) * 4 <= DataSize) Then
begin
P := Buffer;
System.Inc(LongInt(P), (Index - 1) * 4);
GetAtPos := P^;
end;
end;
function TLongArray.GetCount: LongInt;
begin
If DataSize = 0 Then GetCount := 0
Else GetCount := DataSize div 4;
end;
procedure TLongArray.Replace(AtPos: LongInt; ALongInt: LongInt);
var P: ^LongInt;
begin
If (AtPos > 0) and ((AtPos - 1) * 4 <= DataSize) Then
begin
P := Buffer;
System.Inc(LongInt(P), (AtPos - 1) * 4);
P^ := ALongInt;
end;
end;
// Used for setting the "write" property of "At"
procedure TLongArray.ReplacePos(Index: Integer; AValue: LongInt);
begin
Replace(Index, AValue);
end;
procedure TLongArray.Inc(AtPos, ANum: LongInt);
var i: LongInt;
begin
i := At[AtPos] + ANum;
Replace(AtPos, i);
end;
procedure TLongArray.Dec(AtPos, ANum: LongInt);
var i: LongInt;
begin
i := At[AtPos] - ANum;
Replace(AtPos, i);
end;
end.
[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]