(* FILE_FMS использует: UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O-,R+,S+,V+,X-}
{$M 16384,0,65536}
Unit FILE_FMS;
INTERFACE
Uses DOS, CRT, UNIF_FMS;
TYPE tPOF = function( Fn : String) : integer;
Tcls = procedure(var Tf : text);
TBFF = array [1..$FFF0] of byte;
DeBill = record LogRec : longint;
Colly : array [1..257] of integer;
Rolly : array [1..256] of char;
NumCol : integer;
BasAdr : longint;
Errors : word;
BaseRc : integer;
MemPTR : ^TBFF; { Буфер }
MemSIZ : word; { Размер }
MemRec : integer; { К.записей }
MemAdr : word; { Б.ардес }
Mem1st : LongInt; { Первое загруженное }
end;
CONST SizeDeBi = SizeOf(DeBill) and $7FFE; { Четное }
VAR DeBi : DeBill; { Основная структура DBF-файла }
F_text : Text;
F_file : File;
function SeekFile(var F : file; L : LongInt) : boolean;
function ReadFile(var F : file; var B; L : word ) : boolean;
function WritFile(var F : file; var B; L : word ) : boolean;
function PushFile(var F : file; var B; L : word ) : boolean;
function Pop_File(var F : file; var B ) : boolean;
function OpenText(FN : String) : boolean;
function OpenFile(FN : String) : boolean;
function Open_Uni(FN : String; POF : tPOF) : boolean;
procedure KillFile(FN : String);
procedure BuffFile(var P : pointer; var W : LongInt);
function MoveFile(var F_file,T_file : file; M : LongInt) : boolean;
procedure Cls_File(var F : File);
procedure Cls_Text(var T : Text);
procedure ClerFile(var F : File);
procedure ClerText(var F : Text);
function NameFile( S : String) : String;
function SizeFile( FN : String) : LongInt;
function FindFile( FN : String) : boolean;
function CopyFile(SF,ST : String) : boolean;
function CopyText(SF,ST : String) : boolean;
function EquaFile(SF,ST : String) : boolean;
{ ;;;;;;;;; Multi Sections File ;;;;;;;;;;;;; }
procedure OpnSec(NB : LongInt);
procedure DelSec(NF : LongInt);
function NmrSec : LongInt;
function NewSec : LongInt;
function pEoSec : boolean;
procedure EndSec;
procedure WraSec(var A; L : integer);
procedure RdsSec(var S : String );
procedure OpnMSF( FN : String);
procedure ClsMSF;
function ErrMSF : integer;
IMPLEMENTATION
procedure Cls_File(var F : file);
begin {$I-} Close(F);
{$I+} if IOresult = 0 then end;
procedure Cls_Text(var T : text);
begin {$I-} Close(T);
{$I+} if IOresult = 0 then end;
function geName(var A) : String;
var B : array [0..79] of char absolute A;
S : String[80];
I : integer;
begin S[0]:=chr(80);
for I:=79 downto 0 do begin
S[I+1]:=B[I];
if B[I] = chr(0) then S[0]:=chr(I)
end;
geName:=S end;
procedure ClerFile(var F : file);
var I,J : integer;
G : file;
S : String[80];
begin S:=geName(FileRec(F).Name);
assign(G,S);
{$I-} reset(G,1);
{$I+} I:=IOresult;
Cls_File(F);
{$I-} Erase(F);
{$I+} J:=IOresult;
if I = 0 then Cls_File(G);
if FindFile(S) then KillFile(S) end;
procedure ClerText(var F : text);
var I,J : integer;
G : text;
S : String[80];
begin S:=geName(TextRec(F).Name);
assign(G,S);
{$I-} reset(G);
{$I+} I:=IOresult;
Cls_Text(F);
{$I-} Erase(F);
{$I+} J:=IOresult;
if I = 0 then Cls_Text(G);
if FindFile(S) then KillFile(S) end;
function SizeFile(FN : String) : LongInt;
var Dif : SearchRec;
begin FindFirst(FN,Archive,Dif);
if DosError = 0 then SizeFile:=Dif.Size
else SizeFile:=-1 end;
function FindFile(FN : String) : boolean;
begin FindFile:=(0 <= SizeFile(FN)) end;
function NameFile(S : String) : String;
var Ds : DirStr;
Nm : NameStr;
Et : ExtStr;
begin Fsplit(S,Ds,Nm,Et);
S:='';
SummStr(S,Ds);
SummStr(S,Nm);
SummStr(S,Et);
NameFile:=S end;
function SeekFile(var F : file; L : LongInt) : boolean;
begin {$I-} Seek(F,L);
{$I+} SeekFile:=(IOresult = 0) end;
function ReadFile(var F : file; var B; L : word) : boolean;
begin {$I-} BlockRead(F,B,L);
{$I+} ReadFile:=(IOresult = 0) end;
function WritFile(var F : file; var B; L : word) : boolean;
begin {$I-} BlockWrite(F,B,L);
{$I+} WritFile:=(IOresult = 0) end;
function PushFile(var F : file; var B; L : word) : boolean;
begin if WritFile(F,B,L) then PushFile:=WritFile(F,L,2)
else PushFile:=false end;
function Pop_File(var F : file; var B) : boolean;
var FP : LongInt;
L : word;
begin FP:=FilePos(F)-2; Pop_File:=false;
if SeekFile(F, FP ) then
if ReadFile(F, L,2) then
if SeekFile(F,FP-L) then
if ReadFile(F,B,L) then Pop_File:=SeekFile(F,FP-L) end;
function Open_Uni(FN : String; POF : tPOF) : boolean;
var T : LongInt;
W : boolean;
begin Open_Uni:=false;
T:=TimeSec;
repeat;
if FindFile(FN) then W:=(POF(FN) = 0)
else Exit;
until TimeOvr(T,3) or W;
Open_Uni:=W end;
function ResetText(FN : String) : integer;
begin assign(F_text,FN);
{$I-} reset(F_text); {$I+}
ResetText:=IOresult end;
function OpenText(FN : String) : boolean;
begin OpenText:=Open_Uni(FN,ResetText) end;
function ResetFile(FN : String) : integer;
begin assign(F_file,FN);
{$I-} reset(F_file,1); {$I+}
ResetFile:=IOresult end;
function OpenFile(FN : String) : boolean;
begin OpenFile:=Open_Uni(FN,ResetFile) end;
procedure KillFile(FN : String);
var I : integer;
F : file;
begin if FN = 'PRN' then Exit;
assign(F,FN);
{$I-} Erase(F); {$I+}
I:=IOresult end;
procedure BuffFile(var P : pointer; var W : LongInt);
begin W:=MaxAvail;
if 64000 < W then W:=64000;
if odd(W) then W:=W-1;
if SizeDeBi < W then GetMem(P,W) else begin
P:=addr(DeBi);
W:=SizeDeBi
end end;
function MoveFile(var F_file,T_file : file; M : LongInt) : boolean;
var V,W : LongInt;
R : boolean;
BF : pointer;
begin BuffFile(BF,W);
R:=true;
while (0 < M) and R do begin
if W < M then V:=W
else V:=M;
M:=M-V;
R:=ReadFile(F_file,BF^,V) and WritFile(T_file,BF^,V)
end;
if SizeDeBi < W then FreeMem(BF,W);
MoveFile:=R end;
function CopyText(SF,ST : String) : boolean;
var T_text : text;
W : boolean;
S : String;
begin W:=OpenText(SF);
if W then begin
assign(T_text,ST); {$I-}
rewrite(T_text); {$I+}
W:=(IOresult = 0);
if W then begin
while W and (not eof(F_text)) do begin
{$I-} readln(F_text,S);
{$I+} W:=(IOresult = 0);
if W then begin
{$I-} writeln(T_text,S);
{$I+} W:=(IOresult = 0)
end
end;
Cls_Text(F_text);
if not W then KillFile(ST)
end;
Cls_Text(T_text)
end;
CopyText:=W end;
function CopyFile(SF,ST : String) : boolean;
var T_file : file;
W : boolean;
begin W:=OpenFile(SF);
if W then begin
assign(T_file,ST); {$I-}
rewrite(T_file, 1); {$I+}
W:=(IOresult = 0);
if W then begin
W:=MoveFile(F_File,T_file,FileSize(F_file));
Cls_File(T_file);
if not W then KillFile(ST)
end;
Cls_File(F_file)
end;
CopyFile:=W end;
function EquaFile(SF,ST : String) : boolean;
Type A = array [1..64000] of byte;
var W,M : longint;
V : word;
R : boolean;
BF : ^A;
PF : pointer absolute BF;
T_file : file;
begin EquaFile:=false;
if not OpenFile(SF) then Exit;
assign(T_file,ST);
{$I-} reset(T_file,1); {$I+}
if IOresult <> 0 then begin
Cls_File(F_file);
Exit
end;
BuffFile(PF,W);
W:=W div 2;
M:= FileSize(F_file);
R:=(M = FileSize(T_file));
while (0 < M) and R do begin
if W < M then V:=W
else V:=M;
M:=M-V;
R:=false;
if ReadFile(F_file,BF^[ 1],V) then
if ReadFile(T_file,BF^[W+1],V) then
repeat
R:=(BF^[V] = BF^[W+V]);
V:=V-1;
until (V <= 0) or (not R)
end;
W:=W shl 1; { W:=2*W }
if SizeDebi < W then FreeMem(BF,W);
Cls_File(F_file);
Cls_File(T_file);
EquaFile:=R end;
{end.}
{ ;;;;;;;;;;;;;;;;;;; Multi Sections File ;;;;;;;;;;;;;;;;;;;;;;; }
type tMSF = record NL : LongInt; { Next FP | -(Занято+1) }
TS : array [1..508] of byte;
PT : integer; { Текущая позиция в блоке }
WT : boolean; { Признак записи в блок }
FP : LongInt; { FilePos тек.блока }
FR : LongInt; { -1,-2... | начало цеп. Free блоков }
ER : integer; { Ошибка }
WA : boolean; { Файл изменялся - спасти Free цеп-ку}
end;
var MSF : tMSF;
MTB : file;
{ MSF.ER = 0 - O'K }
{ 901 - не могу открыть MSF-файл }
{ 902 - нарушена структура MSF-файла }
{ 903 - ошибка чтения }
{ 904 - ошибка записи }
function Rds_File(var F : file; L : LongInt; var B; S : word) : boolean;
begin if SeekFile(F,L) then Rds_File:=ReadFile(F,B,S)
else Rds_File:=false end;
function Wrt_File(var F : file; L : LongInt; var B; S : word) : boolean;
begin if SeekFile(F,L) then Wrt_File:=WritFile(F,B,S)
else Wrt_File:=false end;
procedure rXxBLK(L : LongInt; var B; S : word);
begin with MSF do
if ER = 0 then
if not Rds_File(MTB,L,B,S) then ER:=903 end;
procedure wXxBLK(L : LongInt; var B; S : word);
begin with MSF do
if ER = 0 then
if not Wrt_File(MTB,L,B,S) then ER:=904 end;
function LstBLK : LongInt;
begin LstBLK:=FileSize(MTB) and $7FFFFFE0 end;
{ OpnSec : читать новый блок по адресу NB }
{ если NB < 0 , то [запись] }
{ ;;;;;;; ОТКРЫТЬ СТАРУЮ СЕКЦИЮ ;;;;;;;; }
procedure OpnSec(NB : LongInt);
var K : integer;
begin with MSF do begin
if WT then begin { Записать текущий блок }
wXxBLK(FP,MSF,512);
WA:=true;
WT:=false
end;
if 0 <= NB then begin { Читать новый блок }
rXxBLK(NB,MSF,512);
FP:=NB
end;
PT:=1
end end;
{ DelSec : Удалить секцию NF }
procedure DelSec(NF : LongInt);
var FF : LongInt;
begin if 0 <= NF then with MSF do begin { Есть присоединяемая цепочка }
FF:=FR;
FR:=NF;
if FF < 0 then Exit; { Основная цепочка еще не сформирована }
repeat
OpnSec(NF);
NF:=NL
until NF < 0;
WT:=true;
NL:=FF
end end;
{ NmrSec : Позиция секции, которая будет получена }
{ следующей операцией NewSec }
function NmrSec : LongInt;
begin with MSF do
if FR < 0 then NmrSec:=LstBLK
else NmrSec:=FR end;
{ NewSec : Открыть новую секцию }
{ Res = Позиция новой секции }
{ NmrSec позволяет заранее узнать номер новой секции }
function NewSec : LongInt;
var L : LongInt;
begin OpnSec(-1);
with MSF do begin
L:=NmrSec;
if 0 <= FR then begin
OpnSec(FR); { Прихватить Free-блок }
FR:=NL
end;
FP:=L;
WT:=true;
NL:= -1;
PT:= 1;
NewSec:=FP
end end;
function ErrMSF : integer;
begin ErrMSF:=MSF.ER end;
{ pEoSec : Признак конца секции }
function pEoSec : boolean;
begin with MSF do pEoSec:=(NL < 0) and (abs(NL)-1 < PT) end;
{ EndSec : Внести признак конца секции }
procedure EndSec;
var FF : LongInt;
begin with MSF do begin
FF:=NL;
NL:=-PT;
WT:=true;
DelSec(FF)
end end;
procedure in_BLK(var L,D : integer);
var B : integer;
begin B:=508-MSF.PT; { В текущем блоке }
if L < B then B:=L;
D:=L-B;
L:=B end;
{ RdsSec : Читать из секции очередную строку }
procedure RdsSec(var S : String);
var D,L : integer;
begin with MSF do begin
if 508 < PT then OpnSec(NL);
L:=TS[PT];
in_BLK(L,D);
Move(TS[PT],S[0],L+1); { В текущем }
PT:=PT+L+1;
if 0 < D then begin
OpnSec(NL); { В следующем }
Move(TS[PT],S[L+1],D);
PT:=PT+D
end
end end;
{ wGoBLK : Перейти к следующему блоку при записи }
procedure wGoBLK;
begin with MSF do
if 0 < NL then OpnSec(NL) else begin
if FR < 0 then begin { Нет свободной цепочки }
NL:=LstBLK;
if FP = NL then NL:=NL+512;
OpnSec(-1); { Сбросить текущий блок }
FP:=NL
end else begin
NL:=FR;
OpnSec(FR); { Прихватить Free- блок }
FR:=NL
end;
NL:=-1
end end;
{ WraSec : записать Var A в очередную позицию }
{ L = длина A }
procedure WraSec(var A; L : integer);
type B255 = array [1..255] of byte;
var D : integer;
X : ^B255;
begin if L < 0 then Exit;
if 255 < L then Exit;
X:=addr(A);
with MSF do begin
if 508 < PT then wGoBLK;
TS[PT]:=L;
WT:=true;
In_BLK(L,D);
PT:=PT+1;
if 0 < L then begin
Move(X^[1],TS[PT],L);
WT:=true;
PT:=PT+L
end;
if 0 < D then begin
wGoBLK;
Move(X^[L+1],TS[PT],D);
WT:=true;
PT:=PT+D
end
end end;
function ResMTB(Fn : String) : integer;
begin assign(MTB,Fn);
{$I-} reset(MTB,1); {$I+}
ResMTB:=IOresult end;
procedure OpnMSF(FN : String);
var W : boolean;
L,M : LongInt;
begin if FindFile(Fn) then W:=Open_Uni(FN,ResMTB) else begin
assign(MTB,FN);
{$I-} rewrite(MTB,1);
{$I+} W:=(IOresult = 0)
end;
with MSF do begin
if not W then ER:=901 else begin
ER:=0;
L:=FileSize(MTB);
M:=L and $1F;
if M = 0 then FR:= -1
else if M <> 4 then ER:=902 { Не соответствие логической структуры }
else rXxBLK(L-4,FR,4);
WT:=false;
WA:=false;
PT:=1;
ER:=0;
FP:=0;
NL:=-1;
if ER = 0 then
if L = 0 then L:=NewSec
else OpnSec(0)
end;
if ER <> 0 then Cls_File(MTB)
end end;
procedure ClsMSF;
var L : LongInt;
begin with MSF do begin
OpnSec(-1); { [ Сбросить последний блок ]}
if WA then wXxBLK(LstBLK,FR,4);
end;
Cls_File(MTB) end;
end.
|