home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programming
/
powerprogramming1994.iso
/
progtool
/
filutl
/
ldiff12s.arc
/
LDPROC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-07-15
|
11KB
|
470 lines
(*---------------------------------------------------------------------------*)
(*LDProc.pas ékécé`éÆéâùpè╓Éö (C) ÄOû╪ÿaòF NIFTY SDR SDI00147 1989/7/1 *)
(*$B-,F-,I-,N- *)
(*---------------------------------------------------------------------------*)
UNIT LDProc;
INTERFACE
USES
Dos,
MyType,
MyTool,
LDVari;
PROCEDURE ReadDic (VAR fs:LONGINT);
PROCEDURE BlkClose (VAR f:BFILE);
PROCEDURE BlkCopy (VAR fdi,fdo:BFILE;size:LONGINT);
PROCEDURE BlkERase (VAR f:BFILE);
FUNCTION BlkFilePos (VAR f:BFILE):LONGINT;
FUNCTION BlkFileSize (VAR f:BFILE):LONGINT;
FUNCTION BlkOpen (VAR f:BFILE;modes:STRING;s:PathStr):BOOLEAN;
FUNCTION BlkRead (VAR f:BFILE;VAR mem;cnt:WORD):WORD;
PROCEDURE BlkSeek (VAR f:BFILE;pnt:LONGINT);
PROCEDURE BlkWrite (VAR f:BFILE;VAR mem;cnt:WORD);
PROCEDURE Error (s:STRING;n:BYTE);
PROCEDURE FReName (s1,s2:STRING);
PROCEDURE GetBAttr (VAR f:BFILE;VAR attr:WORD);
PROCEDURE GetBTime (VAR f:BFILE;VAR time:LONGINT);
FUNCTION MEG (n:BYTE):STRING;
PROCEDURE Msg (s:STRING);
PROCEDURE MsgLn (s:STRING);
FUNCTION ReadHdr (VAR f:BFILE):BOOLEAN;
FUNCTION ChkHdr (VAR f:BFILE):BOOLEAN;
FUNCTION SkipArcHdr (VAR f:BFILE):BOOLEAN;
PROCEDURE SetBAttr (VAR f:BFILE;attr:WORD);
PROCEDURE SetBTime (VAR f:BFILE;time:LONGINT);
PROCEDURE TxtCopy (VAR fdi,fdo:BFILE;size:LONGINT);
FUNCTION YesNo (s:STRING):BOOLEAN;
IMPLEMENTATION
FUNCTION MEG; EXTERNAL;{$L MEG.OBJ}
FUNCTION BlkReadCrc(VAR f:BFILE;VAR mem;size:WORD):WORD;
VAR
buf : array[1..$8000] OF BYTE ABSOLUTE mem;
i : WORD;
BEGIN
size:=BlkRead(f,mem,size);
FOR i:=1 TO size DO CRC:=Hi(CRC) XOR CrcTable[Lo(CRC) XOR buf[i]];
BlkReadCrc:=size;
END;
PROCEDURE ReadDic(VAR fs:LONGINT);
BEGIN
IF NOT BlkOpen(OldFVar,'I',OldFName) THEN Error(OldFName,CantOpenErMsg);
CRC:=0;
New(DicBuf);
New(DicBuf2);
New(DicBuf3);
New(DicBuf4);
DicSeg:=Seg(DicBuf^);
IF BlkReadCrc(OldFVar,DicBuf^ ,$8000)=$8000 THEN
IF BlkReadCrc(OldFVar,DicBuf2^,$8000)=$8000 THEN
IF BlkReadCrc(OldFVar,DicBuf3^,$8000)=$8000 THEN
IF BlkReadCrc(OldFVar,DicBuf4^,$8000)=$8000 THEN BEGIN
New(DicBuf5);
IF BlkReadCrc(OldFVar,DicBuf5^,$8000)=$8000 THEN BEGIN
New(DicBuf6);
IF BlkReadCrc(OldFVar,DicBuf6^,$8000)=$8000 THEN BEGIN
New(DicBuf7);
IF BlkReadCrc(OldFVar,DicBuf7^,$8000)=$8000 THEN BEGIN
New(DicBuf8);
IF BlkReadCrc(OldFVar,DicBuf8^,$8000)=$8000 THEN ;
END;
END;
END;
END;
fs:=BlkFileSize(OldFVar);
BlkClose(OldFVar);
END;
FUNCTION BlkRead(VAR f:BFILE;VAR mem;cnt:WORD):WORD;
BEGIN
WITH Regs,f DO BEGIN
AH:=$3F;
DS:=Seg(mem);
DX:=Ofs(mem);
CX:=cnt;
BX:=Handle;
MsDos(Regs);
IF (Flags AND FCarry)<>0 THEN Error(AscZ(f.Name),ReadingErMsg)
ELSE BlkRead:=AX;
END;
END;
PROCEDURE BlkWrite(VAR f:BFILE;VAR mem;cnt:WORD);
BEGIN
WITH Regs,f DO BEGIN
AH:=$40;
DS:=Seg(mem);
DX:=Ofs(mem);
CX:=cnt;
BX:=Handle;
MsDos(Regs);
IF (Flags AND FCarry)<>0 THEN BEGIN
BlkClose(f);
BlkErase(f);
Error(AscZ(f.Name),WritingErMsg);END
ELSE IF AX<>CX THEN BEGIN
BlkClose(f);
BlkErase(f);
Error(AscZ(f.Name),DiskFullErMsg);
END;
END;
END;
PROCEDURE BlkSeek(VAR f:BFILE;pnt:LONGINT);
BEGIN
WITH Regs,f DO BEGIN
AX:=$4200;
CX:=WORD((pnt AND $FFFF0000) SHR 16);
DX:=WORD(pnt);
BX:=Handle;
MsDos(Regs);
END;
END;
PROCEDURE FReName(s1,s2:STRING);
BEGIN
s1:=s1+NUL;
s2:=s2+NUL;
WITH Regs DO BEGIN
AX:=$5600;
DS:=Seg(s1);
DX:=Ofs(s1[1]);
ES:=Seg(s2);
DI:=Ofs(s2[1]);
MsDos(Regs);
END;
END;
FUNCTION BlkFilePos(VAR f:BFILE):LONGINT;
BEGIN
WITH Regs,f DO BEGIN
AX:=$4201;
CX:=0;
DX:=0;
BX:=Handle;
MsDos(Regs);
BlkFilePos:=(LONGINT(DX) SHL 16)+AX;
END;
END;
FUNCTION BlkFileSize(VAR f:BFILE):LONGINT;
VAR
tmp : LONGINT;
BEGIN
tmp:=BlkFilePos(f);
WITH Regs,f DO BEGIN
AX:=$4202;
CX:=0;
DX:=0;
BX:=Handle;
MsDos(Regs);
BlkFileSize:=(LONGINT(DX) SHL 16)+AX;END;
BlkSeek(f,tmp);
END;
PROCEDURE BlkClose(VAR f:BFILE);
BEGIN
WITH Regs,f DO BEGIN
AH:=$3E;
BX:=Handle;
MsDos(Regs);
OpenFlg:=FALSE;
END;
END;
PROCEDURE BlkERase(VAR f:BFILE);
VAR
savedir : PathStr;
BEGIN
GetDir(0,savedir);
WITH Regs,f DO BEGIN
ChDir(Path);
AH:=$41;
DS:=Seg(Name);
DX:=Ofs(Name);
MsDos(Regs);END;
ChDir(savedir);
END;
PROCEDURE BlkCopy(VAR fdi,fdo:BFILE;size:LONGINT);
CONST
maxbuf = $2000;
VAR
buf : array[1..maxbuf] OF BYTE;
BEGIN
WHILE size>maxbuf DO BEGIN
BlkWrite(fdo,buf,BlkRead(fdi,buf,maxbuf));
Dec(size,maxbuf);END;
BlkWrite(fdo,buf,BlkRead(fdi,buf,size));
END;
PROCEDURE TxtCopy(VAR fdi,fdo:BFILE;size:LONGINT);
CONST
maxbuf = $2000;
VAR
i : WORD;
buf : array[1..maxbuf] OF BYTE;
BEGIN
WHILE size>maxbuf DO BEGIN
FOR i:=1 TO BlkRead(fdi,buf,maxbuf) DO
IF buf[i]=Ord(^Z) THEN BEGIN BlkWrite(fdo,buf,Pred(i));Exit;END;
BlkWrite(fdo,buf,maxbuf);
Dec(size,maxbuf);END;
FOR i:=1 TO BlkRead(fdi,buf,size) DO
IF buf[i]=Ord(^Z) THEN BEGIN BlkWrite(fdo,buf,Pred(i));Exit;END;
BlkWrite(fdo,buf,size);
END;
FUNCTION BlkOpen(VAR f:BFILE;modes:STRING;s:PathStr):BOOLEAN;
FUNCTION Open1(mode:CHAR):Boolean;
BEGIN
Open1:=FALSE;
WITH f,Regs DO BEGIN
DS:=Seg(s[1]);
DX:=Ofs(s[1]);
CASE mode OF
'I' : BEGIN
AX:=$3D00;
MsDos(Regs);
IF (Flags AND FCarry)<>0 THEN BEGIN
IF AX=4 THEN Error('',FileOpenMaxErMsg);Exit;
END;
END;
'O' : BEGIN
AH:=$3C;
CX:=0;
MsDos(Regs);
IF (Flags AND FCarry)<>0 THEN BEGIN
IF AX=4 THEN Error('',FileOpenMaxErMsg);Exit;
END;
END;
ELSE Exit;END;
Open1 :=TRUE;
OpenFlg:=TRUE;
Handle :=AX;
END;
END;
VAR
i : INTEGER;
BEGIN
s:=s+NUL;
Move(s[1],f.Name,Ord(s[0]));
GetDir(0,f.Path);
BlkOpen:=TRUE;
FOR i:=1 TO Length(modes) DO IF Open1(modes[i]) THEN Exit;
BlkOpen:=FALSE
END;
PROCEDURE SetBTime(VAR f:BFILE;time:LONGINT);
BEGIN
WITH Regs,f DO BEGIN
AX:=$5701;
BX:=Handle;
CX:=Word(time);
DX:=(time AND $FFFF0000) SHR 16;
MsDos(Regs);
END;
END;
PROCEDURE GetBTime(VAR f:BFILE;VAR time:LONGINT);
BEGIN
WITH Regs,f DO BEGIN
AX:=$5700;
BX:=Handle;
MsDos(Regs);
time:=(LONGINT(DX) SHL 16)+CX;
END;
END;
PROCEDURE SetBAttr(VAR f:BFILE;attr:WORD);
VAR
savedir : PathStr;
BEGIN
GetDir(0,savedir);
WITH Regs,f DO BEGIN
ChDir(Path);
AX:=$4301;
DS:=Seg(Name);
DX:=Ofs(Name);
CX:=attr;
MsDos(Regs);END;
ChDir(savedir);
END;
PROCEDURE GetBAttr(VAR f:BFILE;VAR attr:WORD);
VAR
savedir : PathStr;
BEGIN
GetDir(0,savedir);
WITH Regs,f DO BEGIN
ChDir(Path);
AX:=$4300;
DS:=Seg(Name);
DX:=Ofs(Name);
MsDos(Regs);
attr:=CX;END;
ChDir(savedir);
END;
FUNCTION ChkHdr(VAR f:BFILE):BOOLEAN;
VAR
i,chksum : BYTE;
buf : ARRAY[0..256] OF BYTE;
fp : LONGINT;
BEGIN
fp:=BlkFilePos(f);
ChkHdr:=FALSE;
IF BlkRead(f,buf[0],1)=1 THEN
IF BlkRead(f,buf[1],1)=1 THEN
IF buf[0]>=2 THEN
IF BlkRead(f,buf[2],buf[0])=buf[0] THEN
IF buf[2]=Ord('-') THEN
IF buf[3] IN [Ord('L'),Ord('l')] THEN BEGIN
chksum:=0;
FOR i:=2 TO Succ(buf[0]) DO Inc(chksum,buf[i]);
IF buf[1]=chksum THEN ChkHdr:=TRUE;
END;
BlkSeek(f,fp);
END;
FUNCTION SkipArcHdr(VAR f:BFILE):BOOLEAN;
VAR
chksum : BYTE;
archdrsize : WORD;
buf : ARRAY[0..1047] OF BYTE;
BEGIN
SkipArcHdr:=FALSE;
IF BlkRead(f,buf[0],3)=3 THEN
IF buf[0]=$1A THEN BEGIN
archdrsize:=buf[1]+buf[2]*256;
IF archdrsize<=1048 THEN BEGIN
IF BlkRead(f,buf,archdrsize)=archdrsize THEN SkipArcHdr:=TRUE;
END;
END;
END;
FUNCTION ReadHdr(VAR f:BFILE):BOOLEAN;
VAR
lh3size : WORD;
BEGIN
ReadHdr:=FALSE;
IF NOT ChkHdr(f) THEN Exit;
WITH lh1 DO BEGIN
IF BlkRead(f,buf1[0],2)<>2 THEN Exit;
IF BlkRead(f,buf1[2],LNum)<>LNum THEN Exit;
IF LHdrID[2]='L' THEN BEGIN
Move(LFName[Length(LFName)+1],buf2,SizeOf(lh2));
lh3size:=buf2[10+buf2[9]]+buf2[11+buf2[9]]*256;
IF BlkRead(f,buf3,lh3size)<>lh3size THEN Exit;
END;
END;
ReadHdr:=TRUE;
END;
FUNCTION YesNo(s:STRING):BOOLEAN;
VAR
c : CHAR;
BEGIN
s:=s+' [Y/N]';
Msg(S);
REPEAT
c:=Upcase(GetChar);
UNTIL c IN ['Y','N',ESC,^C];
YesNo:=(c='Y');
Msg(Fill(Length(s),BS)+ClrL(Length(s),' '));
IF c=^C THEN Error('',StopErMsg);
END;
PROCEDURE Msg(s:STRING);
BEGIN
Write(ERRF,s);
END;
PROCEDURE MsgLn(s:STRING);
BEGIN
Msg(s+CRLF);
END;
PROCEDURE Error(s:STRING;n:BYTE);
VAR
nn : STRING;
BEGIN
Str(n,nn);
IF s<>'' THEN ErrStr:=s+' ' ELSE ErrStr:='';
ErrStr:=CRLF+ErrStr+MEG(n)+'(ErrCode='+nn+')';
Halt(n);
END;
{$F+}
FUNCTION HeapFunc(size:WORD):INTEGER;{$F-}
VAR
s : Str6;
BEGIN
Str(DosFree:6,s);
Error(s,HeapErMsg);
END;
VAR
ExitSave : POINTER;
{$F+}
PROCEDURE LarcOut;{$F-}
BEGIN
IF NewFVar.OpenFlg THEN BlkClose(NewFVar);
IF OldFVar.OpenFlg THEN BlkClose(OldFVar);
IF LzdFVar.OpenFlg THEN BlkClose(LzdFVar);
IF WrkFVar.OpenFlg THEN BEGIN BlkClose(WrkFVar);BlkErase(WrkFVar);END;
ExitProc:=ExitSave;
END;
BEGIN
ExitSave := ExitProc;
ExitProc := @LarcOut;
NewFVar.OpenFlg:=FALSE;
LzdFVar.OpenFlg:=FALSE;
OldFVar.OpenFlg:=FALSE;
WrkFVar.OpenFlg:=FALSE;
HeapError:=@HeapFunc;
IF Lo(DosVersion)<2 THEN Error('',DosVerErMsg);
END.