(* D_UNIT использует: CRUF_FMS *)
(* FILE_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O-,R+,S+,V+,X-}
{$M 16384,0,65536}
unit D_Unit;
INTERFACE
uses DOS, CRT, UNIF_FMS, CRUF_FMS, TYPE_FMS, FILE_FMS;
function OpnMed(fName : String) : boolean;
function D_Back(var Fb : file) : boolean;
procedure D_Close; { Message спасаем }
procedure D_Close1; { Message не спасаем }
procedure D_Erase; { Message удаляем }
procedure D_MEMOS;
procedure D_Write( I : Word);
procedure D_Read ( I : Word);
Const CCK = 10000;
Type TIF = record FLD,GEN : integer end;
CKT = array [0..CCK] of TIF;
pCKT = ^CKT;
TYPE_HABOPOT = array [0..16] of integer;
procedure FISQ_HABOPOT(L : integer; var A : TYPE_HABOPOT);
function D_MAKE( SQ : pCKT;
CEL0 : pMessage;
CDL0 : word;
var Fo : file) : boolean;
CONST medMEDmed : String[9] = 'medMEDmed'; { Опознавательный префикс }
{ W-формата сообщений }
var SizeOfField : word; { Размер текущего поля в байтах }
SizeOfMessa : word; { Размер последов.полей в байтах }
D_Init_Name : String[80];
Err_D_Init : integer; { 0 - O'k }
{ 401 - Файл отсутствует или блокирован }
{ 402 - Ошибка чтения из файла }
{ 403 - Некорректная структура файла }
{ 404 - Недостаточно оперативной памяти }
{ 405 - Ошибка последовательности полей }
FogMed : byte; { Количество логических полей в сообщении }
PthMed : array [1..256] of byte; { Ссылки на генераторы }
FisMed : array [1..256] of integer; { Представители лог.полей }
IMPLEMENTATION
TYPE ArBy = array [0..65534] of byte;
VAR F_work : file;
Med_Memo : ^ArBy; { = NIL - файл находится на диске }
CONST Init : boolean = false; { Признак открытого/закрытого сообщения }
function ResetWork(Fn : String) : integer;
begin assign(F_work,Fn);
{$I-} reset(F_work,1); {$I+}
ResetWork:=IOresult end;
type TML = array [0.. 1000] of Longint;
Grupa_VRF = record {для параметров группы в указатель VRF}
Kp,Kg,N,K : byte; {кол повт, кол сгенерир, начало, конец}
end;
var ML : ^TML;
KolML : word; { количество элементов ML }
DL0 : word; { длина 0-го элемента }
MaxZona : word; { длина максимальной зоны }
Zona1 : pointer;
Zona : pHead; { реальное начало }
R : record O,S:word end absolute Zona;
EL01 : pointer;
EL0 : pMessage;
RE : record O,S:word end absolute EL0;
KOL,KolM,KolM0 : word;
I_read : word;
MAS : array [1..1000] of word; { для настройки }
Med_Size : LongInt; { FileSize(F) }
Pos_Memo : LongInt;
const TFR : boolean = false;
function wBlockRead(var F : file; var V; S : word) : boolean;
var L : LongInt;
begin if Med_Memo = NIL
then wBlockRead:=ReadFile(F,V,S)
else begin
L:=Pos_Memo+S;
if L <= Med_Size then begin
Move(Med_Memo^[Pos_Memo],V,S);
Pos_Memo:=L;
wBlockRead:=true
end else wBlockRead:=false
end end;
function wBlockWrite(var F : file; var V; S : word) : boolean;
var L : LongInt;
begin if Med_Memo = NIL
then wBlockWrite:=WritFile(F,V,S)
else begin
L:=Pos_Memo+S;
if L <= Med_Size then begin
Move(V,Med_Memo^[Pos_Memo],S);
Pos_Memo:=L;
wBlockWrite:=true
end else wBlockWrite:=false
end end;
function wSeek(var F : file; L : LongInt) : boolean;
begin wSeek:=true;
if Med_Memo = NIL
then wSeek:=SeekFile(F,L)
else if (0 <= L) and (L <= Med_Size)
then Pos_Memo:=L
else wSeek:=false end;
procedure POP(var V);
var FP : Longint;
begin if not Init then Exit;
if Med_Memo = NIL then FP:=FilePos(F_work)
else FP:=Pos_Memo;
if wSeek(F_work,FP-2 ) then if wBlockRead(F_work,KOL, 2) then
if wSeek(F_work,FP-2-KOL) then if wBlockRead(F_work,V ,KOL) then
if wSeek(F_work,FP-2-KOL) then end;
{ D_Close, }
{ D_Close1 : - закрытие файла, }
{ - высвобождение памяти для: -- Message, }
{ -- первого Head }
{ -- общей зоны }
procedure wFAL(var F : File; var A; L : word);
begin if wBlockWrite(F,A,L) then
if wBlockWrite(F,L,2) then end;
procedure FreeMemo;
begin if Med_Memo <> NIL then FreeMem(Med_Memo,Med_Size )
else FreeMem(ML , 4*KolML);
if Zona1 <> NIL then FreeMem(Zona1 ,MaxZona+16);
if EL01 <> NIL then FreeMem(EL01 ,DL0 +16);
MESSAGE:=NIL;
Med_Memo:=NIL;
Zona1:=NIL;
EL01:=NIL;
ML:=NIL end;
function PTRmem(S : word) : pointer;
var P : pointer;
begin if S <= MaxAvail then GetMem(P,S)
else P:=NIL;
PTRmem:=P end;
procedure O_Close1;
begin Init:=false;
Cls_File(F_work);
FreeMemo end;
procedure D_Close1;
begin if Init then O_Close1 end;
{ D_Erase : Закрыть и удалить W-сообщение }
procedure D_Erase;
begin if Init then begin
Init:=false;
ClerFile(F_work);
FreeMemo
end end;
procedure D_Close;
begin if not Init then Exit;
D_Write(0);
if Med_Memo <> NIL then begin
if SeekFile(F_work,0) then
if WritFile(F_work,Med_Memo^[0],Med_Size) then
end;
O_Close1 end;
{ D_Back - Минимальная операция копирования текущего }
{ открытого сообщения в файл Fb }
{ Метод : Reset(Fb,1); Seek(Fb,0); D_Back(Fb); Trancate(Fb); Close(Fb) }
function D_Back(var Fb : file) : boolean;
begin D_Write(0);
if Med_Memo <> NIL
then D_Back:=WritFile(Fb,Med_Memo^[0],Med_Size)
else if SeekFile(F_work,0)
then D_Back:=MoveFile(F_work,Fb,Med_Size)
else D_Back:=false end;
{ D_Init : - открытие файла Fname }
{ - выделение памяти для Message, первого Head и общей зоны; }
{ (если D_Init = NIL, то нет достаточной памяти) }
{ - загрузка поля Message и первого Head }
{ общая зона пока что не загружена }
function Get_PSP : boolean;
var MMM : array [0..6] of word;
begin Get_PSP:=false;
if wSeek(F_work,Med_Size-14) then
if wBlockRead(F_work,MMM,14) then
if MMM[1] > 1 then
if MMM[2] = 2 then
if MMM[4] = 2 then
if MMM[6] = 2 then
if MMM[0] = 4*MMM[1] then
if MMM[0]+24 <= Med_size then begin
KolML:=MMM[1]; { к-во элементов в ML (и 0-ой эл-т включит.) }
DL0:=MMM[3]; { длина 0-го элемента }
MaxZona:=MMM[5]; { загрузить максимальную длину зоны }
Get_PSP:=true
end end;
function Get_Memo : boolean;
var K4 : word;
L : LongInt;
begin K4:=4*KolML;
L:=Med_Size-14-K4;
Zona1:=PTRmem(MaxZona+16);
EL01:=PTRmem(DL0 +16);
if Med_Memo <> NIL
then ML:=addr(Med_Memo^[L])
else if SeekFile(F_work,L) then begin
ML:=PTRmem(K4);
if ML <> NIL then
if not ReadFile(F_work,ML^,K4) then begin
FreeMem(ML,K4);
ML:=NIL
end
end;
Get_Memo:=(Zona1 <> NIL) and (ML <> NIL) and (EL01 <> NIL) end;
{ D_MEMOS : Изменить базирование сообщения Оп.Память -> ДИСК }
procedure D_MEMOS;
var K4 : word;
L : LongInt;
begin if not Init then Exit;
if Med_Memo = NIL then Exit;
K4:=4*KolML;
L:=Med_Size-14-K4;
if SeekFile(F_work,0) then
if WritFile(F_work,Med_Memo^[0],Med_Size) then;
FreeMem(Med_Memo,Med_Size);
GetMem(ML,K4);
Med_Memo:=NIL;
if SeekFile(F_work, L ) then
if ReadFile(F_work,ML^,K4) then; end;
{ INIT_HABOPOT : Построить структуру вложенных групп }
{ для полностью свернутого сообщения }
{ Res = FALSE, если в сообщении нарушена сплошная нумерация полей }
function INIT_HABOPOT : boolean;
var I,J,M : integer;
P : pointer;
begin FillChar(PthMed,SizeOf(PthMed),0);
with EL0^.DTL^ do begin { MEAD^ }
FogMed:=BDS[HSF].LFT;
if HSF < FogMed then M:=-1
else M:=FogMed;
for I:=HSF downto 1 do
if BDS[I].LFT = M then begin
FisMed[M]:=I;
P:=BDS[I].VRF;
if P <> NIL then
for J:=Grupa_VRF(P).N to Grupa_VRF(P).K-1 do PthMed[J]:=M;
M:=M-1
end
end;
INIT_HABOPOT:=(M = 0) end;
{ FISQ_HABOPOT : L - Номер логического поля }
{ RES = A - список представителей внешних генераторов }
{ A[0] - длина списка }
procedure FISQ_HABOPOT(L : integer; var A : TYPE_HABOPOT);
var I,N : integer;
begin N:=0;
with MEAD^ do
while PthMed[L] <> 0 do begin
L:=PthMed[L];
N:=N+1;
A[17-N]:=L
end;
A[0]:=N;
for I:=1 to N do A[I]:=FisMed[A[16-N+I]] end;
function OpnMed(fName : String) : boolean;
var S : String[9];
W : boolean;
begin if Init then Exit;
D_Init_Name:=Fname;
MESSAGE:=NIL; Err_D_Init:=401; { Файл отсутствует или блокирован }
FITEK:=0;
OpnMed:=false;
Zona1:=NIL;
ML:=NIL;
EL01:=NIL;
Med_Memo:=NIL;
if not Open_Uni(Fname,ResetWork) then Exit;
Med_Size:=FileSize(F_work);
if Med_Size < 10 then begin { Случай файлов нулевой длины }
Err_D_Init:=403; { Некорректная структура файла }
Cls_File(F_work);
Exit
end;
{ Если сообщение может полностью разместиться в }
{ оперативной памяти - разместить его там }
if Med_Size <= SizeOf(ArBy) then
if Med_Size < MaxAvail then begin
GetMem(Med_Memo,Med_Size);
if not ReadFile(F_work,Med_Memo^,Med_Size) then begin
O_Close1;
Err_D_Init:=402; { Ошибка чтения из файла }
Exit
end
end;
Pos_Memo:=0;
Err_D_Init:=403; { Некорректная структура файла }
W:=false;
if wBlockRead(F_work,S,10) then
if S = medMEDmed then
if Get_PSP then begin
Err_D_Init:=404; { Недостаточно оперативной памяти }
W:=Get_Memo;
if not W then begin
FreeMemo;
W:=Get_Memo
end
end;
if not W then begin O_Close1; Exit end;
Zona:=Zona1; if R.O <> 0 then begin Inc( R.S); R.O:=0 end;
EL0:=EL01; if RE.O <> 0 then begin Inc(RE.S); RE.O:=0 end;
Init:=true;
D_Read(0);
KolM0:=KolM;
if INIT_HABOPOT then begin
Err_D_Init:=0;
MESSAGE:=EL0;
MEAD:=MESSAGE^.DTL;
OpnMed:=true
end else begin
Err_D_Init:=405; { Нарушение в посл.полей }
D_Close1 { Init = TRUE }
end end;
{ D_Read : 1. загрузить общую зону информацией для BDS[I] }
{ 2. поместить в BDS[I].DTL адрес общей зоны }
{ 3. если I = 0, то загрузить Message и первый Head }
procedure D_Read(I : word);
var FP : Longint;
S,J : word;
begin if (ML^[I] <> 0) and Init then
else Exit;
if wSeek(F_work,ML^[I]) then begin
I_Read:=I;
TFr:=true;
POP(KolM);
POP(MAS );
if I = 0 then begin
POP(EL0^);
SizeOfMessa:=KOL;
S:=Seg(EL0^)
end else begin
POP(Zona^);
SizeOfField:=KOL;
EL0^.DTL^.BDS[I].DTL:=Zona;
S:=Seg(Zona^)
end;
for J:=1 to Kolm do { настройка на новое место }
Move(S,Ptr(S,MAS[J]+2)^,2)
end end;
procedure D_Write(I : Word); {cкопировать общую зону на прежнее место}
var L : LongInt;
begin if TFr and (ML^[I] <> 0) and Init then
else Exit;
L:=ML^[I]-4-2-2;
if I = 0
then begin if wSeek(F_work,L-2*Kolm0-DL0) then wFAL(F_work,EL0^ ,DL0) end
else begin if wSeek(F_work,L-2*Kolm -KOL) then wFAL(F_work,Zona^,KOL) end end;
{ D_MAKE : SQ - новая последовательность полей = ЗАДАНИЕ НА ПЕРКРОЙКУ }
{ CEL0 - выделенная память размером CDL0 = РАБОЧАЯ ОБЛАСТЬ D_MAKE }
{ Fo - файл для размещения результата }
{ Res = TRUE = новый файл Fo построен! |Файлы Fo и F_work не закрываюся}
{ FALSE = Ошибка записи на диск | и не удаляются }
function D_MAKE(SQ : pCKT; CEL0 : pMessage; CDL0 : word; var Fo : file) : boolean;
var I,NN,HX : integer;
XPT,XPF : pHead;
NoErr : boolean;
S : word;
procedure MADD(V : word);
begin Inc(Kolm);
MAS[Kolm]:=V
end;
procedure FPS(N,V : integer);
begin if V = 0 then LongInt(SQ^[N]):=0
else LongInt(SQ^[N]):=FilePos(Fo)
end;
procedure FAL(var A; L : word);
begin if NoErr then NoErr:=PushFile(Fo,A,L);
end;
procedure BAL(var A; L : word; I : integer);
begin FAL( A ,L ); { зап элемент }
FAL(MAS ,2*Kolm ); { зап настройку }
FAL(Kolm,2 ); { зап кол элт-ов настр }
FPS(I,-1) { новые ссылки }
end;
begin HX:=SQ^[0].FLD; { Новое количество полей }
if wSeek(F_work,ML^[0]) then begin
POP(KolM);
POP(MAS );
Move(EL0^,CEL0^,DL0); { DL0 <= CDL0 ! }
S:=Seg(CEL0^);
for I:=1 to KolM do { настройка на новое место }
Move(S,Ptr(S,MAS[I]+2)^,2)
end;
XPT:=CEL0^.DTL;
XPF:= EL0^.DTL;
XPT^.HSF:=HX;
for I:=1 to HX do begin
XPT^.BDS[I]:=XPF^.BDS[abs(SQ^[I].FLD)];
NN:=SQ^[I].GEN;
if NN <> 0 then
with XPT^.BDS[I] do
with Grupa_VRF(VRF) do KG:=NN
end;
S:=MAS[Kolm]; { последний эл-т настройки }
Kolm:=0;
for I:=1 to HX do
with XPT^.BDS[I] do begin
if RFT <> NIL then MADD(Ofs( RFT));
if INP <> NIL then MADD(Ofs( INP));
if CTP <> NIL then MADD(Ofs( CTP));
if RP_PAT <> NIL then MADD(Ofs(RP_PAT));
if TIT <> NIL then MADD(Ofs( TIT))
end;
{последний эл-т} MADD(S);
NoErr:=true;
BAL(CEL0^,CDL0,0); { зап 0-й эл-т }
for I:=1 to HX do begin
with SQ^[I] do begin
NN:=abs(FLD);
if ML^[NN] <= 0 then FPS(I,0) else begin
D_Read(NN);
if FLD < 0 then KillHead(XPF^.BDS[NN].DTL); { чистить }
BAL(Zona^,KOL,I)
end
end
end;
I:=HX+1;
FAL(SQ^ ,4*I); { зап мас ссылок }
FAL(I ,2 ); { зап кол ссылок }
FAL(CDL0 ,2 ); { зап дл 0-го эл-та }
FAL(MaxZona ,2 ); { зап дл макс зоны }
D_MAKE:=NoErr end;
end.
|