unit dbf_level1;

interface

uses classes,SysUtils;

const
 DBF_SizeSegment  = 512;     //Размер сегмента

 DBF_WithMemo     = 3;       //Файл содержит MEMO поля
 DBF_WithoutMemo  = 131;     //Файл не содержит MEMO полей

 DBF_FieldChar    = 67;      //Поле типа char
 DBF_FieldDate    = 68;      //Поле типа data
 DBF_FieldLogic   = 76;      //Поле типа logic
 DBF_FieldMemo    = 77;      //Поле типа Memo
 DBF_FieldNumeric = 78;      //Поле типа Numeric

 DBF_EndMemo      = 26;      //Конец MEMO поля
 DBF_EndFields    = 13;      //Код указывающий конец таблицы описывающей поля

 DBF_LengthDate   = 8;       //Длина поля Data
 DBF_LengthMemo   = 10;      //Длина поля Memo
 DBF_LengthLogic  = 1;       //Длина поля Logical

 DBF_RecDel       = 42;      //Код указывает, что запись удалена
 DBF_NonDel       = 32;      //Код указывает, что запись не удалена

 DBF_PosLastRec   = 4;       //Смещение указателя количества записей от начала

type
 EDBFError = class(Exception)
 end;

 TDBF_HEAD = record
  dbf_id      : Byte;                  //Идентификация типа файла. 3 - без memo полей, 131 - есть memo поля.
  last_update : array [1..3] of Byte;  //Дата последнего обновления. Первый байт две цифры года, второй месяц, третий день.
  last_rec    : LongInt;               //Номер последней записи.
  data_offset : SmallInt;              //Смещение первой записи.
  rec_size    : SmallInt;              //Размер записи. Сумма длин полей плюс байт удаления.
  filler      : array [1..20] of Byte; //Зарезервированно.
 end;

 TDBF_FIELD_REC = record
  field_name : array [0..10] of Char;  //Имя файла оканчивается #0.
  field_type : Byte;                   //Тип поля. 67,68,76,77,78 - Char,Data,Logic,Memo,Numeric соответственно.
  dummy      : array [1..4] of Byte;   //Значение этого поля пока не знаю.
  len_field  : array [1..2] of Byte;   //Длина поля. Если тип Numeric первый байт общ. длина второй после дес. точки.
  filler     : array [1..14] of Byte;  //Зарезервированно.
 end;

 TDBF_fields = class(TObject)
  protected
   FList : TList;
   function GetCount : integer;
   function GetField(index : integer) : TDBF_FIELD_REC;
  public
   property Count : integer read GetCount;
   property List : TList read FList;
   property Field[index : integer] : TDBF_FIELD_REC read GetField;

   constructor Create (n : integer = 0);
   destructor Destroy; override;
   function Add : integer;             //Добавляет пустое поле
   procedure Delete(index : integer);  //Удаляет поле
   procedure Insert(index : integer);  //Вставляет пустое поле в позицию index
   procedure Clear;                    //Удаляет все поля и освобождает память
   procedure Check;                    //Проверяет правильность заполнения полей
 end;

 TDBF_fileMemo = class(TObject)
  protected
   FileStream : TFileStream;
   procedure SetCountSegments;
  public
   constructor Create;
   destructor  Destroy; override;
   procedure   Open(name : string);                             //Открывает файл
   procedure   New(name : string);                              //Создаёт файл
   procedure   Close;                                           //Закрывает файл
   procedure   GetSegment(n : integer; p : pointer);            //Загрузить сегмент по адресу p
   procedure   Put(n : integer; p : pointer; size : integer);   //Записать сегмент из адреса p
   function    Add(p : pointer = nil; size : integer = DBF_SizeSegment) : integer; //Добавить новый сегмент
 end;


 TDBF_file = class(TObject)
  protected
   FDbf_fields : TDBF_fields;
   FFileStream : TFileStream;
   FDBF_HEAD   : TDBF_HEAD;
   function GetField(index : integer) : string;
   procedure SetField(index : integer; value : string);
   function IsEof : Boolean;
   procedure SetCountRec;
   function IsDel : Boolean;
  public
   CurrentRecord : PChar;
   property DBF_HEAD : TDBF_HEAD read FDBF_HEAD;
   property Dbf_fields : TDBF_fields read FDbf_fields;
   property FileStream : TFileStream read FFileStream;
   property Field[index : integer] : string read GetField write SetField;
   property Eof : Boolean read IsEof;
   property IsDelete : Boolean read IsDel;
   constructor Create;
   destructor Destroy; override;
   procedure New(file_ : string);
   procedure GetRecord(MoveP : Boolean = False);
   procedure Update(MoveP : Boolean = False);
   procedure Add;
   function GetIndex(name : string) : integer;
   procedure Open(file_ : string);
   procedure Next(n : integer = 1);
   procedure Del;
   procedure AbortDelete;
   procedure Close;
   procedure First;
 end;

function StrWinToDos(s : string) : string;
function StrDosToWin(s : string) : string;


implementation

uses Windows;

function StrWinToDos(s : string) : string;
begin
 if s = '' then Result :=''
  else begin
   SetLength(Result,Length(s));
   CharToOemBuff(PChar(s),PChar(Result),Length(s));
  end;
end;

function StrDosToWin(s : string) : string;
begin
 if s = '' then Result :=''
  else begin
   SetLength(Result,Length(s));
   OemToCharBuff(PChar(s),PChar(Result),Length(s));
  end;
end;

constructor TDBF_fileMemo.Create;
begin
 inherited Create;
 FileStream :=nil;
end;

destructor TDBF_fileMemo.Destroy;
begin
 FileStream.Free;
 inherited Destroy;
end;

procedure TDBF_fileMemo.New(name : string);
begin
 FileStream := TFileStream.Create(name,fmCreate);
 Add;
end;

procedure TDBF_fileMemo.Open(name : string);
var i,j : LongWord;
begin
 FileStream := TFileStream.Create(name,fmOpenReadWrite);
//Сравниваю первые четыре байта с длиной файла
 FileStream.Seek(0,soFromBeginning);
 FileStream.Read(i,4);
 j :=FileStream.Size div DBF_SizeSegment;
 if (FileStream.Size mod DBF_SizeSegment) <> 0 then j :=j+1;
 if i <> j then begin
  Close;
  raise EDBFError.Create('Структура не соответствует файлу содержащему MEMO поля.');
 end;
end;

procedure TDBF_fileMemo.Close;
begin
 FileStream.Free;
 FileStream :=nil;
end;

procedure TDBF_fileMemo.GetSegment(n : integer; p : pointer);
var CountSegment : integer;
begin
 if FileStream = nil then raise EDBFError.Create('Файл не указан');
//Вычисляю количество сегментов
 CountSegment :=FileStream.Size div DBF_SizeSegment;
 if (FileStream.Size mod DBF_SizeSegment) <> 0 then Inc(CountSegment);

 if (n < 0) or (n > CountSegment -1) then raise EDBFError.Create('Неверный номер сегмента ' + IntToStr(n));
 FileStream.Seek(DBF_SizeSegment*n,soFromBeginning);
 FileStream.Read(p^,DBF_SizeSegment);
end;

procedure TDBF_fileMemo.Put(n : integer; p : pointer; size : integer);
var CountSegment : integer;
begin
 if FileStream = nil then raise EDBFError.Create('Файл не указан');
//Вычисляю количество сегментов
 CountSegment :=FileStream.Size div DBF_SizeSegment;
 if (FileStream.Size mod DBF_SizeSegment) <> 0 then Inc(CountSegment);

 if (n < 0) or (n > CountSegment -1) then raise EDBFError.Create('Неверный номер сегмента ' + IntToStr(n));
 FileStream.Seek(DBF_SizeSegment*n,soFromBeginning);
 FileStream.Write(p^,size);
//Если размер изменился устанавливаю новый
 if (DBF_SizeSegment*n + size) > (CountSegment * DBF_SizeSegment) then SetCountSegments;
end;

function TDBF_fileMemo.Add(p : pointer = nil; size : integer = DBF_SizeSegment) : integer;
var a : pointer;
    l : integer;
begin
 if FileStream = nil then raise EDBFError.Create('Файл не указан');
//Достраиваю последний сегмент
 if (FileStream.Size mod DBF_SizeSegment) <> 0 then begin
  l :=DBF_SizeSegment - (FileStream.Size mod DBF_SizeSegment);
  GetMem(a,l);
  try
   FillChar(a^,l,0);
   FileStream.Seek(0,soFromEnd);
   FileStream.Write(a^,l);
  finally
   FreeMem(a,l);
  end;
 end;
//Возвращаю номер первого добавленного сегмента. (Первый сегмент имеет номер 0)
 Result :=FileStream.Size div DBF_SizeSegment;
//Добавляю сегменты
 if p = nil then begin
   GetMem(a,size);
   FillChar(a^,size,0);
  end else a :=p;
 try
  FileStream.Seek(0,soFromEnd);
  FileStream.Write(a^,size);
  SetCountSegments;
 finally
  if p = nil then FreeMem(a,size);
 end;
end;

procedure TDBF_fileMemo.SetCountSegments;
var CountSegment : LongWord;
begin
 if FileStream = nil then raise EDBFError.Create('Файл не указан');
//Вычисляю количество сегментов
 CountSegment :=FileStream.Size div DBF_SizeSegment;
 if (FileStream.Size mod DBF_SizeSegment) <> 0 then CountSegment :=CountSegment + 1;

 FileStream.Seek(0,soFromBeginning);
 FileStream.Write(CountSegment,4);
end;

constructor TDBF_fields.Create(n : integer = 0);
var i : integer;
begin
 inherited Create;
 FList :=TList.Create;
 for i :=1 to n do Add;
end;

destructor TDBF_fields.Destroy;
begin
 Clear;
 FList.Free;
 inherited Destroy;
end;

function TDBF_fields.Add : integer;
var p : pointer;
begin
 GetMem(p,SizeOf(TDBF_FIELD_REC));
 FillChar(p^,SizeOf(TDBF_FIELD_REC),0);
 Result :=FList.Add(p);
end;

procedure TDBF_fields.Delete(index : integer);
begin
 FreeMem(FList.Items[index],SizeOf(TDBF_FIELD_REC));
 FList.Delete(index);
end;

procedure TDBF_fields.Clear;
begin
 while FList.Count <> 0 do Delete(0);
end;

function TDBF_fields.GetCount : integer;
begin
 Result :=FList.Count;
end;

function TDBF_fields.GetField(index : integer) : TDBF_FIELD_REC;
begin
 Result :=TDBF_FIELD_REC(FList.Items[index]^);
end;

procedure TDBF_fields.Insert(index : integer);
var p : pointer;
begin
 GetMem(p,SizeOf(TDBF_FIELD_REC));
 FillChar(p^,SizeOf(TDBF_FIELD_REC),0);
 FList.Insert(index,p);
end;

procedure TDBF_fields.Check;
var i : integer;
begin
 if Count = 0 then raise EDBFError.Create('Информация о полях отсутствует.');
 for i :=0 to Count-1 do begin
  if trim(Field[i].field_name) = '' then raise EDBFError.Create('Имя поля не должно быть пустым.');
  case Field[i].field_type of
    DBF_FieldChar    : if Field[i].len_field[1] = 0 then raise EDBFError.Create('Длина поля должна быть больше ноля.');
    DBF_FieldDate    : if Field[i].len_field[1] <> DBF_LengthDate  then raise EDBFError.Create('Длина поля Date должна равняться '    + IntToStr(DBF_LengthDate)  + '.');
    DBF_FieldLogic   : if Field[i].len_field[1] <> DBF_LengthLogic then raise EDBFError.Create('Длина поля Logical должна равняться ' + IntToStr(DBF_LengthLogic) + '.');
    DBF_FieldMemo    : if Field[i].len_field[1] <> DBF_LengthMemo  then raise EDBFError.Create('Длина поля Memo должна равняться '    + IntToStr(DBF_LengthMemo)  + '.');
    DBF_FieldNumeric : if (Field[i].len_field[1] <= 0) or
                          (Field[i].len_field[1] < Field[i].len_field[2]) then raise EDBFError.Create('Не верно указана длина поля типа Numeric.');
   else
    raise EDBFError.Create('Не верно указан тип поля.');
  end;
 end;
end;

constructor TDBF_file.Create;
begin
 inherited Create;
 FFileStream :=nil;
 CurrentRecord :=nil;
 FDbf_fields :=TDBF_fields.Create;
end;

destructor TDBF_file.Destroy;
begin
 if FFileStream <> nil then Close;
 FDbf_fields.Free;
 FFileStream.Free;
 inherited Destroy;
end;

procedure TDBF_file.New(file_ : string);
var
 DBF_FIELD_REC : TDBF_FIELD_REC;
 i : integer;
 Year,Month,Day : Word;
 b : Byte;
begin
//Проверяю корректность заполнения информации о полях
 FDbf_fields.Check;

//Формирую заголовок
//Устанавливаю идентификатор файла
 FDBF_HEAD.dbf_id :=DBF_WithoutMemo;
 for i :=0 to FDbf_fields.Count -1 do
  if FDbf_fields.Field[i].field_type = DBF_FieldMemo then begin
   FDBF_HEAD.dbf_id :=DBF_WithMemo;
   break;
  end;
//Устанавливаю дату последнего обновления
 DecodeDate(Date,Year,Month,Day);
 FDBF_HEAD.last_update[1] :=Year mod 100;
 FDBF_HEAD.last_update[2] :=Byte(Month);
 FDBF_HEAD.last_update[3] :=Byte(Day);
//Устанавливаю номер последней записи
 FDBF_HEAD.last_rec :=0;
//Устанавливаю смещение данных
 FDBF_HEAD.data_offset :=SizeOf(TDBF_HEAD) + (SizeOf(TDBF_FIELD_REC) * FDbf_fields.Count) + 1;
//Устанавливаю длину записи
 FDBF_HEAD.rec_size :=0;
 for i :=0 to FDbf_fields.Count -1 do
  FDBF_HEAD.rec_size :=FDBF_HEAD.rec_size + FDbf_fields.Field[i].len_field[1];
 FDBF_HEAD.rec_size :=FDBF_HEAD.rec_size + 1;
//Обнуляю поле filler
 FillChar(FDBF_HEAD.filler,SizeOf(FDBF_HEAD.filler),0);

//Создаю фвйл
 FFileStream :=TFileStream.Create(file_,fmCreate);
//Записываю заголовок
 FFileStream.WriteBuffer(FDBF_HEAD,SizeOf(TDBF_HEAD));
//Записываю информацию о полях
 for i :=0 to FDbf_fields.Count -1 do begin
  DBF_FIELD_REC :=FDbf_fields.Field[i];
  FFileStream.WriteBuffer(DBF_FIELD_REC,SizeOf(TDBF_FIELD_REC));
 end;
 b :=DBF_EndFields;
 FFileStream.WriteBuffer(b,SizeOf(b));
 CurrentRecord :=StrAlloc(FDBF_HEAD.rec_size + 1);
 FillChar(CurrentRecord[0],FDBF_HEAD.rec_size + 1,0);
end;

function TDBF_file.IsEof : Boolean;
begin
 if FileStream = nil then raise EDBFError.Create('Файл не указан');
 Result :=((FileStream.Position+1) = FileStream.Size);
end;

procedure TDBF_file.First;
begin
 if FileStream = nil then raise EDBFError.Create('Файл не указан');
 FileStream.Seek(FDBF_HEAD.data_offset,soFromBeginning);
end;

procedure TDBF_file.Next(n : integer = 1);
begin
 if FileStream = nil then raise EDBFError.Create('Файл не указан');
 if Eof then Exit;
 FileStream.Seek(FDBF_HEAD.rec_size * n,soFromCurrent);
 if FileStream.Position > FileStream.Size then FileStream.Position :=FileStream.Size;
end;

procedure TDBF_file.GetRecord(MoveP : Boolean = False);
var p : LongInt;
begin
 if Eof then raise EDBFError.Create('Указатель находится на конце файла.');
 p :=FileStream.Position;
 FileStream.ReadBuffer(CurrentRecord[0],FDBF_HEAD.rec_size);
 if MoveP then FileStream.Seek(p,soFromBeginning);
end;

procedure TDBF_file.Update(MoveP : Boolean = False);
var p : LongInt;
begin
 if Eof then raise EDBFError.Create('Указатель находится на конце файла.');
 p :=FileStream.Position;
 FileStream.WriteBuffer(CurrentRecord[0],FDBF_HEAD.rec_size);
 if MoveP then FileStream.Seek(p,soFromBeginning);
end;

procedure TDBF_file.Add;
begin
 if FileStream = nil then raise EDBFError.Create('Файл не указан');
 FileStream.Seek(0,soFromEnd);
 FileStream.WriteBuffer(CurrentRecord[0],FDBF_HEAD.rec_size);
 SetCountRec;
end;

procedure TDBF_file.SetCountRec;
var l,p : LongInt;
begin
 l :=(FileStream.Size - FDBF_HEAD.data_offset) div FDBF_HEAD.rec_size;
 p :=FileStream.Position; FileStream.Seek(DBF_PosLastRec,soFromBeginning);
 FileStream.WriteBuffer(l,SizeOf(l));
 FileStream.Seek(p,soFromBeginning);
 FDBF_HEAD.last_rec :=l;
end;

function TDBF_file.GetField(index : integer) : string;
var i,j : integer;
begin
 Result :=''; j :=1;
 for i :=0 to index -1 do j :=j+FDbf_fields.Field[i].len_field[1];
 SetLength(Result,FDbf_fields.Field[index].len_field[1]);
 FillChar(Result[1],FDbf_fields.Field[index].len_field[1],0);
 Move(CurrentRecord[j],Result[1],FDbf_fields.Field[index].len_field[1]);
end;

procedure TDBF_file.SetField(index : integer; value : string);
var i,j : integer;
begin
 j :=1;
 for i :=0 to index -1 do j :=FDbf_fields.Field[i].len_field[1];
 if length(value) > FDbf_fields.Field[index].len_field[1] then Delete(value, FDbf_fields.Field[index].len_field[1]+1,length(value) - FDbf_fields.Field[index].len_field[1])
  else if length(value) < FDbf_fields.Field[index].len_field[1] then begin
   i :=Length(value);
   SetLength(value,FDbf_fields.Field[index].len_field[1]);
   FillChar(value[i+1],Length(value) - i,' ');
 end;
 Move(value[1],CurrentRecord[j],FDbf_fields.Field[index].len_field[1]);
end;

function TDBF_file.GetIndex(name : string) : integer;
var i : integer;
begin
 Result :=-1;        //Чтобы не выскакивало предупреждение
 name :=trim(name);
 for i :=0 to FDbf_fields.Count -1 do
  if name = trim(FDbf_fields.Field[i].field_name) then begin
   Result :=i;
   Exit;
  end;
 if Result = -1 then raise EDBFError.Create('Поле: ' + name + ' не найдено.');
end;

function TDBF_file.IsDel : Boolean;
begin
 Result :=(CurrentRecord[0] = Chr(DBF_RecDel));
end;

procedure TDBF_file.Del;
begin
 CurrentRecord[0] :=Chr(DBF_RecDel);
end;

procedure TDBF_file.AbortDelete;
begin
 CurrentRecord[0] :=Chr(DBF_NonDel);
end;

procedure TDBF_file.Open(file_ : string);
var b : Byte;
begin
 if FileStream <> nil then raise EDBFError.Create('Имеется открытый файл.');
//Открываю файл
 FFileStream :=TFileStream.Create(file_,fmOpenReadWrite);
//Читаю заголовок
 FileStream.ReadBuffer(FDBF_HEAD,SizeOf(TDBF_HEAD));
//Проверяю первый байт заголовка
 if (FDBF_HEAD.dbf_id <> DBF_WithMemo) and (FDBF_HEAD.dbf_id <> DBF_WithoutMemo)
  then raise EDBFError.Create('Структура не соответствует файлу dbf');
//Читаю параметры полей
 FileStream.ReadBuffer(b,1); FileStream.Seek(-1,soFromCurrent);
 while b <> DBF_EndFields do begin
  FileStream.ReadBuffer(FDbf_Fields.List.Items[FDbf_Fields.Add]^,SizeOf(TDBF_FIELD_REC));
  FileStream.ReadBuffer(b,1); FileStream.Seek(-1,soFromCurrent);
 end;

 CurrentRecord :=StrAlloc(FDBF_HEAD.rec_size + 1);
 FillChar(CurrentRecord[0],FDBF_HEAD.rec_size + 1,0);
end;

procedure TDBF_file.Close;
begin
 FileStream.Free;
 FDbf_fields.Clear;
 if CurrentRecord <> nil then StrDispose(CurrentRecord);
 FFileStream   :=nil;
 CurrentRecord :=nil;
end;

end.