{$TPO-} // treat all pointer inc/dec's as byte adjusts
unit lists;
interface
type
int8 = shortInt;
int16 = smallInt;
int32 = longInt;
uInt8 = byte;
uInt16 = word;
uInt32 = dWord;
type
treeTypes = (BT_CUSTOM, BT_PCHAR, BT_STRING, BT_SINGLE, BT_DOUBLE, BT_INT32, BT_INT64);
PbNode = ^TbNode;
PbNodeData = ^TbNodeData;
TBlockRun = packed record
AG : int32;
start : uInt16;
len : uInt16;
end;
inodeAddr = TblockRun;
uPtr = packed record
case integer of
0: (i : int32);
1: (u : uInt32);
2: (s : single);
3: (d : double);
4: (p : pointer);
5: (bPtr : PbNode);
6: (offset : int64);
7: (iAddr : inodeAddr);
end;
PQueue = ^TQueue;
TQueue = object
private
queue : pointer;
elements : uInt32;
maxElements : uInt32;
size : uInt32;
head, tail : uInt32;
public
constructor init(elementCount, elementSize:uInt32);
function dequeue(var item):boolean;
function enqueue(var item):boolean;
function getElementCount:uInt32;
destructor done;
end; // TQueue
PBTreeVFS = ^TBTreeVFS;
TBTreeVFS = object
public
constructor init;
function fClose:boolean; virtual;
function fCreate(const filename:string):boolean; virtual;
function fExist(const filename:string):boolean; virtual;
function fOpen(const filename:string):boolean; virtual;
function fRead(var buf; size:uInt32):boolean; virtual;
function fSeek(offset:uInt32):boolean; virtual;
function fWrite(var buf; size:uInt32):boolean; virtual;
destructor done; virtual;
end; // TBTreeVFS
TbNodeData = packed record
link : uPtr;
key : record
case treeTypes of
BT_PCHAR,
BT_STRING: (str:string[1]);
BT_SINGLE: (s:single);
BT_DOUBLE: (d:double);
BT_INT32 : (i:int32);
BT_INT64 : (x:int64);
end; // record
end; // TbNodeData
TbNode = packed record
magic : uInt32;
tag : uInt32;
numKeys : uInt32;
size : uInt32;
left : uPtr;
right : uPtr;
parent : uPtr;
reserved : uPtr;
data : TbNodeData;
end; // TbNode
type
BTreeSearchRec = record
value : uPtr;
key : pointer;
keySize : integer;
end; {BTreeSearchRec}
type
PBTreeInfo = ^BTreeInfo;
BTreeInfo = packed record
magic : int64;
root : uPtr;
firstDeleted : uPtr;
nodes : uInt32;
height : uInt32;
keys : uInt32;
bNodeSize : uInt32;
treeType : treeTypes;
end; {BTreeHeader}
type compareKeyFunc = function(key1, key2:pointer):integer;
type copyKeyProc = procedure(srcKey, destKey:pointer);
type keySizeFunc = function(key:pointer):integer;
type
PbTree = ^bTree;
bTree = object
private
treeName : string;
compareKeys : compareKeyFunc;
copyKey : copyKeyProc;
keySize : keySizeFunc;
info : PBTreeInfo;
vfs : PBTreeVFS;
//dataFile : file;
memoryTree : boolean;
treeChanged : boolean;
function align(keyLength:integer):integer;
function allocEmptyNode:uPtr;
function calcSize(node:PbNode):integer;
procedure deAllocNode(node:PbNode);
function deleteEntry(u:uPtr; key:pointer; value:uPtr):uPtr;
procedure discardPage(node:PbNode);
function fetchFirstKey(u:uPtr; var searchRec:BTreeSearchRec):boolean;
function fetchLastKey(u:uPtr; var searchRec:BTreeSearchRec):boolean;
function findLeafNode(u:uPtr; key:pointer):uPtr;
procedure freeAll;
procedure freePage(u:uPtr);
function getAddress(node:PbNode):uPtr;
function getRoot:uPtr;
function getFirstDeleted:uPtr;
function getNodes:uInt32;
function getHeight:uInt32;
function getKeys:uInt32;
function insertEntry(u:uPtr; key:pointer; value:uPtr):boolean;
function isNull(u:uPtr):boolean;
function loadPage(u:uPtr):PbNode;
procedure loadSuperBlock;
procedure Print(var f:text; u:uPtr);
procedure PrintInfo(var f:text; u:uPtr);
function replaceEntry(u:uPtr; key:pointer; value:uPtr):boolean;
procedure savePage(node:PbNode);
procedure saveSuperBlock;
procedure setLeft(u:uPtr; newPtr:uPtr);
procedure setNull(var u:uPtr);
procedure setRight(u:uPtr; newPtr:uPtr);
procedure setParent(u:uPtr; newPtr:uPtr);
procedure setFirstDeleted(value:uPtr);
procedure setNodes(value:uInt32);
procedure setHeight(value:uInt32);
procedure setKeys(value:uInt32);
procedure setRoot(value:uPtr);
public
constructor init(const filename:string; nodeSize:uInt32; tt:treeTypes; virtualFS:PBTreeVFS);
constructor open(const filename:string; virtualFS:PBTreeVFS);
function Delete(key:pointer; value:uPtr):uPtr;
function Insert(key:pointer; value:uPtr):boolean;
procedure InstallUserFunctions(cmpFunc:compareKeyFunc; copyProc:copyKeyProc; ksFunc:keySizeFunc);
function Find(key:pointer; var u:uPtr):boolean;
procedure FindClose(var searchRec:BTreeSearchRec);
function FindFirst(key:pointer; var searchRec:BTreeSearchRec):boolean;
function FindNext(var searchRec:BTreeSearchRec):boolean;
function FindPrev(var searchRec:BTreeSearchRec):boolean;
function GetFirstKey(var searchRec:BTreeSearchRec):boolean;
function GetKeyCount:uInt32;
function GetTreeHeight:uInt32;
function GetLastKey(var searchRec:BTreeSearchRec):boolean;
procedure PrintList(const filename:string);
procedure PrintWholeTree(const filename:string);
destructor done; virtual;
end; // bTree
implementation
uses strings, dos;
const B_NODE_LEAF = $4641454C; // LEAF
const B_NODE_INDEX = $58444E49; // INDX
const B_NODE_OPEN = $4E45504F; // OPEN
const B_NODE_TREEINFO = $4F464E4945455254; // TREEINFO
type
PStandardVFS = ^TStandardVFS;
TStandardVFS = object(TBTreeVFS)
private
dataFile:file;
openFile:boolean;
public
constructor init;
function fClose:boolean; virtual;
function fCreate(const filename:string):boolean; virtual;
function fExist(const filename:string):boolean; virtual;
function fOpen(const filename:string):boolean; virtual;
function fRead(var buf; size:uInt32):boolean; virtual;
function fSeek(offset:uInt32):boolean; virtual;
function fWrite(var buf; size:uInt32):boolean; virtual;
destructor done; virtual;
end; // TStandardVFS
// TVFS virtual abstract functions
constructor TBTreeVFS.init;
begin
writeln('Don''t call the parent constructor');
end; // TBTreeVFS.init
function TBTreeVFS.fClose; result := FALSE;
function TBTreeVFS.fCreate; result := FALSE;
function TBTreeVFS.fExist; result := FALSE;
function TBTreeVFS.fOpen; result := FALSE;
function TBTreeVFS.fRead; result := FALSE;
function TBTreeVFS.fSeek; result := FALSE;
function TBTreeVFS.fWrite; result := FALSE;
destructor TBTreeVFS.done;
begin
writeln('Don''t call the parent destructor');
end; // TBTreeVFS.done
// TStandardVFS methods
constructor TStandardVFS.init;
begin
openFile := FALSE;
end; // TStandardVFS.init
function TStandardVFS.fClose;
begin
if (openFile) then {$I-} close(dataFile); {$I+}
openFile := (IOResult() <> 0);
result := not openFile
end; // TStandardVFS.fClose
function TStandardVFS.fCreate;
begin
assign(dataFile, filename);
{$I-} rewrite(dataFile, 1); {$I+}
openFile := (IOResult() = 0);
result := openFile
end; // TStandardVFS.fCreate
function TStandardVFS.fExist;
begin
result := (fSearch(filename, '') <> '')
end; // TStandardVFS.fExist
function TStandardVFS.fOpen;
begin
assign(dataFile, filename);
{$I-} reset(dataFile, 1); {$I+}
openFile := (IOResult() = 0);
result := openFile
end; // TStandardVFS.fOpen
function TStandardVFS.fRead;
var lResult:uInt32;
begin
blockread(dataFile, buf, size, lResult);
result := ((IOResult() = 0) and (lResult = size));
end; // TStandardVFS.fRead
function TStandardVFS.fSeek;
begin
{$I-} seek(dataFile, offset); {$I+}
result := (IOResult() = 0)
end; // TStandardVFS.fSeek
function TStandardVFS.fWrite;
var lResult:uInt32;
begin
// writeln('fWrite(dataFile, buf, ', count, ') @ position: ', filePos(dataFile));
blockwrite(dataFile, buf, size, lResult);
result := ((IOResult() = 0) and (lResult = size));
end; // TStandardVFS.fWrite
destructor TStandardVFS.done;
begin
if (openFile) then fClose();
end; // TStandardVFS.done
function compareKeyNull(key1, key2:pointer):integer; result := 0; // compareKeyNull
procedure copyKeyNull(srcKey, destKey:pointer); begin end; // copyKeyNull
function keySizeNull(key:pointer):integer; result := 0; // keySizeNull
(*
* CompareKey functions
*
*)
function compareKeyString(key1, key2:pointer):integer;
begin
result := 0;
if ((key1 = NIL) or (key2 = NIL)) then exit;
if string(key1^) < string(key2^) then
result := -1
else
if string(key1^) > string(key2^) then result := 1;
end; {comapreKeyString}
function compareKeyPChar(key1, key2:pointer):integer;
begin
result := 0;
if ((key1 = NIL) or (key2 = NIL)) then exit;
result := strcomp(pchar(key1), pchar(key2));
end; {compareKeyPChar}
function compareKeyDouble(key1, key2:pointer):integer;
begin
result := 0;
if ((key1 = NIL) or (key2 = NIL)) then exit;
if (double(key1^) < double(key2^)) then
result := -1
else
if (double(key1^) > double(key2^)) then result := 1;
end; {compareKeyDouble}
function compareKeySingle(key1, key2:pointer):integer;
begin
result := 0;
if ((key1 = NIL) or (key2 = NIL)) then exit;
if (single(key1^) < single(key2^)) then
result := -1
else
if (single(key1^) > single(key2^)) then result := 1;
end; {compareKeySingle}
function compareKeyInt32(key1, key2:pointer):integer;
begin
result := 0;
if ((key1 = NIL) or (key2 = NIL)) then exit;
if (int32(key1^) < int32(key2^)) then
result := -1
else
if (int32(key1^) > int32(key2^)) then result := 1;
end; {compareKeyInt32}
function compareKeyInt64(key1, key2:pointer):integer;
begin
result := 0;
if ((key1 = NIL) or (key2 = NIL)) then exit;
if (int64(key1^) < int64(key2^)) then
result := -1
else
if (int64(key1^) > int64(key2^)) then result := 1;
end; // compareKeyInt64
(*
* CopyKey functions
*
*)
procedure copyKeyPChar(srcKey, destKey:pointer);
begin
if ((srcKey = NIL) or (destKey = NIL)) then exit;
strcopy(pchar(destKey), pchar(srcKey));
end; {copyeKeyPChar}
procedure copyKeyString(srcKey, destKey:pointer);
begin
if ((srcKey = NIL) or (destKey = NIL)) then exit;
string(destKey^) := string(srcKey^);
end; {copyKeyString}
procedure copyKeySingle(srcKey, destKey:pointer);
begin
if ((srcKey = NIL) or (destKey = NIL)) then exit;
single(destKey^) := single(srcKey^);
end; {copyKeySingle}
procedure copyKeyDouble(srcKey, destKey:pointer);
begin
if ((srcKey = NIL) or (destKey = NIL)) then exit;
double(destKey^) := double(srcKey^);
end; {copyKeyDouble}
procedure copyKeyInt32(srcKey, destKey:pointer);
begin
if ((srcKey = NIL) or (destKey = NIL)) then exit;
int32(destKey^) := int32(srcKey^);
end; {copyKeyInt32}
procedure copyKeyInt64(srcKey, destKey:pointer);
begin
if ((srcKey = NIL) or (destKey = NIL)) then exit;
int64(destKey^) := int64(srcKey^);
end; {copyKeyInt64}
(*
* KeySize functions
*
*)
function keySizePChar(key:pointer):integer;
begin
result := 0;
if (key = NIL) then exit;
result := strlen(pchar(key))+1;
end; {keySizePChar}
function keySizeString(key:pointer):integer;
begin
result := 0;
if (key = NIL) then exit;
result := length(string(key^))+1;
end; {keySizeString}
function keySizeSingle(key:pointer):integer;
begin
if (key = NIL) then result := 0 else result := sizeof(single);
end; {keySizeSingle}
function keySizeDouble(key:pointer):integer;
begin
if (key = NIL) then result := 0 else result := sizeof(double);
end; {keySizeDouble}
function keySizeInt32(key:pointer):integer;
begin
if (key = NIL) then result := 0 else result := sizeof(int32);
end; {keySizeInt32}
function keySizeInt64(key:pointer):integer;
begin
if (key = NIL) then result := 0 else result := sizeof(int64);
end; {keySizeInt64}
(********************************)
function compareUPtrs(u1, u2:uPtr):boolean;
begin
result := (u1.offset = u2.offset)
end; // compareUPtrs
overload = = compareUPtrs;
(*
*
* B^Tree object methods
*
*)
(*
magic : int64;
root : uPtr;
firstDeleted : uPtr;
nodes : uInt32;
height : uInt32;
keys : uInt32;
bNodeSize : uInt32;
treeType : treeTypes;
*)
function bTree.getFirstDeleted;
begin
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.firstDeleted)-dword(info)) then runError;
if not vfs^.fRead(info^.firstDeleted, sizeof(info^.firstDeleted)) then RunError;
end;
result := info^.firstDeleted;
end;
function bTree.getNodes;
begin
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.nodes)-dword(info)) then RunError;
if not vfs^.fRead(info^.nodes, sizeof(info^.nodes)) then RunError;
end;
result := info^.nodes;
end;
function bTree.getHeight;
begin
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.height)-dword(info)) then RunError;
if not vfs^.fRead(info^.height, sizeof(info^.height)) then RunError;
end;
result := info^.height;
end;
function bTree.getKeys;
begin
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.keys)-dword(info)) then RunError;
if not vfs^.fRead(info^.keys, sizeof(info^.keys)) then RunError;
end;
result := info^.keys;
end;
function bTree.getRoot;
begin
if (info = NIL) then
begin
setNull(result);
exit;
end;
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.root)-dword(info)) then RunError;
if not vfs^.fRead(info^.root, sizeof(info^.root)) then RunError;
end;
result := info^.root;
end;
procedure bTree.setFirstDeleted;
begin
info^.firstDeleted := value;
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.firstDeleted)-dword(info)) then runError;
if not vfs^.fWrite(info^.firstDeleted, sizeof(info^.firstDeleted)) then RunError;
end;
end;
procedure bTree.setNodes;
begin
info^.nodes := value;
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.nodes)-dword(info)) then RunError;
if not vfs^.fWrite(info^.nodes, sizeof(info^.nodes)) then RunError;
end;
end;
procedure bTree.setHeight;
begin
info^.height := value;
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.height)-dword(info)) then RunError;
if not vfs^.fWrite(info^.height, sizeof(info^.height)) then RunError;
end;
end;
procedure bTree.setKeys;
begin
info^.keys := value;
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.keys)-dword(info)) then RunError;
if not vfs^.fWrite(info^.keys, sizeof(info^.keys)) then RunError;
end;
end;
procedure bTree.setRoot;
begin
info^.root := value;
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.root)-dword(info)) then RunError;
if not vfs^.fWrite(info^.root, sizeof(info^.root)) then RunError;
end;
end;
(*
procedure bTree.setRoot;
begin
info^.keys := value;
if not(memoryTree) then
begin
if not vfs^.fSeek(dword(@info^.keys)-dword(info)) then RunError;
if not vfs^.fWrite(info^.keys, sizeof(info^.keys)) then RunError;
end;
end;
*)
constructor bTree.init;
var lResult:longint;
begin
memoryTree := fileName = '';
treeName := filename;
// allocate the info section
// getmem(info, sizeof(BTreeInfo));
new(info);
if (info = NIL) then runError;
fillchar(info^, sizeof(BTreeInfo), 0);
vfs := virtualFS;
with info^ do
begin
magic := B_NODE_TREEINFO;
setNull(root);
setNull(firstDeleted);
nodes := 0;
height := 0;
keys := 0;
bNodeSize := nodeSize;
treeType := tt;
end; {with}
if not (memoryTree) then
begin
if (vfs = NIL) then vfs := new(PStandardVFS, init);
if (vfs^.fExist(filename)) then
begin
if not (vfs^.fOpen(filename)) then runError;
if not vfs^.fRead(info^, sizeof(BTreeInfo)) then writeln('Error reading in bTreeInfo');
end
else
begin
if not vfs^.fCreate(filename) then runError;
if not vfs^.fWrite(info^, sizeof(BTreeInfo)) then writeln('Error writing bTreeInfo');
end;
// if not vfs^.fClose() then runError;
// if not (vfs^.fOpen(filename, info^.bNodeSize)) then runError;
end;
case info^.treeType of
BT_CUSTOM : InstallUserFunctions(compareKeyNull, copyKeyNull, keySizeNull);
BT_PCHAR : InstallUserFunctions(compareKeyPChar, copyKeyPChar, keySizePChar);
BT_STRING : InstallUserFunctions(compareKeyString, copyKeyString, keySizeString);
BT_SINGLE : InstallUserFunctions(compareKeySingle, copyKeySingle, keySizeSingle);
BT_DOUBLE : InstallUserFunctions(compareKeyDouble, copyKeyDouble, keySizeDouble);
BT_INT32 : InstallUserFunctions(compareKeyInt32, copyKeyInt32, keySizeInt32);
BT_INT64 : InstalluserFunctions(compareKeyInt64, copyKeyInt64, keySizeInt64);
else
InstallUserFunctions(compareKeyNull, copyKeyNull, keySizeNull);
end; // case
treeChanged := FALSE; // The superblock of the tree hasn't been modified
end; // bTree.init
constructor bTree.open;
var
lResult:longint;
label safeExit;
begin
info := NIL;
memoryTree := FALSE;
treeChanged := FALSE; // The superblock of the tree hasn't been modified
treeName := filename;
InstallUserFunctions(compareKeyNull, copyKeyNull, keySizeNull);
//if (filename = '') or (fsearch(filename, '') = '') then begin writeln(filename, ' does not exist'); exit; end;
// allocate the info section
vfs := virtualFS;
if (vfs = NIL) then vfs := new(PStandardVFS, init);
if not vfs^.fExist(filename) then
begin
writeln('in bTree.open(): file does not exist');
goto safeExit;
end;
new(info);
fillchar(info^, sizeof(info^), 0);
if not vfs^.fOpen(filename) then runError;
if not vfs^.fRead(info^, sizeof(BTreeInfo)) then runError;
if (info^.magic <> B_NODE_TREEINFO) then runError;
// if not vfs^.fClose() then runError;
// vfs^.fOpen(filename, info^.bNodeSize);
case info^.treeType of
BT_CUSTOM : InstallUserFunctions(compareKeyNull, copyKeyNull, keySizeNull);
BT_PCHAR : InstallUserFunctions(compareKeyPChar, copyKeyPChar, keySizePChar);
BT_STRING : InstallUserFunctions(compareKeyString, copyKeyString, keySizeString);
BT_SINGLE : InstallUserFunctions(compareKeySingle, copyKeySingle, keySizeSingle);
BT_DOUBLE : InstallUserFunctions(compareKeyDouble, copyKeyDouble, keySizeDouble);
BT_INT32 : InstallUserFunctions(compareKeyInt32, copyKeyInt32, keySizeInt32);
BT_INT64 : InstalluserFunctions(compareKeyInt64, copyKeyInt64, keySizeInt64);
end; // case
safeExit:
end; // bTree.open
function bTree.align;
begin
result := ((sizeof(uptr) + keyLength + 7) shr 3) shl 3;
end; {bTree.align}
function bTree.allocEmptyNode;
var newNode:PbNode;
begin
saveSuperBlock();
setNull(result);
if (not isNull(getFirstDeleted())) then
begin
newNode := loadPage(getFirstDeleted());
if (newNode = NIL) then exit;
setFirstDeleted(newNode^.parent);
end
else
begin
getmem(newNode, info^.bNodeSize);
fillchar(newNode^, info^.bNodeSize, 0);
setNodes(getNodes() + 1);
// inc(info^.nodes);
newNode^.tag := getNodes();
end;
with newNode^ do
begin
magic := B_NODE_LEAF;
numKeys := 1;
size := dword(@newNode^.data) - dword(newNode);
setNull(left);
setNull(right);
setNull(parent);
setNull(reserved);
end; {with}
result := getAddress(newNode);
savePage(newNode);
discardPage(newNode);
// loadSuperBlock();
end; {bTree.allocEmptyNode}
function bTree.calcSize;
var
size:integer;
curNode:integer;
dataNode:PbNodeData;
begin
if (node = NIL) then exit;
dataNode := @node^.data;
size := dword(dataNode) - dword(node);
for curNode := 1 to node^.numKeys do
begin
inc(size, align(keySize(@dataNode^.key)));
inc(dataNode, align(keySize(@dataNode^.key)));
end;
if (node^.magic = B_NODE_INDEX) then inc(size, sizeof(uPtr));
result := size;
end;
procedure bTree.deAllocNode;
begin
if (node = NIL) then exit;
with node^ do
begin
magic := B_NODE_OPEN;
setNull(left);
setNull(right);
setNull(reserved);
if not memoryTree then parent := getFirstDeleted;
size := dword(@node^.data) - dword(node);
fillchar(data, info^.bNodeSize - size, 0);
end;
if not memoryTree then setFirstDeleted(getAddress(node));
savePage(node);
freemem(node, info^.bNodeSize);
end; {btree.deAllocNode}
function bTree.deleteEntry;
var
bnode, tmpNode, neighbor, parent : PbNode;
neighborSize:integer;
dataNode, nextDataNode, tmpDataNode:PbNodeData;
src, dst : pointer;
tmpLink:uPtr;
nodeSize:uInt32;
curNode, res, size: integer;
tmpTag:uInt32;
found : boolean;
procedure getNeighbor;
var
l, r:PbNode;
begin
neighbor := NIL;
neighborSize := 0;
l := loadPage(bnode^.left);
r := loadPage(bnode^.right);
if (l = NIL) then
begin
// this next check may be unecessary
if (r^.parent = bnode^.parent) then
begin
neighbor := r;
neighborSize := r^.size;
end;
exit
end;
if (r = NIL) then
begin
// this next check may be unecessary
if (l^.parent = bnode^.parent) then
begin
neighbor := l;
neighborSize := l^.size;
end;
exit
end;
if (l^.parent = r^.parent) then // left/right neighbors are children of the same parent
begin
if (l^.size < r^.size) then
begin
neighbor := l;
neighborSize := l^.size;
discardPage(r);
exit
end
else
begin
neighbor := r;
neighborSize := r^.size;
discardPage(l);
exit
end;
end
else // one of the neighbors has a different parent
begin
if (l^.parent = bnode^.parent) then
begin
neighbor := l;
neighborSize := l^.size;
discardPage(r);
exit
end
else
begin
neighbor := r;
neighborSize := r^.size;
discardPage(l);
exit
end;
end;
discardPage(l);
discardPage(r);
end; {getNeighbor local function}
begin
setNull(result);
if (isNull(u)) then exit;
bnode := loadPage(u);
if (bnode^.numKeys = 0) then runError; {this should never happen}
if (bnode^.magic = B_NODE_LEAF) then
begin
{ case info^.treeType of
BT_STRING:writeln(f, 'Deleting ', string(key^), ' size: ', align(keySize(key)));
BT_PCHAR:writeln(f, 'Deleting ', pchar(key));
end;}
dataNode := @bnode^.data;
curNode := 0;
repeat
res := compareKeys(@dataNode^.key, key);
if (res >= 0) then break;
inc(dataNode, align(keySize(@dataNode^.key)));
inc(curNode);
until (curNode = bnode^.numKeys);
if (res <> 0) then
begin
// writeln(f, 'Could not find in leaf node');
discardPage(bnode);
exit
end;
// Since we found the entry, we will have to save the
// superblock at the end. Set treeChanged to TRUE
treeChanged := TRUE;
result := dataNode^.link;
nodeSize := align(keySize(@dataNode^.key));
nextDataNode := dataNode;
inc(nextDataNode, nodeSize);
move(nextDataNode^, dataNode^, bnode^.size - (dword(nextDataNode) - dword(bnode)));
dec(bnode^.numKeys);
dec(bnode^.size, nodeSize);
dataNode := pointer(dword(bnode) + bnode^.size);
fillchar(dataNode^, nodeSize, 0);
setKeys(getKeys() - 1);
// dec(info^.keys);
// check for merges and other stuff
if (getAddress(bnode) = getRoot()) then
begin
if (bnode^.numKeys = 0) then
begin
setNull(info^.root);
setRoot(info^.root);
setHeight(getHeight() - 1);
//dec(info^.height);
deAllocNode(bnode);
exit;
end;
end
else // not root
begin
if (bnode^.size < (info^.bNodeSize / 2)) then
begin
getNeighbor;
if (neighbor <> NIL) and (neighborSize <> 0) then
begin
if (bnode^.size + neighborSize <= info^.bNodeSize) then
begin
//writeln(f, 'Merging leaf pages');
// if neighbor is a predecessor of bnode then swap them
if (getAddress(neighbor) = bnode^.left) then
begin
tmpNode := bnode;
bnode := neighbor;
neighbor := tmpNode;
end;
// merge the two nodes together
// bnode is the left node, neighbor is the right node
src := @neighbor^.data;
dst := pointer(dword(bnode) + bnode^.size);
size := neighbor^.size - (dword(src) - dword(neighbor));
move(src^, dst^, size);
inc(bnode^.size, size);
inc(bnode^.numKeys, neighbor^.numKeys);
setRight(bnode^.left, getAddress(neighbor));
bnode^.right := neighbor^.right;
tmpTag := neighbor^.tag; // save tag info
move(bnode^, neighbor^, info^.bNodeSize);
neighbor^.tag := tmpTag; // restore tag info
savePage(neighbor);
deleteEntry(bnode^.parent, NIL, getAddress(bnode));
discardPage(neighbor);
deAllocNode(bnode);
exit;
end //if (bnode^.size + neighborSize <= info^.bNodeSize)
else // "acquire" an entry from a neighbor
begin
if (getAddress(neighbor) = bnode^.right) then
begin
//writeln(f, 'acquiring from leaf bnode/neighbor');
// neighbor node is to the right. Append an entry from it to bnode
dataNode := @neighbor^.data;
src := dataNode;
dst := pointer(dword(bnode) + bnode^.size);
nodeSize := align(keySize(@dataNode^.key));
move(src^, dst^, nodeSize);
inc(bnode^.size, nodeSize);
inc(bnode^.numKeys);
nextDataNode := dataNode;
inc(nextDataNode, nodeSize);
move(nextDataNode^,
dataNode^,
neighbor^.size - (dword(dataNode) - dword(neighbor)) - nodeSize);
dec(neighbor^.size, nodeSize);
dec(neighbor^.numKeys);
// clear off the end of the neighbor node
dataNode := pointer(dword(neighbor) + neighbor^.size);
fillchar(dataNode^, nodeSize, 0);
savePage(bnode);
savePage(neighbor);
dataNode := dst;
replaceEntry(bnode^.parent, @dataNode^.key, getAddress(bnode));
end
else
begin
//writeln(f, 'acquiring from leaf neighbor/bnode');
// neighbor node is to the left. Take the last entry and prepend to bnode
dataNode := @neighbor^.data;
for curNode := 1 to neighbor^.numKeys-1 do
inc(dataNode, align(keySize(@dataNode^.key)));
// dataNode (hopefully) now points to the last key/value pair in neighbor
nodeSize := align(keySize(@dataNode^.key));
src := @bnode^.data;
dst := src;
inc(dst, nodeSize);
move(src^, dst^, bnode^.size - (dword(src) - dword(bnode)));
dst := src;
src := dataNode;
move(src^, dst^, nodeSize);
fillchar(src^, nodeSize, 0);
dec(neighbor^.size, nodeSize);
dec(neighbor^.numKeys);
inc(bnode^.size, nodeSize);
inc(bnode^.numKeys);
savePage(bnode);
savePage(neighbor);
// this can be optimized by storing the previous
// node from the for loop above
dataNode := @neighbor^.data;
for curNode := 1 to neighbor^.numKeys-1 do
inc(dataNode, align(keySize(@dataNode^.key)));
replaceEntry(neighbor^.parent, @dataNode^.key, getAddress(neighbor));
end; // else
discardPage(bnode);
discardPage(neighbor);
exit;
end;
end; //if (neighbor <> NIL) and (neighborSize <> 0)
discardPage(neighbor);
end; // if (bnode^.size < (info^.bNodeSize / 2))
end; {else not root}
end
else {not a leaf}
begin
dataNode := @bnode^.data;
nextDataNode := dataNode;
nodeSize := align(keySize(@dataNode^.key));
inc(nextDataNode, nodeSize);
found := FALSE;
for curNode := 1 to bnode^.numKeys do
begin
found := (dataNode^.link = value);
if (found) then break;
if (curNode <> bnode^.numKeys) then
begin
dataNode := nextDataNode;
nodeSize := align(keySize(@nextDataNode^.key));
inc(nextDataNode, nodeSize);
end;
end;
if (not found) then
begin
if (nextDataNode^.link = value) then
nextDataNode^.link := dataNode^.link
else
begin
// writeln(f, 'Could not find in index node');
discardPage(bnode);
exit;
end;
end;
{if (dataNode = nextDataNode) then inc(nextDataNode, align(keySize(@dataNode^.key)));}
// Copy this link into the next link so we can just delete this node
{nextDataNode^.link := dataNode^.link;}
fillchar(dataNode^, nodeSize, 0);
move(nextDataNode^, dataNode^, bnode^.size - (dword(nextDataNode) - dword(bnode)));
dec(bnode^.numKeys);
dec(bnode^.size, nodeSize);
dst := pointer(dword(bnode) + bnode^.size);
fillchar(dst^, nodeSize, 0);
// check for merges and other stuff
if (getAddress(bnode) = getRoot()) then
begin
if (bnode^.numKeys = 0) then
begin
dataNode := @bnode^.data;
//info^.root := dataNode^.link;
setRoot(dataNode^.link);
setHeight(getHeight() - 1);
//dec(info^.height);
deAllocNode(bnode);
///bnode := loadPage(info^.root);
bnode := loadPage(getRoot());
setNull(bnode^.parent);
savePage(bnode);
discardPage(bnode);
exit
end;
end
else {not root}
begin
if (bnode^.size < (info^.bNodeSize / 2)) then
begin
getNeighbor;
if (neighbor<>NIL) and (neighborSize<>0) then
begin
if (bnode^.size + neighborSize <= info^.bNodeSize) then
begin
//writeln(f, 'merging index pages');
// if neighbor is a predecessor of bnode then swap them
if (getAddress(neighbor) = bnode^.left) then
begin
tmpNode := bnode;
bnode := neighbor;
neighbor := tmpNode;
end;
// We need to get the key that currently resides between
// the bnode (left) link and the neighbor (right) link in the parent
parent := loadPage(bnode^.parent);
if (parent = NIL) then runError; // this would be bad
dataNode := @parent^.data;
for curNode := 0 to parent^.numKeys-1 do
begin
if (dataNode^.link = getAddress(bnode)) then break;
inc(dataNode, align(keySize(@dataNode^.key)));
end; {for}
// theoretically dataNode^.key is the key between the two links
size := align(keySize(@dataNode^.key));
if ((bnode^.size + neighbor^.size + size - (dword(@bnode^.data) - dword(bnode))) > info^.bNodeSize) then
begin
// The key wouldn't fit. bail
discardPage(parent);
savePage(neighbor);
savePage(bnode);
discardPage(neighbor);
discardPage(bnode);
exit;
end;
// copy the key to the end of bnode
src := @dataNode^.key;
dst := pointer(dword(bnode) + bnode^.size);
move(src^, dst^, keySize(@dataNode^.key));
inc(bnode^.numKeys); // we just added a key
dec(size, sizeof(uPtr));
inc(bnode^.size, size); // increment by aligned size
inc(dst, size); // also increment the dst by aligned size
discardPage(parent); // don't need the parent any more
// merge the two nodes together
// bnode is the left node, neighbor is the right node
src := @neighbor^.data;
// dst := pointer(dword(bnode) + bnode^.size); // set above
size := neighbor^.size - (dword(src) - dword(neighbor));
move(src^, dst^, size);
inc(bnode^.size, size);
inc(bnode^.numKeys, neighbor^.numKeys);
dataNode := @bnode^.data;
for curNode := 0 to bnode^.numKeys do
begin
setParent(dataNode^.link, getAddress(neighbor));
inc(dataNode, align(keySize(@dataNode^.key)));
end; {for}
setRight(bnode^.left, getAddress(neighbor));
bnode^.right := neighbor^.right;
tmpTag := neighbor^.tag; // save tag info
move(bnode^, neighbor^, info^.bNodeSize);
neighbor^.tag := tmpTag; // restore tag info
savePage(neighbor);
deleteEntry(bnode^.parent, NIL, getAddress(bnode));
deAllocNode(bnode);
discardPage(neighbor);
exit;
end
else // "acquire" an entry from a neighbor
begin
// we need to do one extra check
if (getAddress(neighbor) = bnode^.right) then
begin
tmpLink := getAddress(bnode);
tmpDataNode := @neighbor^.data;
end
else
begin
tmpLink := getAddress(neighbor);
tmpDataNode := @neighbor^.data;
for curNode := 1 to neighbor^.numKeys-1 do
inc(dataNode, align(keySize(@tmpDataNode^.key)));
end;
if (neighbor^.size - align(keySize(@tmpDataNode^.key)) < info^.bNodeSize / 2) then
begin
savePage(bnode);
discardPage(bnode);
discardPage(neighbor);
exit
end;
// get the key between the neighbor/bnode pair
parent := loadPage(bnode^.parent);
if (parent = NIL) then runError; // this would be bad
dataNode := @parent^.data;
for curNode := 1 to parent^.numKeys do
begin
if (dataNode^.link = tmpLink) then break;
inc(dataNode, align(keySize(@dataNode^.key)));
end; {for}
// theoretically dataNode^.key is the key between the two links
nodeSize := align(keySize(@dataNode^.key));
if (getAddress(neighbor) = bnode^.right) then
begin
//writeln(f, 'acquiring from index bnode/neighbor');
savePage(neighbor); // hmm.. did we change neighbor?
src := @dataNode^.key;
dataNode := @neighbor^.data;
savePage(bnode);
insertEntry(getAddress(bnode), src, dataNode^.link);
replaceEntry(getAddress(parent), @dataNode^.key, getAddress(bnode));
deleteEntry(getAddress(neighbor), NIL, dataNode^.link);
end
else // neighbor is to the left, bnode is to the right
begin
//writeln(f, 'acquiring from index neighbor/bnode');
// We need to take the key from the parent node, coupled with the
// last value in the neighbor, and insert them into bnode
// To do this we have to move everything in bnode over
src := @dataNode^.key;
nodeSize := align(keySize(@dataNode^.key));
dataNode := @bnode^.data;
nextDataNode := dataNode;
inc(nextDataNode, nodeSize);
move(dataNode^, nextDataNode^, bnode^.size - (dword(dataNode) - dword(bnode)));
// copy in the key
fillchar(dataNode^, nodeSize, 0);
move(src^, dataNode^.key, keySize(src));
// now we update the size and keys
inc(bnode^.size, nodeSize);
inc(bnode^.numKeys);
// we still have to insert the value and update the child's parent ptr
tmpDataNode := dataNode;
dataNode := @neighbor^.data;
for curNode := 1 to neighbor^.numKeys-1 do
inc(dataNode, align(keySize(@dataNode^.key)));
nextDataNode := dataNode;
inc(nextDataNode, align(keySize(@dataNode^.key)));
// insert the value
tmpDataNode^.link := nextDataNode^.link;
setParent(tmpDataNode^.link, getAddress(bnode));
// need to change the insert (don't forget to update the child's parent ptr)
// insertEntry(getAddress(bnode), src, nextDataNode^.link);
savePage(bnode);
savePage(neighbor);
replaceEntry(getAddress(parent), @dataNode^.key, getAddress(neighbor));
deleteEntry(getAddress(neighbor), NIL, nextDataNode^.link);
end;
discardPage(bnode);
discardPage(neighbor);
discardPage(parent);
exit;
end;
discardPage(neighbor);
end; // if (bnode^.size + neighborSize <= info^.bNodeSize) then
end; // if (bnode^.size < (info^.bNodeSize / 2)) then
end; // else not root
end; // not a leaf
savePage(bnode);
discardPage(bnode);
end; {bTree.deleteEntry}
procedure bTree.discardPage;
begin
// disk based trees allocate temporary memory to hold a page. So, if we're not
// a memory tree, dispose of the temp page
if not (memoryTree) then if (node <> NIL) then freemem(node, info^.bNodeSize);
end; {bTree.discardPage}
function bTree.getAddress;
var u:uPtr;
begin
setNull(u);
if (memoryTree) then
u.bPtr := node
else
u.offset := node^.tag; { * bNodeSize;}
result := u;
end; {bTree.getAddress}
(*
function bTree.getRoot;
begin
if (info = NIL) then
setNull(result)
else
result := info^.root;
end; // bTree.getRoot
*)
function bTree.insertEntry;
var
tmpUPtr, tmpRoot:uPtr;
dataNode, nextDataNode, prevDataNode:PbNodeData;
midKey:BTreeSearchRec;
keyLength, curNode, dataSize, res:integer;
bnode, newNode, rootNode:PbNode;
nodeSize:uInt32;
begin
result := FALSE;
if (key = NIL) then exit;
{ case info^.treeType of
BT_STRING:writeln(f, 'Inserting ', string(key^));
BT_PCHAR:writeln(f, 'Inserting ', pchar(key));
end;}
midKey.key := NIL;
midKey.keySize := 0;
keyLength := keySize(key);
if (keyLength = 0) or (keyLength > info^.bNodeSize) then exit;
// The superblock will have to be updated when the tree is destructed
// set treeChanged to TRUE
treeChanged := TRUE;
nodeSize := align(keyLength);
if (isNull(getRoot())) then ///
begin
///write('1');
(*
* This case should only occur once when a directory is first created.
*)
tmpRoot := allocEmptyNode();
// info^.root := allocEmptyNode();
if (isNull(tmpRoot)) then runError;
rootNode := loadPage(tmpRoot);
///info^.root := tmpRoot;
setRoot(tmpRoot);
setKeys(getKeys() + 1);
setHeight(getHeight() + 1);
//inc(info^.keys);
//inc(info^.height);
rootNode^.magic := B_NODE_LEAF;
dataNode := @rootNode^.data;
fillchar(dataNode^, nodeSize, 0);
dataNode^.link := value;
copyKey(key, @dataNode^.key);
inc(rootNode^.size, nodeSize); {hm.. should I add the sizeof the link?}
savePage(rootNode);
discardPage(rootNode);
result := TRUE;
exit
end;
bnode := loadPage(u);
if (bnode^.size + nodeSize <= info^.bNodeSize) then
begin
/// if not memoryTree then writeln('2');
dataNode := @bnode^.data;
curNode := 0;
repeat
res := compareKeys(key, @dataNode^.key);
if (res <= 0) then break;
inc(dataNode, align(keySize(@dataNode^.key)));
inc(curNode);
until curNode = bnode^.numKeys;
if (res = 0) then
begin
dataNode^.link := value;
savePage(bnode);
discardPage(bnode);
result := TRUE;
exit;
end;
nextDataNode := dataNode;
inc(nextDataNode, nodeSize); {cast to byte size records}
move(dataNode^, nextDataNode^, bnode^.size - (dword(dataNode) - dword(bNode)));
fillchar(dataNode^, nodeSize, 0);
copyKey(key, @dataNode^.key);
dataNode^.link := value;
if (bnode^.magic = B_NODE_INDEX) then
begin
if (not isNull(dataNode^.link)) then setParent(dataNode^.link, getAddress(bnode));
{ if (curNode = bnode^.numKeys) then
begin}
tmpUPtr := dataNode^.link;
dataNode^.link := nextDataNode^.link;
nextDataNode^.link := tmpUPtr;
{ end;}
end;
inc(bnode^.numKeys);
if (bnode^.magic = B_NODE_LEAF) then setKeys(getKeys() + 1); //inc(info^.keys);
inc(bNode^.size, nodeSize);
savePage(bnode);
end
else
begin
newNode := loadPage(allocEmptyNode());
if (newNode = NIL) then runError;
if not memoryTree then
begin
// If we're not a memory tree, then we should reload the page.
// This allows the B^Tree to be re-entrant.
discardPage(bnode);
bnode := loadPage(u); // reload it, because it could have changed?
end;
newNode^.magic := bnode^.magic;
newNode^.left := getAddress(bnode);
newNode^.right := bnode^.right;
newNode^.parent := bnode^.parent;
if not(isNull(newNode^.right)) then setLeft(newNode^.right, getAddress(newNode));
bnode^.right := getAddress(newNode);
dataNode := @bnode^.data;
{for curNode:=0 to (bnode^.numKeys div 2)-1 do
inc(dataNode, align(keySize(@dataNode^.key)));}
curNode := 1;
repeat
prevDataNode := dataNode;
inc(dataNode, align(keySize(@dataNode^.key)));
inc(curNode);
until (dword(dataNode) - dword(bnode) >= bnode^.size shr 1);
{midKey := dataNode;}
dataNode := prevDataNode;
midKey.keySize := keySize(@dataNode^.key);
GetMem(midKey.key, midKey.KeySize);
{if (midKey.key = NIL) then halt;}
copyKey(@dataNode^.key, midKey.key);
dec(curNode);
if (bnode^.magic = B_NODE_LEAF) then
begin
inc(dataNode, align(keySize(@dataNode^.key)));
dataSize := bnode^.size - (dword(dataNode) - dword(bnode));
move(dataNode^, newNode^.data, dataSize);
fillchar(dataNode^, dataSize, 0);
dec(bnode^.size, dataSize);
newNode^.size := dataSize + (dword(@newNode^.data) - dword(newNode));
newNode^.numKeys := bnode^.numKeys - curNode;
dec(bnode^.numKeys, newNode^.numKeys);
savePage(bnode);
savePage(newNode);
if memoryTree then /// <-- new check (re-entrancy)
begin
// The following code was original, but in order to allow for re-entrancy on
// disk based trees, we have to insert later (see last insertEntry() call in this
// function)
/// original code:
if (compareKeys(key, midKey.key) <= 0) then
insertEntry(getAddress(bnode), key, value)
else
insertEntry(getAddress(newNode), key, value);
/// end original code
end;
end
else // not a leaf
begin
inc(dataNode, align(keySize(@dataNode^.key)));
dataSize := bnode^.size - (dword(dataNode) - dword(bnode));
move(dataNode^, newNode^.data, dataSize);
fillchar(dataNode^, dataSize, 0);
dec(bnode^.size, dataSize);
// we need to adjust the size because we're taking out the midkey
// and we're also adding that extra pointer
dec(bnode^.size, align(keySize(midkey.key)));
inc(bnode^.size, sizeof(uPtr));
newNode^.size := dataSize + (dword(@newNode^.data) - dword(newNode));
newNode^.numKeys := bnode^.numKeys - curNode;
dec(bnode^.numKeys, newNode^.numKeys);
dec(bnode^.numKeys);
savePage(bnode);
savePage(newNode);
dataNode := @newNode^.data;
for curNode := 0 to newNode^.numKeys do
begin
setParent(dataNode^.link, getAddress(newNode));
inc(dataNode, align(keySize(@dataNode^.key)));
end;
//savePage(bnode);
if (compareKeys(key, midKey.key) <= 0) then
insertEntry(getAddress(bnode), key, value)
else
insertEntry(getAddress(newNode), key, value);
end;
(*
* If we were the root node, then create a new one
*)
if (getAddress(bnode) = getRoot()) then ///
begin
tmpRoot := allocEmptyNode();
// info^.root := allocEmptyNode;
rootNode := loadPage(tmpRoot);
///info^.root := tmpRoot;
setRoot(tmpRoot);
setParent(getAddress(bnode), getRoot()); ///
setParent(getAddress(newNode), getRoot()); ///
setHeight(getHeight() +1);
//inc(info^.height);
{dataNode := @newNode^.data; }
dataNode := @rootNode^.data;
with rootNode^ do
begin
magic := B_NODE_INDEX;
{numKeys := 1;}
dataNode^.link := getAddress(bnode);
keyLength := midKey.keySize;
copyKey(midKey.key, @dataNode^.key);
inc(size, align(keyLength));
inc(size, sizeof(uPtr));
inc(dataNode, align(keyLength));
dataNode^.link := getAddress(newNode);
end; {with}
savePage(rootNode);
discardPage(rootNode);
end {if oldNode = root}
else
begin
insertEntry(bnode^.parent, midKey.key, getAddress(newNode));
end;
if not(memoryTree) and (bNode^.magic = B_NODE_LEAF) then insertEntry(findLeafNode(getRoot(), key), key, value); /// <- Allows re-entrancy
if (midKey.key <> NIL) and (midKey.keySize <> 0) then FreeMem(midKey.key, midKey.keySize);
discardPage(newNode);
end; {if out of space in this node}
discardPage(bnode);
result := TRUE
end; {bTree.insertEntry}
function bTree.isNull;
begin
{if (memoryTree) then
result := (u.bPtr = NIL)
else}
result := (u.offset = 0)
end; {bTree.isNull}
function bTree.loadPage;
var
node:PbNode;
begin
result := NIL;
if isNull(u) then exit;
if (memoryTree) then
node := u.bPtr
else
begin
if not vfs^.fSeek(dword(u.offset) * info^.bNodeSize) then runError; {exit}
getmem(node, info^.bNodeSize);
if (node = NIL) then exit;
if not vfs^.fRead(node^, info^.bNodeSize) then runError; {exit;}
end; // !memoryTree
result := node
end; // bTree.loadPage
procedure bTree.loadSuperBlock;
begin
if memoryTree then exit;
if not vfs^.fSeek(0) then writeln('Error seeking in bTree.loadSuperBlock');
if not vfs^.fRead(info^, sizeof(BTreeInfo)) then writeln('Error reading in bTree Info in bTree.loadSuperBlock');
end;
function bTree.replaceEntry;
var
dataNode:PbNodeData;
node:PbNode;
curNode, res, srcKeySize, dstKeySize, deltaSize:integer;
src, dst:pointer;
begin
result := FALSE;
if ((key = NIL) or (isNull(u))) then exit;
node := loadPage(u);
if (node = NIL) then exit;
if (node^.magic <> B_NODE_INDEX) then
begin
writeln('Error! Not in index nodes.');
discardPage(node);
exit
end;
dataNode := @node^.data;
// possible bug on count
for curNode := 0 to node^.numKeys do
begin
if (dataNode^.link = value) then
begin
srcKeySize := keySize(key);
dstKeySize := keySize(@dataNode^.key);
deltaSize := align(srcKeySize) - align(dstKeySize);
if (deltaSize = 0) then
begin
// source and dest keys are equal length. Replace old key with new key
fillchar(dataNode^.key, dstKeySize, 0);
move(key^, dataNode^.key, srcKeySize);
savePage(node);
end
else
if (deltaSize < 0) then
begin
// source key is smaller than dest key.
fillchar(dataNode^.key, dstKeySize, 0);
move(key^, dataNode^.key, srcKeySize);
src := dataNode;
dst := dataNode;
inc(src, align(dstKeySize)); // no, this isn't backwards
inc(dst, align(srcKeySize)); // we're copying from the old size
move(src^, dst^, node^.size - (dword(src) - dword(node)));
inc(node^.size, deltaSize); // deltaSize is negative
savePage(node);
end
else
begin
// source key is bigger than dest key
if ((deltaSize + node^.size) > info^.bNodeSize) then
begin
// writeln(f, 'Source key would cause split');
end
else // source key will fit
begin
// dataNode points to the value/key pair
src := dataNode;
dst := dataNode;
inc(src, align(dstKeySize));
inc(dst, align(srcKeySize));
move(src^, dst^, node^.size - (dword(src) - dword(node)));
fillchar(dataNode^.key, dstKeySize, 0);
move(key^, dataNode^.key, srcKeySize);
inc(node^.size, deltaSize);
savePage(node);
end;
end;
break;
end;
inc(dataNode, align(keySize(@dataNode^.key)));
end;
discardPage(node);
result := TRUE;
end; {bTree.replaceEntry}
procedure bTree.savePage;
begin
if (memoryTree) then exit;
if (node = NIL) then exit;
if not vfs^.fSeek(dword(node^.tag) * info^.bNodeSize) then writeln('Error seeking in bTree.savePage()');
if not vfs^.fWrite(node^, info^.bNodeSize) then writeln('Error writing page in bTree.savePage()');
end; // bTree.savePage
procedure bTree.saveSuperBlock;
begin
if memoryTree then exit;
// if not vfs^.fClose() then writeln('Error calling fClose (for the first time) file in bTree.done()');
// if not vfs^.fOpen(treeName, 1) then writeln('Error calling fOpen in bTree.done()');
if not vfs^.fSeek(0) then writeln('Error seeking in bTree.saveSuperBlock()'); // reset back to the beginning
if not vfs^.fWrite(info^, sizeof(BTreeInfo)) then writeln('Error saving superblock in bTree.saveSuperBlock()');
end; // bTree.saveSuperBlock
procedure bTree.setLeft;
var node:PbNode;
begin
node := loadPage(u);
if (node = NIL) then exit;
node^.left := newPtr;
savePage(node);
discardPage(node);
end; {bTree.setLeft}
procedure bTree.setParent;
var node:PbNode;
begin
node := loadPage(u);
if (node = NIL) then exit;
node^.parent := newPtr;
savePage(node);
discardPage(node);
end; {bTree.setParent}
procedure bTree.setNull;
begin
{ if (memoryTree) then}
u.offset := 0
{else
u.offset := -1;}
end; {bTree.setNull}
procedure bTree.setRight;
var node:PbNode;
begin
node := loadPage(u);
if (node = NIL) then exit;
node^.right := newPtr;
savePage(node);
discardPage(node);
end; {bTree.setRight}
function bTree.fetchFirstKey;
var
node:PbNode;
dataNode:PbNodeData;
begin
result := FALSE;
if isNull(u) then exit;
node := loadPage(u);
if (node = NIL) then exit;
dataNode := @node^.data;
if (node^.magic = B_NODE_LEAF) then
begin
searchRec.value := dataNode^.link;
searchRec.keySize := keySize(@dataNode^.key);
GetMem(searchRec.key, align(searchRec.keySize));
if (searchRec.key = NIL) then exit;
fillchar(searchRec.key^, align(searchRec.keySize), 0);
copyKey(@dataNode^.key, searchRec.key);
result := TRUE;
end
else
begin
result := fetchFirstKey(dataNode^.link, searchRec);
end;
discardPage(node);
end; {bTree.fetchFirstKey}
function bTree.fetchLastKey;
var
node:PbNode;
dataNode:PbNodeData;
curNode:integer;
begin
result := FALSE;
if isNull(u) then exit;
node := loadPage(u);
if (node = NIL) then exit;
dataNode := @node^.data;
if (node^.magic = B_NODE_LEAF) then
begin
for curNode := 1 to node^.numKeys-1 do
inc(dataNode, align(keySize(@dataNode^.key)));
searchRec.value := dataNode^.link;
searchRec.keySize := keySize(@dataNode^.key);
GetMem(searchRec.key, align(searchRec.keySize));
if (searchRec.key = NIL) then exit;
fillchar(searchRec.key^, align(searchRec.keySize), 0);
copyKey(@dataNode^.key, searchRec.key);
result := TRUE;
end
else
begin
for curNode := 1 to node^.numKeys do
inc(dataNode, align(keySize(@dataNode^.key)));
result := fetchLastKey(dataNode^.link, searchRec);
end;
discardPage(node);
end; {bTree.fetchLastKey}
procedure bTree.findLeafNode;
var
bNode:PbNode;
dataNode:PbNodeData;
i:integer;
link:uPtr;
begin
setNull(result);
if (key = NIL) then exit;
if (isNull(u)) then exit;
bnode := loadPage(u);
if (bnode^.magic = B_NODE_LEAF) then
begin
result := u;
discardPage(bnode);
exit;
end
else
begin
dataNode := @bnode^.data;
for i:=0 to bnode^.numKeys -1 do
begin
if (compareKeys(key, @dataNode^.key) <= 0) then
begin
link := dataNode^.link;
discardPage(bnode);
result := findLeafNode(link, key);
exit;
end;
inc(dataNode, align(keySize(@dataNode^.key)));
end; {for}
link := dataNode^.link;
discardPage(bnode);
result := findLeafNode(link, key);
end;
end; {bTree.findLeafNode}
procedure bTree.freeAll;
begin
if not(memoryTree) then exit;
freePage(getRoot());
setNull(info^.root);
end; {bTree.freeAll}
procedure bTree.freePage;
var
curNode:integer;
dataNode:PbNodeData;
node : PbNode;
begin
if isNull(u) then exit;
node := u.bPtr;
curNode := 0;
if (node^.magic = B_NODE_INDEX) then
begin
dataNode := @node^.data;
for curNode := 0 to node^.numKeys-1 do
begin
freePage(dataNode^.link);
inc(dataNode, align(keySize(@dataNode^.key)));
end;
freePage(dataNode^.link);
end;
freemem(node, info^.bNodeSize);
end; // bTree.freePage
function bTree.Delete;
begin
result := deleteEntry(findLeafNode(getRoot(), key), key, value);
end; {bTree.Delete}
function bTree.Find;
var
bnode:PbNode;
dataNode:PbNodeData;
i, res:integer;
begin
result := FALSE;
setNull(u);
bnode := loadPage(findLeafNode(getRoot(), key));
if (bnode = NIL) then exit; {oops! serious problem}
if (bnode^.magic <> B_NODE_LEAF) then writeln('Error! not in leaf nodes');
dataNode := @bnode^.data;
for i:=0 to bnode^.numKeys-1 do
begin
res := compareKeys(@dataNode^.key, key); // strcomp(@dataNode^.key.str[1], pchar(key));
if (res >= 0) then break;
inc(dataNode, align(keySize(@dataNode^.key)));
end; {for i}
// did we find it?
if (res = 0) then
begin
u := dataNode^.link;
result := TRUE;
end; {if res = 0}
discardPage(bnode);
end; {bTree.Find}
procedure bTree.FindClose;
begin
with searchRec do
begin
setNull(value);
if (key<>NIL) then
FreeMem(key, align(keySize));
key := NIL;
keySize := 0;
end; {with F}
end; {bTree.FindClose}
function bTree.FindFirst;
var
node:PbNode;
dataNode:PbNodeData;
curNode, res:integer;
begin
result := FALSE;
with searchRec do
begin
setNull(value);
key := NIL;
keySize := 0
end; {with searchRec}
if (key = NIL) then exit;
node := loadPage(findLeafNode(getRoot(), key));
if (node = NIL) then exit;
dataNode := @node^.data;
curNode := 0;
repeat
res := compareKeys(key, @dataNode^.key);
if (res <= 0) then break;
inc(dataNode, align(keySize(@dataNode^.key)));
inc(curNode);
until curNode = node^.numKeys;
if (res = 0) then // we found it
begin
searchRec.value := dataNode^.link;
searchRec.keySize := keySize(@dataNode^.key);
GetMem(searchRec.key, align(searchRec.keySize));
fillchar(searchRec.key^, align(searchRec.keySize), 0);
if (searchRec.key = NIL) then exit;
copyKey(@dataNode^.key, searchRec.key);
result := TRUE;
end; {if res = 0}
discardPage(node);
end; {bTree.FindFirst}
function bTree.FindNext;
var
nextNode:uPtr;
node:PbNode;
dataNode:PbNodeData;
curNode, res:integer;
begin
result := FALSE;
if (searchRec.key = NIL) then exit;
node := loadPage(findLeafNode(getRoot(), searchRec.key));
if (node = NIL) then
begin
findClose(searchRec);
exit
end;
dataNode := @node^.data;
curNode := 0;
repeat
res := compareKeys(@dataNode^.key, searchRec.key);
if (res > 0) then break;
inc(dataNode, align(keySize(@dataNode^.key)));
inc(curNode);
until curNode = node^.numKeys;
if (res <= 0) and (curNode = node^.numKeys) then
begin
nextNode := node^.right;
discardPage(node);
node := loadPage(nextNode);
if (node = NIL) then
begin
findClose(searchRec);
exit
end; {node = NIL}
dataNode := @node^.data;
end;
FreeMem(searchRec.key, align(searchRec.keySize));
searchRec.value := dataNode^.link;
searchRec.keySize := keySize(@dataNode^.key);
searchRec.key := NIL;
GetMem(searchRec.key, align(searchRec.keySize));
// sanity check
if (searchRec.key <> NIL) then
begin
fillchar(searchRec.key^, align(searchRec.keySize), 0);
copyKey(@dataNode^.key, searchRec.key);
result := TRUE
end;
discardPage(node);
end; {bTree.FindNext}
function bTree.FindPrev;
var
prevNode:uPtr;
node:PbNode;
lastDataNode, dataNode:PbNodeData;
curNode, res:integer;
begin
result := FALSE;
if (searchRec.key = NIL) then exit;
node := loadPage(findLeafNode(getRoot(), searchRec.key));
if (node = NIL) then
begin
findClose(searchRec);
exit
end;
dataNode := @node^.data;
lastDataNode := dataNode;
curNode := 0;
res := compareKeys(searchRec.key, @dataNode^.key);
if (res > 0) then
repeat
lastDataNode := dataNode;
inc(curNode);
inc(dataNode, align(keySize(@dataNode^.key)));
res := compareKeys(searchRec.key, @dataNode^.key);
until (res <= 0) or (curNode = node^.numKeys);
dataNode := lastDataNode;
if ((res <= 0) and (curNode = 0)) then
begin
prevNode := node^.left;
discardPage(node);
node := loadPage(prevNode);
if (node = NIL) then
begin
FindClose(searchRec);
exit
end;
dataNode := @node^.data;
// scan to the end of the previous node.
// If there's only 1 key, this will do nothing
for curNode := 1 to node^.numKeys-1 do
inc(dataNode, align(keySize(@dataNode^.key)));
end;
FreeMem(searchRec.key, align(searchRec.keySize));
searchRec.value := dataNode^.link;
searchRec.keySize := keySize(@dataNode^.key);
searchRec.key := NIL;
GetMem(searchRec.key, align(searchRec.keySize));
// sanity check
if (searchRec.key <> NIL) then
begin
fillchar(searchRec.key^, align(searchRec.keySize), 0);
copyKey(@dataNode^.key, searchRec.key);
result := TRUE
end;
discardPage(node)
end; {bTree.FindPrev}
function bTree.GetFirstKey;
begin
with searchRec do
begin
setNull(value);
key := NIL;
keySize := 0;
end; {with searchRec}
result := fetchFirstkey(getRoot(), searchRec);
end; {bTree.GetFirstKey}
function bTree.GetKeyCount;
begin
if (info <> NIL) then
result := getKeys() //info^.keys
else
result := 0
end; // bTree.GetKeyCount
function bTree.GetTreeHeight;
begin
result := getHeight();
end; // bTree.GetTreeHeight
function bTree.GetLastKey;
begin
with searchRec do
begin
setNull(value);
key := NIL;
keySize := 0;
end; {with searchRec}
result := fetchLastKey(getRoot(), searchRec);
end; {bTree.GetLastKey}
procedure bTree.Print;
var
curNode:integer;
dataNode:PbNodeData;
node : PbNode;
link : uPtr;
begin
if isNull(u) then exit;
PrintInfo(f, u);
node := loadPage(u);
curNode := 0;
if (node^.magic = B_NODE_INDEX) then
begin
dataNode := @node^.data;
for curNode := 0 to node^.numKeys-1 do
begin
Print(f, dataNode^.link);
inc(dataNode, align(keySize(@dataNode^.key)));
end;
Print(f, dataNode^.link);
end;
discardPage(node);
end; {bTree.Print}
procedure bTree.PrintInfo;
const leafStr:array[boolean] of string[5] = ('INDEX', 'LEAF');
var
dataNode:PbNodeData;
curNode:integer;
node : PbNode;
i:integer;
begin
node := loadPage(u);
if (node = NIL) then exit;
write(f, ' ', hex(dword(node^.parent.offset)));
writeln(f, ' ', leafStr[node^.magic = B_NODE_LEAF], ' (', hex(node^.magic), ')');
write(f, hex(dword(node^.left.bPtr)), ' <-> ', hex(getAddress(node).u), ' <-> ', hex(dword(node^.right.bPtr)));
writeln(f, ' | capacity ', node^.size, '[', calcSize(node), '](', info^.bNodeSize, ') | keys:', node^.numKeys);
if (node^.numKeys = 0) then exit;
dataNode := @node^.data;
curNode := 0;
for curNode := 0 to node^.numKeys-(ord(node^.magic = B_NODE_LEAF)) do
begin
write(f, '| ', curNode:2, '| ');
{if (node^.magic = B_NODE_INDEX) then}
write(f, '[', hex(dword(dataNode^.link.offset)), ']');
if (curNode <> node^.numKeys) then
case info^.treeType of
BT_custom:with TBlockRun(dataNode^.key) do writeln(f, ' {', AG, ':', start, ':', len, '} ');
BT_INT32:writeln(f, ' {', hex(dataNode^.key.i), '} ');
BT_INT64:writeln(f, ' {', hex(dataNode^.key.x), '} ');
BT_SINGLE:writeln(f, ' {', dataNode^.key.s, '} ');
BT_DOUBLE:writeln(f, ' {', dataNode^.key.d, '} ');
BT_STRING:writeln(f, ' {', dataNode^.key.str, '} ');
BT_PCHAR:begin
(*writeln(f, ' {', pchar(@dataNode^.key)^, '} '); *)
write(f, ' {');
i:=0;
while (dataNode^.key.str[i]<>#0) do
begin
write(f, dataNode^.key.str[i]);
inc(i);
end;
writeln(f, '} ');
end;
end;
inc(dataNode, align(keySize(@dataNode^.key)));
end;
discardPage(node);
writeln(f);
end; {bTree.PrintInfo}
function bTree.Insert;
begin
result := insertEntry(findLeafNode(getRoot(), key), key, value);
end; {bTree.Insert}
procedure bTree.InstallUserFunctions;
begin
compareKeys := cmpFunc;
copyKey := copyProc;
keySize := ksFunc;
end; {bTree.InstallUserFunc}
procedure bTree.PrintList;
var
dataNode:PbNodeData;
node:PbNode;
link:uPtr;
i, j : integer;
f:text;
begin
if (isNull(getRoot())) then exit;
assign(f, filename);
{$I-} rewrite(f); {$I+}
if (IOResult() <> 0) then exit;
node := loadPage(getRoot());
if (node = NIL) then exit;
while (node^.magic = B_NODE_INDEX) do
begin
dataNode := @node^.data;
link := dataNode^.link;
discardPage(node);
node := loadPage(link);
end;
while (not isNull(link)) do
begin
dataNode := @node^.data;
for i := 0 to node^.numKeys -1 do
begin
case info^.treeType of
BT_CUSTOM:with TBlockRun(dataNode^.key) do writeln(f, AG, ':', start, ':', len);
BT_INT32:writeln(f, hex(dataNode^.key.i));
// BT_INT64:writeln(f, dataNode^.key.x);
BT_SINGLE:writeln(f, dataNode^.key.s);
BT_DOUBLE:writeln(f, dataNode^.key.d);
BT_STRING:writeln(f, dataNode^.key.str);
BT_PCHAR:begin
j:=0;
while (dataNode^.key.str[j]<>#0) do
begin
write(f, dataNode^.key.str[j]);
inc(j);
end;
writeln(f);
end;
end; // case
inc(dataNode, align(keySize(@dataNode^.key)));
end; {for i}
link := node^.right;
discardPage(node);
node := loadPage(link);
end; {while}
{$I-} close(f); {$I+}
if (IOResult() <> 0) then writeln('Error calling close() in bTree.PrintList');
end; {bTree.PrintList}
procedure bTree.PrintWholeTree;
var f:text;
begin
assign(f, filename);
{$I-} rewrite(f); {$I+}
if (IOResult() <> 0) then exit;
Print(f, getRoot());
{$I-} close(f); {$I+}
if (IOResult() <> 0) then writeln('Error calling close() in bTree.PrintWholeTree');
end; {bTree.PrintWholeTree}
destructor bTree.done;
begin
// if (not isNull(getRoot())) then freeAll();
if (memoryTree) then freePage(getRoot());
if (info <> NIL) then dispose(info);
if (vfs <> NIL) then dispose(vfs, done);
info := NIL;
vfs := NIL;
end; // bTree.done
constructor TQueue.init;
begin
queue := NIL;
elements := 0;
maxElements := elementCount;
size := elementSize;
head := 0;
tail := 0;
if (size <> 0) and (maxElements <> 0) then
begin
GetMem(queue, size*maxElements);
fillchar(queue^, size*maxElements, 0);
end;
end; // TQueue.init
function TQueue.dequeue;
var p:pointer;
begin
result := FALSE;
if (queue = NIL) or (elements = 0) then exit;
p := queue;
inc(p, head*size);
head := (head+1) mod maxElements;
move(p^, item, size);
dec(elements);
result := TRUE;
end; // TQueue.dequeue
function TQueue.enqueue;
var p:pointer;
begin
result := FALSE;
if (queue = NIL) or (elements = maxElements) then exit;
p := queue;
inc(p, tail*size);
move(item, p^, size);
tail := (tail+1) mod maxElements;
inc(elements);
result := TRUE;
end; // TQueue.enqueue
function TQueue.getElementCount; result := elements;
destructor TQueue.done;
begin
if (size <> 0) and (maxElements <> 0) then FreeMem(queue, size*maxElements);
queue := NIL;
elements := 0;
maxElements := 0;
size := 0;
head := 0;
tail := 0;
end; // TQueue.done
end.
