[roamer]

Когда-то пришлось писать базу данных в Pascal for DOS.
Тогда пришлось написать инструментарий.
Не шедевр (по текстам), но рабочий вариант.
Может кому-то пригодится.
================================

Код:

{Дополнить запись в конец файла}
function AppendRecToFile(NameF : String;
                         Var PBuf : Pointer;
                         SizeRec : LongInt) : LongInt;
{Записать запись в файл}
function PutRecToFile(NameF : String;
                      Var PBuf : Pointer;
                      NumRec,SizeRec : LongInt) : Boolean;
{Прочитать запись из файла по номеру}
function GetRecFromFile(NameF : String;
                        Var PBuf : Pointer;
                        NumRec,SizeRec : LongInt) : Boolean;



implementation


function GetFAttrWithNameFile(NameF : String;Var A : integer) : Boolean;
{Прочитать атрибуты файла}
{
faReadOnly  $00000001  Read-only files
faHidden    $00000002  Hidden files
faSysFile   $00000004  System files
faVolumeID  $00000008  Volume ID files
faDirectory $00000010  Directory files
faArchive   $00000020  Archive files
faAnyFile   $0000003F  Any file
}
begin
  Result:=false;
  A:=0;
  if FileExists(NameF) then begin
     A:=FileGetAttr(NameF);
     if A=128 then A:=0;
     if A>0 then begin
        Result:=true;
     end;
  end;
end;


function SetFAttrWithNameFile(NameF : String;A : integer) : Boolean;
{Записать атрибуты файла}
begin
  Result:=false;
  if FileExists(NameF) then begin
     Result:=true;
     if FileSetAttr(NameF,A)<0 then Result:=false;
  end;
end;


function CountRecInFile(NameF : String; SizeRec : LongInt) : LongInt;
{Количество записей в файле}
Var
  A : integer;
  Yes : Byte;
  CCC999 : LongInt;
  Ok99 : Boolean;
  FF : file of byte;
begin
  {SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);}
  Result:=-1;
  if SizeRec>0 then begin
     Yes:=0;
     CCC999:=0;
     if  GetFAttrWithNameFile(NameF,A) then begin
        if  SetFAttrWithNameFile(NameF,0) then begin
           AssignFile(FF,NameF);
           {$I-} reset(FF) {$I+};
           Ok99:=(IoResult=0);
           if Ok99 then begin
              {$I-} CCC999:=FileSize(FF) {$I+};
              Ok99:=(IoResult=0);
              if Ok99 then begin
                 Yes:=1;
              end;
              {$I-} CloseFile(FF) {$I+};
              Ok99:=(IoResult=0);
           end;
           if Yes>0 then begin
               Result:=trunc(CCC999/SizeRec);
           end;
        end;
        SetFAttrWithNameFile(NameF,A);
     end;
  end;
end;


function CreateFile(NameF : String) : Boolean;
{Создать файл}
Var
  Ok99 : Boolean;
  FF : file of byte;
begin
  {SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);}
  Result:= False;
  AssignFile(FF,NameF);
  {$I-} rewrite(FF) {$I+};
  Ok99:=(IoResult=0);
  if Ok99 then begin
     {$I-} CloseFile(FF) {$I+};
     Ok99:=(IoResult=0);
     Result := True;
  end;
end;


function GetFromFile0(NameF : String;
                      Var PBuf : Pointer;
                      StartByte, Count : LongInt) : Boolean;
{Прочитать количество байт из файла}
Var
  A : integer;
  Res : LongInt;
  Yes:byte;
  CountRec : LongInt;
  Ok99 : Boolean;
  FF : file;
  NumRead : Integer;
  NumWritten: integer;
  i : word;

begin
  {SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);}
  Yes:=0;
  Result := False;
  if (StartByte>=0) and (Count>0) then begin
     AssignFile(FF,NameF);
     if GetFAttrWithNameFile(NameF,A) then begin
        if SetFAttrWithNameFile(NameF,0) then begin
           {$I-} reset(FF,1) {$I+};
           Ok99:=(IoResult=0);
           if Ok99 then begin
              {$I-} CountRec:=FileSize(FF) {$I+};
              Ok99:=(IoResult=0);
              if Ok99 then begin
                 if (StartByte+Count-1) <= CountRec then begin
                    {$I-} seek(FF,StartByte) {$I+};
                    Ok99:=(IoResult=0);
                    if Ok99 then begin
                       {$I-} BlockRead(FF, PBuf^, Count, NumRead) {$I+};
                       Ok99:=(IoResult=0);
                       if Ok99 then begin
                          if Count= NumRead then begin
                             Yes:=1;
                          end;
                       end;
                    end;
                 end;
              end;
              {$I-} CloseFile(FF) {$I+};
              Ok99:=(IoResult=0);
           end;
           if Yes>0 then Result := True;
        end;
        SetFAttrWithNameFile(NameF,A);
     end;
  end;
end;


function PutToFile0(NameF : String;
                    Var PBuf : Pointer;
                    StartByte,Count : LongInt) : Boolean;
{Записать количество байт в файл}
Var
  A : integer;
  Res : LongInt;
  Yes:byte;
  CountRec : LongInt;
  Ok99 : Boolean;
  FF : file;
  NumRead : integer;
  NumWritten: integer;
  i : word;

begin
  {SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);}
  Yes:=0;
  Result := False;
  if (StartByte>=0) and (Count>0) then begin
     AssignFile(FF,NameF);
     if GetFAttrWithNameFile(NameF,A) then begin
        if SetFAttrWithNameFile(NameF,0) then begin
           {$I-} reset(FF,1) {$I+};
           Ok99:=(IoResult=0);
           if Ok99 then begin
              {$I-} CountRec:=FileSize(FF) {$I+};
              Ok99:=(IoResult=0);
              if Ok99 then begin
                 if (StartByte+Count-1) <= CountRec then begin
                    {$I-} seek(FF,StartByte) {$I+};
                    Ok99:=(IoResult=0);
                    if Ok99 then begin
                       {$I-} BlockWrite(FF, PBuf^, Count, NumRead) {$I+};
                       Ok99:=(IoResult=0);
                       if Ok99 then begin
                          if Count = NumRead then begin
                             Yes:=1;
                          end;
                       end;
                    end;
                 end;
              end;
              {$I-} CloseFile(FF) {$I+};
              Ok99:=(IoResult=0);
           end;
           if Yes>0 then Result := True;
        end;
        SetFAttrWithNameFile(NameF,A);
     end;
  end;
end;


function AppendToFile0(NameF : String;
                       Var PBuf : Pointer;
                       Count : LongInt) : Boolean;
{Дополнить количество байт в конец файл}
Var
  A : integer;
  Res : LongInt;
  Yes:byte;
  CountRec : LongInt;
  Ok99 : Boolean;
  FF : file;
  NumRead : integer;
  NumWritten: integer;
  i : word;

begin
  {SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);}
  Yes:=0;
  Result := False;
  if (Count>0) then begin
     AssignFile(FF,NameF);
     if GetFAttrWithNameFile(NameF,A) then begin
        if SetFAttrWithNameFile(NameF,0) then begin
           {$I-} reset(FF,1) {$I+};
           Ok99:=(IoResult=0);
           if Ok99 then begin
              {$I-} CountRec:=FileSize(FF) {$I+};
              Ok99:=(IoResult=0);
              if Ok99 then begin
                 {$I-} seek(FF,CountRec) {$I+};
                 Ok99:=(IoResult=0);
                 if Ok99 then begin
                    {$I-} BlockWrite(FF, PBuf^, Count, NumRead) {$I+};
                    Ok99:=(IoResult=0);
                    if Ok99 then begin
                       if Count= NumRead then begin
                          Yes:=1;
                       end;
                    end;
                 end;
              end;
              {$I-} CloseFile(FF) {$I+};
              Ok99:=(IoResult=0);
           end;
           if Yes>0 then Result := True;
        end;
        SetFAttrWithNameFile(NameF,A);
     end;
  end;
end;




function GetRecFromFile(NameF : String;
                        Var PBuf : Pointer;
                        NumRec,SizeRec : LongInt) : Boolean;
{Прочитать запись из файла по номеру}
begin
  Result := GetFromFile0(NameF,PBuf,NumRec*SizeRec,SizeRec);
end;

function PutRecToFile(NameF : String;
                      Var PBuf : Pointer;
                      NumRec,SizeRec : LongInt) : Boolean;
{Записать запись в файл}
begin
   Result := PutToFile0(NameF,PBuf,NumRec*SizeRec,SizeRec);
end;

function AppendRecToFile(NameF : String;
                         Var PBuf : Pointer;
                         SizeRec : LongInt) : LongInt;
{Дополнить запись в конец файла}
Var
  Yes : byte;
begin
  Result := -1;
  Yes:=1;
  if not FileExists(NameF) then begin
     if not CreateFile(NameF) then Yes:=0;
  end;
  if Yes>0 then begin
     if AppendToFile0(NameF,PBuf,SizeRec) then begin
        Result := CountRecInFile(NameF,SizeRec);
     end;
  end;
end;



end.