home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FILUTL / LDIFF12S.ARC / LDEXTR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-07-15  |  3.9 KB  |  148 lines
  1. (*---------------------------------------------------------------------------*)
  2. (*LDExtr.pas ë≡ôÇÅêù¥ü@ü@  ü@       (C) ÄOû╪ÿaòF NIFTY SDR SDI00147 1989/7/1 *)
  3. (*$B-,F-,I-,N-                                                               *)
  4. (*---------------------------------------------------------------------------*)
  5. UNIT LDExtr;
  6.  
  7.  
  8. INTERFACE
  9.  
  10.  
  11. USES
  12.    Dos,
  13.    MyType,
  14.    MyTool,
  15.    LDVari,
  16.    LDProc;
  17.  
  18.  
  19. PROCEDURE ExtrJob;
  20.  
  21.  
  22. IMPLEMENTATION
  23.  
  24.  
  25. {$L LDD }
  26. FUNCTION  DeCode(inf,outf:WORD;size:LONGINT;flg:WORD):BOOLEAN;EXTERNAL;
  27.  
  28.  
  29. FUNCTION GetHdrVer(s:STR3):BYTE;
  30. BEGIN
  31.    GetHdrVer:=0;
  32.    IF (s[2]='s') AND (s[3]='-') THEN GetHdrVer:=1 ELSE
  33.    IF s[2] IN ['0'..'9'] THEN
  34.       IF s[3] IN ['0'..'9']
  35.      THEN GetHdrVer:=(ORD(s[2])-ORD('0'))*10+ORD(s[3])-ORD('0')
  36.      ELSE GetHdrVer:=ORD(s[2])-ORD('0');
  37. END;
  38.  
  39.  
  40. PROCEDURE SetLzdHdr;
  41. VAR
  42.    ep    : WORD;
  43.    d     : DirStr;
  44.    n     : NameStr;
  45.    e     : ExtStr;
  46. BEGIN
  47.    IF NOT ReadHdr(LzdFVar) THEN Error(LzdFName,IsNotLzdErMsg);
  48.    WITH lh1,lh2,lh3,LzdFN DO BEGIN
  49.       FSplit(LFName,d,n,e);
  50.       CASE LHdrSID[1] OF
  51.      'H','h' : Error(LzdFName,LzhErMsg);
  52.      'Z','z' : IF (LHdrSID[2]<>'6') AND (LHdrSID[3]<>'-') THEN
  53.               Error(LzdFName,LzsErMsg);
  54.      'D','d' : ;
  55.       ELSE
  56.      Error(LzdFName,UnknownErMsg);
  57.       END;
  58.       IF GetHdrVer(LHdrSID)<>6 THEN Error('',NewVerErMsg);
  59.       NewName  := n+e;
  60.       IF LHdrID[2]='L' THEN BEGIN
  61.      NewCrc  :=LCRC;
  62.      NewAttr :=LAttr;
  63.      OldCrc  :=LOldCrc;
  64.      OldFSize:=LOldFSize;
  65.      OldName :=LOldName;
  66.      EI      :=LEI;
  67.      EJ      :=LEJ;
  68.      CTYPE   :=LCTYPE;END
  69.       ELSE BEGIN
  70.      ep:=SizeOf(LHdr)-255+Length(LFName);
  71.      NewAttr:=LCRC;
  72.      NewCrc :=buf1[ep]+buf1[ep+1]*256;
  73.      OldCrc :=buf1[ep+2]+buf2[ep+3]*256;
  74.      Move(buf1[ep+4],OldFSize,4);
  75.      Move(buf1[ep+8],OldName,Succ(buf1[ep+8]));
  76.      EI      :=18;
  77.      EJ      :=14;
  78.      CTYPE   :='N';END;
  79.       NewFSize :=LFSize;
  80.       NewTime  :=LTime;
  81.       NewSize  :=LSize;
  82.       NewHSize :=LNum+2;
  83.    END;
  84. END;
  85.  
  86.  
  87. PROCEDURE ExtrJob;
  88. VAR
  89.    d : DirStr;
  90.    n : NameStr;
  91.    e : ExtStr;
  92.    fs : LONGINT;
  93. BEGIN
  94.    IF NOT BlkOpen(LzdFVar,'I',LzdFName) THEN Error(LzdFName,CannotFoundErMsg);
  95.    IF NOT ChkHdr(LzdFVar) THEN BEGIN
  96.       IF NOT SkipArcHdr(LzdFVar) THEN Error(LzdFName,IsNotLzdErMsg);
  97.    END;
  98.    SetLzdHdr;
  99.    WITH LzdFN DO BEGIN
  100.       IF NOT( ((EI=18) AND (EJ=14)) OR ((EI=16) AND (EJ=16)) ) THEN
  101.          Error('',Wait150Msg);
  102.       IF (CTYPE<>'N') THEN Error('',Wait200Msg);
  103.       IF NewFName='' THEN NewFName:=NewName;
  104.       IF OldFName='' THEN BEGIN
  105.          IF BlkOpen(OldFVar,'I',OldName) THEN BEGIN
  106.             OldFName:=OldName;BlkClose(OldFVar);END
  107.          ELSE BEGIN
  108.             OldFName:=NewFName;
  109.          END;END;
  110.       ReadDic(fs);
  111.       IF OldFSize<>fs THEN Error(OldFName,OldFSizeErMsg);
  112.       IF OldCrc<>CRC THEN Error(OldFName,OldCrcErMsg);
  113.       WriteLn(OUTF,MEG(OldFileMsg)+OldFName+MEG(OldFileOKMsg));
  114.       IF FExist(NewFName)<>0 THEN BEGIN
  115.      IF NOT YesNo(NewFName+' '+MEG(OverWriteMsg)) THEN Halt(2);
  116.      FSplit(NewFName,d,n,e);
  117.      IF FExist(d+OldName)=0 THEN FReName(NewFName,d+OldName);
  118.       END;
  119.       IF NOT BlkOpen(NewFVar,'O',NewFName) THEN
  120.      Error(NewFName,CantCreateErMsg);
  121.       WriteLn(OUTF,MEG(CreatingMsg)+' '+NewFName+' '+MEG(FromMsg)+' '+
  122.            OldFName+' '+MEG(WithMsg)+' '+LzdFName);
  123.       CRC:=0;
  124.       IF NOT DeCode(LzdFVar.Handle,NewFVar.Handle,NewSize,EI) THEN
  125.      Error(LzdFName,DecodeErMsg);
  126.       WriteLn(OUTF);
  127.       IF CRC<>NewCrc THEN
  128.           MsgLn(MEG(FatalErMsg))
  129.       ELSE BEGIN
  130.          Write(MEG(ExtractOKMsg)+' '+NewFVar.Path);
  131.          IF Length(NewFVar.Path)=3
  132.         THEN WriteLn(AscZ(NewFVar.Name))
  133.         ELSE WriteLn(PathDelim+AscZ(NewFVar.Name));END;
  134.       IF (CRC=NewCRC) OR (CMD='T') THEN BEGIN
  135.          SetBTime(NewFVar,NewTime);
  136.          BlkClose(NewFVar);
  137.          SetBAttr(NewFVar,NewAttr);END
  138.       ELSE BEGIN
  139.      BlkClose(NewFVar);
  140.      BlkErase(NewFVar);
  141.       END;
  142.    END;
  143.    BlkClose(LzdFVar);
  144. END;
  145.  
  146.  
  147. END.
  148.