home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FILUTL / LDIFF12S.ARC / LDPROC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-07-15  |  10.4 KB  |  470 lines
  1. (*---------------------------------------------------------------------------*)
  2. (*LDProc.pas ékécé`éÆéâùpè╓Éö       (C) ÄOû╪ÿaòF NIFTY SDR SDI00147 1989/7/1 *)
  3. (*$B-,F-,I-,N-                                                               *)
  4. (*---------------------------------------------------------------------------*)
  5. UNIT LDProc;
  6.  
  7.  
  8. INTERFACE
  9.  
  10.  
  11. USES
  12.    Dos,
  13.    MyType,
  14.    MyTool,
  15.    LDVari;
  16.  
  17.  
  18.  
  19. PROCEDURE ReadDic      (VAR fs:LONGINT);
  20. PROCEDURE BlkClose     (VAR f:BFILE);
  21. PROCEDURE BlkCopy      (VAR fdi,fdo:BFILE;size:LONGINT);
  22. PROCEDURE BlkERase     (VAR f:BFILE);
  23. FUNCTION  BlkFilePos   (VAR f:BFILE):LONGINT;
  24. FUNCTION  BlkFileSize  (VAR f:BFILE):LONGINT;
  25. FUNCTION  BlkOpen      (VAR f:BFILE;modes:STRING;s:PathStr):BOOLEAN;
  26. FUNCTION  BlkRead      (VAR f:BFILE;VAR mem;cnt:WORD):WORD;
  27. PROCEDURE BlkSeek      (VAR f:BFILE;pnt:LONGINT);
  28. PROCEDURE BlkWrite     (VAR f:BFILE;VAR mem;cnt:WORD);
  29. PROCEDURE Error        (s:STRING;n:BYTE);
  30. PROCEDURE FReName      (s1,s2:STRING);
  31. PROCEDURE GetBAttr     (VAR f:BFILE;VAR attr:WORD);
  32. PROCEDURE GetBTime     (VAR f:BFILE;VAR time:LONGINT);
  33. FUNCTION  MEG          (n:BYTE):STRING;
  34. PROCEDURE Msg          (s:STRING);
  35. PROCEDURE MsgLn        (s:STRING);
  36. FUNCTION  ReadHdr      (VAR f:BFILE):BOOLEAN;
  37. FUNCTION  ChkHdr       (VAR f:BFILE):BOOLEAN;
  38. FUNCTION  SkipArcHdr   (VAR f:BFILE):BOOLEAN;
  39. PROCEDURE SetBAttr     (VAR f:BFILE;attr:WORD);
  40. PROCEDURE SetBTime     (VAR f:BFILE;time:LONGINT);
  41. PROCEDURE TxtCopy      (VAR fdi,fdo:BFILE;size:LONGINT);
  42. FUNCTION  YesNo        (s:STRING):BOOLEAN;
  43.  
  44.  
  45. IMPLEMENTATION
  46.  
  47.  
  48. FUNCTION  MEG; EXTERNAL;{$L MEG.OBJ}
  49.  
  50.  
  51. FUNCTION BlkReadCrc(VAR f:BFILE;VAR mem;size:WORD):WORD;
  52. VAR
  53.    buf : array[1..$8000] OF BYTE ABSOLUTE mem;
  54.    i   : WORD;
  55. BEGIN
  56.    size:=BlkRead(f,mem,size);
  57.    FOR i:=1 TO size DO CRC:=Hi(CRC) XOR CrcTable[Lo(CRC) XOR buf[i]];
  58.    BlkReadCrc:=size;
  59. END;
  60.  
  61.  
  62. PROCEDURE ReadDic(VAR fs:LONGINT);
  63. BEGIN
  64.    IF NOT BlkOpen(OldFVar,'I',OldFName) THEN Error(OldFName,CantOpenErMsg);
  65.    CRC:=0;
  66.    New(DicBuf);
  67.    New(DicBuf2);
  68.    New(DicBuf3);
  69.    New(DicBuf4);
  70.    DicSeg:=Seg(DicBuf^);
  71.    IF BlkReadCrc(OldFVar,DicBuf^ ,$8000)=$8000 THEN
  72.    IF BlkReadCrc(OldFVar,DicBuf2^,$8000)=$8000 THEN
  73.    IF BlkReadCrc(OldFVar,DicBuf3^,$8000)=$8000 THEN
  74.    IF BlkReadCrc(OldFVar,DicBuf4^,$8000)=$8000 THEN BEGIN
  75.       New(DicBuf5);
  76.       IF BlkReadCrc(OldFVar,DicBuf5^,$8000)=$8000 THEN BEGIN
  77.          New(DicBuf6);
  78.          IF BlkReadCrc(OldFVar,DicBuf6^,$8000)=$8000 THEN BEGIN
  79.             New(DicBuf7);
  80.             IF BlkReadCrc(OldFVar,DicBuf7^,$8000)=$8000 THEN BEGIN
  81.                New(DicBuf8);
  82.                IF BlkReadCrc(OldFVar,DicBuf8^,$8000)=$8000 THEN ;
  83.             END;
  84.          END;
  85.       END;
  86.    END;
  87.    fs:=BlkFileSize(OldFVar);
  88.    BlkClose(OldFVar);
  89. END;
  90.  
  91.  
  92. FUNCTION BlkRead(VAR f:BFILE;VAR mem;cnt:WORD):WORD;
  93. BEGIN
  94.    WITH Regs,f DO BEGIN
  95.       AH:=$3F;
  96.       DS:=Seg(mem);
  97.       DX:=Ofs(mem);
  98.       CX:=cnt;
  99.       BX:=Handle;
  100.       MsDos(Regs);
  101.       IF (Flags AND FCarry)<>0 THEN Error(AscZ(f.Name),ReadingErMsg)
  102.                                ELSE BlkRead:=AX;
  103.    END;
  104. END;
  105.  
  106.  
  107. PROCEDURE BlkWrite(VAR f:BFILE;VAR mem;cnt:WORD);
  108. BEGIN
  109.    WITH Regs,f DO BEGIN
  110.       AH:=$40;
  111.       DS:=Seg(mem);
  112.       DX:=Ofs(mem);
  113.       CX:=cnt;
  114.       BX:=Handle;
  115.       MsDos(Regs);
  116.       IF (Flags AND FCarry)<>0 THEN BEGIN
  117.          BlkClose(f);
  118.          BlkErase(f);
  119.      Error(AscZ(f.Name),WritingErMsg);END
  120.       ELSE IF AX<>CX THEN BEGIN
  121.          BlkClose(f);
  122.          BlkErase(f);
  123.      Error(AscZ(f.Name),DiskFullErMsg);
  124.       END;
  125.    END;
  126. END;
  127.  
  128.  
  129. PROCEDURE BlkSeek(VAR f:BFILE;pnt:LONGINT);
  130. BEGIN
  131.    WITH Regs,f DO BEGIN
  132.       AX:=$4200;
  133.       CX:=WORD((pnt AND $FFFF0000) SHR 16);
  134.       DX:=WORD(pnt);
  135.       BX:=Handle;
  136.       MsDos(Regs);
  137.    END;
  138. END;
  139.  
  140.  
  141. PROCEDURE FReName(s1,s2:STRING);
  142. BEGIN
  143.    s1:=s1+NUL;
  144.    s2:=s2+NUL;
  145.    WITH Regs DO BEGIN
  146.       AX:=$5600;
  147.       DS:=Seg(s1);
  148.       DX:=Ofs(s1[1]);
  149.       ES:=Seg(s2);
  150.       DI:=Ofs(s2[1]);
  151.       MsDos(Regs);
  152.    END;
  153. END;
  154.  
  155.  
  156. FUNCTION BlkFilePos(VAR f:BFILE):LONGINT;
  157. BEGIN
  158.    WITH Regs,f DO BEGIN
  159.       AX:=$4201;
  160.       CX:=0;
  161.       DX:=0;
  162.       BX:=Handle;
  163.       MsDos(Regs);
  164.       BlkFilePos:=(LONGINT(DX) SHL 16)+AX;
  165.    END;
  166. END;
  167.  
  168.  
  169. FUNCTION BlkFileSize(VAR f:BFILE):LONGINT;
  170. VAR
  171.    tmp : LONGINT;
  172. BEGIN
  173.    tmp:=BlkFilePos(f);
  174.    WITH Regs,f DO BEGIN
  175.       AX:=$4202;
  176.       CX:=0;
  177.       DX:=0;
  178.       BX:=Handle;
  179.       MsDos(Regs);
  180.       BlkFileSize:=(LONGINT(DX) SHL 16)+AX;END;
  181.    BlkSeek(f,tmp);
  182. END;
  183.  
  184.  
  185. PROCEDURE BlkClose(VAR f:BFILE);
  186. BEGIN
  187.    WITH Regs,f DO BEGIN
  188.       AH:=$3E;
  189.       BX:=Handle;
  190.       MsDos(Regs);
  191.       OpenFlg:=FALSE;
  192.    END;
  193. END;
  194.  
  195.  
  196. PROCEDURE BlkERase(VAR f:BFILE);
  197. VAR
  198.    savedir : PathStr;
  199. BEGIN
  200.    GetDir(0,savedir);
  201.    WITH Regs,f DO BEGIN
  202.       ChDir(Path);
  203.       AH:=$41;
  204.       DS:=Seg(Name);
  205.       DX:=Ofs(Name);
  206.       MsDos(Regs);END;
  207.    ChDir(savedir);
  208. END;
  209.  
  210.  
  211. PROCEDURE BlkCopy(VAR fdi,fdo:BFILE;size:LONGINT);
  212. CONST
  213.    maxbuf = $2000;
  214. VAR
  215.    buf : array[1..maxbuf] OF BYTE;
  216. BEGIN
  217.    WHILE size>maxbuf DO BEGIN
  218.       BlkWrite(fdo,buf,BlkRead(fdi,buf,maxbuf));
  219.       Dec(size,maxbuf);END;
  220.    BlkWrite(fdo,buf,BlkRead(fdi,buf,size));
  221. END;
  222.  
  223.  
  224. PROCEDURE TxtCopy(VAR fdi,fdo:BFILE;size:LONGINT);
  225. CONST
  226.    maxbuf = $2000;
  227. VAR
  228.    i   : WORD;
  229.    buf : array[1..maxbuf] OF BYTE;
  230. BEGIN
  231.    WHILE size>maxbuf DO BEGIN
  232.       FOR i:=1 TO BlkRead(fdi,buf,maxbuf) DO
  233.          IF buf[i]=Ord(^Z) THEN BEGIN BlkWrite(fdo,buf,Pred(i));Exit;END;
  234.       BlkWrite(fdo,buf,maxbuf);
  235.       Dec(size,maxbuf);END;
  236.    FOR i:=1 TO BlkRead(fdi,buf,size) DO
  237.        IF buf[i]=Ord(^Z) THEN BEGIN BlkWrite(fdo,buf,Pred(i));Exit;END;
  238.    BlkWrite(fdo,buf,size);
  239. END;
  240.  
  241.  
  242. FUNCTION BlkOpen(VAR f:BFILE;modes:STRING;s:PathStr):BOOLEAN;
  243.  
  244.  
  245.    FUNCTION Open1(mode:CHAR):Boolean;
  246.    BEGIN
  247.       Open1:=FALSE;
  248.       WITH f,Regs DO BEGIN
  249.          DS:=Seg(s[1]);
  250.          DX:=Ofs(s[1]);
  251.          CASE mode OF
  252.             'I' : BEGIN
  253.                      AX:=$3D00;
  254.                      MsDos(Regs);
  255.                      IF (Flags AND FCarry)<>0 THEN BEGIN
  256.             IF AX=4 THEN Error('',FileOpenMaxErMsg);Exit;
  257.                      END;
  258.                   END;
  259.             'O' : BEGIN
  260.                      AH:=$3C;
  261.                      CX:=0;
  262.                      MsDos(Regs);
  263.                      IF (Flags AND FCarry)<>0 THEN BEGIN
  264.             IF AX=4 THEN Error('',FileOpenMaxErMsg);Exit;
  265.                      END;
  266.                   END;
  267.          ELSE Exit;END;
  268.          Open1  :=TRUE;
  269.          OpenFlg:=TRUE;
  270.          Handle :=AX;
  271.       END;
  272.    END;
  273.  
  274. VAR
  275.    i : INTEGER;
  276. BEGIN
  277.    s:=s+NUL;
  278.    Move(s[1],f.Name,Ord(s[0]));
  279.    GetDir(0,f.Path);
  280.    BlkOpen:=TRUE;
  281.    FOR i:=1 TO Length(modes) DO IF Open1(modes[i]) THEN Exit;
  282.    BlkOpen:=FALSE
  283. END;
  284.  
  285.  
  286. PROCEDURE SetBTime(VAR f:BFILE;time:LONGINT);
  287. BEGIN
  288.    WITH Regs,f DO BEGIN
  289.       AX:=$5701;
  290.       BX:=Handle;
  291.       CX:=Word(time);
  292.       DX:=(time AND $FFFF0000) SHR 16;
  293.       MsDos(Regs);
  294.    END;
  295. END;
  296.  
  297.  
  298. PROCEDURE GetBTime(VAR f:BFILE;VAR time:LONGINT);
  299. BEGIN
  300.    WITH Regs,f DO BEGIN
  301.       AX:=$5700;
  302.       BX:=Handle;
  303.       MsDos(Regs);
  304.       time:=(LONGINT(DX) SHL 16)+CX;
  305.    END;
  306. END;
  307.  
  308.  
  309. PROCEDURE SetBAttr(VAR f:BFILE;attr:WORD);
  310. VAR
  311.    savedir : PathStr;
  312. BEGIN
  313.    GetDir(0,savedir);
  314.    WITH Regs,f DO BEGIN
  315.       ChDir(Path);
  316.       AX:=$4301;
  317.       DS:=Seg(Name);
  318.       DX:=Ofs(Name);
  319.       CX:=attr;
  320.       MsDos(Regs);END;
  321.    ChDir(savedir);
  322. END;
  323.  
  324.  
  325. PROCEDURE GetBAttr(VAR f:BFILE;VAR attr:WORD);
  326. VAR
  327.    savedir : PathStr;
  328. BEGIN
  329.    GetDir(0,savedir);
  330.    WITH Regs,f DO BEGIN
  331.       ChDir(Path);
  332.       AX:=$4300;
  333.       DS:=Seg(Name);
  334.       DX:=Ofs(Name);
  335.       MsDos(Regs);
  336.       attr:=CX;END;
  337.    ChDir(savedir);
  338. END;
  339.  
  340.  
  341. FUNCTION ChkHdr(VAR f:BFILE):BOOLEAN;
  342. VAR
  343.    i,chksum : BYTE;
  344.    buf      : ARRAY[0..256] OF BYTE;
  345.    fp       : LONGINT;
  346. BEGIN
  347.    fp:=BlkFilePos(f);
  348.    ChkHdr:=FALSE;
  349.    IF BlkRead(f,buf[0],1)=1 THEN
  350.    IF BlkRead(f,buf[1],1)=1 THEN
  351.    IF buf[0]>=2 THEN
  352.    IF BlkRead(f,buf[2],buf[0])=buf[0] THEN
  353.    IF buf[2]=Ord('-') THEN
  354.    IF buf[3] IN [Ord('L'),Ord('l')] THEN BEGIN
  355.       chksum:=0;
  356.       FOR i:=2 TO Succ(buf[0]) DO Inc(chksum,buf[i]);
  357.       IF buf[1]=chksum THEN ChkHdr:=TRUE;
  358.    END;
  359.    BlkSeek(f,fp);
  360. END;
  361.  
  362.  
  363. FUNCTION SkipArcHdr(VAR f:BFILE):BOOLEAN;
  364. VAR
  365.    chksum     : BYTE;
  366.    archdrsize : WORD;
  367.    buf        : ARRAY[0..1047] OF BYTE;
  368. BEGIN
  369.    SkipArcHdr:=FALSE;
  370.    IF BlkRead(f,buf[0],3)=3 THEN
  371.    IF buf[0]=$1A THEN BEGIN
  372.       archdrsize:=buf[1]+buf[2]*256;
  373.       IF archdrsize<=1048 THEN BEGIN
  374.          IF BlkRead(f,buf,archdrsize)=archdrsize THEN SkipArcHdr:=TRUE;
  375.       END;
  376.    END;
  377. END;
  378.  
  379.  
  380. FUNCTION ReadHdr(VAR f:BFILE):BOOLEAN;
  381. VAR
  382.    lh3size : WORD;
  383. BEGIN
  384.    ReadHdr:=FALSE;
  385.    IF NOT ChkHdr(f) THEN Exit;
  386.    WITH lh1 DO BEGIN
  387.       IF BlkRead(f,buf1[0],2)<>2 THEN Exit;
  388.       IF BlkRead(f,buf1[2],LNum)<>LNum THEN Exit;
  389.       IF LHdrID[2]='L' THEN BEGIN
  390.      Move(LFName[Length(LFName)+1],buf2,SizeOf(lh2));
  391.      lh3size:=buf2[10+buf2[9]]+buf2[11+buf2[9]]*256;
  392.          IF BlkRead(f,buf3,lh3size)<>lh3size THEN Exit;
  393.       END;
  394.    END;
  395.    ReadHdr:=TRUE;
  396. END;
  397.  
  398.  
  399. FUNCTION YesNo(s:STRING):BOOLEAN;
  400. VAR
  401.    c : CHAR;
  402. BEGIN
  403.    s:=s+' [Y/N]';
  404.    Msg(S);
  405.    REPEAT
  406.       c:=Upcase(GetChar);
  407.    UNTIL c IN ['Y','N',ESC,^C];
  408.    YesNo:=(c='Y');
  409.    Msg(Fill(Length(s),BS)+ClrL(Length(s),' '));
  410.    IF c=^C THEN Error('',StopErMsg);
  411. END;
  412.  
  413.  
  414. PROCEDURE Msg(s:STRING);
  415. BEGIN
  416.    Write(ERRF,s);
  417. END;
  418.  
  419.  
  420. PROCEDURE MsgLn(s:STRING);
  421. BEGIN
  422.    Msg(s+CRLF);
  423. END;
  424.  
  425.  
  426. PROCEDURE Error(s:STRING;n:BYTE);
  427. VAR
  428.    nn : STRING;
  429. BEGIN
  430.    Str(n,nn);
  431.    IF s<>'' THEN ErrStr:=s+' ' ELSE ErrStr:='';
  432.    ErrStr:=CRLF+ErrStr+MEG(n)+'(ErrCode='+nn+')';
  433.    Halt(n);
  434. END;
  435.  
  436.  
  437. {$F+}
  438. FUNCTION HeapFunc(size:WORD):INTEGER;{$F-}
  439. VAR
  440.    s : Str6;
  441. BEGIN
  442.   Str(DosFree:6,s);
  443.   Error(s,HeapErMsg);
  444. END;
  445.  
  446.  
  447. VAR
  448.    ExitSave : POINTER;
  449. {$F+}
  450. PROCEDURE LarcOut;{$F-}
  451. BEGIN
  452.    IF NewFVar.OpenFlg THEN BlkClose(NewFVar);
  453.    IF OldFVar.OpenFlg THEN BlkClose(OldFVar);
  454.    IF LzdFVar.OpenFlg THEN BlkClose(LzdFVar);
  455.    IF WrkFVar.OpenFlg THEN BEGIN BlkClose(WrkFVar);BlkErase(WrkFVar);END;
  456.    ExitProc:=ExitSave;
  457. END;
  458.  
  459.  
  460. BEGIN
  461.    ExitSave := ExitProc;
  462.    ExitProc := @LarcOut;
  463.    NewFVar.OpenFlg:=FALSE;
  464.    LzdFVar.OpenFlg:=FALSE;
  465.    OldFVar.OpenFlg:=FALSE;
  466.    WrkFVar.OpenFlg:=FALSE;
  467.    HeapError:=@HeapFunc;
  468.    IF Lo(DosVersion)<2 THEN Error('',DosVerErMsg);
  469. END.
  470.