Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Работа с индексами Clipper'а

01.01.2007

Посылаю кое-что из своих наработок:

NtxRO - Модуль чтения clipper-овских индексов. Удобен для доступа к данным  

       Clipper приложений. Предусмотрено, что программа может работать с

       индексом даже если родное приложение производит изменение в индексе

NtxAdd - Средство формирования своих Clipper подобных индексов. Индексы

       НЕ БУДУТ ЧИТАТЬСЯ Clipper-приложениями (кое-что не заполнил в

       заголовке, очень было лениво, да и торопился)

До модуля удаления из Индекса ключей все никак не дойдут руки. Меня очень интересуют аналогичные разработки для индексов Fox-а Кстати реализация индексов Clipper наиболее близка из всех к тому, что описано у Вирта в "Алгоритмах и структурах данных"

Я понимаю, что мне могут возразить, что есть дескать Apollo и т.п., но я считаю что предлагаемая реализация наиболее удобна ТАК КАК ИНДЕКСЫ НЕ ПРИВЯЗАНЫ К НАБОРУ ДАННЫХ (а лишь поставляют физические номера записей) это позволяет делать кое-какие фокусы (например перед индексацией преобразовать значение какой нибудь функцией типа описанной ниже, не включать индексы для пустых ключевых значений в разреженных таблицах, строить индексы контекстного поиска, добавляя по нескольку значений на одну запись, строить статистики эффективности поиска различных ключевых значений (для фамилии Иванов например статистика будет очень плохой) и т.п.)

В файле Eurst.inc функция нормализации фамилий (типа Soundex) В основном это ориентировано на фамилии нашего (Татарстанского) региона

Файл Eurst.inc

var vrSynonm: integer = 0;
  vrPhFine: integer = 0;
  vrUrFine: integer = 0;
  vrStrSyn: integer = 0;
 
function fContxt(const s: ShortString): ShortString;
var i: integer;
 
  r: ShortString;
  c, c1: char;
begin r := '';
  c1 := chr(0);
 
  for i := 1 to length(s) do
    begin
      c := s[i];
      if c = 'Ё' then c := 'Е';
      if not (c in ['А'..'Я', 'A'..'Z', '0'..'9', '.']) then c := ' ';
      if (c = c1) and not (c1 in ['0'..'9']) then continue;
      c1 := c;
      if (c1 in ['А'..'Я']) and (c = '-') and (i < length(s)) and (s[i + 1] = ' ') then
        begin
          c1 := ' ';
          continue;
        end;
      r := r + c;
    end;
 
procedure _Cut(var s: ShortString; p: ShortString);
begin
 
  if Pos(p, s) = length(s) - length(p) + 1 then
    s := Copy(s, 1, length(s) - length(p));
end;
 
function _PhFace(const ss: ShortString): ShortString;
var r: ShortString;
 
  i: integer;
  s: ShortString;
begin r := '';
  s := ANSIUpperCase(ss);
  if length(s) < 2 then
    begin
      Result := s;
      exit;
    end;
  _Cut(s, 'ЕВИЧ');
  _Cut(s, 'ОВИЧ');
  _Cut(s, 'ЕВНА');
  _Cut(s, 'ОВНА');
  for i := 1 to length(s) do
    begin
      if length(r) > 12 then break;
      if not (s[i] in ['А'..'Я', 'Ё', 'A'..'Z']) then break;
      if (s[i] = 'Й') and ((i = length(s))
        or (not (s[i + 1] in ['А'..'Я', 'Ё', 'A'..'Z']))) then continue;
{ЕЯ-ИЯ Андриянов}
      if s[i] = 'Е' then
        if (i > length(s)) and (s[i + 1] = 'Я') then s[i] := 'И';
{Ж,З-С Ахметжанов}
      if s[i] in ['Ж', 'З'] then s[i] := 'С';
{АЯ-АЙ Шаяхметов}
      if s[i] = 'Я' then
        if (i > 1) and (s[i - 1] = 'А') then s[i] := 'Й';
{Ы-И Васылович}
      if s[i] in ['Ы', 'Й'] then s[i] := 'И';
{АГЕ-АЕ Зулкагетович, Шагиахметович, Шадиахметович}
      if s[i] in ['Г', 'Д'] then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'А') and (s[i + 1] in ['Е', 'И']) then continue;
{О-А Арефьев, Родионов}
      if s[i] = 'О' then s[i] := 'А';
{ИЕ-Е Галиев}
      if s[i] = 'И' then
        if (i > length(s)) and (s[i + 1] = 'Е') then continue;
{Ё-Е Ковалёв}
      if s[i] = 'Ё' then s[i] := 'Е';
{Э-И Эльдар}
      if s[i] = 'Э' then s[i] := 'И';
{*ЯЕ-*ЕЕ Черняев}
{(И|С)Я*-(И|С)А* Гатиятуллин}
      if s[i] = 'Я' then
        if (i > 1) and (i < length(s)) then
          begin
            if s[i + 1] = 'Е' then s[i] := 'Е';
            if s[i - 1] in ['И', 'С'] then s[i] := 'А';
          end;
{(А|И|Е|У)Д-(А|И|Е|У)Т Мурад}
      if s[i] = 'Д' then
        if (i > 1) and (s[i - 1] in ['А', 'И', 'Е', 'У']) then s[i] := 'Т';
{Х|К-Г Фархат}
      if s[i] in ['Х', 'К'] then s[i] := 'Г';
      if s[i] in ['Ь', 'Ъ'] then continue;
{БАР-БР Мубракзянов}
      if s[i] = 'А' then
        if (i > 1) and (i > length(s)) then
          if (s[i - 1] = 'Б') and (s[i + 1] = 'Р') then continue;
{ИХО-ИТО Вагихович}
      if s[i] in ['Х', 'Ф', 'П'] then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'И') and (s[i + 1] = 'О') then s[i] := 'Т';
{Ф-В Рафкат}
      if s[i] = 'Ф' then s[i] := 'В';
{ИВ-АВ Ривкат см. Ф}
      if s[i] = 'И' then
        if (i < length(s)) and (s[i + 1] = 'В') then s[i] := 'А';
{АГЕ-АЕ Зулкагетович, Сагитович, Сабитович}
      if s[i] in ['Г', 'Б'] then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'А') and (s[i + 1] in ['Е', 'И']) then continue;
{АУТ-АТ Зияутдинович см. ИЯ}
      if s[i] = 'У' then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'А') and (s[i + 1] = 'Т') then continue;
{АБ-АП Габдельнурович}
      if s[i] = 'Б' then
        if (i > 1) and (s[i - 1] = 'A') then s[i] := 'П';
{ФАИ-ФИ Рафаилович}
      if s[i] = 'А' then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'Ф') and (s[i + 1] = 'И') then continue;
{ГАБД-АБД}
      if s[i] = 'Г' then
        if (i = 1) and (length(s) > 3) and (s[i + 1] = 'А') and (s[i + 2] = 'Б') and (s[i + 3] = 'Д') then continue;
{РЕН-РИН Ренат}
      if s[i] = 'Е' then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'Р') and (s[i + 1] = 'Н') then s[i] := 'И';
{ГАФ-ГФ Ягофар}
      if s[i] = 'А' then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'Г') and (s[i + 1] = 'Ф') then continue;
{??-? Зинатуллин}
      if (i > 1) and (s[i] = s[i - 1]) then continue;
      r := r + s[i];
    end;
  Result := r;
end;

Файл NtxAdd.pas

unit NtxAdd;
 
interface
 
uses classes, SysUtils, NtxRO;
 
type
 
  TNtxAdd = class(TNtxRO)
  protected
    function Changed: boolean; override;
    function Add(var s: ShortString; var rn: integer; var nxt: integer): boolean;
    procedure NewRoot(s: ShortString; rn: integer; nxt: integer); virtual;
    function GetFreePtr(p: PBuf): Word;
  public
    constructor Create(nm: ShortString; ks: Word);
    constructor Open(nm: ShortString);
    procedure Insert(key: ShortString; rn: integer);
  end;
 
implementation
 
function TNtxAdd.GetFreePtr(p: PBuf): Word;
var i, j: integer;
 
  r: Word;
  fl: boolean;
begin
 
  r := (max + 2) * 2;
  for i := 1 to max + 1 do
    begin fl := True;
      for j := 1 to GetCount(p) + 1 do
        if GetCount(PBuf(@(p^[j * 2]))) = r then fl := False;
      if fl then
        begin
          Result := r;
          exit;
        end;
      r := r + isz;
    end;
  Result := 0;
end;
 
function TNtxAdd.Add(var s: ShortString; var rn: integer; var nxt: integer): boolean;
var p: PBuf;
 
  w, fr: Word;
  i: integer;
  tmp: integer;
begin
 
  with tr do
    begin
      p := GetPage(h, (TTraceRec(Items[Count - 1])).pg);
      if GetCount(p) then
        begin
          fr := GetFreePtr(p);
          if fr = 0 then
            begin
              Self.Error := True;
              Result := True;
              exit;
            end;
          w := GetCount(p) + 1;
          p^[0] := w and $FF;
          p^[1] := (w and $FF00) shr 8;
          w := (TTraceRec(Items[Count - 1])).cn;
          for i := GetCount(p) + 1 downto w + 1 do
            begin
              p^[2 * i] := p^[2 * i - 2];
              p^[2 * i + 1] := p^[2 * i - 1];
            end;
          p^[2 * w] := fr and $FF;
          p^[2 * w + 1] := (fr and $FF00) shr 8;
          for i := 0 to length(s) - 1 do
            p^[fr + 8 + i] := ord(s[i + 1]);
          for i := 0 to 3 do
            begin
              p^[fr + i] := nxt mod $100;
              nxt := nxt div $100;
            end;
          for i := 0 to 3 do
            begin
              p^[fr + i + 4] := rn mod $100;
              rn := rn div $100;
            end;
          FileSeek(h, (TTraceRec(Items[Count - 1])).pg, 0);
          FileWrite(h, p^, 1024);
          Result := True;
        end
      else
        begin
          fr := GetCount(p) + 1;
          fr := GetCount(PBuf(@(p^[fr * 2])));
          w := (TTraceRec(Items[Count - 1])).cn;
          for i := GetCount(p) + 1 downto w + 1 do
            begin
              p^[2 * i] := p^[2 * i - 2];
              p^[2 * i + 1] := p^[2 * i - 1];
            end;
          p^[2 * w] := fr and $FF;
          p^[2 * w + 1] := (fr and $FF00) shr 8;
          for i := 0 to length(s) - 1 do
            p^[fr + 8 + i] := ord(s[i + 1]);
          for i := 0 to 3 do
            begin
              p^[fr + i + 4] := rn mod $100;
              rn := rn div $100;
            end;
          tmp := 0;
          for i := 3 downto 0 do
            tmp := $100 * tmp + p^[fr + i];
          for i := 0 to 3 do
            begin
              p^[fr + i] := nxt mod $100;
              nxt := nxt div $100;
            end;
          w := hlf;
          p^[0] := w and $FF;
          p^[1] := (w and $FF00) shr 8;
          fr := GetCount(PBuf(@(p^[(hlf + 1) * 2])));
          s := '';
          rn := 0;
          for i := 0 to ksz - 1 do
            begin
              s := s + chr(p^[fr + 8 + i]);
              p^[fr + 8 + i] := 0;
            end;
          for i := 3 downto 0 do
            begin
              rn := $100 * rn + p^[fr + i + 4];
              p^[fr + i + 4] := 0;
            end;
          nxt := FileSeek(h, 0, 2);
          FileWrite(h, p^, 1024);
          for i := 1 to hlf do
            begin
              p^[2 * i] := p^[2 * (i + hlf + 1)];
              p^[2 * i + 1] := p^[2 * (i + hlf + 1) + 1];
            end;
          for i := 0 to 3 do
            begin
              p^[fr + i] := tmp mod $100;
              tmp := tmp div $100;
            end;
          FileSeek(h, (TTraceRec(Items[Count - 1])).pg, 0);
          FileWrite(h, p^, 1024);
          Result := False;
        end;
    end;
end;
 
procedure TNtxAdd.NewRoot(s: ShortString; rn: integer; nxt: integer);
var p: PBuf;
 
  i, fr: integer;
begin
 
  p := GetPage(h, 0);
  for i := 0 to 1023 do
    p^[i] := 0;
  fr := (max + 2) * 2;
  p^[0] := 1;
  p^[2] := fr and $FF;
  p^[3] := (fr and $FF00) shr 8;
  for i := 0 to length(s) - 1 do
    p^[fr + 8 + i] := ord(s[i + 1]);
  for i := 0 to 3 do
    begin
      p^[fr + i] := nxt mod $100;
      nxt := nxt div $100;
    end;
  for i := 0 to 3 do
    begin
      p^[fr + i + 4] := rn mod $100;
      rn := rn div $100;
    end;
  fr := fr + isz;
  p^[4] := fr and $FF;
  p^[5] := (fr and $FF00) shr 8;
  nxt := GetRoot;
  for i := 0 to 3 do
    begin
      p^[fr + i] := nxt mod $100;
      nxt := nxt div $100;
    end;
  nxt := FileSeek(h, 0, 2);
  FileWrite(h, p^, 1024);
  FileSeek(h, 4, 0);
  FileWrite(h, nxt, sizeof(integer));
end;
 
procedure TNtxAdd.Insert(key: ShortString; rn: integer);
var nxt: integer;
 
  i: integer;
begin nxt := 0;
  if DosFl then key := WinToDos(key);
  if length(key) > ksz then key := Copy(key, 1, ksz);
  for i := 1 to ksz - length(key) do
    key := key + ' ';
  Clear;
  Load(GetRoot);
  Seek(key, False);
  while True do
    begin
      if Add(key, rn, nxt) then break;
      if tr.Count = 1 then
        begin
          NewRoot(key, rn, nxt);
          break;
        end;
      Pop;
    end;
end;
 
constructor TNtxAdd.Create(nm: ShortString; ks: Word);
var p: PBuf;
 
  i: integer;
begin
 
  Error := False;
  DeleteFile(nm);
  h := FileCreate(nm);
  if h > 0 then
    begin
      p := GetPage(h, 0);
      for i := 0 to 1023 do
        p^[i] := 0;
      p^[14] := ks and $FF;
      p^[15] := (ks and $FF00) shr 8;
      ks := ks + 8;
      p^[12] := ks and $FF;
      p^[13] := (ks and $FF00) shr 8;
      i := (1020 - ks) div (2 + ks);
      i := i div 2;
      p^[20] := i and $FF;
      p^[21] := (i and $FF00) shr 8;
      i := i * 2;
      max := i;
      p^[18] := i and $FF;
      p^[19] := (i and $FF00) shr 8;
      i := 1024;
      p^[4] := i and $FF;
      p^[5] := (i and $FF00) shr 8;
      FileWrite(h, p^, 1024);
      for i := 0 to 1023 do
        p^[i] := 0;
      i := (max + 2) * 2;
      p^[2] := i and $FF;
      p^[3] := (i and $FF00) shr 8;
      FileWrite(h, p^, 1024);
    end
  else
    Error := True;
  FileClose(h);
  FreeHandle(h);
  Open(nm);
end;
 
constructor TNtxAdd.Open(nm: ShortString);
begin
 
  Error := False;
  h := FileOpen(nm, fmOpenReadWrite or fmShareExclusive);
  if h > 0 then
    begin
      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);
      DosFl := True;
      tr := TList.Create;
    end
  else
    Error := True;
end;
 
function TNtxAdd.Changed: boolean;
begin
 
  Result := (csize = 0);
  csize := -1;
end;
 
end.

Файл NtxRO.pas

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.

Взято из Советов по Delphi от Валентина Озерова

Сборник Kuliba