Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Работа с индексами Clipper-а

Автор: Валентин Чесноков

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

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 World © Выпуск 2002 - 2024
Автор проекта: USU Software
Вы можете выкупить этот проект.