(* EXEC_FMS использует: KEYS_FMS *)
(* MENU_FMS *)
(* OKHO_FMS *)
(* SHOW_FMS *)
(* STAK_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O+,R+,S+,V+,X-}
{$M 16384,0,65536}
Unit EXEC_FMS; INTERFACE { Вызовы сопрограмм }
uses CRT, DOS, UNIF_FMS, TYPE_FMS, STAK_FMS,
OKHO_FMS, KEYS_FMS, MENU_FMS, SHOW_FMS;
Const Sdin = 16383;
Type pSearchRec = ^SearchRec;
TypIndMem = array [1..Sdin] of pointer;
Const AdrIndMem : ^TypIndMem = NIL; { Index Add memory }
CkoIndMem : LongInt = 0; { Size Full Index }
SizeAddMem : LongInt = 640123;
Code_Exec : char = ' '; { для замены |+| -> Code_Exec }
{ параметр настройки Call_Exec }
function E_GetFre ( L : LongInt) : pointer;
function OpnNewInd(MB : boolean) : boolean; { if MB then New else Old }
procedure ClsIndMem;
procedure PutNewVal(var B; S : word);
procedure GetAddMem(var Pnt; S : word);
function AddMaxAvail : LongInt;
function Adr_Mel(N,S : integer) : pointer;
function New_Mel( S : integer) : integer;
procedure FreeInd( I : integer);
procedure Scan_Dir(Pth : integer; { DIRS[Pth] - Dir for scan }
Pt : String; { Образец поиска: *.* | *.TYP }
SOR : integer); { P-p эл-тa = Max(SOR,SizeOf(SearshRec) )}
Type TMGE_type = record EXE_ : String[12]; { Имя сопрограммы }
RES_ : integer; { Код результата }
SKY_ : boolean; { Признак "звезного неба" }
DRS_ : pointer; { addr(DIRS) }
ADM_ : char;
MDS_ : word; { Режимы редактирования }
NAF_ : String;
EVT_ : pTypeOfEvents; { Контроль каталогов Keys_FMS }
end;
TMGF_type = record EXE_ : String[12]; { Имя сопрограммы }
RES_ : integer; { Код результата }
SKY_ : boolean; { Признак "звезного неба" }
TRM_ : char;
MED_ : String[92]; { DIRS[WRK]+MedName }
STF_ : String[92]; { DIRS[PFM]+Name-ST-form }
CMD_ : String; { Номер/К-во N/K N/K N/K }
PRF_ : String; { Гипер-строка ПРЕФИКС }
PST_ : String; { Гипер-строка ПОСТФИКС }
end;
TMGT_type = record EXE_ : String[12]; { Имя сопрограммы }
RES_ : integer; { Код результата }
SKY_ : boolean; { Признак "звезного неба" }
DRS_ : pointer; { addr(DIRS) }
TRN_ : String[12];
BAS_ : integer;
BAX_ : integer;
EVT_ : pTypeOfEvents; { Контроль директорий Keys_FMS }
end;
TMGS_type = record EXE_ : String[12]; { 13 Имя сопрограммы MGS.EXE }
RES_ : integer; { 2 Код результата 0 .... }
SKY_ : boolean; { 1 Признак "звезного неба" }
USR_ : char; { 1 Код терминала }
FMT_ : char; { 1 x a n d }
LEN_ : integer; { 2 Длина поля }
HMS_ : integer; { 2 Количество строк }
KPM_ : pointer; { 4 Внутренний буфер MGE.EXE }
end;
TMGH_type = record EXE_ : String[12]; { Имя сопрограммы }
RES_ : integer; { Код результата }
SKY_ : boolean; { Признак "звезного неба" }
MOR_ : String[16]; { }
ABO_ : LongInt;
MES_ : PathStr;
USR_ : char; { Код терминала }
AF1_ : PathStr; { Имя первого арх.файла }
AF2_ : PathStr; { Имя второго арх.файла }
TMR_ : String[68]; { Каталог рабочих файлов }
COP_ : byte; { 1|2|3|4|5 - КодОперации }
MAR_ : PathStr; { Message Archive Ref. }
end;
TMGG_type = record EXE_ : String[12]; { Имя сопрограммы }
RES_ : integer; { Код результата }
SKY_ : boolean; { Признак "звезного неба" }
TRM_ : char; { Код терминала }
DRS_ : pointer; { addr(DIRS) }
MOT_ : pointer; { = MC_CARDS.MOT }
ECH_ : pointer; { addr вызывающей оп. ECH }
IOC_ : String[12]; { Имя индекса в DIRS[WRK] }
end;
Type Morec = record CKO : integer; { Количество ссылок }
AMP : array [1..20] of String[16]; { Массив MOR-ов }
end;
function Full_Exec(var Pr,Arg : String ) : integer;
function Call_Exec( Pr,Arg : String ) : integer;
function Run_Exe( Arg : pointer) : boolean;
function Bgn_Exe : pointer;
Var LongAddMem : LongInt; { LongInt(AdrIndMem) }
FullAddMem : LongInt; { Последний занятый "снизу" }
FullAddOld : LongInt; { Save FullAddMem }
IMPLEMENTATION
procedure E_GetMem(var P : pointer; var KOL : Longint);
var K,K1 : word;
begin if 0 < (KOL and 15) then Inc(KOL,16);
K:=KOL shr 4;
asm
mov AH,$48
mov BX,K
int $21
mov K,AX
jnc @ee
mov K,0
@ee: nop
mov K1,BX
end;
P:=ptr(K,0);
KOL:=K1;
KOL:=KOL shl 4 end;
procedure E_FreeMem(var P : pointer);
var K : word;
begin K:=seg(P^);
asm
mov AH,$49
mov ES,K
int $21
mov K,0
jnc @ee
mov K,AX
@ee: nop
end;
if K = 0 then P:=NIL end;
{ E_GetFre : L - Размер заказываемой памяти }
{ Если L <= 0 - только освободить }
{ RES = Указатель на начало }
{ NIL, Если памяти не нашлось }
function E_GetFre(L : LongInt) : pointer;
var P : pointer;
begin E_GetFre:=NIL;
if AdrIndMem <> NIL then begin { Освободить память }
P:=AdrIndMem; { Изменить тип аргумента }
E_FreeMem(P);
AdrIndMem:=P { Факт : AdrIndMem:=NIL }
end;
if 0 < L then { Выделить память }
if AdrIndMem = NIL then begin
E_GetMem(P,L);
E_GetFre:=P;
AdrIndMem:=P
end end;
{ LTP = Longint To Pointer | PTL = Pointer To LongInt }
function LTP(L : LongInt) : pointer;
var G : LongInt;
P : pointer absolute G;
begin G:=L;
G:=((G shl 12) and $FFFF0000) or (G and $F);
LTP:=P end;
function PTL(P : pointer) : LongInt;
var L : LongInt;
begin Move(P,L,4);
PTL:=((L shr 12) and $000FFFF0) or (L and $F) end;
function AddMaxAvail : LongInt;
begin AddMaxAvail:=FullAddMem-LongAddMem-4*CkoIndMem end;
function OpnNewInd(MB : boolean) : boolean; { if MB then New else Old }
var P : pointer;
begin if MB then begin
if AdrIndMem = NIL then begin
OpnNewInd:=false;
E_GetMem(P,SizeAddMem);
if P = NIL then E_GetMem(P,SizeAddMem);
AdrIndMem:=P;
if AdrIndMem = NIL then Exit;
LongAddMem:=PTL(P)
end;
FullAddMem:=LongAddMem+SizeAddMem
end;
OpnNewInd:=(AdrIndMem <> NIL);
if AdrIndMem <> NIL then begin { *** SFM:Исчерпана оп.память *** }
CkoIndMem:=0;
FullAddOld:=FullAddMem;
OpnNewInd:=(36 <= AddMaxAvail)
end end;
procedure ClsIndMem;
begin FullAddMem:=FullAddOld end;
procedure GetAddMem(var Pnt; S : word);
var P : pointer;
begin if FullAddMem-S < LongAddMem then P:=NIL else begin
Dec(FullAddMem,S);
P:=LTP(FullAddMem)
end;
Move(P,Pnt,4) end;
{ ???IndAddMem - аппарат работы с индексной дополнительной памятью }
procedure PutNewVal(var B; S : word);
const COO:String[31]='*** SFM:Исчерпана оп.память *** ';
var L : LongInt;
P,R : pointer;
begin if Sdin <= CkoIndMem then Exit;
L:=AddMaxAvail;
P:=addr(COO);
if LongInt(S)+40 <= L then P:=addr(B)
else if 36 <= L then S:=32
else Exit;
GetAddMem(R,S);
if R <> NIL then begin
Move(P^,R^,S);
Inc(CkoIndMem);
AdrIndMem^[CkoIndMem]:=R
end end;
type pFreedom = ^Freedom;
Freedom = record NEXT_ : pFreedom end;
var FreeAddMem : pFreedom;
{ Adr_Mel : Выдать адрес T_mel структуры с номером N }
{ S = SizeOf(T_mel) }
{ Res = NIL, если памяти не нашлось }
function Adr_Mel(N,S : integer) : pointer;
var G : LongInt;
P : pointer;
begin G:=abs(N);
G:=LongAddMem+SizeAddMem-G*S;
if G < LongAddMem then P:=NIL
else P:=LTP(G);
Adr_Mel:=P end;
function New_Mel(S : integer) : integer;
var L : LongInt;
begin if S = 0 then L:=0
else if FreeAddMem = NIL then L:=0
else begin
L:=PTL(FreeAddMem);
FreeAddMem:=FreeAddMem^.NEXT_;
L:=(LongAddMem+SizeAddMem-L) div S;
L:=L and $7FFF
end;
New_Mel:=L end;
procedure FreeInd(I : integer);
var P : pFreedom;
begin P:=AdrIndMem^[I];
P^.NEXT_:=FreeAddMem;
FreeAddMem:=P end;
{ Сканирование и упорядочение каталога файлов с предварительным отсеиванием }
procedure Scan_Dir(Pth : integer; { DIRS[Pth] - Dir for scan }
Pt : String; { Образец поиска: *.* | *.TYP }
SOR : integer); { P-p эл-тa = Max(SOR,SizeOf(SearshRec) )}
Const SS = SizeOf(SearchRec);
var BE : pSearchRec;
SR : SearchRec;
K : integer;
Hf,Kf : integer; { [Hf..Kf] - ограничения на длину имени файла }
He,Ke : integer; { [He..Ke] - ограничения на длину расширения }
PAT : String[12];{ Образец для запуска FIndFirst }
PTf : String[ 8];{ Доп.анализ имени файла }
PTe : String[ 3];{ Доп.анализ расширения }
procedure BIP;
var I : integer;
begin PTf:=''; Hf:=ord(Pt[1]);
PTe:=''; He:=ord(Pt[2]);
Delete(Pt,1,2);
I:=MinPos('.',Pt);
if I <> 0 then begin
PTf:=Copy(Pt, 1,I-1);
PTe:=Copy(Pt,I+1, 3)
end;
Kf:=Length(PTf);
Ke:=Length(PTe);
PAT:=PTf+'.'+PTe;
for I:=1 to Length(PAT) do
if 0 < Pos(PAT[I],'abn') then PAT[I]:='?'
end;
function BAD(I : integer; A : char) : boolean;
var B : char;
begin B:=PAT[I];
BAD:=false;
if A = 'a' then BAD:=not Cchar(B)
else if A = 'b' then BAD:=not(Cnumb(B) or Cchar(B))
else if A = 'n' then BAD:=not Cnumb(B)
end;
function TST : boolean;
var I,K,M : integer;
begin K:=MinPos('.',PAT);
M:=Length(PAT) - K;
if M < 0 then M:=0;
TST:=false;
I:=K-1;
if (I < Hf) or (Kf < I) then Exit;
if (M < He) or (Ke < M) then Exit;
for I:=1 to K-1 do if BAD( I,PTf[I]) then Exit;
for I:=1 to M do if BAD(K+I,PTe[I]) then Exit;
TST:=true
end;
function LTSC(J : integer) : boolean;
begin LTSC:=LTFn(PAT,SearchRec(AdrIndMem^[J]^).Name)
end;
procedure InCLU(var N : LongInt);
var K : integer;
procedure WHET;
var I,H : integer;
begin H:=1;
K:=N;
while 1 < K-H do begin
I:=(K+H) div 2;
if LTSC(I) then K:=I
else H:=I
end
end;
begin with SR do begin
PAT:=Name;
if Size < 16 then Exit; { Грубый контроль }
if not TST then Exit { Тонкий контроль }
end;
GetAddMem(BE,SOR); { Новая запись в AddMem }
if BE = NIL then Exit;
Move(SR,BE^,SS); { BE <> SOR ! }
if N = 0 then K:=1 { Вписать по порядку }
else if LTSC(1) then K:=1
else if LTSC(N) then WHET
else K:=N+1;
N:=N+1;
if K < N then Move(AdrIndMem^[K],AdrIndMem^[K+1],4*(N-K));
AdrIndMem^[K]:=BE
end;
var MaxFiles : LongInt;
begin CkoIndMem:=0;
if not OpnNewInd(true) then Exit; { Заказ памяти }
if SOR < SS then SOR:=SS;
GetAddMem(FreeAddMem,SOR); { Прокладка безопасности }
if FreeAddMem = NIL then Exit;
FreeAddMem^.NEXT_:=NIL;
MaxFiles:=SizeAddMem div (SOR+40) - 1;
if SDIN < MaxFiles then MaxFiles:=SDIN;
BIP;
CkoIndMem:=0;
FindFirst(DIRS[Pth]+PAT,Archive,SR);
while (DosError = 0) and (CkoIndMem < MaxFiles) do begin
InCLU(CkoIndMem);
FindNext(SR)
end
end;
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;; Full_Exec ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{ Full_Exec - универсальный вызов процедуры Exec }
{ обязательный для всех модулей SFM-2 }
function Full_Exec(var Pr,Arg : String) : integer;
var P : byte;
begin P:=TheSCR;
PgSCR(0); { Выставить 0 ВидеоСтраницу }
SwapVectors;
Exec(Pr,Arg);
SwapVectors;
Full_Exec:=DosError;
PgSCR(P) { Вос-вить ВидеоСтраницу } end;
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;; Run.Exe ;;;;;;;;;;;;;;;;;; Bgn_Exe ;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{ Call_Exec : Pr - имя внешнего модуля }
{ Arg - строка аргументов }
function Call_Exec(Pr,Arg : String) : integer;
var K : integer;
begin if E_GetFre(0) = NIL then; { Освободить память }
if OpnNewInd(true) then; { Связать память в 1 кусок }
if E_GetFre(0) = NIL then; { Освободить память }
if Code_Exec <> ' ' then begin
Arg:=' '+Arg+' ';
repeat
K:=Pos(' |+| ',Arg);
if 0 < K then begin
Arg[K+1]:=Code_Exec;
Delete(Arg,K+2,2)
end
until K = 0;
TwoPress(Arg)
end;
Call_Exec:=Full_Exec(Pr,Arg) end;
{ Run_Exe - "Секретный" вызов собственного модуля системы SFM-2 }
{ Res = TRUE, если вызов был успешным }
function Run_Exe(Arg : pointer) : boolean;
var P : pointer;
L : LongInt absolute P;
D : integer;
B : byte;
begin P:=Arg;
with TMGT_type(P^) do begin
RES_:=0;
SKY_:=false;
B:=TheSCR; { Обмануть Full_Exec }
TheSCR:=0; { Блокировать перемену ВидеоСтраницы }
D:=Call_Exec(DIRS[OWN]+EXE_,NNN(L)+' X(*');
TheSCR:=B; { Закончить обман }
Run_Exe:=(D = 0);
if D = 0 then begin
if SKY_ then KEYS_FMS.SKY:=true
end else begin
SHOM_CR('Не могу вызвать программу '+
EXE_+'. DosError='+NNN(D))
end;
Save_Scurs
end end;
function Bgn_Exe : pointer;
var P : pointer;
L : LongInt absolute P;
N : integer;
begin Bgn_Exe:=NIL;
if ParamCount <> 2 then Exit;
if ParamStr(2) <> 'X(*' then Exit;
Val(ParamStr(1),L,N);
if N <> 0 then Exit;
Bgn_Exe:=P end;
end.
|