Archive
MyOwnDB – internal structure and layout
Note: This post is a follow-up to My own database engine. Make sure you read that article first for context.
Also make sure you download and play with ByteRage, which can be downloaded from google code.
Basic database theory
Stop and think about how a database works, not on the level of sql or anything like that, but in low level terms dealing with the actual database disk file and storage. If you ponder how a record is stored inside the database file you will immediately reach a point where you realize, that a single record of variable size cannot really be pre-calculated. If your records are fixed, so that you know that each post will take up exactly 2k of data, then writing the IO routines for a database file is quite simple. But the moment you introduce BLOBS, CLOBS and MEMO fields – being able to pre calculate the position of a record inside a file goes out the window.
I mean, if you know that each record is 1024 bytes in size, then finding the position of record #25 inside the file is just a matter of:
mFileOffset := SizeOf(TPageData) * 25; mFileStream.position:=mFileOffset;
But when each record can have a unique length, there is no way of pinpointing the location of a record using math alone. You need to keep track of where records starts in a list, and you also need some mechanism for re-using record space.
Break it down
The solution to “variable length records” is that you have to break the record data into smaller pieces, called pages (or “blocks”) of a fixed size. If you can store a record inside one block, then that is great – but when the data exceeds the size of a single page, then you have to figure out a clever way of chaining these blocks together inside the file. Such a chain of blocks is simply called a “sequence”.
But once you have divided a file into pages, you also introduce another problem. Namely how do you keep track of free blocks in the middle of a database file versus those containing record data. If you delete a record that is stored in the middle of a database file, you really dont want to truncate the entire file just to keep things linear (if your database file is 10 gigabytes in size, that can take forever, even with memory mapping).
First, lets look at how a page inside the database file looks like:
PSRLPageData = ^TSRLPageData; TSRLPageData = Packed Record pdUsedBytes: Integer; pdPrevPage: Longword; pdNextPage: Longword; pdData: Array[1..SRL_PageFile_PageSize-12] of Byte; End;
As you can see it has an array to contain data (which can be the whole record, or a part of a record). It also have two fields that contains a reference to the next block in the chain and the previous. This solves how you chain blocks of data together.
The problem now is keeping track of “free” pages, so we can recycle the space occupied by deleted records for new ones.
The “free block/page” problem
When you delete a sequence of pages (a record broken into X pieces), how will you keep track of the free pages? How will you re-cycle those pages for new records? Since the pages can be spread throughout the entire file (just like files on a disk can be fragmented) this can be tricky. You can’t use an array of bytes or integers since the datasize is hardly justified. You need something smaller, something small enough to be saved inside the table file without being unreasonable – yet effective and fast enough for practical use.
The answer is to represent each page in the file as a single BIT. If the bit is set, then you know that this page is in use. If the bit is zero, then you know this can be re-cycled. The maximum amount of pages a TFileStream can handle can thus be allocated straight away (!) And its reasonable in size for a database file that can span gigabytes.
TotalBits = (MaxSize / PageSize);
TotalBytes = TotalBits / 8;
Voila! We can now pack a lot of information into a very small storage medium (doesn’t get any smaller than bits!). This “bit map” of the file is isolated in the TSRLBitBuffer class.
In short: a single byte can now keep track of 8 pages of data. Meaning, that if the pagesize is set to 2048 bytes, and your database file is 10.000 pages in size, the full “map” of the file will only require 10.000 / 8 = 1250 bytes. When we add ZLib compression to the bit-buffer on saving, the number is even smaller. That is extremely cost-effective and very, very fast for looking up the state of a database page.
I mean, if you quickly want to find a “free bit”, you simply use a normal PByte and check for a value less than 255. If the value is less, you know that there is a free bit in that byte. This can be made very fast using loop expansion (reading 8 or 16 bytes in one go until you find a byte that is <255 in value).
NOTE: Like pointed out by a reader, it is also custom to keep track of free/
mAddr:=Pbyte(FBuffer); mOffset:=0; Repeat if not (mAddr^=255) then Begin //We have a byte with a bit not set! //Now figure out which bit, and calculate page number from that Break; end; inc(mAddr); inc(mOffset); until mOffset:=FBytesInbuffer;
Now, when I create new technology, I don’t give a flying spaghetti monster about speed. The prototype is always about solving the problem. Once the prototype has been tested and verified, then I start to refactor the classes and tuning the code for better speed. The bitbuffer class would gain a few clock cycles if it was a part of TSRLPageFile, and even more if I re-wrote it in assembler.
Having said that, posting 10.000 records to the table takes less than a second – so I am actually quite pleased with the speed. Using TBRPersistent for storage is completely overkill, so it will be even faster once I have some time to work on it. And naturally it will be wrapped into TDataset.
Working with a stream as an array of pages
The base class for the database engine simply implements the basics: namely to read data from the table stream in pages (or blocks). So the class TSRLPageFile contains the code for creating, reading and writing to the stream in segments rather than at offset positions.
Reading and writing sequences of pages
Since a database record can span several pages we need to be able to read pages in sequence, glue them together using page-numbers, delete a complete sequence – and of course, re-cycle unused or deleted pages. The mechanisms for this is isolated in TSRLSequenceFile, which interhits from TSRLPageFile.
Working with a stream as an array of records
The actual table class, which adds stuff like storing the bit-map and list of record offsets to the file — is TSRLTable. This class also adds a rudimentary “cursor”, BOF/EOF/Next/Prev functions and so on. It is just a raw shell over the table system.
Indexing, the mother of all.. well, quite cool actually
As you probably have guessed, myOwnDB is just the “raw” storage engine. It takes care of breaking record data into pieces, storing them in sequence, keeping track of free pages inside the databasefile, and stuff like compacting the file and updating internal list information. In some ways you can say that it provides half a database, since there is no code for things like indexing, sql and other things.
I did implement a very crude, brute force search function. It allows you to search the database for a simple string value — but it’s no more effective than filters in TDataset (if not worse). It was just a bit of fun. It gives the same results as the HTML5 objective database would give, where you would insert an object with a key (GUID) and quickly get it back again.
Proper database indexing requires a much more detailed scheme. You would first need a clearly defined field-model, not just stuffing the equivalent of a Microsoft property-bag and calling it a record. String indexes usually have an array of “key phrases” that are either included or excluded – and from this you build a BTree node/lead structure which is updated on inserting data and removing data.
Indexing is very expensive in terms of storage space. If you index your database wrong, your index file can actually exceed your database file (!) So this is not something you slap together over the weekend.
Having said that, my database engine makes it very easy to store and handle indexing within a single file. It would be stored inside the database as a sequence of data just like the sequence-list, the bitmap and whatever else. It would be loaded into memory when you open the table-file, and stored when you close it (if changes has been made and write access to the file is allowed).
With indexing in place, writing a good SQL parser is all that is left (which is not a walk in the park, but more time consuming than technical challenging).
Imagine the speed of this thing if we added memory mapping to the equation 🙂 But better to keep it native Delphi so it’s 100% portable.
My own database engine – check it out
Right, you are probably going to think me mad, but yes — i have coded my own database engine. And the core engine is simple, effective and very very cool! Before you jump to conclusions let me warn you that I havent added SQL support yet, but the fundamental engine of records, record lists, file-block management and the rest is there.
You will need the latest version of Byterage to compile it — but give me a few days to clean it up and you can play around with it.
And it works in both memory and disk – since everything is handled by a normal stream. Here is how you post some data to it:
procedure TForm1.Button4Click(Sender: TObject); var mTable: TSRLTable; x: Integer; mStart: TDateTime; begin mTable:=TSRLTable.Create; try mTable.FieldDefs.WriteStr('name',''); mTable.FieldDefs.WriteInt('value',0); mTable.Open('c:\temp\mydb.dbx',baCreate); if mTable.Lock(lmAppend) then Begin try mStart:=now; for x:=1 to 10000 do Begin mTable.Cursor.WriteStr('name','This is very cool #' + IntToStr(x)); mtable.Cursor.WriteInt('value',1200); mTable.Post; end; finally mTable.UnLock; end; end;
And here is the engine itself. A bit of a brain teaser, but fun to play with. Now to add SQL support and wrap it in a TDataset decendant.
unit qtxdb; {.$INCLUDE srldef.inc} {.$DEFINE SRL_DB_DISKLIST} {$DEFINE SRL_DB_SEEKBUFFER} interface uses sysutils, classes, System.Generics.Collections, brage, qtxobj; //########################################################################## // Constants //########################################################################## Const SRL_PageFile_PageSize = 1024; SRL_PageFile_BitsTotal = 8000000; // maximum pages (can be set to 8xx} SRL_PageFile_BitsBytes = SRL_PageFile_BitsTotal div 8; SRL_PageFile_BitsPages = SRL_PageFile_BitsBytes div SRL_PageFile_PageSize; SRL_PageFile_InvalidPage = 0; SRL_PageFile_SeekRange = SRL_PageFile_PageSize * 4; ERR_SRL_PAGEFILE_NOTACTIVE = 'Invalid operation, file is not active error'; ERR_SRL_PAGEFILE_FILENOTFOUND = 'Invalid file name (%s), file not found error'; ERR_SRL_PAGEFILE_NOTWRITEMODE = 'Invalid access mode, write not permitted error'; ERR_SRL_SEQFILE_InvalidWriteData = 'Failed to write sequence #%d, data object is empty or NIL error'; ERR_SRL_SEQFILE_NotActive = 'Operation failed, file is not active error'; //########################################################################## // Unit exceptions //########################################################################## type ESRLPageFile = Class(Exception); ESRLSequenceFile = Class(Exception); ESRLTable = Class(Exception); //########################################################################## // Forward declarations //########################################################################## TSRLTable = Class; TSRLPageFile = Class; TSRLSequenceFile = Class; (* TSRLRecordFieldDef = Class(TBRPersistent) Private FFieldClass: TSRLRecordFieldClass; FFieldName: AnsiString; FFieldLen: TSRLInt; FReadOnly: Boolean; Procedure SetFieldClass(Const Value:TSRLRecordFieldClass); Procedure SetFieldName(Value:AnsiString); Procedure SetFieldLen(Const Value:TSRLInt); Protected Procedure BeforeReadObject;Override; Procedure ReadObject(Const Reader:TSRLReader);Override; Procedure WriteObject(Const Writer:TSRLWriter);Override; Procedure SetReadOnly(Const Value:TSRLBool); Public Property FieldClass:TSRLRecordFieldClass read FFieldClass write SetFieldClass; property FieldName:AnsiString read FFieldName write SetFieldName; Property Length:TSRLInt read FFieldLen write SetFieldLen; Constructor Create(Const Owner:TSRLRecordFieldDefs);reintroduce; End; TSRLRecordFieldDefs = Class(TSRLPersistent,ISRLRecordFieldDefs) Private {$IFNDEF SRL_USE_LISTS} FObjects: TSRLObjList; {$ELSE} FObjects: TObjectList; {$ENDIF} FReadOnly: Boolean; Function GetItem(Const Index:TSRLInt):TSRLRecordFieldDef; Procedure SetItem(Const Index:TSRLInt; Const Value:TSRLRecordFieldDef); Function GetCount:TSRLInt; Protected Procedure SetReadOnly(Const Value:TSRLBool); Procedure BeforeReadObject;Override; Procedure ReadObject(Const Reader:TSRLReader);Override; Procedure WriteObject(Const Writer:TSRLWriter);Override; Public property Count:TSRLInt read GetCount; Property Items[Const Index:TSRLInt]:TSRLRecordFieldDef Read GetItem write SetItem;default; Function Add(Const AFieldName:AnsiString; Const AFieldClass:TSRLRecordFieldClass; Const ALength:TSRLInt=0):TSRLRecordFieldDef; Function IndexOf(Const Value:TSRLRecordFieldDef):Integer; Function ObjectOf(AFieldName:String):TSRLRecordFieldDef; Procedure Delete(Const Index:TSRLInt);overload; procedure Delete(Const Value:TSRLRecordFieldDef);overload; Procedure Clear; Constructor Create;override; Destructor Destroy;Override; End; *) //########################################################################## // Custom datatypes //########################################################################## TLongArray = Array of Longword; PSRLPageData = ^TSRLPageData; TSRLPageData = Packed Record pdUsedBytes: Integer; pdPrevPage: Longword; pdNextPage: Longword; pdData: Array[1..SRL_PageFile_PageSize-12] of Byte; End; TSRLSearchRec = Packed Record srId: Integer; srCurrent: Integer; srFieldName: String; srKeyword: String; End; TSRLBinaryAccessMode = (baNone,baCreate,baRead,baReadWrite); TSRLBinaryRequirement = set of (brHeadWrite,brHeadRead); TSRLTableLockMode = (lmNone,lmRead,lmWrite,lmAppend,lmInsert); TSRLTableOptions = Set of (toCompress,toAutoCompact); //########################################################################## // Events //########################################################################## (* Pagefile events *) TSRLPageFileBeforeOpenEvent = TNotifyevent; TSRLPageFileBeforeCloseEvent = TNotifyevent; TSRLPageFileAfterOpenEvent = TNotifyevent; TSRLPageFileAfterCloseEvent = TNotifyevent; (* table events *) TSRLTableLockedEvent = Procedure (Const Sender:TObject;Const LockMode:TSRLTableLockMode) of Object; TSRLTableWriteDescriptorEvent = Procedure (Const Sender:TObject;Const Writer:TBRWriter) of Object; TSRLTableReadDescriptorEvent = Procedure (Const Sender:TObject;Const Reader:TBRReader) of Object; TSRLTableCompactingBeginsEvent = TNotifyevent; TSRLTableCompactingEndsEvent = TNotifyevent; TSRLTableCompactProgressEvent = Procedure (Const Sender:TObject; BytesCompacted:Integer) of Object; //########################################################################## // TBRBitBuffer //########################################################################## TBRBitBuffer = Class(TBRPersistent) Private FData: Pointer; FDataLng: Integer; FDataLen: Integer; FBitsMax: Longword; FReadyByte: Longword; FAddr: PByte; BitOfs: 0..255; FByte: Byte; Function GetByte(Const Index:Integer):Byte; Procedure SetByte(Const Index:Integer;Const Value:Byte); Function GetBit(Const Index:Longword):Boolean; Procedure SetBit(Const Index:Longword;Const Value:Boolean); Protected Procedure BeforeReadObject;Override; procedure ReadObject(Const Reader:TBRReader);override; procedure WriteObject(Const Writer:TBRWriter);override; Public Property Data:Pointer read FData; Property Size:Integer read FDataLen; Property Count:Longword read FBitsMax; Property Bytes[Const Index:Integer]:Byte Read GetByte write SetByte; Property Bits[Const Index:Longword]:Boolean Read GetBit write SetBit;default; Procedure Allocate(MaxBits:Integer); Procedure Release; Function Empty:Boolean; Procedure Zero; Procedure SetBitRange(First,Last:Longword; Const Bitvalue:Boolean); Procedure SetBits(Const Value:Array of longword; Const BitValue:Boolean); Function FindIdleBit(var Value:Longword; Const FromStart:Boolean=False):Boolean; Destructor Destroy;Override; End; //########################################################################## // Class declarations //########################################################################## TSRLPageFile = Class(TBRPersistent) Private //FBitBuffer: TBRBufferMemory; //FBitmap: TBRBitAccess; FBitmap: TBRBitBuffer; FFile: TStream; FRequires: TSRLBinaryRequirement; FFileMode: TSRLBinaryAccessMode; FFilename: AnsiString; FActive: Boolean; FInMemory: Boolean; FOnBeforeOpen: TSRlPageFileBeforeOpenEvent; FOnBeforeClose: TSRlPageFileBeforeCloseEvent; FOnAfterOpen: TSRlPageFileAfterOpenEvent; FOnAfterClose: TSRlPageFileAfterCloseEvent; Private Function GetCount:Longword; Procedure WriteHeaderData; Procedure ReadHeaderData; Procedure WriteBitBuffer; Procedure ReadBitBuffer; Protected Procedure SetCurrentPage(Const Value:Longword); Function GetCurrentPage:Longword; Function GetPageCount:Longword; Function GetIdlePage(Const AllowGrow:Boolean=True):Longword; Function ReadPage(Const PageIndex:Longword; var Buffer:TSRLPageData):Longword; Procedure WritePage(Const PageIndex:Longword;Const Buffer:TSRLPageData); Function GrowPageFile(Value:Longword):Longword; Procedure ShrinkPageFile(Value:Longword); Protected (* Event dispatchers *) Procedure SignalBeforeOpen; Procedure SignalBeforeClose; Procedure SignalAfterOpen; Procedure SignalAfterClose; Protected Procedure DoBeforeOpen;virtual; procedure DoAfterOpen;virtual; Procedure DoBeforeClose;virtual; Procedure DoAfterClose;virtual; Procedure DoWriteHeader(Const Writer:TBRWriter);virtual; Procedure DoReadHeader(Const Reader:TBRReader);virtual; Protected Procedure AddRequirement(Const Value:TSRLBinaryRequirement); Procedure DelRequirement(Const Value:TSRLBinaryRequirement); Procedure ApplyRequirements; Protected Property OnBeforeOpen:TSRlPageFileBeforeOpenEvent Read FOnBeforeOpen write FOnBeforeOpen; Property OnBeforeClose:TSRlPageFileBeforeCloseEvent Read FOnBeforeClose write FOnBeforeClose; Property OnAfterOpen:TSRlPageFileAfterOpenEvent Read FOnAfterOpen write FOnAfterOpen; Property OnAfterClose:TSRlPageFileAfterCloseEvent Read FOnAfterClose write FOnAfterClose; Property Filename:AnsiString read FFilename; Public //Property Bitmap:TBRBitAccess read FBitmap; Property Bitmap:TBRBitBuffer read FBitmap; Property Active:Boolean read FActive; Property AccessMode:TSRLBinaryAccessMode read FFileMode; Property PageCount:Longword read GetCount; Property InMemory:Boolean read FInMemory; Procedure Open(Const Filename:AnsiString; Const AccessMode:TSRLBinaryAccessMode = baReadWrite);overload; Procedure Open;overload; Procedure Close; Procedure SaveToFile(Const Filename:String); Procedure BeforeDestruction;Override; Constructor Create;override; Destructor Destroy;Override; End; TSRLSequenceFile = Class(TSRLPageFile) Private FSeqStart: Longword; {$IFDEF SRL_DB_DISKLIST} FSeqList: LongwordFileList; {$ELSE} FSeqList: TList<Longword>; {$ENDIF} FOnCompBegins: TSRLTableCompactingBeginsEvent; FOnCompEnds: TSRLTableCompactingEndsEvent; FOnCompProgress: TSRLTableCompactProgressEvent; Function AppendSequenceEx(Const Data:TBRBuffer):Longword; Procedure ReleaseSequenceEx(Const StartPage:Longword); Procedure ReadSequenceEx(Const StartPage:Longword; Const Data:TBRBuffer); Function GetSequence(Const Index:Integer):Longword; Function GetSequenceCount:Integer; Protected Procedure SignalCompactingBegins; Procedure SignalCompactingProgress(Value:Integer); Procedure SignalCompactingEnds; Protected Procedure DoWriteDescriptor(Const Writer:TBRWriter);Virtual; Procedure DoReadDescriptor(Const Reader:TBRReader);Virtual; Procedure DoWriteHeader(Const Writer:TBRWriter);override; Procedure DoReadHeader(Const Reader:TBRReader);override; Procedure DoAfterOpen;Override; Procedure DoBeforeClose;Override; Procedure DoBeforeOpen;Override; Procedure DoAfterClose;Override; Protected Function AppendSequence(Const Data:TBRBuffer):Integer; Procedure ReplaceSequence(Const Index:Integer;Const Data:TBRBuffer); Procedure ReadSequence(Const Sequence:Integer;Const Data:TBRBuffer); Procedure WriteSequence(Const Index:Integer;Const Data:TBRBuffer); Procedure ReleaseSequence(Const Sequence:Integer); Function GetSequencePages(Sequence:Integer; var Value:TLongArray):Boolean; Protected Property Sequence[Const Index:Integer]:Longword read GetSequence; Property Count:Integer read GetSequenceCount; Public Procedure Compact; Constructor Create;override; Destructor Destroy;Override; Public Property OnCompactingBegins:TSRLTableCompactingBeginsEvent read FOnCompBegins write FOnCompBegins; Property OnCompactingEnds:TSRLTableCompactingEndsEvent read FOnCompEnds write FOnCompEnds; Property OnCompactProgress:TSRLTableCompactProgressEvent read FOnCompProgress write FOnCompProgress; End; TSRLTable = Class(TSRLSequenceFile) Private FRecNo: Integer; FLockMode: TSRLTableLockMode; FCurDat: TBRBuffer; FCursor: TBRRecord; FDefs: TBRRecord; FOptions: TSRLTableOptions; Procedure SetOptions(Value:TSRLTableOptions); Procedure SetFieldDefs(Value:TBRRecord); Private FOnLocked: TSRLTableLockedEvent; FOnWriteHeader: TSRLTableWriteDescriptorEvent; FOnReadHeader: TSRLTableReadDescriptorEvent; Private Function GetRecordIndex:Integer; Procedure SetRecordIndex(Const Value:Integer); Function GetRecordCount:Integer; Protected Procedure WriteRecord(Const Data:TBRBuffer; Const Disposable:Boolean=False); Procedure ReadRecord(Const Data:TBRBuffer); Protected Procedure SignalTableLocked; procedure DoAfterOpen;override; Procedure DoAfterClose;override; Procedure DoWriteDescriptor(Const Writer:TBRWriter);override; Procedure DoReadDescriptor(Const Reader:TBRReader);override; Public Property Options:TSRLTableOptions read FOptions write SetOptions; Property FieldDefs:TBRRecord read FDefs write SetFieldDefs; { Property Reader:TSRLRecordReader read FRecRead; Property Writer:TSRLRecordWriter read FRecWrite; } Property Cursor:TBRRecord read FCursor; Property Filename; Property LockMode:TSRLTableLockMode read FlockMode; Property RecNo:Integer read GetRecordIndex write SetRecordIndex; Property RecordCount:Integer read GetRecordCount; Function BOF:Boolean; Function EOF:Boolean; Function First:Boolean; Function Last:Boolean; Function Next:Boolean; Function Previous:Boolean; Procedure Delete; Function FindFirst(Keyword:String;FieldName:String; var SearchRec:TSRLSearchRec):Boolean; Function FindNext(var SearchRec:TSRLSearchRec):Boolean; Procedure Post(Const UnLockState:Boolean=False); Function Lock(Const Value:TSRLTableLockMode):Boolean; Procedure UnLock; Constructor Create;override; Destructor Destroy;Override; Public Property OnWriteDescriptor: TSRLTableWriteDescriptorEvent Read FOnWriteHeader write FOnWriteHeader; Property OnReadDescriptor:TSRLTableReadDescriptorEvent Read FOnReadHeader write FOnReadHeader; Property OnBeforeOpen; Property OnBeforeClose; Property OnAfterOpen; Property OnAfterClose; Property OnTableLocked:TSRLTableLockedEvent read FOnLocked write FOnLocked; End; implementation const ERR_SRLBitBuffer_InvalidBitIndex = 'Invalid bit index, expected 0..%d not %d'; ERR_SRLBitBuffer_InvalidByteIndex = 'Invalid byte index, expected 0..%d not %d'; ERR_SRLBitBuffer_BitBufferEmpty = 'Bitbuffer is empty error'; //########################################################################## // TBRBitBuffer //########################################################################## Destructor TBRBitBuffer.Destroy; Begin If not Empty then Release; inherited; end; Procedure TBRBitBuffer.BeforeReadObject; Begin inherited; If FData<>NIL then Release; end; procedure TBRBitBuffer.ReadObject(Const Reader:TBRReader); Begin inherited; If Reader.ReadBool then Begin Allocate(Reader.ReadInt); Reader.Read(FData^,FDataLen); end; end; procedure TBRBitBuffer.WriteObject(Const Writer:TBRWriter); Begin inherited; Writer.WriteBool(Empty=False); If FData<>NIL then Begin Writer.WriteInt(FDataLen); Writer.Write(FData^,FDataLen); end; end; Function TBRBitBuffer.Empty:Boolean; Begin result:=FData=NIL; end; Function TBRBitBuffer.GetByte(Const Index:Integer):Byte; Begin If FData<>NIL then Begin If (index>=0) and (Index<FDataLen) then result:=PByte(PTR(FDataLng + index))^ else Raise Exception.CreateFmt (ERR_SRLBitBuffer_InvalidByteIndex,[FDataLen-1,index]); end else Raise Exception.Create(ERR_SRLBitBuffer_BitBufferEmpty); end; Procedure TBRBitBuffer.SetByte(Const Index:Integer;Const Value:Byte); Begin If FData<>NIL then Begin If (index>=0) and (Index<FDataLen) then PByte(PTR(FDataLng + index))^:=Value else Raise Exception.CreateFmt (ERR_SRLBitBuffer_InvalidByteIndex,[FDataLen-1,index]); end else Raise Exception.Create(ERR_SRLBitBuffer_BitBufferEmpty); end; Procedure TBRBitBuffer.SetBitRange(First,Last:Longword; Const Bitvalue:Boolean); procedure LSwap(var aFirst,aSecond:Longword); var mTemp: Longword; Begin mTemp:=aSecond; aSecond:=aFirst; aFirst:=aSecond; end; Function SRLDiff(Const Primary,Secondary:Longword; Const Exclusive:Boolean=False):Longword; Begin If Primary<>Secondary then Begin If Primary>Secondary then result:=Primary-Secondary else result:=Secondary-Primary; If Exclusive then If (Primary<1) or (Secondary<1) then inc(result); end else result:=0; end; var x: Longword; FLongs: Integer; FSingles: Integer; FCount: Longword; Begin If FData<>NIL then Begin If First<FBitsMax then Begin If Last<FBitsMax then Begin (* Conditional swap *) If First>Last then LSwap(First,Last); (* get totals, take ZERO into account *) FCount:=SRLDiff(First,Last,True); (* use refactoring & loop reduction *) FLongs:=Integer(FCount shr 3); x:=First; while FLongs>0 do Begin SetBit(x,Bitvalue);inc(x); SetBit(x,Bitvalue);inc(x); SetBit(x,Bitvalue);inc(x); SetBit(x,Bitvalue);inc(x); SetBit(x,Bitvalue);inc(x); SetBit(x,Bitvalue);inc(x); SetBit(x,Bitvalue);inc(x); SetBit(x,Bitvalue);inc(x); dec(FLongs); end; (* process singles *) FSingles:=Integer(FCount mod 8); while FSingles>0 do Begin SetBit(x,Bitvalue);inc(x); dec(FSingles); end; end else Begin If First=Last then SetBit(First,True) else Raise Exception.CreateFmt (ERR_SRLBitBuffer_InvalidBitIndex,[FBitsMax,Last]); end; end else Raise Exception.CreateFmt(ERR_SRLBitBuffer_InvalidBitIndex, [FBitsMax,First]); end else Raise Exception.Create(ERR_SRLBitBuffer_BitBufferEmpty); end; Procedure TBRBitBuffer.SetBits(Const Value:Array of longword; Const BitValue:Boolean); var x: Integer; FCount: Integer; Begin If FData<>NIL then Begin FCount:=length(Value); If FCount>0 then Begin for x:=low(Value) to High(Value) do SetBit(Value[x],BitValue); end; end else Raise Exception.Create(ERR_SRLBitBuffer_BitBufferEmpty); end; Function TBRBitBuffer.FindIdleBit(var Value:Longword; Const FromStart:Boolean=False):Boolean; var FOffset: Longword; FBit: Longword; FAddr: PByte; x: Integer; Begin result:=FData<>NIL; if result then Begin (* Initialize *) FAddr:=FData; FOffset:=0; If FromStart then FReadyByte:=0; If FReadyByte<1 then Begin (* find byte with idle bit *) While FOffset<Longword(FDataLen) do Begin If TBRBuffer.BitsSetInByte(FAddr^)=8 then Begin inc(FOffset); inc(FAddr); end else break; end; end else inc(FOffset,FReadyByte); (* Last byte exhausted? *) result:=FOffset<Longword(FDataLen); If result then Begin (* convert to bit index *) FBit:=FOffset shl 3; (* scan byte with free bit in it *) for x:=1 to 8 do Begin If not GetBit(FBit) then Begin Value:=FBit; (* more than 1 bit available in byte? remember that *) FAddr:=FData; inc(FAddr,FOffset); If TBRBuffer.BitsSetInByte(FAddr^)>7 then FReadyByte:=0 else FReadyByte:=FOffset; Break; end; inc(FBit); end; end; end; end; Function TBRBitBuffer.GetBit(Const Index:Longword):Boolean; begin If FData<>NIL then Begin If index<FBitsMax then Begin FAddr:=PTR(FDataLng + Integer(index shr 3)); BitOfs:=Index mod 8; Result:=(FAddr^ and (1 shl (BitOfs mod 8))) <> 0; end else Raise Exception.CreateFmt (ERR_SRLBitBuffer_InvalidBitIndex,[Count-1,index]); end else Raise Exception.Create(ERR_SRLBitBuffer_BitBufferEmpty); end; Procedure TBRBitBuffer.SetBit(Const Index:Longword;Const Value:Boolean); begin If FData<>NIL then Begin If index<=FBitsMax then Begin FByte:=PByte(FDataLng + Integer(index shr 3))^; BitOfs:=Index mod 8; If Value then Begin (* set bit if not already set *) If (FByte and (1 shl (BitOfs mod 8)))=0 then Begin FByte:=(FByte or (1 shl (BitOfs mod 8))); PByte(FDataLng + Integer(index shr 3))^:=FByte; (* if this was the "ready" byte, then reset it to zero *) If (Index shr 3=FReadyByte) and (FReadyByte>0) then Begin If TBRBuffer.BitsSetInByte(FByte)>7 then FReadyByte:=0; end; end; end else Begin (* clear bit if not already clear *) If (FByte and (1 shl (BitOfs mod 8)))<>0 then Begin FByte:=(FByte and not (1 shl (BitOfs mod 8))); PByte(FDataLng + Integer(index shr 3))^:=FByte; (* remember this byte pos *) FReadyByte:=Index shr 3; end; end; end else Raise Exception.CreateFmt (ERR_SRLBitBuffer_InvalidBitIndex,[Count-1,index]); end else Raise Exception.Create(ERR_SRLBitBuffer_BitBufferEmpty); end; Procedure TBRBitBuffer.Allocate(MaxBits:Integer); Function SRLToNearest(Const Value,Factor:Integer):Integer; var FTemp: Integer; Begin Result:=Value; FTemp:=Value mod Factor; If FTemp>0 then inc(Result,Factor - FTemp); end; Begin (* release buffer if not empty *) If FData<>NIL then Release; If Maxbits>0 then Begin (* Round off to nearest byte *) MaxBits:=SRLToNearest(MaxBits,8); (* Allocate new buffer *) try FReadyByte:=0; FDataLen:=MaxBits shr 3; FData:=AllocMem(FDataLen); FDataLng:=Longword(FData); FBitsMax:=Longword(FDataLen shl 3); except on e: exception do Begin FData:=NIL; FDataLen:=0; FBitsMax:=0; FDataLng:=0; Raise; end; end; end; end; Procedure TBRBitBuffer.Release; Begin If FData<>NIL then Begin try FreeMem(FData); finally FReadyByte:=0; FData:=NIL; FDataLen:=0; FBitsMax:=0; FDataLng:=0; end; end; end; Procedure TBRBitBuffer.Zero; Begin If FData<>NIL then Fillchar(FData^,FDataLen,0) else Raise Exception.Create(ERR_SRLBitBuffer_BitBufferEmpty); end; //########################################################################### // TSRLTable //########################################################################### Constructor TSRLTable.Create; Begin inherited; FCurDat:=TBRBufferMemory.Create; FCursor:=TBRRecord.Create; //FCursor.Options:=[roExplicit]; FOptions:=[]; //toCompress FDefs:=TBRRecord.Create; //FRecRead:=FCursor.Reader; //FRecWrite:=FCursor.Writer; end; Destructor TSRLTable.Destroy; Begin FDefs.free; FCursor.free; FCurDat.free; inherited; end; Function TSRLTable.FindFirst(Keyword:String;FieldName:String; var SearchRec:TSRLSearchRec):Boolean; var FField: TBRRecordField; FText: String; Begin (* initialize the search record *) Fillchar(SearchRec,SizeOf(TSRLSearchRec),#0); Result:=Active; If result then Begin If FLockmode=lmNone then Begin Keyword:=trim(Keyword); FieldName:=Trim(FieldName); Result:=length(Keyword)>0; If result then Begin Result:=Length(FieldName)>0; If result then Begin FField:=FieldDefs.ObjectOf(FieldName); Result:=FField<>NIL; If result then Begin SearchRec.srId:=$125F; SearchRec.srFieldName:=FieldName; SearchRec.srKeyword:=Keyword; result:=RecordCount>0; If result then Begin First; While not EOF do Begin SearchRec.srCurrent:=RecNo; Result:=Lock(lmRead); If result then Begin try FText:=FCursor.Fields[fieldname].asString; //FText:=Reader.ReadString(FieldName); Result:=pos(Keyword,FText)>=1; If result then Break; finally Unlock; end; end; Next; end; end; end else Raise exception.Create('Search fieldname not found error'); end else Raise exception.Create('Invalid search fieldname error'); end else Raise exception.Create('Invalid search keyword error'); end else Raise exception.Create('Invalid lock-mode for search operation error'); end; end; Function TSRLTable.FindNext(var SearchRec:TSRLSearchRec):Boolean; var FText: String; Begin result:=SearchRec.srId=$125F; If result then Begin RecNo:=SearchRec.srCurrent; Next; While not EOF do Begin SearchRec.srCurrent:=RecNo; Result:=Lock(lmRead); If result then Begin try FText:=FCursor.Fields[SearchRec.srFieldName].asString; //FText:=Reader.ReadString(SearchRec.srFieldName); Result:=pos(SearchRec.srKeyword,FText)>=1; If result then Break; finally Unlock; end; end; Next; end; end; end; Procedure TSRLTable.SignalTableLocked; Begin If not QueryObjectState([osDestroying,osSilent]) {If not (osDestroying in ObjectState) and not (osSilent in ObjectState) } and assigned(FOnLocked) then FOnLocked(Self,FLockMode); end; Procedure TSRLTable.DoReadDescriptor(Const Reader:TBRReader); var mAccess: IBRPersistent; Begin inherited; FDefs.GetInterface(iBRPersistent,mAccess); mAccess.ObjectFrom(Reader); //IBRPersistent(FDefs).ObjectFrom(Reader); If assigned(FOnReadHeader) then FOnReadHeader(self,Reader); end; Procedure TSRLTable.DoWriteDescriptor(Const Writer:TBRWriter); var mAccess: IBRPersistent; Begin inherited; FDefs.GetInterface(IBRPersistent,mAccess); mAccess.ObjectTo(Writer); //IBRPersistent(FDefs).ObjectTo(Writer); If assigned(FOnWriteHeader) then FOnWriteHeader(self,Writer); end; procedure TSRLTable.DoAfterOpen; Begin inherited; FRecNo:=-1; FCursor.Assign(FDefs); //FCursor.Allocate; //IBRRecordFieldDefs(FCursor.FieldDefs).SetReadOnly(True); end; Procedure TSRLTable.DoAfterClose; Begin inherited; FRecNo:=-1; //ISRLRecordFieldDefs(FCursor.FieldDefs).SetReadOnly(False); FCursor.Clear; end; Function TSRLTable.GetRecordCount:Integer; Begin If Active then result:=inherited GetSequenceCount else Raise exception.Create('Table is not active error'); end; Function TSRLTable.GetRecordIndex:Integer; Begin result:=FRecNo; end; Procedure TSRLTable.SetFieldDefs(Value:TBRRecord); Begin If not Active then FDefs.Assign(Value); end; Procedure TSRLTable.SetOptions(Value:TSRLTableOptions); Begin If not Active then FOptions:=Value; end; Procedure TSRLTable.SetRecordIndex(Const Value:Integer); var FCount: Integer; Begin If Active then Begin If Value<>FRecNo then Begin If FLockmode=lmNone then Begin FCount:=GetSequenceCount; If (Value>=0) and (Value<FCount) then FRecNo:=Value else If Value=-1 then FRecNo:=-1 else If Value=FCount then FRecNo:=Value else Raise exception.CreateFmt ('Invalid record index error: expected 0..%d, not %d', [FCount-1,Value]); end; end; end; end; Function TSRLTable.BOF:Boolean; Begin If Active then result:=FRecNo<0 else result:=False; end; Function TSRLTable.EOF:Boolean; Begin result:=not Active; if not result then Result:=FRecNo>GetSequenceCount-1; end; Function TSRLTable.First:Boolean; Begin Result:=active; If Result then Begin Result:=FLockMode=lmNone; If result then Begin Result:=GetSequenceCount>0; If Result then SetRecordIndex(0); end; end; end; Function TSRLTable.Last:Boolean; var FCount: Integer; Begin Result:=Active; If Result then Begin Result:=FLockMode=lmNone; If result then Begin FCount:=GetSequenceCount; Result:=FCount>0; If Result then SetRecordIndex(FCount-1); end; end; end; Function TSRLTable.Next:Boolean; Begin Result:=active; If Result then Begin Result:=(FLockMode in [lmNone,lmRead]); If result then Begin Result:=EOF=False; if result then Begin If BOF then SetRecordIndex(0) else SetRecordIndex(FRecNo + 1); end; end; end; end; Function TSRLTable.Previous:Boolean; Begin Result:=active; If Result then Begin Result:=GetSequenceCount>0; If Result then Begin Result:=FLockMode=lmNone; If result then Begin Result:=FRecNo>0; if result then SetRecordIndex(FRecNo - 1); end; end; end; end; Procedure TSRLTable.Delete; Begin If Active then Begin If FLockMode=lmNone then Begin (* Make sure accessmode supports a write-lock *) If (AccessMode in [baCreate,baReadWrite]) then Begin If (RecordCount>0) and (FRecNo>=0) then Begin ReleaseSequence(FRecNo); If FRecNo>=GetSequenceCount then dec(FRecNo); If toAutoCompact in FOptions then Compact; end else Raise Exception.Create('Invalid records number error'); end else Raise Exception.Create('Invalid lock mode error, table does not allow modification'); end else Raise Exception.Create('Invalid lock mode error'); end; end; Function TSRLTable.Lock(Const Value:TSRLTableLockMode):Boolean; {var FTemp: TSRLData; } var mAccess: IBRPersistent; Begin Result:=Active; if result then Begin Result:=FLockMode=lmNone; If result then Begin Result:=Value>lmNone; if result then Begin (* Make sure accessmode supports a write-lock *) If (Value in [lmWrite,lmAppend,lmInsert]) then Result:=(AccessMode in [baCreate,baReadWrite]); If result then Begin (* make sure table can support a read-lock *) If (value=lmRead) then Result:=RecordCount>0; If result then Begin FLockmode:=Value; SignalTableLocked; If FLockMode=lmRead then Begin If (BOF=False) and (EOF=False) then Begin try ReadRecord(FCurDat); if FCursor.GetInterface(IBRPersistent,mAccess) then mAccess.ObjectFromData(FCurDat,false); //(FCursor).ObjectFromData(FCurDat,false); finally FCurDat.Release; end; end; end; end; end; end{ else Raise Exception.Create('Invalid lock mode error'); } end; //Raise Exception.Create('Table already in lock mode'); end; end; Procedure TSRLTable.UnLock; Begin If Active then Begin If FLockMode>lmNone then Begin FLockMode:=lmNone; SignalTableLocked; end; end; end; Procedure TSRLTable.Post(Const UnLockState:Boolean=False); var mAccess: IBRPersistent; Begin If Active and (FLockmode in [lmAppend,lmInsert]) then Begin try FCurDat.Release; if FCursor.GetInterface(IBRPersistent,mAccess) then mAccess.ObjectToData(FCurDat); //IBRPersistent(FCursor).ObjectToData(FCurDat); WriteRecord(FCurDat,false); finally FCurDat.Release; If UnLockState then UnLock; end; end; end; Procedure TSRLTable.WriteRecord(Const Data:TBRBuffer; Const Disposable:Boolean=False); var FCount: Integer; Begin If Active then Begin If (FLockMode in [lmWrite,lmAppend,lmInsert]) then Begin If Data<>NIL then Begin try If toCompress in FOptions then Data.Compress; FCount:=GetSequenceCount; Case FLockMode of lmAppend: begin AppendSequence(Data); FRecNo:=FCount; end; lmWrite: begin If FCount>0 then WriteSequence(FRecNo,Data) else Begin AppendSequence(Data); FRecNo:=FCount; end; end; lmInsert: Begin If FCount<1 then Begin AppendSequence(Data); FRecNo:=FCount; end else ReplaceSequence(FRecNo,Data); end; end; finally If disposable then Data.free; end; end else Raise Exception.Create('Invalid record data error'); end else Raise Exception.Create('table not in write mode error'); end; end; Procedure TSRLTable.ReadRecord(Const Data:TBRBuffer); var FCount: Integer; Begin If Active then Begin If FLockMode=lmRead then Begin If Data<>NIL then Begin (* release current data if not empty *) If Data.Size>0 then Data.Release; (* read record data *) FCount:=GetSequenceCount; If FCount>0 then Begin ReadSequence(FRecNo,Data); If toCompress in FOptions then Data.DeCompress; end else Raise Exception.Create('Table is empty error'); end else Raise Exception.Create('Invalid record data error'); end else Raise Exception.Create('table not in write mode error'); end; end; //########################################################################### // TSRLSequenceFile //########################################################################### Const CNT_BINFILE_MAJOR = 1; CNT_BINFILE_MINOR = 0; Constructor TSRLSequenceFile.Create; Begin inherited; {$IFDEF SRL_DB_DISKLIST} FSeqList:=LongwordFileList.Create; {$ELSE} FSeqList:=TList<Longword>.Create; {$ENDIF} end; Destructor TSRLSequenceFile.Destroy; Begin FSeqList.free; inherited; end; Procedure TSRLSequenceFile.SignalCompactingBegins; Begin If not QueryObjectState([osDestroying,osSilent]) {if not (osDestroying in ObjectState) and not (osSilent in ObjectState)} and assigned(FOnCompBegins) then FOnCompBegins(self); end; Procedure TSRLSequenceFile.SignalCompactingProgress(Value:Integer); Begin {if not (osDestroying in ObjectState) and not (osSilent in ObjectState) } If not QueryObjectState([osDestroying,osSilent]) and assigned(FOnCompProgress) then FOnCompProgress(self,Value * SizeOf(TSRLPageData)); end; Procedure TSRLSequenceFile.SignalCompactingEnds; Begin If not QueryObjectState([osDestroying,osSilent]) {if not (osDestroying in ObjectState) and not (osSilent in ObjectState)} and assigned(FOnCompEnds) then FOnCompEnds(self); end; Procedure TSRLSequenceFile.Compact; var FPages: Longword; FFree: Longword; FBack: TSRLPageData; FThis: TSRLPageData; FNext: TSRLPageData; FIndex: Integer; FDone: Integer; Begin If Active then Begin FPages:=GetPageCount; SignalCompactingBegins; FDone:=0; (* First, truncate file if the ending blocks are empty & not used *) //While GetPageIdleState(FPages-1)=False do While Bitmap.Bits[FPages-1]=False do Begin ShrinkPageFile(1); dec(FPages); inc(FDone); SignalCompactingProgress(FDone); end; While FBitmap.FindIdleBit(FFree,true) do Begin FPages:=GetPageCount; If (FFree<FPages) and (FFree>SRL_PageFile_BitsPages-1) then Begin try (* Read the current page *) ReadPage(FPages-1,FThis); (* Check for left-over blank page *) If (FThis.pdUsedBytes=0) and (FThis.pdPrevPage=0) and (FThis.pdNextPage=0) then Begin If FSeqlist.IndexOf(FPages-1)<0 then Begin ShrinkPageFile(1); //SetPageIdleState(FPages-1,false); Bitmap[FPages-1]:=False; inc(FDone); SignalCompactingProgress(FDone); Continue; end; end; (* read previous page if there *) If FThis.pdPrevPage>0 then ReadPage(FThis.pdPrevPage,FBack) else Begin (* This is a sequence-head. Look it up *) FIndex:=FSeqList.IndexOf(FPages-1); If FIndex>=0 then Begin FSeqList[FIndex]:=FFree; end; end; (* Read next page if there *) If FThis.pdNextPage>0 then ReadPage(FThis.pdNextPage,FNext); (* OK. Currentpage has moved *) If FThis.pdPrevPage>0 then FBack.pdNextPage:=FFree; If FThis.pdNextPage>0 then FNext.pdPrevPage:=FFree; (* write changes *) If FThis.pdPrevPage>0 then WritePage(FThis.pdPrevPage,FBack); If FThis.pdNextPage>0 then WritePage(FThis.pdNextPage,FNext); (* Now write page @ new location *) WritePage(FFree,FThis); (* Allocate new block *) Bitmap[FFree]:=True; //SetPageIdleState(FFree,True); (* Release current block *) Bitmap[FPages-1]:=False; //SetPageIdleState(FPages-1,False); (* shrink the database *) ShrinkPageFile(1); inc(FDone); SignalCompactingProgress(FDone); except on exception do Break; end; end else break; end; (* header needs to be re-written *) AddRequirement([brHeadWrite]); SignalCompactingEnds; end else Raise Exception.Create('Table is not active error'); end; Function TSRLSequenceFile.AppendSequenceEx(Const Data:TBRBuffer):Longword; var FNeeded: Integer; FItem: Longword; FPages: Array of Longword; FCount: Integer; x: Integer; FTemp: TSRLPageData; FOffset: Integer; Begin //result:=0; FNeeded:=Data.Size div SizeOf(Ftemp.pdData); If Data.Size mod SizeOf(Ftemp.pdData)> 0 then inc(FNeeded); (* reserve # of pages, grow if required *) FCount:=0; While FNeeded>0 do Begin (* locate a free page & mark as reserved *) FItem:=GetIdlePage; Bitmap[FItem]:=True; (* add reserved page to collection *) SetLength(FPages,FCount+1); FPages[FCount]:=FItem; inc(FCount); dec(FNeeded); end; FOffset:=0; //Fillchar(FTemp,SizeOf(FTemp),0); for x:=Low(FPages) to high(FPages) do Begin (* inter-link pages *) If x<High(FPages) then FTemp.pdNextPage:=FPages[x+1] else FTemp.pdNextPage:=0; If x>Low(FPages) then FTemp.pdPrevPage:=FPages[x-1] else FTemp.pdPrevPage:=0; (* get data into page *) FTemp.pdUsedBytes:=Data.Read (FOffset,SizeOf(Ftemp.pdData),FTemp.pdData); inc(FOffset,FTemp.pdUsedBytes); (* write page to disk *) WritePage(FPages[x],FTemp); end; result:=FPages[0]; If Length(FPages)>0 then AddRequirement([brHeadWrite]); end; Procedure TSRLSequenceFile.WriteSequence(Const Index:Integer; Const Data:TBRBuffer); var FOffset: Longword; Begin (* release current sequence data *) ReleaseSequenceEx(FSeqList[Index]); (* write new sequence content *) FOffset:=AppendSequenceEx(Data); (* insert new sequence start into list *) FSeqlist[index]:=FOffset; end; Procedure TSRLSequenceFile.ReplaceSequence(Const Index:Integer; Const Data:TBRBuffer); Begin (* register new data sequence and insert it @ new position *) FSeqList.Insert(Index,AppendSequenceEx(Data)); (* header needs to be re-written *) AddRequirement([brHeadWrite]); end; Function TSRLSequenceFile.AppendSequence(Const Data:TBRBuffer):Integer; Begin result:=0; If Data<>NIL then Begin (* register sequence & return sequence number *) Result:=FSeqList.add(AppendSequenceEx(Data)); (* header needs to be re-written *) AddRequirement([brHeadWrite]); end; end; Procedure TSRLSequenceFile.ReleaseSequenceEx(Const StartPage:Longword); var FStart: Longword; FTemp: TSRLPageData; FDummy: TSRLPageData; FBits: Array of longword; FCount: Integer; FNext: Longword; mTok: Longword; Begin (* Initialize *) FCount:=0; FStart:=StartPage; //Fillchar(FDummy,Sizeof(FDummy),'*'); FDummy.pdUsedBytes:=0; FDummy.pdPrevPage:=0; FDummy.pdNextPage:=0; While FStart>1 do Begin (* get current page from disk *) FNext:=ReadPage(FStart,FTemp); (* Insert page into bits array *) SetLength(FBits,FCount+1); FBits[FCount]:=FStart; inc(FCount); (* write empty page back to disk *) WritePage(FStart,FDummy); (* Do next page in sequence, we use swap so we can re-use the FNext variable after the loop *) mTok:=FNext; FNext:=FStart; FStart:=mTok; //SRLSwap(FStart,FNext); end; (* reset file bitmap bits *) If FCount>0 then FBitmap.SetBits(FBits,False) else FBitmap[FNext]:=False; end; Procedure TSRLSequenceFile.ReleaseSequence(Const Sequence:Integer); Begin ReleaseSequenceEx(FSeqlist[Sequence]); FSeqList.Delete(Sequence); end; Function TSRLSequenceFile.GetSequencePages(Sequence:Integer; var Value:TLongArray):Boolean; var FStart: Longword; FTemp: TSRLPageData; Begin SetLength(Value,0); result:=(Sequence>0) and (Sequence<FSeqList.Count-1); If result then Begin FStart:=FSeqList[Sequence]; SetLength(Value,1); Value[0]:=FStart; While FStart>1 do Begin (* read page content. Function returns PTR to next page *) FStart:=ReadPage(FStart,FTemp); If FStart>0 then Begin SetLength(Value,Length(Value)+1); Value[length(Value)-1]:=FStart; end; end; end; end; Procedure TSRLSequenceFile.ReadSequenceEx (Const StartPage:Longword;Const Data:TBRBuffer); var FStart: Longword; FTemp: TSRLPageData; Begin FStart:=StartPage; While FStart>1 do Begin (* read page content. Function returns PTR to next page *) FStart:=ReadPage(FStart,FTemp); (* extract page data *) If FTemp.pdUsedBytes>0 then Data.Append(FTemp.pdData,FTemp.pdUsedBytes); end; end; Function TSRLSequenceFile.GetSequenceCount:Integer; Begin result:=FSeqList.Count; end; Function TSRLSequenceFile.GetSequence(Const Index:Integer):Longword; Begin result:=FSeqList[index]; end; Procedure TSRLSequenceFile.ReadSequence (Const Sequence:Integer;Const Data:TBRBuffer); Begin ReadSequenceEx(FSeqList[Sequence],Data); end; Procedure TSRLSequenceFile.DoWriteDescriptor(Const Writer:TBRWriter); var x: Integer; Begin Writer.WriteInt(FSeqList.count); for x:=0 to FSeqList.Count-1 do Writer.WriteLong(FSeqList[x]); end; Procedure TSRLSequenceFile.DoReadDescriptor(Const Reader:TBRReader); var mCount: Integer; Begin mCount:=Reader.ReadInt; FSeqList.clear; while mCount>0 do begin FSeqList.add(Reader.ReadLong); dec(mCount); end; end; Procedure TSRLSequenceFile.DoWriteHeader(Const Writer:TBRWriter); Begin With Writer do Begin WriteAsc('$DB8'); (* Identifier *) WriteWord(SizeOf(TSRLPageData)); (* Page size *) WriteByte(CNT_BINFILE_MAJOR); (* Major version *) WriteByte(CNT_BINFILE_MINOR); (* Minor version *) WriteLong(FSeqStart); (* Sequence list pageIndex *) WriteAsc('SRL DB Engine, copyright JOLEAD EM'); end; end; Procedure TSRLSequenceFile.DoReadHeader(Const Reader:TBRReader); {var FTemp: AnsiString; } Begin If Reader.ReadAsc='$DB8' then Begin If Reader.ReadWord=SizeOf(TSRLPageData) then Begin Reader.ReadByte; Reader.ReadByte; FSeqStart:=Reader.ReadLong; // Get offset to record list {FTemp:=Reader.ReadAsc; FTemp:=Reader.ReadString; } end else Raise Exception.Create('Incompatible page size error'); end else Raise Exception.Create('Unknown table format'); end; Procedure TSRLSequenceFile.DoBeforeOpen; Begin inherited; FSeqStart:=0; FSeqList.Clear; end; Procedure TSRLSequenceFile.DoAfterOpen; var FBuff: TBRBufferMemory; FReader: TBRReaderBuffer; Begin If FSeqStart>0 then Begin FBuff:=TBRBufferMemory.Create; try ReadSequenceEx(FSeqStart,FBuff); FReader:=TBRReaderBuffer.Create(FBuff); try DoReadDescriptor(FReader); finally FReader.free; end; If (Accessmode in [baCreate,baReadWrite]) then ReleaseSequenceEx(FSeqStart); finally FBuff.free; end; end; Inherited; End; Procedure TSRLSequenceFile.DoBeforeClose; var FBuffer: TBRBufferMemory; FWriter: TBRWriterBuffer; Begin If (Accessmode in [baCreate,baReadWrite]) then Begin (* append list data to file *) FBuffer:=TBRBufferMemory.Create; try FWriter:=TBRWriterBuffer.Create(FBuffer); try DoWriteDescriptor(FWriter); finally FWriter.free; end; FSeqStart:=AppendSequenceEx(FBuffer); finally FBuffer.free; end; (* Header must be re-written *) AddRequirement([brHeadWrite]); end; end; Procedure TSRLSequenceFile.DoAfterClose; Begin Inherited; //If not (osDestroying in ObjectState) then If not QueryObjectState([osDestroying]) then FSeqList.Clear; end; //########################################################################### // TSRLPageFile //########################################################################### Constructor TSRLPageFile.Create; Begin inherited; //FBitBuffer:=TBRBufferMemory.Create; //FBitmap:=TBRBitAccess.Create(FBitBuffer); FBitmap:=TBRBitBuffer.Create; FFileMode:=baNone; FRequires:=[]; end; Destructor TSRLPageFile.Destroy; Begin FBitmap.free; //FBitBuffer.Free; inherited; end; Procedure TSRLPageFile.BeforeDestruction; Begin inherited; If FActive then Close; end; Procedure TSRLPageFile.WriteBitBuffer; var x: Integer; FTemp: PSRLPageData; Begin FTemp:=FBitmap.Data; ///FTemp:=PSRLPageData(FBitBuffer.Data); for x:=1 to SRL_PageFile_BitsPages do Begin WritePage(x,FTemp^); inc(FTemp); end; end; Procedure TSRLPageFile.ReadBitBuffer; var x: Integer; FTemp: PSRLPageData; Begin If FBitmap.Empty then //FBitBuffer.Size:=SRL_PageFile_BitsBytes; FBitmap.Allocate(SRL_PageFile_BitsTotal); x:=1; FTemp:=FBitmap.Data; //FTemp:=PSRLPageData(FBitBuffer.Data); While x<SRL_PageFile_BitsPages do Begin ReadPage(x,FTemp^); inc(FTemp); inc(x); end; end; Function TSRLPageFile.GetIdlePage(Const AllowGrow:Boolean=True):Longword; Begin {If FActive then Begin } If not FBitmap.FindIdleBit(Result,false) then Begin If AllowGrow then //and (FFileMode in [baCreate,baReadWrite]) then Result:=GrowPageFile(1) else result:=0; end; {end else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTACTIVE);} end; { Function TSRLPageFile.GetPageIdleState(Const PageIndex:Longword):Boolean; Begin Result:=FBitmap[PageIndex]; end; Procedure TSRLPageFile.SetPageIdleState(Const PageIndex:Longword; Const Value:Boolean); Begin FBitmap[PageIndex]:=Value; AddRequirement([brHeadWrite]); end; } Procedure TSRLPageFile.AddRequirement(Const Value:TSRLBinaryRequirement); begin If FActive then FRequires:=FRequires + Value else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTACTIVE); end; Procedure TSRLPageFile.DelRequirement(Const Value:TSRLBinaryRequirement); Begin If FActive then FRequires:=FRequires - Value else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTACTIVE); end; Procedure TSRLPageFile.ApplyRequirements; Begin If FActive then Begin If (FFileMode in [baCreate,baRead,baReadWrite]) then Begin (* Read header if required *) If (brHeadRead in FRequires) then Begin ReadHeaderData; FRequires:=FRequires - [brHeadRead]; end; (* write header if required *) If (brHeadWrite in FRequires) then Begin WriteHeaderData; FRequires:=FRequires - [brHeadWrite]; end; end; end else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTACTIVE); end; Procedure TSRLPageFile.Open; Begin If FActive then Close; SignalBeforeOpen; DoBeforeOpen; FActive:=True; FFileMode:=baCreate; //FBitBuffer.Size:=qtxdb.SRL_PageFile_BitsBytes; FBitmap.Allocate(SRL_PageFile_BitsTotal); try FFile:=TMemoryStream.Create; (* reserve header Page *) Bitmap[0]:=True; //SetPageIdleState(0,True); (* reserve pages for file-bitmap bits *) FBitmap.SetBitRange(1,SRL_PageFile_BitsPages,True); AddRequirement([brHeadWrite]); ApplyRequirements; except on e: exception do Begin FActive:=False; FFileMode:=baNone; FRequires:=[]; FBitmap.Release; //FBitBuffer.Release; If FFile<>NIL then FreeAndNil(FFile); Raise Exception.Create(e.Message); //Raise Exception.Create(e.message); end; end; FInMemory:=True; FFilename:=''; DoAfterOpen; SignalAfterOpen; end; Procedure TSRLPageFile.Open(Const Filename:AnsiString; Const AccessMode:TSRLBinaryAccessMode = baReadWrite); var FTemp: Word; Begin If FActive then Close; If AccessMode>baNone then Begin SignalBeforeOpen; DoBeforeOpen; (* check that file exists & if read or write mode applies *) If (AccessMode in [baRead,baReadWrite]) then Begin if not FileExists(Filename) then Raise Exception.CreateFmt(ERR_SRL_PAGEFILE_FILENOTFOUND,[Filename]); end; FActive:=True; FFileMode:=AccessMode; FBitmap.Allocate(SRL_PageFile_BitsTotal); Case AccessMode of baCreate: FTemp:=fmCreate; baRead: FTemp:=fmOpenRead; baReadWrite: FTemp:=fmOpenReadWrite; else FTemp:=fmOpenRead; End; try FFile:=TFileStream.Create(Filename,FTemp); If AccessMode=baCreate then Begin (* reserve pages for file-bitmap bits *) FBitmap.SetBitRange(0,SRL_PageFile_BitsPages,True); self.GrowPageFile(1); //Header self.GrowPageFile(SRL_PageFile_BitsPages); AddRequirement([brHeadWrite]); end else AddRequirement([brHeadRead]); ApplyRequirements; except on e: exception do Begin FActive:=False; FFileMode:=baNone; FRequires:=[]; //FBitBuffer.Release; FBitmap.Release; If FFile<>NIL then FreeAndNil(FFile); Raise Exception.Create(e.message); end; end; FFilename:=Filename; DoAfterOpen; SignalAfterOpen; end; end; Procedure TSRLPageFile.SaveToFile(Const Filename:String); var FTemp: TFileStream; Begin If FActive then Begin If FInMemory then Begin AddRequirement([brHeadWrite]); ApplyRequirements; FTemp:=TFileStream.Create(Filename,fmCreate); try FFile.Position:=0; FTemp.CopyFrom(FFile,FFile.Size); finally FTemp.free; end; end else raise Exception.Create('Only in-memory tables can be saved'); end; end; Procedure TSRLPageFile.Close; Begin If FActive then Begin SignalBeforeClose; DoBeforeClose; try If FRequires<>[] then ApplyRequirements; finally FreeAndNil(FFile); FRequires:=[]; FFileName:=''; FFileMode:=baNone; FActive:=False; FInMemory:=False; FBitmap.Release; //FBitBuffer.Release; SignalAfterClose; DoAfterClose; end; end; end; Procedure TSRLPageFile.DoWriteHeader(Const Writer:TBRWriter); Begin end; Procedure TSRLPageFile.DoReadHeader(Const Reader:TBRReader); Begin end; Function TSRLPageFile.GetCurrentPage:Longword; Begin result:=Longword(FFile.Position Div SizeOf(TSRLPageData)); end; Function TSRLPageFile.GetPageCount:Longword; Begin result:=Longword(FFile.Size Div SizeOf(TSRLPageData)); end; Procedure TSRLPageFile.SetCurrentPage(Const Value:Longword); Begin FFile.Position:=Int64(Value * SizeOf(TSRLPageData)); end; Procedure TSRLPageFile.WriteHeaderData; var FTemp: TSRLPageData; FWriter: TBRWriterMemory; begin If (FFileMode in [baCreate,baReadWrite]) then Begin (* The file header (page #0) is reserved and fixed. However, the content of the header page is not defined by this base class, decendant classes are free to write information to the header page - as long as it does not exceed the pagesize limit. NOTE: The content of the header will be clipped to the pagesize! *) Fillchar(FTemp,SizeOf(FTemp),0); FWriter:=TBRWriterMemory.Create(@FTemp,SizeOf(TSRLPageData)); try DoWriteHeader(FWriter); (* write header content *) WritePage(0,FTemp); (* Immediatly following the header-page, is the file bitmap. Each page in the file is represented as one bit. If the bit is set this means the page is occupied. If the bit is 0 (zero) the page does not contain data. The number of pages reserved for the file bitmap depends on the pagesize and page limitation. By default the maximum number of pages is set to 131072 (in bits), resulting in 16384 bytes. If the pagesize is 1024, the file bitmap reserves 16 pages *) WriteBitBuffer; finally FWriter.free; end; end; end; Procedure TSRLPageFile.ReadHeaderData; var FTemp: TSRLPageData; FReader: TBRReaderMemory; Begin (* read raw data *) Fillchar(FTemp,SizeOf(FTemp),0); ReadPage(0,FTemp); (* allow decendants to decode header *) FReader:=TBRReaderMemory.Create(@FTemp,SizeOf(FTemp)); try DoReadHeader(FReader); finally FReader.free; end; (* load file bitmap *) ReadBitBuffer; end; Function TSRLPageFile.GetCount:Longword; Begin If FActive then Result:=Longword( FFile.Size div SizeOf(TSRLPageData) ) else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTACTIVE); end; Procedure TSRLPageFile.ShrinkPageFile(Value:Longword); var FCount: Longword; FBytes: Int64; Begin If FActive then Begin If (FFileMode in [baCreate,baReadWrite]) then Begin FCount:=GetCount; If (Value>0) and (Value<FCount) then Begin FBytes:=Value * SizeOf(TSRLPageData); FFile.Size:=FFile.Size - FBytes; (* reset pages *) While Value>0 do Begin Bitmap[FCount-1]:=False; dec(Value); dec(FCount); end; AddRequirement([brHeadWrite]); end; end else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTWRITEMODE); end else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTACTIVE); end; Function TSRLPageFile.GrowPageFile(Value:Longword):Longword; var FTemp: TSRLPageData; FCount: Longword; Begin If FActive then Begin If (FFileMode in [baCreate,baReadWrite]) then Begin FCount:=GetCount; If (Value>0) and (FCount + Value < SRL_PageFile_BitsTotal) then Begin (* update count *) inc(FCount,Value); (* append empty blocks to file *) Fillchar(FTemp,SizeOf(FTemp),0); FFile.Position:=FFile.Size; While Value>0 do Begin FFile.WriteBuffer(FTemp,SizeOf(FTemp)); dec(Value); end; (* return new page count *) Result:=FCount; AddRequirement([brHeadWrite]); end else result:=0; end else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTWRITEMODE); end else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTACTIVE); end; Function TSRLPageFile.ReadPage(Const PageIndex:Longword; var Buffer:TSRLPageData):Longword; {$IFDEF SRL_DB_SEEKBUFFER} var FNewPos: Int64; FOldPos: Int64; FDiff: Int64; {$ENDIF} Begin If FActive then Begin {$IFDEF SRL_DB_SEEKBUFFER} FOldPos:=FFile.Position; FNewpos:=PageIndex * SizeOf(TSRLPageData); if FNewPos>FOldPos then Begin FDiff:=FNewPos - FOldPos; If FDiff<SRL_PageFile_SeekRange then FFile.Seek(FDiff,soCurrent) else FFile.Position:=FNewPos; end else if FNewpos<FOldPos then Begin FDiff:=FOldPos - FNewPos; If FDiff<SRL_PageFile_SeekRange then FFile.Seek(-FDiff,soCurrent) else FFile.Position:=FNewPos; end; {$ELSE} If Longword(FFile.Position Div SizeOf(TSRLPageData)) <> PageIndex then FFile.Position:=Int64(PageIndex * SizeOf(TSRLPageData)); {$ENDIF} FFile.ReadBuffer(Buffer,SizeOf(Buffer)); result:=Buffer.pdNextPage; end else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTACTIVE); end; Procedure TSRLPageFile.WritePage(Const PageIndex:Longword; Const Buffer:TSRLPageData); {$IFDEF SRL_DB_SEEKBUFFER} var FNewPos: Int64; FOldPos: Int64; FDiff: Int64; {$ENDIF} Begin If FActive then Begin {$IFDEF SRL_DB_SEEKBUFFER} FOldPos:=FFile.Position; FNewpos:=PageIndex * SizeOf(TSRLPageData); if FNewPos>FOldPos then Begin FDiff:=FNewPos - FOldPos; If FDiff<SRL_PageFile_SeekRange then FFile.Seek(FDiff,soCurrent) else FFile.Position:=FNewPos; end else if FNewpos<FOldPos then Begin FDiff:=FOldPos - FNewPos; If FDiff<SRL_PageFile_SeekRange then FFile.Seek(-FDiff,soCurrent) else FFile.Position:=FNewPos; end; {$ELSE} If Longword(FFile.Position Div SizeOf(TSRLPageData)) <> PageIndex then FFile.Position:=Int64(PageIndex * SizeOf(TSRLPageData)); {$ENDIF} FFile.WriteBuffer(Buffer,SizeOf(Buffer)); end else Raise Exception.Create(ERR_SRL_PAGEFILE_NOTACTIVE); end; Procedure TSRLPageFile.SignalBeforeOpen; Begin {If not (osDestroying in ObjectState) and not (osSilent in ObjectState) then} If not QueryObjectState([osDestroying,osSilent]) and assigned(FOnBeforeOpen) then FOnBeforeOpen(Self); end; Procedure TSRLPageFile.SignalBeforeClose; Begin {If not (osDestroying in ObjectState) and not (osSilent in ObjectState) } If not QueryObjectState([osDestroying,osSilent]) and assigned(FOnBeforeClose) then FOnBeforeClose(Self); end; Procedure TSRLPageFile.SignalAfterOpen; Begin {If not (osDestroying in ObjectState) and not (osSilent in ObjectState) } If not QueryObjectState([osDestroying,osSilent]) and assigned(FOnAfterOpen) then FOnAfterOpen(Self); end; Procedure TSRLPageFile.SignalAfterClose; Begin {If not (osDestroying in ObjectState) and not (osSilent in ObjectState)} If not QueryObjectState([osDestroying,osSilent]) and assigned(FOnAfterClose) then FOnAfterClose(Self); end; Procedure TSRLPageFile.DoBeforeOpen; Begin end; procedure TSRLPageFile.DoAfterOpen; Begin end; Procedure TSRLPageFile.DoBeforeClose; Begin end; Procedure TSRLPageFile.DoAfterClose; Begin end; end.
Fun with nested classes
A bit overkill, but fun none the less. This post is in reply to georgba on facebook. Here is an example of how to use nested classes. When compiled and you ship the DCU, it will be harder to resource your code.
TBaseDoc = Class(TObject) protected type TLoaderClass = Class(TObject) public function getFormatValue(aValue:Integer):String;virtual; End; strict protected function getAdapter:TLoaderClass;virtual; strict private FAdapter: TLoaderClass; public Property Adapter:TLoaderClass read FAdapter; Constructor Create;virtual; Destructor Destroy;Override; End; TTextDoc = Class sealed(TBaseDoc) protected type TLoaderClass = Class(TBaseDoc.TLoaderClass) public function getFormatValue(aValue:Integer):String;override; End; strict protected function getAdapter:TBaseDoc.TLoaderClass;override; end;
And ofcourse:
{ TBaseDoc } constructor TBaseDoc.Create; begin inherited Create; FAdapter:=getAdapter; end; destructor TBaseDoc.Destroy; begin FAdapter.Free; inherited; end; Function TBaseDoc.TLoaderClass.getFormatValue(aValue: Integer):String; begin raise exception.Create('NOT IMPLEMENTED'); end; function TBaseDoc.getAdapter:TLoaderClass; begin result:=TLoaderClass.Create; end; { TTextDoc } function TTextDoc.getAdapter:TBaseDoc.TLoaderClass; begin result:=TLoaderClass.Create; end; Function TTextDoc.TLoaderClass.getFormatValue(aValue: Integer):String; begin result:=IntToStr(aValue); end;
Recent
The vatican vault
- January 2022
- October 2021
- March 2021
- November 2020
- September 2020
- July 2020
- June 2020
- April 2020
- March 2020
- February 2020
- January 2020
- November 2019
- October 2019
- September 2019
- August 2019
- July 2019
- June 2019
- May 2019
- April 2019
- March 2019
- February 2019
- January 2019
- December 2018
- November 2018
- October 2018
- September 2018
- August 2018
- July 2018
- June 2018
- May 2018
- April 2018
- March 2018
- February 2018
- January 2018
- December 2017
- November 2017
- October 2017
- August 2017
- July 2017
- June 2017
- May 2017
- April 2017
- March 2017
- February 2017
- January 2017
- December 2016
- November 2016
- October 2016
- September 2016
- August 2016
- July 2016
- June 2016
- May 2016
- April 2016
- March 2016
- January 2016
- December 2015
- November 2015
- October 2015
- September 2015
- August 2015
- June 2015
- May 2015
- April 2015
- March 2015
- February 2015
- January 2015
- December 2014
- November 2014
- October 2014
- September 2014
- August 2014
- July 2014
- June 2014
- May 2014
- April 2014
- March 2014
- February 2014
- January 2014
- December 2013
- November 2013
- October 2013
- September 2013
- August 2013
- July 2013
- June 2013
- May 2013
- February 2013
- August 2012
- June 2012
- May 2012
- April 2012
You must be logged in to post a comment.