unit
NtxRO;
interface
uses Classes;
type
TBuf=array[0..1023]of Byte;
PBuf=^TBuf;
TTraceRec=class
public
pg:integer;
cn:SmallInt;
constructor Create(p:integer;c:SmallInt);
end;
TNtxRO=class
protected
fs:string[10];
empty:integer;
csize:integer;
rc:integer; {Текущий
номер записи}
tr:TList; {Стек
загруженных страниц}
h:integer; {Дескриптор
файла}
isz:Word; {Размер
элемента}
ksz:Word; {Размер
ключа}
max:Word; {Максимальное кол-во элементов}
hlf:Word; {Половина
страницы}
function GetRoot:integer; {Указатель на корень}
function GetEmpty:integer; {Пустая страница}
function GetSize:integer; {Возвращает размер файла}
function GetCount(p:PBuf):Word; {Число элементов на странице}
function Changed:boolean; virtual;
procedure Clear;
function Load(n:integer):PBuf;
function Pop:PBuf;
function Seek(const
s:ShortString;fl:boolean):boolean;
function Skip:PBuf;
function GetItem(p:PBuf):PBuf;
function GetLink(p:PBuf):integer;
public
Error:boolean;
DosFl:boolean;
constructor Open(nm:ShortString);
destructor Destroy; override;
function Find(const s:ShortString):boolean;
function GetString(p:PBuf;c:SmallInt):ShortString;
function GetRecN(p:PBuf):integer;
function Next:PBuf;
end;
function
GetPage(h,fs:integer):PBuf;
procedure
FreeHandle(h:integer);
function DosToWin(const
ss:ShortString):ShortString;
function WinToDos(const
ss:ShortString):ShortString;
implementation
uses Windows,
SysUtils;
const MaxPgs=5;
var
Buf:array[1..1024*MaxPgs]of char;
Cache:array[1..MaxPgs]of
record
Handle:integer; {0-страница
свободна}
Offset:integer; { смещение в
файле}
Countr:integer; { счетчик
использования}
Length:SmallInt;
end;
function
TNtxRO.Next:PBuf;
var cr:integer;
p:PBuf;
begin
if h<=0 then
begin
Result:=nil;
exit;
end;
while Changed do
begin
cr:=rc;
Find(fs);
while cr>0 do
begin
p:=Skip;
if GetRecN(p)=cr then break;
end;
end;
Result:=Skip;
end;
function
TNtxRO.Skip:PBuf;
var cnt:boolean;
p,r:PBuf;
n:integer;
begin r:=nil;
cnt:=True;
with tr do
begin
p:=GetPage(h,(TTraceRec(Items[Count-1])).pg);
while cnt do
begin cnt:=False;
if (TTraceRec(Items[Count-1])).cn>GetCount(p)+1 then
begin
if Count<=1 then
begin
Result:=nil;
exit;
end;
p:=Pop;
end
else
while True do
begin
r:=GetItem(p);
n:=GetLink(r);
if n=0 then break;
p:=Load(n);
end;
if (TTraceRec(Items[Count-1])).cn>=GetCount(p)+1 then
cnt:=True
else r:=GetItem(p);
Inc((TTraceRec(Items[Count-1])).cn);
end;
end;
if r<>nil then
begin
rc:=GetRecN(r);
fs:=GetString(r,length(fs));
end;
Result:=r;
end;
function
TNtxRO.GetItem(p:PBuf):PBuf;
var r:PBuf;
begin
with TTraceRec(tr.items[tr.Count-1])
do
r:=PBuf(@(p^[cn*2]));
r:=PBuf(@(p^[GetCount(r)]));
Result:=r;
end;
function
TNtxRO.GetString(p:PBuf;c:SmallInt):ShortString;
var i:integer;
r:ShortString;
begin r:='';
if c=0 then c:=ksz;
for i:=0 to c-1 do
r:=r+chr(p^[8+i]);
if DosFl then r:=DosToWin(r);
Result:=r;
end;
function
TNtxRO.GetLink(p:PBuf):integer;
var i,r:integer;
begin
r:=0;
for i:=3 downto 0 do
r:=r*256+p^[i];
Result:=r;
end;
function
TNtxRO.GetRecN(p:PBuf):integer;
var i,r:integer;
begin
r:=0;
for i:=3 downto 0 do
r:=r*256+p^[i+4];
Result:=r;
end;
function
TNtxRO.GetCount(p:PBuf):Word;
begin
Result:=p^[1]*256+p^[0];
end;
function
TNtxRO.Seek(const s:ShortString;fl:boolean):boolean;
var
r:boolean;
p,q:PBuf;
nx:integer;
begin r:=False;
with TTraceRec(tr.items[tr.Count-1]) do
begin
p:=GetPage(h,pg);
while cn<=GetCount(p)+1
do
begin
q:=GetItem(p);
if
(cn>GetCount(p))or(s<GetString(q,length(s))) or
(fl and (s=GetString(q,length(s)))) then
begin
nx:=GetLink(q);
if nx<>0 then
begin
Load(nx);
r:=Seek(s,fl);
end;
Result:=r or (s=GetString(q,length(s)));
exit;
end;
Inc(cn);
end;
end;
Result:=False;
end;
function
TNtxRO.Find(const s:ShortString):boolean;
var
r:boolean;
begin
if h<=0 then
begin
Result:=False;
exit;
end;
rc:=0;
csize:=0;
r:=False;
while Changed do
begin
Clear;
Load(GetRoot);
if length(s)>10 then
fs:=Copy(s,1,10)
else fs:=s;
R:=Seek(s,True);
end;
Result:=r;
end;
function
TNtxRO.Load(N:integer):PBuf;
var it:TTraceRec;
r:PBuf;
begin r:=nil;
if h>0 then
begin
with tr do
begin
it:=TTraceRec.Create(N,1);
Add(it);
end;
r:=GetPage(h,N);
end;
Result:=r;
end;
procedure
TNtxRO.Clear;
var it:TTraceRec;
begin
while tr.Count>0 do
begin
it:=TTraceRec(tr.Items[0]);
tr.Delete(0);
it.Free;
end;
end;
function
TNtxRO.Pop:PBuf;
var r:PBuf;
it:TTraceRec;
begin r:=nil;
with tr do
if Count>1 then
begin
it:=TTraceRec(Items[Count-1]);
Delete(Count-1);
it.Free;
it:=TTraceRec(Items[Count-1]);
r:=GetPage(h,it.pg)
end;
Result:=r;
end;
function
TNtxRO.Changed:boolean;
var i:integer;
r:boolean;
begin r:=False;
if h>0 then
begin
i:=GetEmpty;
if i<>empty then r:=True;
empty:=i;
i:=GetSize;
if i<>csize then r:=True;
csize:=i;
end;
Result:=r;
end;
constructor
TNtxRO.Open(nm:ShortString);
begin
Error:=False;
h:=FileOpen(nm,fmOpenRead or fmShareDenyNone);
if h>0 then
begin
fs:='';
FileSeek(h,12,0);
FileRead(h,isz,2);
FileSeek(h,14,0);
FileRead(h,ksz,2);
FileSeek(h,18,0);
FileRead(h,max,2);
FileSeek(h,20,0);
FileRead(h,hlf,2);
empty:=-1;
csize:=-1;
DosFl:=True;
tr:=TList.Create;
end else
Error:=True;
end;
destructor
TNtxRO.Destroy;
begin
if h>0 then
begin
FileClose(h);
Clear;
tr.Free;
FreeHandle(h);
end;
inherited Destroy;
end;
function
TNtxRO.GetRoot:integer;
var r:integer;
begin r:=-1;
if h>0 then
begin
FileSeek(h,4,0);
FileRead(h,r,4);
end;
Result:=r;
end;
function
TNtxRO.GetEmpty:integer;
var r:integer;
begin r:=-1;
if h>0 then
begin
FileSeek(h,8,0);
FileRead(h,r,4);
end;
Result:=r;
end;
function
TNtxRO.GetSize:integer;
var r:integer;
begin r:=0;
if h>0 then
r:=FileSeek(h,0,2);
Result:=r;
end;
constructor
TTraceRec.Create(p:integer;c:SmallInt);
begin
pg:=p;
cn:=c;
end;
function
GetPage(h,fs:integer):PBuf; {Протестировать
отдельно}
var i,j,mn:integer;
q:PBuf;
begin
mn:=10000; j:=0;
for i:=1 to MaxPgs
do
if (Cache[i].Handle=h) and
(Cache[i].Offset=fs) then
begin
j:=i;
if Cache[i].Countr<10000
then
Inc(Cache[i].Countr);
end;
if j=0 then
begin
for i:=1 to MaxPgs do
if Cache[i].Handle=0 then
j:=i;
if j=0 then
for i:=1 to MaxPgs do
if Cache[i].Countr<=mn then
begin
mn:=Cache[i].Countr;
j:=i;
end;
Cache[j].Countr:=0;
mn:=0;
end;
q:=PBuf(@(Buf[(j-1)*1024+1]));
if mn=0 then
begin
FileSeek(h,fs,0);
Cache[j].Length:=FileRead(h,q^,1024);
end;
Cache[j].Handle:=h;
Cache[j].Offset:=fs;
Result:=q;
end;
procedure
FreeHandle(h:integer);
var i:integer;
begin
for i:=1 to MaxPgs do
if Cache[i].Handle=h then
Cache[i].Handle:=0;
end;
function
DosToWin(const ss:ShortString):ShortString;
var
r:ShortString;
i:integer;
begin r:='';
for i:=1 to length(ss)
do
if ss[i] in [chr($80)..chr($9F)] then
r:=r+chr(ord(ss[i])-$80+$C0)
else if ss[i] in [chr($A0)..chr($AF)] then
r:=r+chr(ord(ss[i])-$A0+$C0)
else if ss[i] in [chr($E0)..chr($EF)] then
r:=r+chr(ord(ss[i])-$E0+$D0)
else if ss[i] in [chr($61)..chr($7A)] then
r:=r+chr(ord(ss[i])-$61+$41)
else if ss[i] in [chr($F0)..chr($F1)] then
r:=r+chr($C5)
else r:=r+ss[i];
Result:=r;
end;
function
WinToDos(const ss:ShortString):ShortString;
var
r:ShortString;
i:integer;
begin r:='';
for i:=1 to length(ss)
do
if ss[i] in [chr($C0)..chr($DF)] then
r:=r+chr(ord(ss[i])-$C0+$80)
else if ss[i] in [chr($E0)..chr($FF)] then
r:=r+chr(ord(ss[i])-$E0+$80)
else if ss[i] in [chr($F0)..chr($FF)] then
r:=r+chr(ord(ss[i])-$F0+$90)
else if ss[i] in [chr($61)..chr($7A)] then
r:=r+chr(ord(ss[i])-$61+$41)
else if ss[i] in [chr($D5),
chr($C5)] then r:=r+chr($F0)
else r:=r+ss[i];
Result:=r;
end;
end. 
