home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / vp21beta.zip / AEXMPSRC.RAR / UNRAR / UNRAR.PAS < prev   
Pascal/Delphi Source File  |  2000-08-15  |  27KB  |  1,083 lines
  1. {█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
  2. {█                                                       █}
  3. {█      Virtual Pascal Examples. Version 2.1.            █}
  4. {█      RAR archive unpacker                             █}
  5. {█      ─────────────────────────────────────────────────█}
  6. {█      Original C version (C) 1994-95 Eugene Roshal     █}
  7. {█      Copyright (C) 1995-2000 vpascal.com              █}
  8. {█                                                       █}
  9. {▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}
  10.  
  11. Program UnRar;
  12.  
  13. {&Use32+,Delphi-,T-,H-,X+}
  14.  
  15. Uses
  16.   Dos, Unpack;
  17.  
  18. Type
  19.   Errors = ( eEmpty, eWrite, eRead, eOpen, eClose, eMemory, eArch );
  20.  
  21.   MarkHeader = Record
  22.     Mark     : Array[0..4] of Byte;
  23.     HeadSize : SmallWord;
  24.   end;
  25.  
  26.   ArchiveHeader = Record
  27.     HeadCRC  : SmallWord;
  28.     HeadType : Byte;
  29.     Flags    : SmallWord;
  30.     HeadSize : SmallWord;
  31.     Reserved : Array[0..5] of Byte;
  32.   end;
  33.  
  34.   FileHeader = Record
  35.     HeadCRC   : SmallWord;
  36.     HeadType  : Byte;
  37.     Flags     : SmallWord;
  38.     HeadSize  : SmallWord;
  39.     PackSize  : Word;
  40.     UnpSize   : Word;
  41.     HostOS    : Byte;
  42.     FileCRC   : Word;
  43.     FileTime  : Word;
  44.     UnpVer    : Byte;
  45.     Method    : Byte;
  46.     NameSize  : SmallWord;
  47.     FileAttr  : Word;
  48.   end;
  49.  
  50. Const
  51.   SD_MEMORY = 1;
  52.   SD_FILES  = 2;
  53.   SUCCESS     = 0;
  54.   WARNING     = 1;
  55.   FATAL_ERROR = 2;
  56.   CRC_ERROR   = 3;
  57.   LOCK_ERROR  = 4;
  58.   WRITE_ERROR = 5;
  59.   OPEN_ERROR  = 6;
  60.   USER_ERROR  = 7;
  61.   MEMORY_ERROR= 8;
  62.   USER_BREAK  =255;
  63.  
  64.   UNP_VER = 15;
  65.  
  66.   MS_DOS = 0;
  67.   OS2    = 1;
  68.   DOSFA_RDONLY =  $01;
  69.   DOSFA_HIDDEN =  $02;
  70.   DOSFA_SYSTEM =  $04;
  71.   DOSFA_LABEL  =  $08;
  72.   DOSFA_DIREC  =  $10;
  73.   DOSFA_ARCH   =  $20;
  74.  
  75.   MHD_MULT_VOL = 1;
  76.   MHD_COMMENT  = 2;
  77.   MHD_LOCK     = 4;
  78.   MHD_SOLID    = 8;
  79.  
  80.   LHD_SPLIT_BEFORE =  1;
  81.   LHD_SPLIT_AFTER  =  2;
  82.   LHD_PASSWORD     =  4;
  83.   LHD_COMMENT      =  8;
  84.   SKIP_IF_UNKNOWN  =  $4000;
  85.   LONG_BLOCK       =  $8000;
  86.  
  87.   ALL_HEAD  = 0;
  88.   MARK_HEAD = $72;
  89.   MAIN_HEAD = $73;
  90.   FILE_HEAD = $74;
  91.   COMM_HEAD = $75;
  92.  
  93.   COMPARE_PATH = 1;
  94.   NOT_COMPARE_PATH = 2;
  95.  
  96.   PATHDIV      = '\';
  97.  
  98. Const
  99.   MainCommand : Char = #0;
  100.   ArcName : String[80] = '';
  101.   ArgCount : Integer = 0;
  102.  
  103. Var
  104.   ArcFPtr       : File;
  105.   FileFPtr      : File;
  106.   TmpMemory     : Pointer;
  107.   NextBlockPos  : Word;
  108.   UnpPackedSize : Word;
  109.   UnpFileCRC    : Word;
  110.   UnpVolume     : Boolean;
  111.   TestMode      : Boolean;
  112.   SolidType     : Boolean;
  113.   CRC32_Table   : Array[0..255] of Word;
  114.   Mhd           : ArchiveHeader;
  115.   Lhd           : FileHeader;
  116.   CurExtrFile   : String[80];
  117.   ArcFileName   : String[80];
  118.   ExtrPath      : String[80];
  119.   ArgNames      : Array[0..15] of String[80];
  120.  
  121. const
  122.   Digits : array[0..$F] of Char = '0123456789ABCDEF';
  123.  
  124. Function ZStr( x : Word; n : Byte ) : String;
  125. Var
  126.   s : String;
  127.   i : Byte;
  128.  
  129. begin
  130.   Str( x:n, s );
  131.   For i := 1 to Length( s ) do
  132.     If s[i] = ' ' then
  133.       s[i] := '0';
  134.   ZStr := s;
  135. end;
  136.  
  137. Function LeftJustify( s : String; n : Integer ) : String;
  138. begin
  139.   While Length(s) < n do
  140.     s := s + ' ';
  141.   Leftjustify := s;
  142. end;
  143.  
  144. function HexB(B : Byte) : string;
  145.   {-Return hex string for byte}
  146. begin
  147.   HexB[0] := #2;
  148.   HexB[1] := Digits[B shr 4];
  149.   HexB[2] := Digits[B and $F];
  150. end;
  151.  
  152. function HexW(W : Word) : string;
  153.   {-Return hex string for word}
  154. begin
  155.   HexW[0] := #4;
  156.   HexW[1] := Digits[hi(W) shr 4];
  157.   HexW[2] := Digits[hi(W) and $F];
  158.   HexW[3] := Digits[lo(W) shr 4];
  159.   HexW[4] := Digits[lo(W) and $F];
  160. end;
  161.  
  162. function HexL(L : LongInt) : string;
  163.   {-Return hex string for LongInt}
  164. begin
  165.   HexL := HexW(L shr 16)+HexW(L and $FFFF);
  166. end;
  167.  
  168. Function CmpName(Const Mask,Name : String) : Boolean;
  169. Var
  170.   MaskInx : Integer;
  171.   NameInx : Integer;
  172.   MaskLen : Byte;
  173.   NameLen : Byte;
  174.  
  175. begin
  176.   MaskInx := 1; MaskLen := Length( Mask );
  177.   NameInx := 1; NameLen := Length( Name);
  178.   while true do
  179.   begin
  180.     if Mask[ MaskInx ] = '*' then
  181.     begin
  182.       while (Mask[MaskInx] <> '.') and (MaskInx <= MaskLen) do
  183.         Inc(MaskInx);
  184.       while (Name[NameInx] <> '.') and (NameInx <= NameLen) do
  185.         Inc(NameInx);
  186.     end;
  187.     if MaskInx > MaskLen then
  188.       begin
  189.         CmpName := ( NameInx > NameLen );
  190.         Exit;
  191.       end;
  192.  
  193.     if (NameInx > NameLen) and (Mask[MaskInx] = '.') then
  194.     begin
  195.       Inc( MaskInx );
  196.       continue;
  197.     end;
  198.  
  199.     if (UpCase(Mask[MaskInx]) = UpCase(Name[NameInx])) OR
  200.        ( (Mask[MaskInx] = '?') and ( NameInx <= NameLen )) then
  201.     begin
  202.       Inc( MaskInx );
  203.       Inc( NameInx );
  204.     end
  205.     else
  206.       begin
  207.         CmpName := False;
  208.         Exit;
  209.       end;
  210.   end
  211. end;
  212.  
  213. Procedure ShutDown(Mode : Integer);
  214. begin
  215.   if (Mode AND SD_FILES <> 0) then
  216.     begin
  217.       {$I-}
  218.       if FileRec(ArcFPtr).Mode <> fmClosed then
  219.         Close(ArcFPtr);
  220.       {$I+}
  221.       If IOResult = 0 then ;
  222.       {$I-}
  223.       if FileRec(FileFPtr).Mode <> fmClosed then
  224.         Close(FileFPtr);
  225.       {$I+}
  226.       If IOResult = 0 then ;
  227.     end;
  228.  
  229.   if (Mode AND SD_MEMORY <> 0) then
  230.     begin
  231.       if TmpMemory <> nil then
  232.         FreeMem(TmpMemory, unp_Memory);
  233.       Writeln;
  234.     end
  235. end;
  236.  
  237. Procedure ErrExit(ErrCode : Errors; Code : Integer);
  238. Var
  239.   ErrMsg : String;
  240. begin
  241.   Case ErrCode of
  242.     eEmpty  : ErrMsg := '';
  243.     eWrite  : ErrMsg := 'Write error. Disk full ?';
  244.     eRead   : ErrMsg := 'Read error';
  245.     eOpen   : ErrMsg := 'File open error';
  246.     eClose  : ErrMsg := 'File close error';
  247.     eMemory : ErrMsg := 'Not enough memory';
  248.     eArch   : ErrMsg := 'Broken archive';
  249.   end;
  250.   if ( ErrCode <> eEmpty ) then
  251.     Writeln( 'Program Aborted: ',ErrMsg );
  252.  
  253.   ShutDown(SD_FILES OR SD_MEMORY);
  254.   Halt(Code);
  255. end;
  256.  
  257. Procedure CreatePath(fpath : String);
  258. Var
  259.   ChPos : Integer;
  260.   s,s1  : String[80];
  261. begin
  262.   s1 := '';
  263.   Repeat
  264.     ChPos := Pos( PathDiv, fPath );
  265.     If ChPos <> 0 then
  266.       begin
  267.         s := s1+Copy( fPath, 1, ChPos-1 );
  268.         {$I-}
  269.         MkDir( s );
  270.         {$I+}
  271.         If IOResult = 0 then
  272.           begin
  273.             Writeln;
  274.             Write( ' Creating    ',s );
  275.           end;
  276.         s1 := s+'\';
  277.         Delete( fPath, 1, ChPos );
  278.       end;
  279.   Until ChPos = 0;
  280. end;
  281.  
  282. Procedure NextVolumeName;
  283. Var
  284.   Dir     : DirStr;
  285.   Name    : NameStr;
  286.   Ext     : ExtStr;
  287.   Number  : Integer;
  288.   Err     : Integer;
  289.  
  290. begin
  291.   fSplit( ArcName, Dir, Name, Ext );
  292.   Val( Copy( Ext, 3, 2 ), Number, Err );
  293.   If Err <> 0 then
  294.     Number := 0
  295.   else
  296.     Inc( Number );
  297.   Ext := Copy( Ext, 1, 2 ) + ZStr( Number, 2 );
  298.  
  299.   ArcName := Dir + Name + Ext;
  300. end;
  301.  
  302. Procedure tclose(Var FPtr : File);
  303. begin
  304.   {$I-}
  305.   Close( fPtr );
  306.   {$I+}
  307.   if IOResult <> 0 then
  308.     ErrExit(ECLOSE,FATAL_ERROR);
  309. end;
  310.  
  311. Function tread(Var f : File;Var buf; len : Word) : Integer;
  312. Var
  313.   Check : Word;
  314.  
  315. begin
  316.   {$I-}
  317.   BlockRead( f, Buf, Len, Check );
  318.   {$I+}
  319.  
  320.   if (IOResult <> 0) or (Check <> Len) then;
  321.     { ErrExit(EREAD,FATAL_ERROR); }
  322.  
  323.   tRead := Check;
  324. end;
  325.  
  326. Procedure InitCRC;
  327. Var
  328.   I, J : Word;
  329.   C : Word;
  330. begin
  331.   For i := 0 to 255 do
  332.     begin
  333.       C := I;
  334.       For j := 0 to 7 do
  335.         If Odd(C) then
  336.           C := (C shr 1) XOR $EDB88320
  337.         else
  338.           C := C shr 1;
  339.       CRC32_Table[I] := C;
  340.     end
  341. end;
  342.  
  343. Function CRC(StartCRC : Word;Addr : Pointer;Size : Word) : Word;
  344. Var
  345.   i : Word;
  346.  
  347. begin
  348.   if CRC32_Table[1] = 0 then
  349.     InitCRC;
  350.  
  351.   for i := 0 to Size-1 do
  352.     StartCRC := CRC32_Table[ Byte(StartCRC) XOR
  353.                 pBuffer(Addr)^[I]] XOR (StartCRC shr 8);
  354.  
  355.   CRC := StartCRC;
  356. end;
  357.  
  358. Function IsArchive : Boolean;
  359. Var
  360.   Mark : Array[0..6] of Byte;
  361.   Header : Array[0..12] of Byte;
  362. begin
  363.   IsArchive := False;
  364.   SolidType := False;
  365.  
  366.   if (tread(ArcFPtr,Mark,7)<>7) then
  367.     Exit;
  368.  
  369.   if (Mark[0]<>$52) or (Mark[1]<>$61) or (Mark[2]<>$72) or (Mark[3]<>$21) or
  370.      (Mark[4]<>$1a) or (Mark[5]<>$07) or (Mark[6]<>$00) then
  371.     exit;
  372.  
  373.   if (tread(ArcFPtr,Header,13) <> 13) then
  374.     exit;
  375.  
  376.   Mhd.HeadCRC   :=  SmallWord( (@Header[0])^ );
  377.   Mhd.HeadType  :=  Header[2];
  378.   Mhd.Flags     :=  SmallWord( (@Header[3])^ );
  379.   Mhd.HeadSize  :=  SmallWord( (@Header[5])^ );
  380.   if Mhd.HeadCRC <> not SmallWord(CRC($FFFFFFFF,@Header[2],11)) then
  381.     writeln('Archive header broken');
  382.   SolidType := (Mhd.Flags AND MHD_SOLID <> 0);
  383.   Seek(ArcFPtr,FilePos(ArcFPtr)+Mhd.HeadSize-13);
  384.   isArchive := True;
  385. end;
  386.  
  387. Procedure CheckArc;
  388. begin
  389.   if not IsArchive then
  390.     begin
  391.       Writeln('Bad archive ',ArcName);
  392.       ErrExit(EEMPTY,FATAL_ERROR);
  393.     end
  394. end;
  395.  
  396. Function ReadBlock(BlockType : Integer) : Integer;
  397. Var
  398.   HeadCRC : Word;
  399.   Header  : Array[0..31] of byte;
  400.   Size,I  : Integer;
  401.  
  402. begin
  403.   FillChar( Lhd, Sizeof( Lhd ), 0 );
  404.   FillChar( Header, Sizeof( Header ), 0 );
  405.   while true do
  406.     begin
  407.       Size := tread( ArcFPtr, Header, 32 );
  408.       Lhd.HeadCRC  := SmallWord( (@Header[0])^ );
  409.       Lhd.HeadType := Header[2];
  410.       Lhd.Flags    := SmallWord( (@Header[3])^ );
  411.       Lhd.HeadSize := SmallWord( (@Header[5])^ );
  412.       Lhd.PackSize := Word( (@Header[7])^ );
  413.       Lhd.UnpSize  := Word( (@Header[11])^ );
  414.       Lhd.HostOS   := Header[15];
  415.       Lhd.FileCRC  := Word( (@Header[16])^ );
  416.       Lhd.FileTime := Word( (@Header[20])^ );
  417.       Lhd.UnpVer   := Header[24];
  418.       Lhd.Method   := Header[25];
  419.       Lhd.NameSize := SmallWord( (@Header[26])^ );
  420.       Lhd.FileAttr := Word( (@Header[28])^ );
  421.       if (Size <> 0) and ( (Size<7) or (Lhd.HeadSize<7) ) then
  422.         ErrExit(EARCH,FATAL_ERROR);
  423.  
  424.       NextBlockPos := FilePos( ArcFPtr ) - Size + Lhd.HeadSize;
  425.       if (Lhd.Flags AND LONG_BLOCK <> 0) then
  426.         Inc( NextBlockPos, Lhd.PackSize );
  427.       if (Size = 0) or (BlockType = ALL_HEAD) or (Lhd.HeadType = BlockType) then
  428.         break;
  429.       seek( ArcFPtr, NextBlockPos );
  430.     end;
  431.  
  432.   if (Size>0) and (BlockType = FILE_HEAD) then
  433.     begin
  434.       tread(ArcFPtr,ArcFileName[1],Lhd.NameSize);
  435.       ArcFileName[Lhd.NameSize+1] := #0;
  436.       ArcFileName[0] := chr(Lhd.NameSize);
  437.       Inc( Size, Lhd.NameSize );
  438.       HeadCRC := CRC($FFFFFFFF,@Header[2],30);
  439.  
  440.       if Lhd.HeadCRC <> not SmallWord(CRC(HeadCRC,@ArcFileName[1],Lhd.NameSize)) then
  441.         WriteLn(ArcFileName,': file header broken');
  442.  
  443.       for I := 1 to Length(ArcFileName) do
  444.         if (ArcFileName[I] in ['\','/']) then
  445.           ArcFileName[I] := PATHDIV;
  446.     end;
  447.  
  448.   ReadBlock := Size;
  449. end;
  450.  
  451. Procedure MergeArc(ShowFileName : Integer);
  452.   {-Merge archive with next disk }
  453. Var
  454.   Ch  : Char;
  455.   IOR : Integer;
  456.  
  457. begin
  458.   tClose( ArcfPtr );
  459.   NextVolumeName;
  460.   Repeat
  461.     Assign( ArcFPtr, ArcName );
  462.     FileMode := $40;
  463.     {$I-}
  464.     Reset( ArcFPtr, 1 );
  465.     {$I+}
  466.     IOR := IOResult;
  467.     If IOR <> 0 then
  468.       begin
  469.         Writeln;
  470.         Write( ' Disk with ',ArcName,' is required. Continue ? ' );
  471.         Readln( Ch );
  472.         If UpCase( Ch ) = 'N' then
  473.           ErrExit( EEMPTY, USER_BREAK );
  474.       end;
  475.   Until ( IOR = 0 );
  476.  
  477.   CheckArc;
  478.   ReadBlock( FILE_HEAD );
  479.   UnpVolume := ( Lhd.Flags AND LHD_SPLIT_AFTER ) <> 0;
  480.   Seek( ArcFPtr, NextBlockPos-Lhd.PackSize );
  481.   UnPpackedSize := LHd.PackSize;
  482. end;
  483.  
  484. Function UnpRead(Addr : Pointer;Count : Word) : Integer;
  485. Var
  486.   RetCode  : Integer;
  487.   Check    : Integer;
  488.   ReadSize : Integer;
  489.   ReadAddr : pByte;
  490.   TotalRead : Word ;
  491.  
  492. begin
  493.   totalRead := 0;
  494.   RetCode := 0;
  495.   ReadAddr := Addr;
  496.   while (Count > 0) do
  497.     begin
  498.       If Count > UnpPackedSize then
  499.         ReadSize := UnpPackedSize
  500.       else
  501.         ReadSize := Count;
  502.  
  503.       BlockRead( ArcFPtr, Addr^, ReadSize, Check );
  504.       If ReadSize <> Check then
  505.         begin
  506.           RetCode := -1;
  507.           Break;
  508.         end;
  509.  
  510.       Inc( TotalRead, Check );
  511.       Inc( ReadAddr, Check );
  512.       Dec( Count, Check );
  513.       Dec( UnpPackedSize, Check );
  514.       if (UnpPackedSize  =  0 ) and UnpVolume then
  515.         MergeArc(1)
  516.       else
  517.         break;
  518.     end;
  519.  
  520.   if (RetCode<>-1) then
  521.     RetCode := TotalRead;
  522.  
  523.   UnpRead := RetCode;
  524. end;
  525.  
  526. Function UnpWrite(Addr : Pointer;Count : Word) : Integer;
  527. Var
  528.   RetCode  : Integer;
  529.   Check    : Word;
  530.  
  531. begin
  532.   RetCode := 0;
  533.   if TestMode then
  534.     RetCode := Count
  535.   else
  536.     begin
  537.       BlockWrite( FileFPtr, Addr^, Count, Check );
  538.       If Check <> Count then
  539.         RetCode := -1
  540.       else
  541.         RetCode := Check;
  542.     end;
  543.  
  544.   if RetCode <> -1 then
  545.     UnpFileCRC := CRC(UnpFileCRC,Addr,RetCode);
  546.  
  547.   UnpWrite := RetCode;
  548. end;
  549.  
  550. Procedure UnstoreFile;
  551. Var
  552.   Code : Integer;
  553. begin
  554.   while True do
  555.     begin
  556.       Code := UnpRead(TmpMemory,$7f00);
  557.       If Code = -1 then
  558.         ErrExit(EWRITE,WRITE_ERROR);
  559.  
  560.       if (Code = 0) then
  561.         break;
  562.  
  563.       if (UnpWrite(TmpMemory,Code) = -1) then
  564.         ErrExit(EWRITE,WRITE_ERROR);
  565.     end
  566. end;
  567.  
  568. Function strnicomp( Str1,Str2 : String; MaxLen : Integer ) : Boolean;
  569. Var
  570.   i : Integer;
  571.  
  572. begin
  573.   i := 1;
  574.   if MaxLen > 0 then
  575.     while ( MaxLen > 0 ) do
  576.     begin
  577.       Dec( MaxLen );
  578.       If UpCase( Str1[i] ) <> UpCase( Str2[i] ) then
  579.         begin
  580.           strnicomp := False;
  581.           Exit;
  582.         end;
  583.       If i > Length( Str1 )  then
  584.         begin
  585.           strnicomp := True;
  586.           Exit;
  587.         end;
  588.       Inc( i );
  589.     end;
  590.   strniComp := True;
  591. end;
  592.  
  593. Function ToPercent(N1,N2 : Word) : Integer;
  594. begin
  595.   if (N1 > 10000) then
  596.   begin
  597.     N1 := N1 div 100;
  598.     N2 := N2 div 100;
  599.   end;
  600.   if (N2 = 0) then
  601.     ToPercent := 0
  602.   else
  603.     if (N2<N1) then
  604.       ToPercent := 100
  605.     else
  606.       ToPercent := (N1*100) div N2;
  607. end;
  608.  
  609. Procedure SplitCommandLine;
  610. Var
  611.   I,Len : Integer;
  612.   Dir, Name, Ext : String;
  613.   s  : String;
  614.  
  615. begin
  616.   if (ParamCount = 1 ) then
  617.     begin
  618.       MainCommand := 'X';
  619.       ArcName := ParamStr(1);
  620.     end
  621.   else
  622.     for I := 1 to ParamCount do
  623.       begin
  624.         s := ParamStr(i);
  625.         if (MainCommand = #0) then
  626.           MainCommand := UpCase(s[1])
  627.         else
  628.           begin
  629.             if ArcName = '' then
  630.               ArcName := Copy( s, 1, 80 )
  631.             else
  632.               begin
  633.                 Len := Length( s );
  634.                 if ( Len>0 ) and
  635.                    ((s[Len] = ':') or (s[Len] = '\') or (s[Len] = '/')) then
  636.                   begin
  637.                     ExtrPath := s;
  638.                     ExtrPath[Len] := PATHDIV;
  639.                   end
  640.                 else
  641.                   begin
  642.                     ArgNames[ArgCount and $f] := s;
  643.                     Inc( ArgCount );
  644.                   end;
  645.               end
  646.           end
  647.       end;
  648.  
  649.   if (ArgCount = 0 ) and (ArcName <> '') then
  650.     begin
  651.       ArgNames[ArgCount and $f] := '*.*';
  652.       Inc( ArgCount );
  653.     end;
  654.  
  655.   FSplit( ArcName, Dir, Name, Ext );
  656.   If Ext = '' then
  657.     ArcName := ArcName + '.rar';
  658.   ArgCount := ArgCount and $F;
  659. end;
  660.  
  661. Function IsProcessFile(ComparePath : Word) : Boolean;
  662. Var
  663.   NumName       : Integer;
  664.   WildCards     : Boolean;
  665.   dir1, dir2    : PathStr;
  666.   name1, name2  : NameStr;
  667.   ext1, ext2    : ExtStr;
  668.  
  669. begin
  670.   IsProcessFile := False;
  671.   for NumName := 0 to ArgCount-1 do
  672.     begin
  673.       FSplit( ArgNames[NumName], Dir1, Name1, Ext1 );
  674.       FSplit( ArcFileName, Dir2, Name2, Ext2 );
  675.       WildCards := ( Pos('?',ArgNames[NumName]) <> 0 ) or
  676.                    ( Pos('*',ArgNames[NumName]) <> 0 );
  677.       If CmpName( Name1+Ext1, Name2+Ext2 ) and
  678.          ( ( ( ComparePath = NOT_COMPARE_PATH ) and ( dir1 = '' ) ) or
  679.            ( WildCards and strnicomp( dir1, dir2, length(dir1) ) or
  680.              strnicomp( dir1, dir2, 1000 ) ) ) then
  681.         IsProcessFile := True;
  682.     end;
  683. end;
  684.  
  685. Procedure Help;
  686. begin
  687.   WriteLn('Usage:     UNRAR <command> <archive> <files...>');
  688.   WriteLn;
  689.   WriteLn('<Commands>');
  690.   WriteLn(' x       Extract files with full path');
  691.   WriteLn(' e       Extract files to current directory');
  692.   WriteLn(' t       Test archive files');
  693.   WriteLn(' v       Verbosely list contents of archive');
  694.   WriteLn(' l       List contents of archive');
  695.   WriteLn;
  696. end;
  697.  
  698. Function ExtractFile : Integer;
  699.   Const
  700.     FileCount       : Word = 0;
  701.     TotalFileCount  : Word = 0;
  702.     DirCount        : Word = 0;
  703.     ErrCount        : Word = 0;
  704.     ExtrFile        : Boolean = False;
  705.     SkipSolid       : Boolean = False;
  706.   Var
  707.     Dir, Name, Ext : String;
  708.     DestFileName  : String[80];
  709.     Size          : Word;
  710.     UnpSolid      : Boolean;
  711.  
  712. begin
  713.   Assign( ArcFPtr, ArcName );
  714.   FileMode := $40;
  715.   {$I-}
  716.   Reset( ArcFPtr, 1 );
  717.   {$I+}
  718.   If IOResult <> 0 then
  719.     ErrExit(EOPEN,FATAL_ERROR);
  720.  
  721.   CheckArc;
  722.   CreateEncTbl(TmpMemory);
  723.   UnpVolume := False;
  724.   UnpSolid := False;
  725.   Writeln;
  726.   if (MainCommand = 'T') then
  727.     WriteLn(' Testing archive ',ArcName)
  728.   else
  729.     WriteLn(' Extracting from ',ArcName);
  730.  
  731.   while True do
  732.     begin
  733.       Size := ReadBlock(FILE_HEAD);
  734.  
  735.       if (Size<=0) and not UnpVolume then
  736.         break;
  737.  
  738.       if ((Lhd.Flags AND LHD_SPLIT_BEFORE <> 0) and SolidType) then
  739.         begin
  740.           Writeln;
  741.           Write('Solid archive: first volume required');
  742.           ErrExit(EEMPTY,FATAL_ERROR);
  743.         end;
  744.  
  745.       if (UnpVolume and (Size = 0)) then
  746.         MergeArc(0);
  747.  
  748.       UnpVolume := (Lhd.Flags AND LHD_SPLIT_AFTER <> 0);
  749.       seek( ArcFPtr, NextBlockPos-Lhd.PackSize );
  750.  
  751.       TestMode := False;
  752.       ExtrFile := False;
  753.       SkipSolid:= False;
  754.  
  755.       if IsProcessFile(COMPARE_PATH) and
  756.          (Lhd.Flags AND LHD_SPLIT_BEFORE = 0)
  757.           or ( SkipSolid <> SolidType ) then
  758.       begin
  759.         DestFileName := ExtrPath;
  760.         fSplit( ArcFileName, Dir, Name, Ext );
  761.         If MainCommand <> 'E' then
  762.           DestFileName := DestFileName + ArcFileName
  763.         else
  764.           DestFileName := DestFileName + Name + Ext;
  765.         If (Lhd.FileAttr AND DOSFA_DIREC <> 0) then
  766.           DestFileName := DestFileName + PathDiv;
  767.  
  768.         ExtrFile := Not SkipSolid;
  769.  
  770.         if (Lhd.UnpVer<15) or (Lhd.UnpVer>UNP_VER) then
  771.           begin
  772.             Writeln;
  773.             Write(' ',ArcFileName,': unknown method');
  774.             ExtrFile := False;
  775.             Inc( ErrCount );
  776.             ExitCode := WARNING;
  777.           end;
  778.  
  779.         if (Lhd.Flags AND LHD_PASSWORD <> 0) then
  780.         begin
  781.           Writeln;
  782.           Write(' ',ArcFileName,': cannot process encrypted file');
  783.           if (SolidType) then
  784.             ErrExit(EEMPTY,FATAL_ERROR);
  785.           ExtrFile := False;
  786.           Inc( ErrCount );
  787.           ExitCode := WARNING;
  788.         end;
  789.  
  790.         if Lhd.FileAttr AND DOSFA_DIREC <> 0 then
  791.           begin
  792.             if (MainCommand = 'E') then
  793.               continue;
  794.  
  795.             if (SkipSolid) then
  796.             begin
  797.               WriteLn;
  798.               Write(' Skipping    ',ArcFileName,' Ok');
  799.               continue;
  800.             end;
  801.             if (MainCommand = 'T') then
  802.             begin
  803.               WriteLn;
  804.               Write(' Testing     ',ArcFileName,' Ok');
  805.               continue;
  806.             end;
  807.  
  808.             CreatePath(DestFileName);
  809.             {$I-}
  810.             MkDir(DestFileName);
  811.             {$I-}
  812.             If (IOResult = 0) then
  813.               WriteLn(' Creating    ',ArcFileName);
  814.             continue;
  815.           end
  816.         else
  817.           begin
  818.             if (MainCommand = 'T') and  ExtrFile then
  819.               TestMode := True;
  820.  
  821.             if (MainCommand in ['E','X']) and ExtrFile then
  822.               begin
  823.                 CreatePath(DestFileName);
  824.                 FileMode := 2;
  825.                 Assign( FileFPtr, DestFileName );
  826.                 {$I-}
  827.                 Rewrite( FileFPtr, 1 );
  828.                 {$I+}
  829.                 If ( IOResult <> 0 ) then
  830.                 begin
  831.                   If (Lhd.FileAttr AND DOSFA_DIREC = 0) then
  832.                     begin
  833.                       Writeln;
  834.                       Write(' Cannot create ',DestFileName);
  835.                       ExitCode := WARNING;
  836.                     end;
  837.                   ExtrFile := False;
  838.                 end
  839.               end
  840.           end;
  841.  
  842.         if not ExtrFile and SolidType then
  843.           begin
  844.             SkipSolid := True;
  845.             TestMode := True;
  846.             ExtrFile := True;
  847.           end;
  848.  
  849.         if ExtrFile then
  850.           begin
  851.             Inc( TotalFileCount );
  852.             if SkipSolid then
  853.               begin
  854.                 Writeln;
  855.                 Write(' Skipping    ',ArcFileName,' Ok');
  856.               end
  857.             else
  858.               begin
  859.                 Inc( FileCount );
  860.                 Writeln;
  861.                 Case MainCommand of
  862.                   'T':      Write(' Testing     ',ArcFileName);
  863.                   'X', 'E': Write(' Extracting  ',DestFileName);
  864.                 end;
  865.             end;
  866.  
  867.           CurExtrFile := DestFileName;
  868.           UnpFileCRC := $FFFFFFFF;
  869.           UnpPackedSize := Lhd.PackSize;
  870.           DestUnpSize := Lhd.UnpSize;
  871.           if (Lhd.Method = $30) then
  872.             UnstoreFile
  873.           else
  874.             if (DoUnpack(TmpMemory,UnpRead,UnpWrite,UnpSolid) = -1) then
  875.               ErrExit(EWRITE,WRITE_ERROR);
  876.           if (TotalFileCount>0) and SolidType then
  877.             UnpSolid := True;
  878.  
  879.           if (UnpFileCRC = not Lhd.FileCRC) then
  880.             begin
  881.               if MainCommand <> 'P' then
  882.                 Write(' Ok  ');
  883.             end
  884.           else
  885.             begin
  886.               seek( ArcFPtr, NextBlockPos );
  887.               Writeln;
  888.               WriteLn(' ',ArcFileName,' : CRC failed' );
  889.               ExitCode := CRC_ERROR;
  890.               Inc( ErrCount );
  891.             end;
  892.  
  893.           if not TestMode then
  894.             begin
  895.               SetFTime(FileFPtr,Lhd.FileTime);
  896.               close(FileFPtr);
  897.             end;
  898.  
  899.           TestMode := False;
  900.           CurExtrFile := '';
  901.         end
  902.       end;
  903.  
  904.       if not ExtrFile and not SolidType then
  905.         seek( ArcFPtr, NextBlockPos );
  906.  
  907.     end;
  908.  
  909.   close(ArcFPtr);
  910.  
  911.   Writeln;
  912.   if FileCount + DirCount = 0 then
  913.     begin
  914.       Write(' No files');
  915.       ExitCode := WARNING;
  916.     end
  917.   else
  918.     if (ErrCount = 0) then
  919.       Write('  All OK')
  920.     else
  921.       Write('  Total errors: ',ErrCount);
  922.  
  923.   ExtractFile := 0;
  924. end;
  925.  
  926. Procedure ListArchive;
  927. Var
  928.   TotalPackSize : Word;
  929.   TotalUnpSize : Word;
  930.   FileCount : Word;
  931.   i : Word;
  932.   Dir, Name, Ext : String;
  933.  
  934. begin
  935.   TotalPackSize := 0;
  936.   TotalUnpSize := 0;
  937.   FileCount := 0;
  938.   Assign( ArcFPtr, ArcName );
  939.   {$I-}
  940.   Reset( ArcFPtr, 1 );
  941.   {$I+}
  942.   If IOResult <> 0 then
  943.     ErrExit(EOPEN,FATAL_ERROR);
  944.  
  945.   CheckArc;
  946.   WriteLn;
  947.  
  948.   if SolidType then
  949.     Write('Solid ');
  950.   if (Mhd.Flags AND MHD_MULT_VOL <> 0) then
  951.     Write(' Volume ')
  952.   else
  953.     Write(' Archive ');
  954.   WriteLn( ArcName );
  955.  
  956.   if (MainCommand = 'V') then
  957.     Write(' Pathname/Comment')
  958.   else
  959.     Write(' Name       ');
  960.   WriteLn('      Size   Packed  Ratio   Date   Time  Attr   CRC-32  Meth Ver');
  961.  
  962.   for I :=0 to 76 do
  963.     Write('-');
  964.  
  965.   while (ReadBlock(FILE_HEAD) > 0) do
  966.     begin
  967.       if (IsProcessFile(NOT_COMPARE_PATH)) then
  968.         begin
  969.           Writeln;
  970.           If Lhd.Flags AND LHD_PASSWORD = 0 then
  971.             Write( ' ' )
  972.           else
  973.             Write( '*' );
  974.  
  975.           if (MainCommand = 'V') then
  976.           begin
  977.             Writeln(ArcFileName);
  978.           end
  979.           else
  980.             begin
  981.               fSplit( ArcFileName, Dir, Name, Ext );
  982.               Write( LeftJustify(name+Ext,12) );
  983.             end;
  984.  
  985.           Write(Lhd.UnpSize:9,Lhd.PackSize:9,' ');
  986.           if (Lhd.Flags AND (LHD_SPLIT_AFTER OR LHD_SPLIT_BEFORE) <> 0) then
  987.             Write(' Split')
  988.           else
  989.             Write(ToPercent(Lhd.PackSize,Lhd.UnpSize):4,'% ');
  990.  
  991.           Write( ' ', ZStr( (LHd.FileTime shr 16) and $1f,2), '-',
  992.                  ZStr( (LHd.FileTime shr 21) and $f, 2) ,'-',
  993.                  ZStr( (LHd.FileTime shr 25+1980) mod 100, 2), ' ');
  994.           Write( ZStr( (LHd.FileTime shr 11) and $1f, 2 ), ':',
  995.                  ZStr( (LHd.FileTime shr 5) and $3f, 2 ),' ');
  996.  
  997.           if (Lhd.HostOS = MS_DOS) then
  998.             begin
  999.               If (Lhd.FileAttr AND DOSFA_DIREC <> 0) then
  1000.                 write('D')
  1001.               else
  1002.                 write('.');
  1003.               If (Lhd.FileAttr AND DOSFA_RDONLY <> 0) then
  1004.                 write('R')
  1005.               else
  1006.                 write('.');
  1007.               If (Lhd.FileAttr AND DOSFA_HIDDEN <> 0) then
  1008.                 write('H')
  1009.               else
  1010.                 write('.');
  1011.               If (Lhd.FileAttr AND DOSFA_SYSTEM <> 0) then
  1012.                 write('S')
  1013.               else
  1014.                 write('.');
  1015.               If (Lhd.FileAttr AND DOSFA_ARCH <> 0) then
  1016.                 write('A')
  1017.               else
  1018.                 write('.');
  1019.             end
  1020.           else
  1021.             Write('     ');
  1022.  
  1023.           Write( ' ',HexL( Lhd.FileCRC ) );
  1024.           Write( '  m', Lhd.Method-$30,'  ',Lhd.UnpVer div 10,'.',Lhd.UnpVer mod 10 );
  1025.           if (Lhd.Flags AND LHD_SPLIT_BEFORE = 0) then
  1026.           begin
  1027.             Inc( TotalUnpSize, Lhd.UnpSize );
  1028.             Inc( FileCount );
  1029.           end;
  1030.           Inc( TotalPackSize, Lhd.PackSize );
  1031.         end;
  1032.       Seek( ArcFPtr, NextBlockPos );
  1033.     end;
  1034.  
  1035.   WriteLn;
  1036.   for I := 0 to 76 do
  1037.     Write('-');
  1038.  
  1039.   Writeln;
  1040.   WriteLn(FileCount:5,' Files',TotalUnpSize:11,TotalPackSize:9,ToPercent(TotalPackSize,TotalUnpSize):5,'%');
  1041.   tclose(ArcFPtr);
  1042. end;
  1043.  
  1044.  
  1045. Procedure ExecuteCommand;
  1046. begin
  1047.   Case MainCommand of
  1048.     'E', 'X', 'T': ExtractFile;
  1049.     'V', 'L'     : ListArchive;
  1050.     #0           :
  1051.       begin
  1052.         Help;
  1053.         Halt(0);
  1054.       end;
  1055.   else
  1056.     begin
  1057.       Help;
  1058.       Halt(USER_ERROR);
  1059.     end
  1060.   end;
  1061. end;
  1062.  
  1063.  
  1064. begin
  1065.   {$IFDEF LINUX}
  1066.   FileSystem := fsDos;
  1067.   {$ENDIF}
  1068.  
  1069.   WriteLn('UNRAR 1.01 freeware portable version      (C) 1994-95 Eugene Roshal');
  1070.   WriteLn('Virtual Pascal v1 version               (C) 1995-2000 vpascal.com');
  1071.  
  1072.   GetMem( TmpMemory, Unp_Memory );
  1073.   If TmpMemory = nil then
  1074.     ErrExit(EMEMORY,MEMORY_ERROR);
  1075.  
  1076.   MakeTbl;
  1077.   SplitCommandLine;
  1078.   ExecuteCommand;
  1079.   ShutDown(SD_MEMORY);
  1080.   Halt(ExitCode);
  1081. end.
  1082.  
  1083.