home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 September / Chip_2002-09_cd1.bin / zkuste / delphi / kompon / d2345 / JBZIP32.ZIP / jbZip.pas < prev   
Pascal/Delphi Source File  |  2002-05-31  |  122KB  |  3,482 lines
  1. {.$D-,L-}
  2. unit jbZip;
  3.  
  4. {Components for ZIPing a UNZIPing compatible with PkZip v1.1                }
  5. {Now is they compatible with WinZip and can you use longnames too           }
  6.  
  7. {Based on source (c) A.Byrne by old source                                  }
  8. {Convert to component (c) Jaro Benes                                        }
  9. {All right reserved                                                         }
  10. {History and changes:                                                       }
  11. {Modification to TP5.5 by Jaro Benes 1993                                   }
  12. {Modification to TPro V.5.21 by Jaro Benes 1995                             }
  13. {Modification to Delphi 1 and changes by Jaro Benes 1996                    }
  14. {Encapsulated as component for Delphi 1 by Jaro Benes 1997                  }
  15. {Partially portation to Win32 (without assembler) Jaro Benes 1998           }
  16. {Indication errors and connect to TGauge by Jaro Benes 1999                 }
  17. {Note J.B. 16.7.1999}
  18. {Components are free using under Delphi 1..5                                }
  19. {Portation to Win32 finished, big thanks to Ivan Pavelka                    }
  20. {1.12.1999                                                                  }
  21.  
  22. {last changes by J.B.                                                       }
  23. {31.8.2001 fix getZipList                                                   }
  24. {31.5.2002 Fix size of CentralDir for fully compatibility with Winzip       }
  25.  
  26. {for use under Delphi 1 can you use assembler code for packing speed        }
  27. {Please, send me any changes and improvement in code copy to my E-mail      }
  28. {mailto:JBenes@micrel.cz                                                    }
  29.  
  30. {in code is used my library jbStr (c) Jaro Benes                            }
  31.  
  32. interface
  33. uses
  34.   SysUtils, WinTypes, WinProcs, Dialogs, Classes;
  35.  
  36. Type
  37.   TZipProgress = procedure (Sender: TObject; AProgress: Smallint) of object;
  38.   TZipError = procedure (Sender: TObject; Const ErrorMsg: String) of object;
  39.   TZip = class(TComponent)
  40.     private
  41.       FName:String;
  42.       FParam:String;
  43.       FOverWrite:Boolean;
  44.       FOnProgress:TZipProgress;
  45.       FOnError:TZipError;
  46.       { Private declarations }
  47.     protected
  48.       { Protected declarations }
  49.       Procedure SetFName(Name:String);
  50.       Procedure SetParameters(Prm:String);
  51.     public
  52.       { Public declarations }
  53.       constructor Create(AOwner: TComponent); override;
  54.       destructor Destroy; override;
  55.       Function Execute:Boolean;
  56.       Procedure Crunch(PrmLine: String);
  57.     published
  58.       { Published declarations }
  59.       Property ArcName:String Read FName Write SetFName;
  60.       Property Files:String Read FParam Write SetParameters;
  61.       Property Overwrite:Boolean Read FOverWrite Write FOverWrite;
  62.       Property OnProgress:TZipProgress Read FOnProgress Write FOnProgress;
  63.       Property OnError:TZipError Read FOnError Write FOnError;
  64.     end {Zip};
  65.  
  66.   TUnZip = class(TComponent)
  67.     private
  68.       FName:String;
  69.       FExtrPath:String;
  70.       FParam:String;
  71.       FOverWrite:Boolean;
  72.       FOnProgress:TZipProgress;
  73.       FOnError:TZipError;
  74.       { Private declarations }
  75.     protected
  76.       { Protected declarations }
  77.       Procedure SetFName(Name:String);
  78.       Procedure SetExtrPath(Path:String);
  79.       Procedure SetParameters(Prm:String);
  80.       Procedure UnCrunch(Const PrmLine: String);
  81.     public
  82.       { Public declarations }
  83.       constructor Create(AOwner: TComponent); override;
  84.       destructor Destroy; override;
  85.       Function Execute:Boolean;
  86.       Procedure GetZipList(Const iFileName:String;Var A:TStringList);
  87.     published
  88.       { Published declarations }
  89.       Property ArcName:String Read FName Write SetFName;
  90.       Property ExtrPath:String Read FExtrPath Write SetExtrPath;
  91.       Property Files:String Read FParam Write SetParameters;
  92.       Property Overwrite:Boolean Read FOverWrite Write FOverWrite;
  93.       Property OnProgress:TZipProgress Read FOnProgress Write FOnProgress;
  94.       Property OnError:TZipError Read FOnError Write FOnError;
  95.     end {Zip};
  96.  
  97. procedure Register;
  98.  
  99. implementation
  100.  
  101. Uses jbStr;
  102.  
  103.  
  104. Const Spacer=#1;
  105.  
  106. Function SameName(Const N1, N2 : String) : Boolean;
  107. {
  108.   Function to compare filespecs.
  109.  
  110.   Wildcards allowed in either name.
  111.   Filenames should be compared seperately from filename extensions by using
  112.      seperate calls to this function
  113.         e.g.  FName1.Ex1
  114.               FName2.Ex2
  115.               are they the same?
  116.               they are if SameName(FName1, FName2) AND SameName(Ex1, Ex2)
  117.  
  118.   Wildcards work the way DOS should've let them work (eg. *XX.DAT doesn't
  119.   match just any file...only those with 'XX' as the last two characters of
  120.   the name portion and 'DAT' as the extension).
  121.  
  122.   This routine calls itself recursively to resolve wildcard matches.
  123.  
  124. }
  125. Var
  126.    P1, P2 : Smallint;
  127.    Match  : Boolean;
  128. Begin
  129.   P1    := 1;
  130.   P2    := 1;
  131.   Match := True;
  132.   If (Length(N1) = 0) And (Length(N2) = 0) Then
  133.     Match := True
  134.   Else
  135.     If Length(N1) = 0 Then
  136.       If N2[1] = '*' Then
  137.         Match := True
  138.       Else
  139.         Match := False
  140.     Else
  141.       If Length(N2) = 0 Then
  142.         If N1[1] = '*' Then
  143.           Match := True
  144.         Else
  145.           Match := False;
  146.  
  147.   While (Match = True) And (P1 <= Length(N1)) And (P2 <= Length(N2)) Do
  148.     If (N1[P1] = '?') Or (N2[P2] = '?') Then Begin
  149.       Inc(P1);
  150.       Inc(P2);
  151.     End {then}
  152.   Else
  153.     If N1[P1] = '*' Then Begin
  154.       Inc(P1);
  155.       If P1 <= Length(N1) Then Begin
  156.         While (P2 <= Length(N2)) And Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) Do
  157.           Inc(P2);
  158.         If P2 > Length(N2) Then
  159.           Match := False
  160.         Else Begin
  161.           P1 := Succ(Length(N1));
  162.           P2 := Succ(Length(N2));
  163.         End {if};
  164.       End {then}
  165.       Else
  166.         P2 := Succ(Length(N2));
  167.     End {then}
  168.   Else
  169.     If N2[P2] = '*' Then Begin
  170.       Inc(P2);
  171.       If P2 <= Length(N2) Then Begin
  172.         While (P1 <= Length(N1)) And Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) Do
  173.           Inc(P1);
  174.         If P1 > Length(N1) Then
  175.           Match := False
  176.         Else Begin
  177.           P1 := Succ(Length(N1));
  178.           P2 := Succ(Length(N2));
  179.         End {if};
  180.       End {then}
  181.       Else
  182.         P1 := Succ(Length(N1));
  183.     End {then}
  184.   Else
  185.     If UpCase(N1[P1]) = UpCase(N2[P2]) Then Begin
  186.       Inc(P1);
  187.       Inc(P2);
  188.     End {then}
  189.   Else
  190.     Match := False;
  191.   
  192.   If P1 > Length(N1) Then Begin
  193.     While (P2 <= Length(N2)) And (N2[P2] = '*') Do
  194.       Inc(P2);
  195.     If P2 <= Length(N2) Then
  196.       Match := False;
  197.   End {if};
  198.   
  199.   If P2 > Length(N2) Then Begin
  200.     While (P1 <= Length(N1)) And (N1[P1] = '*') Do
  201.       Inc(P1);
  202.     If P1 <= Length(N1) Then
  203.       Match := False;
  204.   End {if};
  205.   
  206.   SameName := Match;
  207.  
  208. End {SameName};
  209.  
  210. { ---------------------------------------------------------------------------- }
  211.  
  212. Function SameFile(Const File1, File2 : String) : Boolean;
  213. Var
  214.   Path1, Path2 : String;
  215. Begin
  216.   {File1 := ExpandFileName(File1);
  217.   File2 := ExpandFileName(File2);}
  218.   Path1 := JustPathName(File1);
  219.   Path2 := JustPathName(File2);
  220.   SameFile := SameName(JustName(File1), JustName(File2)) And
  221.     SameName(JustExtension(File1), JustExtension(File2)) And (Path1 = Path2);
  222. End {SameFile};
  223.  
  224. Const
  225.   Crc_32_Tab : Array[0..255] Of {$IfNDef VER130}LongInt{$Else}DWord{$EndIf} = (
  226. $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3,
  227. $0edb8832, $79dcb8a4, $e0D5e91e, $97D2D988, $09b64c2b, $7eb17cbd, $e7b82D07, $90bf1D91,
  228. $1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47D, $6ddde4eb, $f4D4b551, $83D385c7,
  229. $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3D63, $8D080df5,
  230. $3b6e20c8, $4c69105e, $D56041e4, $a2677172, $3c03e4D1, $4b04D447, $D20D85fd, $a50ab56b,
  231. $35b5a8fa, $42b2986c, $dbbbc9D6, $acbcf940, $32D86ce3, $45df5c75, $dcd60dcf, $abd13D59,
  232. $26D930ac, $51de003a, $c8D75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,
  233. $2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662D3D,
  234. $76dc4190, $01db7106, $98D220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8D433,
  235. $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086D3D2D, $91646c97, $e6635c01,
  236. $6b6b51f4, $1c6c6162, $856530D8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457,
  237. $65b0D9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2D49, $8cd37cf3, $fbd44c65,
  238. $4db26158, $3ab551ce, $a3bc0074, $D4bb30e2, $4adfa541, $3dd895D7, $a4D1c46D, $D3D6f4fb,
  239. $4369e96a, $346ed9fc, $ad678846, $da60b8D0, $44042D73, $33031de5, $aa0a4c5f, $dd0D7cc9,
  240. $5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966D409, $ce61e49f,
  241. $5edef90e, $29D9c998, $b0D09822, $c7D7a8b4, $59b33D17, $2eb40D81, $b7bd5c3b, $c0ba6cad,
  242. $edb88320, $9abfb3b6, $03b6e20c, $74b1D29a, $ead54739, $9dd277af, $04db2615, $73dc1683,
  243. $e3630b12, $94643b84, $0D6D6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9D, $0a00ae27, $7D079eb1,
  244. $f00f9344, $8708a3D2, $1e01f268, $6906c2fe, $f762575D, $806567cb, $196c3671, $6e6b06e7,
  245. $fed41b76, $89D32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,
  246. $D6D6a3e8, $a1D1937e, $38D8c2c4, $4fdff252, $D1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
  247. $D80D2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79,
  248. $cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f,
  249. $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2D7ffa7, $b5D0cf31, $2cd99e8b, $5bdeae1D,
  250. $9b64c2b0, $ec63f226, $756aa39c, $026D930a, $9c0906a9, $eb0e363f, $72076785, $05005713,
  251. $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92D28e9b, $e5D5be0D, $7cdcefb7, $0bdbdf21,
  252. $86D3D2D4, $f1D4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
  253. $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45,
  254. $a00ae278, $D70dd2ee, $4e048354, $3903b3c2, $a7672661, $D06016f7, $4969474D, $3e6e77db,
  255. $aed16a4a, $D9D65adc, $40df0b66, $37D83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
  256. $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23D967bf,
  257. $b3667a2e, $c4614ab8, $5D681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2D02ef8D
  258. );
  259.  
  260. Procedure TZip.Crunch(PrmLine: String);
  261. Const
  262.    MaxFilesSpesc =   21;   { Maximum souboru pouzito }
  263.    BufSize     =  10240;   { Use 10K file buffers }
  264.    MINBITS     =      9;   { Starting code size of 9 bits }
  265.    MAXBITS     =     13;   { Maximum code size of 13 bits }
  266.    TABLESIZE   =   8191;   { We'll need 4K entries in table }
  267.    SPECIAL     =    256;   { Special function code }
  268.    INCSIZE     =      1;   { Code indicating a jump in code size }
  269.    CLEARCODE   =      2;   { Code indicating code table has been cleared }
  270.    FIRSTENTRY  =    257;   { First available table entry }
  271.    UNUSED      =     -1;   { Prefix indicating an unused code table entry }
  272.    STDATTR     =    $23;   { Standard file attribute for DOS Find First/Next }
  273. Const
  274.    LOCAL_FILE_HEADER_SIGNATURE = $04034B50;
  275. Type
  276.    Local_File_Header_Type = packed Record     {by IvanP}
  277.      Signature              :  LongInt;
  278.      Extract_Version_Reqd   :  Word;
  279.      Bit_Flag               :  Word;
  280.      Compress_Method        :  Word;
  281.      Last_Mod_Time          :  Word;
  282.      Last_Mod_Date          :  Word;
  283.      Crc32                  :  LongInt;
  284.      Compressed_Size        :  LongInt;
  285.      Uncompressed_Size      :  LongInt;
  286.      Filename_Length        :  Word;
  287.      Extra_Field_Length     :  Word;
  288.    End;
  289.  
  290. { Define the Central Directory record types }
  291.  
  292. Const
  293.   CENTRAL_FILE_HEADER_SIGNATURE = $02014B50;
  294. Type
  295.   Central_File_Header_Type = packed Record  {by IvanP}
  296.     Signature            :  LongInt;
  297.     MadeBy_Version       :  Word;
  298.     Extract_Version_Reqd :  Word;
  299.     Bit_Flag             :  Word;
  300.     Compress_Method      :  Word;
  301.     Last_Mod_Time        :  Word;
  302.     Last_Mod_Date        :  Word;
  303.     Crc32                :  LongInt;
  304.     Compressed_Size      :  LongInt;
  305.     Uncompressed_Size    :  LongInt;
  306.     Filename_Length      :  Word;
  307.     Extra_Field_Length   :  Word;
  308.     File_Comment_Length  :  Word;
  309.     Starting_Disk_Num    :  Word;
  310.     Internal_Attributes  :  Word;
  311.     External_Attributes  :  LongInt;
  312.     Local_Header_Offset  :  LongInt;
  313.   End;
  314.  
  315. Const
  316.   END_OF_CENTRAL_DIR_SIGNATURE = $06054B50;
  317.  
  318. Type
  319.   End_of_Central_Dir_Type =  packed Record
  320.     Signature               :  LongInt;
  321.     Disk_Number             :  Word;
  322.     Central_Dir_Start_Disk  :  Word;
  323.     Entries_This_Disk       :  Word;
  324.     Total_Entries           :  Word;
  325.     Central_Dir_Size        :  LongInt;
  326.     Start_Disk_Offset       :  LongInt;
  327.     ZipFile_Comment_Length  :  Word;
  328.   End;
  329.  
  330. Type
  331.   { Define data types needed to implement a code table for LZW compression   }
  332.   CodeRec     =  Record{ Code Table record format...         }
  333.     Child   : Smallint; { Addr of 1st suffix for this prefix  }
  334.     Sibling : Smallint; { Addr of next suffix in chain        }
  335.     Suffix  : Byte;    { Suffix character                    }
  336.   End {CodeRec};
  337.   CodeArray   =  Array[0..TABLESIZE] Of CodeRec; { Define the code table     }
  338.   TablePtr    =  ^CodeArray;                     { Allocate dynamically      }
  339.  
  340.   { Define data types needed to implement a free node list                   }
  341.   FreeListPtr    =  ^FreeListArray;
  342.   FreeListArray  =  Array[FIRSTENTRY..TABLESIZE] Of Word;
  343.  
  344.   { Define data types needed to implement input and output file buffers      }
  345.   BufArray    =  Array[1..BufSize] Of Byte;
  346.   BufPtr      =  ^BufArray;
  347.  
  348.   { Define the structure of a DOS Disk Transfer Area (DTA)                   }
  349.   DTARec      =  Packed Record {J.B.}
  350.     Filler   :  Array[1..21] Of Byte;
  351.     Attr     :  Byte;
  352.     Time     :  Word;
  353.     Date     :  Word;
  354.     Size     :  LongInt;
  355.     Name     :  String[{$IfNDef VER80}128{$Else}12{$EndIf}];
  356.   End {DtaRec};
  357.  
  358. //type
  359. //TFileName = string;
  360. //TSearchRec = record
  361. //        Time: Integer;
  362. //        Size: Integer;
  363. //        Attr: Integer;
  364. //        Name: TFileName;
  365. //        ExcludeAttr: Integer;
  366. //        FindHandle: THandle;
  367. //        FindData: TWin32FindData;
  368. //end;
  369.  
  370.  
  371.   { Define data types needed to implement a sorted singly linked list to     }
  372.   { hold the names of all files to be compressed                             }
  373.   NameStr      = String[80]; {12}  {IvanP}
  374.   PathStr      = String[80]; {64}  {IvanP}
  375.   NodePtr      = ^NameList;
  376.   NameList     = Record { Linked list node structure...     }
  377.     Path : PathStr;      { Path of input file                }
  378.     Name : NameStr;      { Name of input file                }
  379.     Size : LongInt;      { Size in bytes of input file       }
  380.     Date : Word;         { Date stamp of input file          }
  381.     Time : Word;         { Time stamp of input file          }
  382.     Next : NodePtr;      { Next node in linked list          }
  383.   End {NameList};
  384. Type TNameFileSpec = Array[1..20] Of String;
  385.  
  386.  
  387. Var
  388.    OutFileName :  String;        { Name of resulting Zip file                 }
  389.    InFile,                       { I/O file variables                         }
  390.    OutFile     :  File;
  391.    InBuf,                        { I/O buffers                                }
  392.    OutBuf      :  BufPtr;
  393.    InBufIdx,                     { Points to next char in buffer to be read   }
  394.    OutBufIdx   :  Word;          { Points to next free space in output buffer }
  395.    MaxInBufIdx :  integer;          { Count of valid chars in input buffer       }
  396.  
  397.    InputEof    :  Boolean;       { End of file indicator                      }
  398.  
  399.    Crc32Val    :  LongInt;       { CRC calculation variable                   }
  400.    CodeTable   :  TablePtr;      { Points to code table for LZW compression   }
  401.  
  402.    FreeList    :  FreeListPtr;   { Table of free code table entries           }
  403.    NextFree    :  Word;          { Index into free list table                 }
  404.  
  405.    ClearList   :  Array[0..1023] Of Byte;  { Bit mapped structure used in     }
  406.                                            {    during adaptive resets        }
  407.    CodeSize    :  Byte;     { Size of codes (in bits) currently being written }
  408.    MaxCode     :  Word;   { Largest code that can be written in CodeSize bits }
  409.  
  410.    LocalHdr    :  Local_File_Header_Type;
  411.    LocalHdrOfs :  LongInt;  { Offset within output file of the local header   }
  412.    CentralHdr  :  Central_File_Header_Type;
  413.    EndHdr      :  End_of_Central_Dir_Type;
  414.  
  415.    FirstCh     :  Boolean;  { Flag indicating the START of a shrink operation }
  416.    TableFull   :  Boolean;  { Flag indicating a full symbol table             }
  417.  
  418.    SaveByte    :  Byte;     { Output code buffer                              }
  419.    BitsUsed    :  Byte;     { Index into output code buffer                   }
  420.  
  421.    BytesIn     :  LongInt;  { Count of input file bytes processed             }
  422.    BytesOut    :  LongInt;  { Count of output bytes                           }
  423.  
  424.    ListHead    :  NodePtr;  { Pointer to head of linked list                  }
  425.  
  426.    TenPercent  :  LongInt;
  427.  
  428. Procedure Fatal(Msg : String);
  429. Begin
  430.   If AsSigned(FOnError) Then FOnError(Self,Msg)
  431.   Else
  432.     MessageDlg(Msg, mtWarning, [mbOk], 0);
  433. End;
  434. { --------------------------------------------------------------------------- }
  435.  
  436. Procedure AddToList(PathSpec : PathStr; DTA : DTARec);
  437. { Add an entry to a linked list of filenames to be crunched.  Maintain        }
  438. { sorted order (standard ASCII collating sequence) by filename                }
  439. Var
  440.   //MemError : Word;
  441.   NewNode  : NodePtr;
  442.   Done     : Boolean;
  443.   ListNode : NodePtr;
  444. Begin
  445.   { Allocate a new node }
  446.   try
  447.     GetMem(NewNode, SizeOf(NewNode^))
  448.   except
  449.   on EOutOfMemory do
  450.   Begin
  451.     Fatal('Not enough memory to process all filenames!');
  452.     Exit
  453.   End;
  454.   end;
  455. //  Odstranil IvanP
  456. //  If MemAvail>SizeOf(NewNode^) Then GetMem(NewNode, SizeOf(NewNode^))
  457. //  Else Begin
  458. //    Fatal('Nenφ dodstatek pam∞ti ke zpracovßnφ vÜech soubor∙!');
  459. //    Exit
  460. //  End;
  461.   {MemError := Malloc(NewNode, SizeOf(NewNode^));
  462.   If MemError <> 0 then Fatal('Not enough memory to process all filenames!');}
  463.  
  464.   { Populate the fields of the new node                                      }
  465.   NewNode^.Path := PathSpec;
  466.   NewNode^.Name := DTA.Name;
  467.   NewNode^.Size := DTA.Size;
  468.   NewNode^.Date := DTA.Date;
  469.   NewNode^.Time := DTA.Time;
  470.   NewNode^.Next := Nil;
  471.  
  472.   { Find the proper location in the list at which to insert the new node     }
  473.   If ListHead = Nil
  474.    Then ListHead := NewNode
  475.    Else
  476.     If DTA.Name < ListHead^.Name
  477.      Then
  478.       Begin // zalozi se novy  zaznam
  479.         NewNode^.Next := ListHead;
  480.         ListHead      := NewNode;
  481.       End {then}
  482.      Else
  483.       Begin
  484.        Done     := False;
  485.        ListNode := ListHead;
  486.        While Not Done Do
  487.          Begin
  488.            If ListNode^.Name = DTA.Name
  489.             Then
  490.               Begin
  491.                 ListNode^.Path := PathSpec;
  492.                 FreeMem(NewNode, SizeOf(NewNode^));
  493.                 {MemError := Dalloc(NewNode);}
  494.                 Done := True;
  495.               End {then}
  496.             Else
  497.              If ListNode^.Next = Nil
  498.               Then
  499.                 Begin
  500.                  ListNode^.Next := NewNode;
  501.                  Done := True;
  502.                 End {then}
  503.               Else
  504.                If ListNode^.Next^.Name > DTA.Name Then Begin
  505.                   NewNode^.Next  := ListNode^.Next;
  506.                   ListNode^.Next := NewNode;
  507.                   Done := True;
  508.                   End {then}
  509.                Else
  510.                   ListNode := ListNode^.Next;
  511.          End {while};
  512.       End {if};
  513. End {AddToList};
  514.  
  515. { --------------------------------------------------------------------------- }
  516. // procedura pridana IvanP
  517. procedure SRecToDTARec(SearchRec:TSearchRec;var DosDTA:DTARec);
  518. Var vx:Array [1..2] of Word;
  519. Begin
  520.   Move(SearchRec.Time,vx,SizeOf(SearchRec.Time));
  521.   DosDTA.Attr:= SearchRec.Attr AND $FF;
  522.   DosDTA.Time:= vx[1]{SearchRec.Time};//datum a cas je slozeny, jmeno klame
  523.   DosDTA.Date:= vx[2]{0};             //musi se rozlozit J.B.
  524.   DosDTA.Size:= (SearchRec.FindData.nFileSizeHigh shl 8) +
  525.                 (SearchRec.FindData.nFileSizeLow);
  526.   DosDTA.Name:= SearchRec.Name;
  527.  
  528. //  Showmessage(format('Attr: %d'#13 +
  529. //                     'time: %d'#13 +
  530. //                     'date: %d'#13 +
  531. //                     'size: %d'#13 +
  532. //                     'name: %s',[DosDTA.Attr,DosDTA.Time,DosDTA.Date,
  533. //                     DosDTA.Size,DosDTA.Name]));
  534. End;
  535.  
  536.  
  537.  
  538.  
  539. Procedure GetNames(MaxSpecs:Word;Var InFileSpecs:TNameFileSpec);
  540. { Expand input file specifications.  Store the name of each file to be        }
  541. { compressed in a sorted, singly linked list                                  }
  542. Var
  543.    DosDTA   : DTARec;
  544.    ActRec   : TSearchRec;
  545.    I        : Word;
  546.    InPath   : String;
  547. Begin
  548.   ListHead := Nil;
  549.   For I := 1 To MaxSpecs Do Begin   { Loop through all input file specs      }
  550.     InPath := AddLastChar('\',StrUpCase(JustPathName(InFileSpecs[I])));
  551.     If SysUtils.FindFirst(InFileSpecs[I], STDATTR, ActRec) = 0 Then
  552.       Repeat
  553.         If (Not SameFile(ExpandFileName(InPath + ActRec.Name), ExpandFileName(OutFileName)))
  554.          then
  555. // nahradil IvanP
  556.            Begin
  557.              SRecToDTARec(ActRec,DosDTA);
  558. //             ShowMessage(InPath);
  559.              AddToList(InPath, DosDTA);
  560.            end;
  561. //          AddToList(InPath, DTARec(ActRec));
  562.       Until SysUtils.FindNext(ActRec)<>0;
  563.     Sysutils.FindClose(ActRec);
  564.   End {for};
  565. End {GetNames};
  566.  
  567. { --------------------------------------------------------------------------- }
  568.  
  569. Function ParamCheck(Const ParamLine:String; OverWrite:Boolean) : Boolean;
  570. {Verify all command line parameters}
  571. Var
  572.    SearchBuf   : TSearchRec;
  573.    //OutPath     : String;  {asi cesta pro extrekci }
  574.    //CH          : Char;
  575.    I           : Word;
  576.    InFileSpecs : TNameFileSpec; {Input file specifications}
  577.    MaxSpecs    : Word;          {Total number of filespecs to be Zipped}
  578. Begin
  579.   ParamCheck := False;
  580.   I:=WordCount(ParamLine,[Spacer]);
  581.   If I < 1 Then Exit;
  582.   {Syntax;}
  583.   If I > MaxFilesSpesc Then Begin
  584.     Fatal('P°φliÜ mnoho vstupnφch parametr∙ !');
  585.     Exit;
  586.   End {if};
  587.  
  588.   OutFileName := ExtractWord(1,ParamLine,[Spacer]);
  589.   If JustExtension(OutFileName)='' Then
  590.     OutFileName:=ForceExtension(OutFileName,'ZIP');
  591.  
  592.   If Sysutils.FindFirst(OutFileName, STDATTR, SearchBuf)=0 Then Begin
  593.     If Not OverWrite Then Exit;
  594.   End {if};
  595.   Sysutils.FindClose(SearchBuf);
  596.   If WordCount(ParamLine,[Spacer]) = 1 Then Begin
  597.     InFileSpecs[1] := '*.*';
  598.     MaxSpecs := 1;
  599.   End {then}
  600.   Else
  601.     For I := 2 To WordCount(ParamLine,[Spacer]) Do Begin
  602. //      Showmessage('Infile: '+ ExtractWord(I,ParamLine,[Spacer]));
  603.       InFilespecs[Pred(I)] := Trim(ExtractWord(I,ParamLine,[Spacer]));
  604.       MaxSpecs := Pred(I);
  605.     End {for};
  606.  
  607.   GetNames(MaxSpecs,InFileSpecs);
  608.   ParamCheck:=True;
  609. End {ParamCheck};
  610.  
  611. { --------------------------------------------------------------------------- }
  612. { Running 32 Bit CRC update function                                          }
  613. { --------------------------------------------------------------------------- }
  614.  
  615. Function UpdC32(Octet: Byte; Crc: LongInt) : LongInt;
  616. Var
  617.    L : LongInt;
  618.    W : Array[1..4] Of Byte Absolute L;
  619. Begin
  620.  
  621.   UpdC32 := Crc_32_Tab[Byte(Crc XOr LongInt(Octet))] XOr ((Crc ShR 8) And $00FFFFFF);
  622.  
  623. End {UpdC32};
  624.  
  625. { --------------------------------------------------------------------------- }
  626. { I/O Support routines                                                        }
  627. { --------------------------------------------------------------------------- }
  628.  
  629. Function GetBuffers:Boolean;
  630. { Allocate Input and Output buffers                                           }
  631. //Var
  632. //   MemError : Word;
  633. Begin
  634.   Result:=False;
  635.  
  636.   {MemError := Malloc(InBuf, Sizeof(InBuf^));}
  637. // predelal IvanP
  638.    try
  639.     GetMem(InBuf, SizeOf(InBuf^))
  640.   except
  641.   on EOutOfMemory do
  642.    Exit;
  643.   end;
  644.  
  645.  // If MemAvail>SizeOf(InBuf^)
  646.  //  Then GetMem(InBuf, SizeOf(InBuf^))
  647.  //  Else Exit;
  648.  
  649.   {MemError := Malloc(OutBuf, SizeOf(OutBuf^));}
  650.   try
  651.     GetMem(OutBuf, SizeOf(OutBuf^))
  652.   except
  653.   on EOutOfMemory do
  654.   Begin
  655.     FreeMem(InBuf, SizeOf(InBuf^));
  656.     Exit
  657.   End;
  658.   end;
  659. //  If MemAvail>SizeOf(OutBuf^) Then GetMem(OutBuf, SizeOf(OutBuf^))
  660. //  Else Begin
  661. //    FreeMem(InBuf, SizeOf(InBuf^));
  662. //    Exit
  663. //  End;
  664.  
  665.   Result := True;
  666. End {GetBuffers};
  667.  
  668. { --------------------------------------------------------------------------- }
  669.  
  670. Procedure DropBuffers;
  671. { Deallocate input and output buffers                                         }
  672. //Var
  673. //   MemError : Word;
  674. Begin
  675.    {MemError := Dalloc(InBuf);}
  676.    FreeMem(InBuf, SizeOf(InBuf^));
  677.    {MemError := Dalloc(OutBuf);}
  678.    FreeMem(OutBuf, SizeOf(OutBuf^))
  679. end {DropBuffers};
  680.  
  681.  
  682. Procedure OpenOutput;
  683. Var
  684.    RC : Smallint;
  685. Begin
  686.   AssignFile(OutFile, OutFileName);
  687.   FileMode := 66; {fmShareDenyNone or fmOpenReadWrite}
  688.   {$I-} Rewrite(OutFile, 1); {$I+}
  689.   RC := IOResult;
  690.   If RC <> 0 Then
  691.     Fatal('Chyba p°i otevφtßnφ souboru');
  692. End {OpenOutput};
  693.  
  694. { --------------------------------------------------------------------------- }
  695.  
  696. Function OpenInput(InFileName : String) : Boolean;
  697. //Var
  698. //   RC : Smallint;
  699. Begin
  700.   AssignFile(InFile, InFileName);
  701.   FileMode := 64;{fmShareDenyNone or fmOpenRead}
  702.   {$I-} Reset(InFile, 1); {$I+}
  703.   OpenInput := (IOResult = 0);
  704. End {OpenInput};
  705.  
  706. { --------------------------------------------------------------------------- }
  707.  
  708. Procedure CloseOutput;
  709. Var
  710.    RC : Smallint;
  711. Begin
  712.   {$I-} CloseFile(OutFile) {$I+};
  713.   RC := IOResult;
  714. End {CloseOutput};
  715.  
  716. { --------------------------------------------------------------------------- }
  717.  
  718. Procedure CloseInput;
  719. Var
  720.    RC : Smallint;
  721. Begin
  722.   {$I-} CloseFile(InFile)  {$I+};
  723.   RC := IOResult;
  724. End {CloseInput};
  725.  
  726. { --------------------------------------------------------------------------- }
  727.  
  728. Procedure Read_Block;
  729. { Read a "block" of data into our our input buffer                            }
  730. Begin
  731.   BlockRead(InFile, InBuf^[1], SizeOf(InBuf^), MaxInBufIdx);
  732.  
  733.   If MaxInBufIdx = 0 Then
  734.     InputEof := True
  735.   Else
  736.     InputEOF := False;
  737.   InBufIdx := 1;
  738. End {Read_Block};
  739.  
  740. { --------------------------------------------------------------------------- }
  741.  
  742. Procedure Write_Block;
  743. { Write a block of data from the output buffer to our output file             }
  744. Begin
  745.   BlockWrite(OutFile, OutBuf^[1], Pred(OutBufIdx));
  746.   OutBufIdx := 1;
  747. End {Write_Block};
  748.  
  749. { --------------------------------------------------------------------------- }
  750.  
  751. Procedure PutChar(B : Byte);
  752. { Put one character into our output buffer                                    }
  753. Begin
  754.   OutBuf^[OutBufIdx] := B;
  755.   Inc(OutBufIdx);
  756.   If OutBufIdx > SizeOf(OutBuf^) Then
  757.     Write_Block;
  758.   Inc(BytesOut);
  759. End {PutChar};
  760.  
  761. { --------------------------------------------------------------------------- }
  762.  
  763. Procedure FlushOutput;
  764. { Write any data sitting in our output buffer to the output file              }
  765. Begin
  766.   If OutBufIdx > 1 Then
  767.     Write_Block;
  768. End {FlushOutput};
  769.  
  770. {--------------------------------------------------------------------------- }
  771.  
  772. Procedure PutCodePas(Code:Smallint);
  773. {kod pro nahradu assembleru}
  774. Var Mask:Word;
  775.     Agent:Byte;
  776. Var iSaveByte,
  777.     iBitsUsed:Byte;
  778.     iCodeSize:Byte;
  779.     //B:Byte;
  780. Begin
  781.   iSaveByte:=SaveByte;
  782.   iBitsUsed:=BitsUsed;
  783.   iCodeSize:=CodeSize;
  784.   If Code=-1 Then Begin
  785.     If iBitsUsed<>0 Then PutChar(SaveByte)
  786.   End
  787.   Else Begin
  788.     Mask:=$0001;{%00000000000000001}
  789.     Repeat
  790.       Agent:=0;
  791.       If (Code And Mask)<>0 Then Inc(Agent);
  792.       Mask := Mask Shl 1;{%0000000000000010}
  793.       Agent := Agent Shl iBitsUsed;
  794.       Inc(iBitsUsed);
  795.       iSaveByte:= iSaveByte Or Agent;
  796.       If iBitsUsed=8 Then Begin
  797.         PutChar(iSaveByte);
  798.         iSaveByte:=0;
  799.         Agent:=0;
  800.         iBitsUsed:=0;
  801.       End;
  802.       Dec(iCodeSize);
  803.     Until iCodeSize=0;
  804.     SaveByte := iSaveByte;
  805.     BitsUsed := iBitsUsed;
  806.   End;
  807. End;
  808.  
  809. Procedure PutCode(Code : Smallint);
  810. { Assemble coded bytes for output }
  811.   {$IFDEF WIN32}
  812. Begin
  813.   PutCodePas(Code);
  814.   {$ELSE}
  815. Var
  816.    PutCharAddr : Pointer;
  817. Begin
  818.   PutCharAddr := @PutChar;
  819.   Inline(
  820.   {;  Register useage:}
  821.   {;}
  822.   {;  AX - holds Code}
  823.   {;  BX - BH is a work register, BL holds SaveByte}
  824.   {;  CX - holds our loop counter CodeSize}
  825.   {;  DX - holds BitsUsed}
  826.   {;}
  827.   $8B/$46/<Code/         {                mov         ax,[bp+<Code]}
  828.   $31/$DB/               {                xor         bx,bx}
  829.   $89/$D9/               {                mov         cx,bx}
  830.   $89/$DA/               {                mov         dx,bx}
  831.   $8A/$1E/>SaveByte/     {                mov         bl,[>SaveByte]}
  832.   $8A/$0E/>CodeSize/     {                mov         cl,[>CodeSize]}
  833.   $8A/$16/>BitsUsed/     {                mov         dl,[>BitsUsed]}
  834.   $3D/$FF/$FF/           {                cmp         ax,-1               ;Any work to do?}
  835.   $75/$0D/               {                jnz         Repeat              ;Yup, go do it}
  836.   $80/$FA/$00/           {                cmp         dl,0                ;Any leftovers?}
  837.   $74/$3A/               {                jz          AllDone             ;Nope, we're done}
  838.   $53/                   {                push        bx                  ;Yup...push leftovers}
  839.   $0E/                   {                push        cs}
  840.   $FF/$96/>PutCharAddr/  {                call        [bp+>PutCharAddr]   ;   and send to output}
  841.   $EB/$32/               {                jmp short   AllDone}
  842.   {;}
  843.   $30/$FF/               {Repeat:         xor         bh,bh               ;Zero out BH}
  844.   $D1/$D8/               {                rcr         ax,1                ;Get low order bit into CY flag}
  845.   $73/$02/               {                jnc         SkipBit             ;Was the bit set?}
  846.   $FE/$C7/               {                inc         bh                  ;Yes, xfer to BH}
  847.   $87/$D1/               {SkipBit:        xchg        cx,dx               ;Swap CX & DX}
  848.   $D2/$E7/               {                shl         bh,cl               ;Shift bit over}
  849.   $87/$D1/               {                xchg        cx,dx               ;Put CX & DX back where they were}
  850.   $42/                   {                inc         dx                  ;Bump count of bit positions used}
  851.   $08/$FB/               {                or          bl,bh               ;Transfer bit to output byte (SaveByte)}
  852.   $83/$FA/$08/           {                cmp         dx,8                ;Full byte yet?}
  853.   $72/$12/               {                jb          GetNext             ;Nope, go get more code bits}
  854.   $50/                   {                push        ax                  ;Yup, save regs in preparation}
  855.   $53/                   {                push        bx                  ;    for call to output routine}
  856.   $51/                   {                push        cx}
  857.   $52/                   {                push        dx}
  858.   $53/                   {                push        bx                  ;Push byte to output onto stack}
  859.   $0E/                   {                push        cs}
  860.   $FF/$96/>PutCharAddr/  {                call        [bp+>PutCharAddr]   ;   and call the output routine}
  861.   $5A/                   {                pop         dx}
  862.   $59/                   {                pop         cx}
  863.   $5B/                   {                pop         bx}
  864.   $58/                   {                pop         ax}
  865.   $31/$DB/               {                xor         bx,bx               ;Prepare SaveByte for next byte}
  866.   $89/$DA/               {                mov         dx,bx               ;Set BitsUsed to zero}
  867.   $E2/$D6/               {GetNext:        loop        Repeat              ;Repeat for all code bits}
  868.   {;}
  869.   $88/$1E/>SaveByte/     {                mov         [>SaveByte],bl      ;Put SaveByte and BitsUsed}
  870.   $88/$16/>BitsUsed);    {                mov         [>BitsUsed],dl      ;   back in memory}
  871.   {;}
  872.   {AllDone:}
  873.   {$ENDIF}
  874. End {Putcode};
  875.  
  876. { --------------------------------------------------------------------------- }
  877. { The following routines are used to allocate, initialize, and de-allocate    }
  878. { various dynamic memory structures used by the LZW compression algorithm     }
  879. { --------------------------------------------------------------------------- }
  880.  
  881. Function Build_Data_Structures:Boolean;
  882. //Var
  883. //   Code  :  Word;
  884. Begin
  885.   Result := False;
  886. //  predelal IvanP
  887.   try
  888.     GetMem(CodeTable, SizeOf(CodeTable^))
  889.   except
  890.   on EOutOfMemory do
  891.     begin
  892.       MessageDlg('Not enough memory to allocate LZW data structures!',
  893.                  mtError,[mbAbort], 0);
  894.       Exit;
  895.     end;
  896.   end;
  897.  
  898.   try
  899.     GetMem(FreeList,  SizeOf(FreeList^ ))
  900.   except
  901.   on EOutOfMemory do
  902.     begin
  903.       MessageDlg('Not enough memory to allocate LZW data structures!',
  904.                  mtError,[mbAbort], 0);
  905.       FreeMem(CodeTable, SizeOf(CodeTable^));
  906.       Exit;
  907.     end;
  908.   end;
  909.  
  910. //  If MemAvail>SizeOf(CodeTable^) Then GetMem(CodeTable, SizeOf(CodeTable^))
  911. //  Else Exit;
  912. //  If MemAvail>SizeOf(FreeList^ ) Then GetMem(FreeList,  SizeOf(FreeList^ ))
  913. //  Else Begin
  914. //    FreeMem(CodeTable, SizeOf(CodeTable^));
  915. //    Exit
  916. //  End;
  917.  
  918.   {Code  := Malloc(CodeTable, SizeOf(CodeTable^)) OR
  919.   Malloc(FreeList,  SizeOf(FreeList^ ));
  920.   If Code <> 0 then
  921.   Fatal('Not enough memory to allocate LZW data structures!');}
  922.   Result := True;
  923. End {Build_Data_Structures};
  924.  
  925. { --------------------------------------------------------------------------- }
  926.  
  927. Procedure Destroy_Data_Structures;
  928. //Var
  929. //   Code  :  Word;
  930. Begin
  931.    {Code := Dalloc(CodeTable);}
  932.    FreeMem(CodeTable, SizeOf(CodeTable^));
  933.    {Code := Dalloc(FreeList);}
  934.    FreeMem(FreeList,  SizeOf(FreeList^ ));
  935. end {Destroy_Data_Structures};
  936.  
  937.  
  938. Procedure Initialize_Data_Structures;
  939. Var
  940.    I  :  Word;
  941. Begin
  942.   For I := 0 To TableSize Do Begin
  943.     With CodeTable^[I] Do Begin
  944.       Child     := -1;
  945.       Sibling   := -1;
  946.       If I <= 255 Then
  947.         Suffix := I;
  948.     End {with};
  949.     If I >= 257 Then
  950.       FreeList^[I] := I;
  951.   End {for};
  952.  
  953.   NextFree  := FIRSTENTRY;
  954.   TableFull := False;
  955.  
  956. End {Initialize_Data_Structures};
  957.  
  958. { --------------------------------------------------------------------------- }
  959. { The following routines handle manipulation of the LZW Code Table            }
  960. { --------------------------------------------------------------------------- }
  961.  
  962. Procedure Prune(Parent : Word);
  963. { Prune leaves from a subtree - Note: this is a recursive procedure }
  964. Var
  965.    CurrChild   : Smallint;
  966.    NextSibling : Smallint;
  967. Begin
  968.   CurrChild := CodeTable^[Parent].Child;
  969.   { Find first Child that has descendants .. clear any that don't }
  970.   While (CurrChild <> -1) And (CodeTable^[CurrChild].Child = -1) Do Begin
  971.     CodeTable^[Parent].Child := CodeTable^[CurrChild].Sibling;
  972.     CodeTable^[CurrChild].Sibling := -1;
  973.     { Turn on ClearList bit to indicate a cleared entry }
  974.     ClearList[CurrChild Div 8] := (ClearList[CurrChild Div 8] Or (1 ShL (CurrChild Mod 8)));
  975.     CurrChild := CodeTable^[Parent].Child;
  976.   End {while};
  977.  
  978.   If CurrChild <> -1 Then Begin   { If there are any children left ...}
  979.     Prune(CurrChild);
  980.     NextSibling := CodeTable^[CurrChild].Sibling;
  981.     While NextSibling <> -1 Do Begin
  982.       If CodeTable^[NextSibling].Child = -1 Then Begin
  983.         CodeTable^[CurrChild].Sibling := CodeTable^[NextSibling].Sibling;
  984.         CodeTable^[NextSibling].Sibling := -1;
  985.         { Turn on ClearList bit to indicate a cleared entry }
  986.         ClearList[NextSibling Div 8] := (ClearList[NextSibling Div 8] Or (1 ShL (NextSibling Mod 8)));
  987.         NextSibling := CodeTable^[CurrChild].Sibling;
  988.       End {then}
  989.       Else Begin
  990.         CurrChild := NextSibling;
  991.         Prune(CurrChild);
  992.         NextSibling := CodeTable^[CurrChild].Sibling;
  993.       End {if};
  994.     End {while};
  995.   End {if};
  996.  
  997. End {Prune};
  998.  
  999. { --------------------------------------------------------------------------- }
  1000.  
  1001. Procedure Clear_Table;
  1002. Var
  1003.    Node : Word;
  1004. Begin
  1005.   FillChar(ClearList, SizeOf(ClearList), $00);
  1006.   { Remove all leaf nodes by recursively pruning subtrees}
  1007.   For Node := 0 To 255 Do
  1008.     Prune(Node);
  1009.   { Next, re-initialize our list of free table entries }
  1010.   NextFree := Succ(TABLESIZE);
  1011.   For Node := TABLESIZE Downto FIRSTENTRY Do Begin
  1012.     If (ClearList[Node Div 8] And (1 ShL (Node Mod 8))) <> 0 Then Begin
  1013.       Dec(NextFree);
  1014.       FreeList^[NextFree] := Node;
  1015.     End {if};
  1016.   End {for};
  1017.   If NextFree <= TABLESIZE Then
  1018.     TableFull := False;
  1019. End {Clear_Table};
  1020.  
  1021. { --------------------------------------------------------------------------- }
  1022.  
  1023. Procedure Table_Add(Prefix : Word; Suffix : Byte);
  1024. Var
  1025.    FreeNode : Word;
  1026. Begin
  1027.   If NextFree <= TABLESIZE Then Begin
  1028.     FreeNode := FreeList^[NextFree];
  1029.     Inc(NextFree);
  1030.     CodeTable^[FreeNode].Child := -1;
  1031.     CodeTable^[FreeNode].Sibling := -1;
  1032.     CodeTable^[FreeNode].Suffix := Suffix;
  1033.     If CodeTable^[Prefix].Child  = -1 Then
  1034.       CodeTable^[Prefix].Child := FreeNode
  1035.     Else Begin
  1036.       Prefix := CodeTable^[Prefix].Child;
  1037.       While CodeTable^[Prefix].Sibling <> -1 Do
  1038.         Prefix := CodeTable^[Prefix].Sibling;
  1039.       CodeTable^[Prefix].Sibling := FreeNode;
  1040.     End {if};
  1041.   End {if};
  1042.  
  1043.   If NextFree > TABLESIZE Then
  1044.     TableFull := True;
  1045. End {Table_Add};
  1046.  
  1047. { --------------------------------------------------------------------------- }
  1048.  
  1049. {$IFDEF WIN32}
  1050. Function Table_Lookup(TargetPrefix:Smallint;TargetSuffix:Byte;
  1051.                         Var FoundAt:Smallint):Boolean;
  1052. Label Loop;
  1053. Var TempChild:Smallint;
  1054. Begin
  1055.   Table_Lookup := False;
  1056.   FoundAt:=-1;
  1057.   If CodeTable^[TargetPrefix].Child=-1 Then Exit;{not found}
  1058.   TempChild:=CodeTable^[TargetPrefix].Child;
  1059.  Loop:
  1060.   With CodeTable^[TempChild] Do Begin
  1061.     If Suffix=TargetSuffix Then Begin {found}
  1062.       FoundAt:=TempChild;
  1063.       Table_Lookup:=True;
  1064.       Exit
  1065.     End;
  1066.     If Sibling=-1 Then Exit;{not found}
  1067.     TempChild:=Sibling;
  1068.   End;
  1069.   GoTo Loop;
  1070. End;
  1071.  
  1072. {$ELSE}
  1073. Function Table_Lookup(    TargetPrefix : Smallint;
  1074.                           TargetSuffix : Byte;
  1075.                       Var FoundAt      : Smallint   ) : Boolean;
  1076. { --------------------------------------------------------------------------- }
  1077. { Search for a Prefix:Suffix pair in our Symbol table.  If found, return the  }
  1078. { index value where found.  If not found, return FALSE and set the VAR parm   }
  1079. { FoundAt to -1.                                                              }
  1080. { --------------------------------------------------------------------------- }
  1081. Begin
  1082.   Inline(
  1083.   {;}
  1084.   {; Lookup an entry in the Hash Table.  If found, return TRUE and set the VAR}
  1085.   {; parameter FoundAt with the index of the entry at which the match was found.}
  1086.   {; If not found, return FALSE and plug a -1 into the FoundAt var.}
  1087.   {;}
  1088.   {;}
  1089.   {; Register usage:}
  1090.   {;   AX - varies                     BL - holds target suffix character}
  1091.   {;                                   BH - If search fails, determines how to}
  1092.   {;                                        add the new entry}
  1093.   {;   CX - not used                   DX - holds size of 1 table entry (5)}
  1094.   {;   DI - varies                     SI - holds offset of 1st table entry}
  1095.   {;   ES - seg addr of hash table     DS - program's data segment}
  1096.   {;}
  1097.   {;}
  1098.   $8A/$5E/<TargetSuffix/ {            mov byte    bl,[bp+<TargetSuffix]   ;Target Suffix character}
  1099.   $8B/$46/<TargetPrefix/ {            mov word    ax,[bp+<TargetPrefix]   ;Index into table}
  1100.   $BA/$05/$00/           {            mov         dx,5                    ;5 byte table entries}
  1101.   $F7/$E2/               {            mul         dx                      ;AX now an offset into table}
  1102.   $C4/$3E/>CodeTable/    {            les         di,[>CodeTable]         ;Hash table address}
  1103.   $89/$FE/               {            mov         si,di                   ;save offset in SI}
  1104.   $01/$C7/               {            add         di,ax                   ;es:di points to table entry}
  1105.   {;}
  1106.   $B7/$00/               {            mov         bh,0                    ;Chain empty flag (0=empty)}
  1107.   $26/$83/$3D/$FF/       {        es: cmp word    [di],-1                 ;Anything on the chain?}
  1108.   $74/$33/               {            jz          NotFound                ;Nope, search fails}
  1109.   $B7/$01/               {            mov         bh,1                    ;Chain empty flag (1=not empty)}
  1110.   {;}
  1111.   $26/$8B/$05/           {        es: mov word    ax,[di]                 ;Get index of 1st entry in chain}
  1112.   $89/$46/<TargetPrefix/ {Loop:       mov word    [bp+<TargetPrefix],ax   ;Save index for later}
  1113.   $BA/$05/$00/           {            mov         dx,5}
  1114.   $F7/$E2/               {            mul         dx                      ;convert index to offset}
  1115.   $89/$F7/               {            mov         di,si                   ;es:di points to start of table}
  1116.   $01/$C7/               {            add         di,ax                   ;es:di points to table entry}
  1117.   {;}
  1118.   $26/$3A/$5D/$04/       {        es: cmp byte    bl,[di+4]               ;match on suffix?}
  1119.   $74/$0D/               {            jz          Found                   ;Yup, search succeeds}
  1120.   {;}
  1121.   $26/$83/$7D/$02/$FF/   {        es: cmp word    [di+2],-1               ;any more entries in chain?}
  1122.   $74/$15/               {            jz          NotFound                ;nope, search fails}
  1123.   {;}
  1124.   $26/$8B/$45/$02/       {        es: mov word    ax,[di+2]               ;get index of next chain entry}
  1125.   $EB/$E1/               {            jmp short   Loop                    ;   and keep searching}
  1126.   {;}
  1127.   $C6/$46/$FF/$01/       {Found:      mov byte    [bp-1],1                ;return TRUE}
  1128.   $C4/$7E/<FoundAt/      {            les         di,[bp+<FoundAt]        ;get address of Var parameter}
  1129.   $8B/$46/<TargetPrefix/ {            mov word    ax,[bp+<TargetPrefix]   ;get index of entry where found}
  1130.   $26/$89/$05/           {        es: mov         [di],ax                 ;and store it}
  1131.   $EB/$0C/               {            jmp short   Done}
  1132.   {;}
  1133.   $C6/$46/$FF/$00/       {NotFound:   mov byte    [bp-1],0                ;return FALSE}
  1134.   $C4/$7E/<FoundAt/      {            les         di,[bp+<FoundAt]        ;get address of Var parameter}
  1135.   $26/$C7/$05/$FF/$FF);  {        es: mov word    [di],-1                 ;and store a -1 in it}
  1136.   {;}
  1137.   {Done:}
  1138.   {;}
  1139.  
  1140. End {Table_Lookup};
  1141. {$ENDIF}
  1142.  
  1143. { --------------------------------------------------------------------------- }
  1144. { These routines build the Header structures for the ZIP file                 }
  1145. { --------------------------------------------------------------------------- }
  1146.  
  1147. Procedure Begin_ZIP(ListPtr : NodePtr);
  1148. { Write a dummy header to the zip.  Include as much info as is currently      }
  1149. { known (we'll come back and fill in the rest later...)                       }
  1150. Begin
  1151.   LocalHdrOfs := FilePos(OutFile);       { Save file position for later use  }
  1152.   With LocalHdr Do Begin
  1153.     Signature := LOCAL_FILE_HEADER_SIGNATURE;
  1154.     Extract_Version_Reqd := 10;
  1155.     Bit_Flag := 0;
  1156.     Compress_Method := 1;
  1157.     Last_Mod_Time := ListPtr^.Time;
  1158.     Last_Mod_Date := ListPtr^.Date;
  1159.     Crc32 := 0;
  1160.     Compressed_Size := 0;
  1161.     Uncompressed_Size := ListPtr^.Size;
  1162.     FileName_Length := Length(ListPtr^.Name);
  1163.     Extra_Field_Length := 0;
  1164.   End {with};
  1165.   Move(LocalHdr, OutBuf^, SizeOf(LocalHdr)); { Put header into output buffer }
  1166.   OutBufIdx := Succ(SizeOf(LocalHdr));   {...adjust buffer index accordingly }
  1167.   Move(ListPtr^.Name[1], OutBuf^[OutBufIdx], Length(ListPtr^.Name));
  1168.   Inc(OutBufIdx, Length(ListPtr^.Name));
  1169.   FlushOutput;                           { Write it now                      }
  1170. End {Begin_ZIP};
  1171.  
  1172. { --------------------------------------------------------------------------- }
  1173.  
  1174. Procedure Update_ZIP_Header(ListPtr : NodePtr);
  1175. { Update the zip's local header with information that we now possess.  Check  }
  1176. { to make sure that our shrinker actually produced a smaller file.  If not,   }
  1177. { scrap the shrunk data, modify the local header accordingly, and just copy   }
  1178. { the input file to the output file (compress method 0 - Storing).            }
  1179. Var
  1180.    EndPos : LongInt;
  1181.    Redo   : Boolean;
  1182. Begin
  1183.   Redo := False;                            { Set REDO flag to false         }
  1184.   EndPos := FilePos(OutFile);               { Save current file position     }
  1185.  
  1186.   Seek(OutFile, LocalHdrOfs);               { Rewind back to file header     }
  1187.  
  1188.   With LocalHdr Do Begin
  1189.     { Update compressed size field   }
  1190.     Compressed_Size := EndPos - LocalHdrOfs - SizeOf(LocalHdr) - Filename_Length;
  1191.     Crc32 := Crc32Val;                     { Update CRC value               }
  1192.     { Have we compressed the file?   }
  1193.     Redo := (Compressed_Size >= Uncompressed_Size);
  1194.     If Redo Then Begin                     { No...                          }
  1195.       Compress_Method := 0;                  { ...change stowage type      }
  1196.       Compressed_Size := Uncompressed_Size;  { ...update compressed size   }
  1197.     End {if};
  1198.  
  1199.   End {with};
  1200.  
  1201.   Move(LocalHdr, OutBuf^, SizeOf(LocalHdr)); { Put header into output buffer }
  1202.   OutBufIdx := Succ(SizeOf(LocalHdr));   {...adjust buffer index accordingly }
  1203.   Move(ListPtr^.Name[1], OutBuf^[OutBufIdx], Length(ListPtr^.Name));
  1204.   Inc(OutBufIdx, Length(ListPtr^.Name));
  1205.   FlushOutput;                           { Write it now                      }
  1206.  
  1207.   If Redo Then Begin
  1208.     { If compression didn't make a smaller file, then ...                   }
  1209.     Seek(InFile, 0);                       { Rewind the input file          }
  1210.     InputEof := False;                     { Reset EOF indicator            }
  1211.     Read_Block;                            { Prime the input buffer         }
  1212.     While Not InputEof Do Begin            { Copy input to output           }
  1213.       BlockWrite(OutFile, InBuf^, MaxInBufIdx);
  1214.       Read_Block;
  1215.     End {while};
  1216.     Truncate(Outfile);                     { Truncate output file           }
  1217.   End {then}
  1218.   Else Begin
  1219.     { Compression DID make a smaller file ...                               }
  1220.     Seek(OutFile, FileSize(OutFile));   { Move output file pos back to eof  }
  1221.   End {if};
  1222. End {Update_ZIP_Header};
  1223.  
  1224. { --------------------------------------------------------------------------- }
  1225.  
  1226. Procedure Build_Central_Dir;
  1227. { Revisit each local file header to build the Central Directory.  When done,  }
  1228. { build the End of Central Directory record.                                  }
  1229. Var
  1230.    BytesRead : Integer;
  1231.    SavePos   : LongInt;
  1232.    HdrPos    : LongInt;
  1233.    CenDirPos : LongInt;
  1234.    pom,
  1235.    Entries   : Word;
  1236.    FileName  : String;
  1237.    pomStr    : array[0..255] of char; {integer}
  1238.    tpmCDSize : LongInt;
  1239. Begin
  1240.   tpmCDSize := 0;
  1241.   Entries := 0;
  1242.   CenDirPos := FilePos(Outfile);
  1243.   Seek(OutFile, 0);             { Rewind output file }
  1244.   HdrPos := FilePos(OutFile);
  1245.   BlockRead(OutFile, LocalHdr, SizeOf(LocalHdr), BytesRead);
  1246.   Repeat
  1247.     BlockRead(OutFile, pomstr, LocalHdr.FileName_Length, BytesRead);
  1248.     pom:=LocalHdr.FileName_Length;
  1249.     if pom>255 then pom:=255;
  1250.     pomstr[pom]:=#0;
  1251.     FileName:=Strpas(pomstr);
  1252.  //    BlockRead(OutFile, FileName[1], LocalHdr.FileName_Length, BytesRead);
  1253.  //   FileName[0] := Chr(LocalHdr.FileName_Length);
  1254. //   pom:=LocalHdr.FileName_Length;
  1255. //    if pom >= 256 then pom:=255;
  1256. //     SetLength(FileName,pom);
  1257.  
  1258.     SavePos := FilePos(OutFile);
  1259.  
  1260.     With CentralHdr Do Begin
  1261.       Signature := CENTRAL_FILE_HEADER_SIGNATURE;
  1262.       MadeBy_Version := LocalHdr.Extract_Version_Reqd;
  1263.       Move(LocalHdr.Extract_Version_Reqd, Extract_Version_Reqd, 26);
  1264.       File_Comment_Length := 0;
  1265.       Starting_Disk_Num := 0;
  1266.       Internal_Attributes := 0;
  1267.       External_Attributes := faARCHIVE;
  1268.       Local_Header_Offset := HdrPos;
  1269.       Seek(OutFile, FileSize(OutFile));
  1270.       BlockWrite(Outfile, CentralHdr, SizeOf(CentralHdr));
  1271.       BlockWrite(OutFile, FileName[1], Length(FileName));
  1272.       Inc(tpmCDSize,SizeOf(CentralHdr)+Length(FileName));
  1273.       Inc(Entries);
  1274.     End {with};
  1275.  
  1276.     Seek(OutFile, SavePos + LocalHdr.Compressed_Size);
  1277.     HdrPos := FilePos(OutFile);
  1278.     BlockRead(OutFile, LocalHdr, SizeOf(LocalHdr), BytesRead);
  1279.   Until LocalHdr.Signature = CENTRAL_FILE_HEADER_SIGNATURE;
  1280.  
  1281.   Seek(OutFile, FileSize(OutFile));
  1282.  
  1283.   With EndHdr Do Begin
  1284.     Signature := END_OF_CENTRAL_DIR_SIGNATURE;
  1285.     Disk_Number := 0;
  1286.     Central_Dir_Start_Disk := 0;
  1287.     Entries_This_Disk := Entries;
  1288.     Total_Entries := Entries;
  1289.     Central_Dir_Size := {CenDirPos - FileSize(OutFile)}tpmCDSize;{fix 31.5.2002 by J.B.}
  1290.     Start_Disk_Offset := CenDirPos;
  1291.     ZipFile_Comment_Length := 0;
  1292.     BlockWrite(Outfile, EndHdr, SizeOf(EndHdr));
  1293.   End {with};
  1294.  
  1295. End {Build_Central_Dir};
  1296.  
  1297. { --------------------------------------------------------------------------- }
  1298. { The actual Crunching algorithm                                              }
  1299. { --------------------------------------------------------------------------- }
  1300.  
  1301. Procedure Shrink(Suffix : Smallint);
  1302. Const
  1303.    LastCode    : Smallint = 0;   { Typed constant, so value retained across calls }
  1304. Var
  1305.    WhereFound   : Smallint;
  1306. //   CrunchRatio  : LongInt;
  1307. Begin
  1308.   If FirstCh Then Begin         { If just getting started ...                }
  1309.     SaveByte := $00;           { Initialize our output code buffer          }
  1310.     BitsUsed := 0;
  1311.     CodeSize := MINBITS;       {     Initialize code size to minimum        }
  1312.     MaxCode  := (1 ShL CodeSize) - 1;
  1313.     LastCode := Suffix;        {     get first character from input,        }
  1314.     FirstCh  := False;         {     and reset the first char flag.         }
  1315.   End {then}
  1316.   Else Begin
  1317.     If Suffix <> -1 Then Begin { If there's work to do ...                  }
  1318.       If TableFull Then Begin
  1319.         { Ok, lets clear the code table (adaptive reset)            }
  1320.         Putcode(LastCode);
  1321.         PutCode(SPECIAL);
  1322.         Putcode(CLEARCODE);
  1323.         Clear_Table;
  1324.         Table_Add(LastCode, Suffix);
  1325.         LastCode := Suffix;
  1326.       End {then}
  1327.       Else Begin
  1328.         If Table_Lookup(LastCode, Suffix, WhereFound) Then Begin
  1329.           { If LastCode:Suffix pair is found in the code table, then ...    }
  1330.           { ... set LastCode to the entry where the pair is located         }
  1331.           LastCode  := WhereFound;
  1332.         End {then}
  1333.         Else Begin
  1334.           { Not in table                                                    }
  1335.           PutCode(LastCode);            { Write current LastCode code       }
  1336.           Table_Add(LastCode, Suffix);  { Attempt to add to code table      }
  1337.           LastCode := Suffix;           { Reset LastCode code for new char  }
  1338.           If (FreeList^[NextFree] > MaxCode) And (CodeSize < MaxBits) Then Begin
  1339.             { Time to increase the code size and change the max. code      }
  1340.             PutCode(SPECIAL);
  1341.             PutCode(INCSIZE);
  1342.             Inc(CodeSize);
  1343.             MaxCode := (1 ShL CodeSize) -1;
  1344.           End {if};
  1345.         End {if};
  1346.       End {if};
  1347.     End {then}
  1348.     Else Begin                    { Nothing to crunch...must be EOF on input   }
  1349.       PutCode(LastCode);         { Write last prefix code                     }
  1350.       PutCode(-1);               { Tell putcode to flush remaining bits       }
  1351.       FlushOutput;               { Flush our output buffer                    }
  1352.     End {if};
  1353.   End {if};
  1354. End {Crunch};
  1355.  
  1356. { --------------------------------------------------------------------------- }
  1357.  
  1358. Procedure Process_Input(Source : String);
  1359. Var
  1360.    I       : Word;
  1361.    PctDone : Smallint;
  1362. //   Smsg    : String;
  1363. Begin
  1364.   If Source = '' Then
  1365.     Shrink(-1)
  1366.   Else
  1367.     For I := 1 To Length(Source) Do Begin
  1368.       Inc(BytesIn);
  1369.       {If (Pred(BytesIn) Mod TenPercent) = 0 Then }Begin
  1370.         PctDone := Round( 100 * ( BytesIn / FileSize(InFile)));
  1371.         {nove hlaseni stavu}
  1372.         {Smsg := Turn(PadCh (CharStr (' ', (100-PctDone+10) DIV 10), ' ', 10));}
  1373.         If AsSigned(FOnProgress) Then
  1374.           FOnProgress(Self,PctDone);
  1375.       End {if};
  1376.       CRC32Val := UpdC32(Ord(Source[I]), CRC32Val);
  1377.       Shrink(Ord(Source[I]));
  1378.     End {for};
  1379. End {Process_Input};
  1380.  
  1381. { --------------------------------------------------------------------------- }
  1382. { This routine handles processing for one input file                          }
  1383. { --------------------------------------------------------------------------- }
  1384.  
  1385. Procedure Process_One_File;
  1386. Var
  1387.    OneString : {$IfNDef Win32}ShortString{$Else}String{$EndIf};
  1388.    Remaining : Word;
  1389.    pom       : array[0..255] of char; {integer}
  1390. Begin
  1391.  
  1392.   Read_Block;                { Prime the input buffer                        }
  1393.   FirstCh   := True;         { 1st character flag for Crunch procedure       }
  1394.   Crc32Val  := $FFFFFFFF;
  1395.  
  1396.   TenPercent := FileSize(InFile) Div 10;
  1397.  
  1398.   While Not InputEof Do Begin
  1399.     Remaining := Succ(MaxInBufIdx - InBufIdx);
  1400.  
  1401.     If Remaining > 255
  1402.      Then Remaining := 255;
  1403.  
  1404.     If Remaining = 0
  1405.      Then Read_Block
  1406.      Else
  1407.       Begin
  1408. //  predelal IvanP
  1409. (*
  1410.         Move(InBuf^[InBufIdx], pom, Remaining);
  1411.         pom[remaining]:=#0;
  1412.         OneString:=StrPas(pom);
  1413. *)
  1414.         OneString:=Space(Remaining);
  1415.         Move(InBuf^[InBufIdx], OneString[1], Remaining);
  1416.         //Setlength(OneString,Remaining);
  1417. //        
  1418.         Inc(InBufIdx, Remaining);
  1419.         Process_Input(OneString);
  1420.       End {if};
  1421.  
  1422.   End {while};
  1423.  
  1424.   Crc32Val := Not Crc32Val;
  1425.  
  1426.   Process_Input('');     { This forces EOF processing }
  1427.  
  1428. End {Process_One_File};
  1429.  
  1430. { --------------------------------------------------------------------------- }
  1431.  
  1432. Procedure Process_All_Files;
  1433. Var
  1434. //   InPath   : String;
  1435.    ComprPct : Word;
  1436.    ListNode : NodePtr;
  1437. Begin
  1438.   If ListHead = Nil Then Begin
  1439.     Fatal('Nejsou ₧ßdnΘ soubory k smrsknutφ !');
  1440.     Exit
  1441.   End {if};
  1442.  
  1443.   OpenOutput;
  1444.   ListNode := ListHead;
  1445.   While ListNode <> Nil Do
  1446.    Begin
  1447. //    Showmessage('concate '+ListNode^.Path+', '+ ListNode^.Name + ' .'); {*****}
  1448.     If OpenInput(Concat(ListNode^.Path, ListNode^.Name))
  1449.      Then
  1450.       Begin
  1451.        BytesIn := 1; BytesOut := 1;
  1452.        TenPercent := FileSize(InFile) Div 10;
  1453.        Initialize_Data_Structures;
  1454.        Begin_ZIP(ListNode);
  1455.        Process_One_File;
  1456.        Update_ZIP_Header(ListNode);
  1457.        CloseInput;
  1458.        If LocalHdr.Uncompressed_Size > 0
  1459.         Then
  1460.          ComprPct := Round((100.0 * (LocalHdr.Uncompressed_Size - LocalHdr.Compressed_Size)) / LocalHdr.Uncompressed_Size)
  1461.         Else
  1462.          ComprPct := 0;
  1463.       End {then}
  1464.      Else
  1465.       Fatal('Nejde otev°φt '+ListNode^.Name+'.  P°ekraΦuji ...');
  1466.     ListNode := ListNode^.Next;
  1467.    End {while};
  1468.   Build_Central_Dir;
  1469.   CloseOutput;
  1470. End {Process_All_Files};
  1471.  
  1472. { Main Program (driver) }
  1473.  
  1474. Begin
  1475.   If ParamCheck(StrUpCase(PrmLine),True) Then Begin
  1476.     If Not GetBuffers Then Exit;   { Allocate input and output buffers ...}
  1477.  
  1478.     If Not Build_Data_Structures Then Exit; { ... and other data structures required }
  1479.     Try
  1480.       Process_All_Files;       { Crunch the file }
  1481.     Finally
  1482.       DropBuffers;             { Be polite and de-allocate Buffer memory and }
  1483.       Destroy_Data_Structures; {    other allocated data structures }
  1484.     End;
  1485.   End {if};
  1486. End;
  1487.  
  1488. Procedure TUnZip.UnCrunch(Const PrmLine: String);
  1489. {Const SignWork:String[10]='Rozbaluji';}
  1490. Const
  1491.   MAXNAMES = 20;
  1492.   GloMem:Pointer=Nil;
  1493.   
  1494. Var
  1495.   InFileSpecs :  Array [1..MAXNAMES] Of String;   { Input file specifications }
  1496.   MaxSpecs    :  Word;         { Total number of entries in InFileSpecs array }
  1497.   OutPath     :  String;       { Output path specification                    }
  1498.  
  1499.   TenPercent  :  LongInt;
  1500.  
  1501.   { Define ZIP file header types }
  1502.   
  1503. Const
  1504.   LOCAL_FILE_HEADER_SIGNATURE = $04034B50;
  1505.   
  1506. Type
  1507.   Local_File_Header_Type = packed Record
  1508.     { Signature              :  LongInt; }
  1509.     Extract_Version_Reqd   :  Word;
  1510.     Bit_Flag               :  Word;
  1511.     Compress_Method        :  Word;
  1512.     Last_Mod_Time          :  Word;
  1513.     Last_Mod_Date          :  Word;
  1514.     Crc32                  :  LongInt;
  1515.     Compressed_Size        :  LongInt;
  1516.     Uncompressed_Size      :  LongInt;
  1517.     Filename_Length        :  Word;
  1518.     Extra_Field_Length     :  Word;
  1519.   End;
  1520.  
  1521. Const
  1522.   CENTRAL_FILE_HEADER_SIGNATURE = $02014B50;
  1523.  
  1524. Type
  1525.   Central_File_Header_Type = packed Record
  1526.     { Signature            :  LongInt; }
  1527.     MadeBy_Version       :  Word;
  1528.     Extract_Version_Reqd :  Word;
  1529.     Bit_Flag             :  Word;
  1530.     Compress_Method      :  Word;
  1531.     Last_Mod_Time        :  Word;
  1532.     Last_Mod_Date        :  Word;
  1533.     Crc32                :  LongInt;
  1534.     Compressed_Size      :  LongInt;
  1535.     Uncompressed_Size    :  LongInt;
  1536.     Filename_Length      :  Word;
  1537.     Extra_Field_Length   :  Word;
  1538.     File_Comment_Length  :  Word;
  1539.     Starting_Disk_Num    :  Word;
  1540.     Internal_Attributes  :  Word;
  1541.     External_Attributes  :  LongInt;
  1542.     Local_Header_Offset  :  LongInt;
  1543.   End;
  1544.   
  1545. Const
  1546.   END_OF_CENTRAL_DIR_SIGNATURE = $06054B50;
  1547.   
  1548. Type
  1549.   End_of_Central_Dir_Type =  packed Record
  1550.     { Signature               :  LongInt; }
  1551.     Disk_Number             :  Word;
  1552.     Central_Dir_Start_Disk  :  Word;
  1553.     Entries_This_Disk       :  Word;
  1554.     Total_Entries           :  Word;
  1555.     Central_Dir_Size        :  LongInt;
  1556.     Start_Disk_Offset       :  LongInt;
  1557.     ZipFile_Comment_Length  :  Word;
  1558.   End;
  1559.  
  1560. Const
  1561.   BufSize = 8192;           { Size of buffers for I/O }
  1562.  
  1563. Type
  1564.    BufPtr = ^BufType;
  1565.    BufType = Array [1..BufSize] Of Byte;
  1566.  
  1567. Var
  1568.    ZipName       :  String;         { Name of Zip file to be processed }
  1569.    ZipFile       :  File;           { Zip file variable }
  1570.    EndFile       :  Boolean;        { End of file indicator for ZipFile }
  1571.    ZipBuf        :  BufPtr;         { Input buffer for ZipFile }
  1572.    ZipPtr        :  Word;           { Index for ZipFile input buffer }
  1573.    ZipCount      :  integer;        { Count of bytes in ZipFile input buffer }
  1574.  
  1575.    ExtFile       :  File;           { Output file variable }
  1576.    ExtBuf        :  BufPtr;         { Output buffer for ExtFile }
  1577.    ExtPtr        :  Word;           { Index for ExtFile output buffer }
  1578.    ExtCount      :  LongInt;        { Count of characters written to output }
  1579.  
  1580.    LocalHdr       : Local_File_Header_Type;  { Storage for a local file hdr }
  1581.    Hdr_FileName   : String;
  1582.    Hdr_ExtraField : String;
  1583.    Hdr_Comment    : String;
  1584.  
  1585.    Crc32Val      :  LongInt;        { Running CRC (32 bit) value }
  1586.  
  1587.    Bytes_To_Go   :  LongInt;        { Bytes left to process in compressed file }
  1588.  
  1589.  
  1590. { Stuff needed for unSHRINKing }
  1591.  
  1592. Const
  1593.    MINCODESIZE    =    9;
  1594.    MAXCODESIZE    =   13;
  1595.    SPECIAL        =  256;
  1596.    FIRSTFREE      =  257;
  1597.    LZW_TABLE_SIZE =  (1 ShL MAXCODESIZE) - 1;      { 0..8191 }
  1598.    LZW_STACK_SIZE =  (1 ShL MAXCODESIZE) - 1;      { 0..8191 }
  1599.  
  1600. Type
  1601.  
  1602.    LZW_Table_Rec  =  Record
  1603.      Prefix      :  Smallint;
  1604.      Suffix      :  Byte;
  1605.      ChildCount  :  Word;  { If ChildCount = 0 then leaf node }
  1606.    End;
  1607.    LZW_Table_Ptr  =  ^LZW_Table_Type;
  1608.    LZW_Table_Type =  Array [0..LZW_TABLE_SIZE] Of LZW_Table_Rec;
  1609.  
  1610.    FreeListPtr    =  ^FreeListArray;
  1611.    FreeListArray  =  Array [FIRSTFREE..LZW_TABLE_SIZE] Of Word;
  1612.  
  1613.    StackPtr       =  ^StackType;
  1614.    StackType      =  Array [0..LZW_STACK_SIZE] Of Word;
  1615.  
  1616. Var
  1617.    LZW_Table   :  LZW_Table_Ptr; { Code table for LZW decoding                }
  1618.    FreeList    :  FreeListPtr;   { List of free table entries                 }
  1619.    NextFree    :  Word;          { Index for free list array                  }
  1620.                                  {   FreeList^[NextFree] always contains the  }
  1621.                                  {   index of the next available entry in     }
  1622.                                  {   the LZW Prefix:Suffix table (LZW_Table^) }
  1623.    LZW_Stack   :  StackPtr;      { A stack used to build decoded strings      }
  1624.    StackIdx    :  Word;          { Stack array index variable                 }
  1625.                                  {   StackIdx always points to the next       }
  1626.                                  {   available entry in the stack             }
  1627.    SaveByte    :  Byte;          { Our input code buffer - 1 byte long        }
  1628.    BitsLeft    :  Byte;          { Unprocessed bits in the input code buffer  }
  1629.    FirstCh     :  Boolean;       { Flag indicating first char being processed }
  1630.  
  1631.  
  1632. { Stuff needed for unREDUCEing }
  1633.  
  1634. Const
  1635.    MAXDICTSIZE    =  8192;       { size will be 4096 for unreduce and either  }
  1636.                                  { 4096 or 8192 for exploding                 }
  1637. Type
  1638.    FollowerSet    =  Record
  1639.      SetSize  :  Word;
  1640.      FSet     :  Array [0..31] Of Byte;
  1641.    End;
  1642.    FollowerPtr    =  ^FollowerArray;
  1643.    FollowerArray  =  Array [0..255] Of FollowerSet;
  1644.  
  1645.    DictPtr        =  ^DictArray;
  1646.    DictArray      =  Array [0..MAXDICTSIZE - 1] Of Byte;
  1647.  
  1648. Var
  1649.    Followers   :  FollowerPtr;
  1650.    Dictionary  :  DictPtr;       { The sliding dictionary }
  1651.    DictIdx     :  Word;          { Always points to next pos. to be filled }
  1652.    DictSize    :  Word;          { size (in bytes) of sliding dictionary }
  1653.    State       :  Byte;
  1654.    Len         :  Word;
  1655.    V           :  Byte;
  1656.  
  1657. { Stuff needed for unIMPLODEing }
  1658.  
  1659. Const
  1660.    MAX_SF_TREE_SIZE     =  511;
  1661.    LITERAL_TREE_ROOT    =  511;
  1662.    DISTANCE_TREE_ROOT   =  127;
  1663.    LENGTH_TREE_ROOT     =  127;
  1664. Type
  1665.    { The following structures are used to define the Shannon-Fano trees used  }
  1666.    { in decoding an imploded file                                             }
  1667.    SF_Node              =  Record
  1668.      LChild   :  Smallint;
  1669.      RChild   :  Smallint;
  1670.    End;
  1671.    SF_Literal_Ptr       =  ^SF_Literal_Array;
  1672.    SF_Distance_Ptr      =  ^SF_Distance_Array;
  1673.    SF_Length_Ptr        =  ^SF_Length_Array;
  1674.    SF_Literal_Array     =  Array [0..LITERAL_TREE_ROOT] Of SF_Node;
  1675.    SF_Distance_Array    =  Array [0..DISTANCE_TREE_ROOT] Of SF_Node;
  1676.    SF_Length_Array      =  Array [0..LENGTH_TREE_ROOT] Of SF_Node;
  1677.    { The Shannon-Fano data that is stored at the beginning of the compressed  }
  1678.    { file is itself compressed.  The following structures are used to decode  }
  1679.    { that data and build the required Shannon-Fano trees                      }
  1680.    SF_BuildRec          =  Record
  1681.      Len   :  Byte;
  1682.      Val   :  Byte;
  1683.      Code  :  Word;
  1684.    End;
  1685.    SF_BuildPtr          =  ^SF_BuildArray;
  1686.    SF_BuildArray        =  Array [0..255] Of SF_BuildRec;
  1687. Var
  1688.    SF_Literal           :  SF_Literal_Ptr;   { These are the 3 Shannon-Fano   }
  1689.    SF_Distance          :  SF_Distance_Ptr;  { trees that are used to implode }
  1690.    SF_Length            :  SF_Length_Ptr;    { a file.                        }
  1691.    NextFreeLiteral      :  Word;    { Free node pointers used while trees     }
  1692.    NextFreeLength       :  Word;    { are being constructed                   }
  1693.    NextFreeDistance     :  Word;
  1694.    SF_Build             :  SF_BuildPtr;      { Array used in building the     }
  1695.                                              { Shannon-Fano trees needed to   }
  1696.                                              { decode the imploded file       }
  1697.    SF_Build_Idx         :  Byte;    { Index var for SF_Build array            }
  1698.    NumOfTrees           :  Byte;    { the # of SF trees needed (2 or 3)       }
  1699.    MinMatchLen          :  Byte;    { minimum dictionary match length (2 or 3)}
  1700.  
  1701. { --------------------------------------------------------------------------- }
  1702.  
  1703. Procedure Abort (Msg : String);
  1704. Begin
  1705.   If AsSigned(FOnError) Then FOnError(Self,Msg)
  1706.   Else
  1707.     MessageDlg(Msg, mtWarning, [mbOk], 0);
  1708. End {Abort} ;
  1709.  
  1710. { --------------------------------------------------------------------------- }
  1711.  
  1712. Procedure Syntax;
  1713. Begin
  1714.   Abort('ChybnΘ volßnφ, chybnΘ parametry')
  1715. End;
  1716.  
  1717. { --------------------------------------------------------------------------- }
  1718.  
  1719. Function HexLInt (L : LongInt) : String;
  1720. Type
  1721.   HexType  = Array [0..15] Of Char;
  1722. Const
  1723.   HexChar : HexType =
  1724.     ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
  1725. Begin
  1726.   Result := HexChar [ (L And $F0000000) ShR 28] +
  1727.   HexChar [ (L And $0F000000) ShR 24] +
  1728.   HexChar [ (L And $00F00000) ShR 20] +
  1729.   HexChar [ (L And $000F0000) ShR 16] +
  1730.   HexChar [ (L And $0000F000) ShR 12] +
  1731.   HexChar [ (L And $00000F00) ShR  8] +
  1732.   HexChar [ (L And $000000F0) ShR  4] +
  1733.   HexChar [ (L And $0000000F)       ] +
  1734.   'h';
  1735. End {HexLInt} ;
  1736.  
  1737. { --------------------------------------------------------------------------- }
  1738.  
  1739. Function IO_Test : Boolean;
  1740. Var
  1741.   ErrorCode : Word;
  1742. //  CodeStr   : String;
  1743.   Ok        : Boolean;
  1744. Begin
  1745.   Ok := True;
  1746.   ErrorCode := IOResult;
  1747.   If ErrorCode <> 0 Then Begin
  1748.     Ok := False;
  1749.     Case ErrorCode Of
  1750.       2 : Abort('Soubor nebyl nalezen');
  1751.       3 : Abort('Cesta nenφ platnß/nebyla nalezana');
  1752.       5 : Abort('Chyba souboru/cesty/syntaxe');
  1753.       101 : Abort('Disk je pln²');
  1754.       Else   Abort('Vstupn∞/v²stupnφ chyba '+Long2Str(ErrorCode));
  1755.     End {Case} ;
  1756.   End {if} ;
  1757.   Result := Ok;
  1758. End {IO_Test} ;
  1759.  
  1760. { --------------------------------------------------------------------------- }
  1761.  
  1762. Function Load_Parms (PrmLine: String):Boolean;
  1763. Var
  1764.   I      : Word;
  1765.   Name   : String;
  1766.   SearchRec   : TSearchRec;
  1767. Begin
  1768.   Result:=False; {prvni parametr je zipname}
  1769.   I := WordCount (PrmLine, [Spacer] ) {ParamCount} ;
  1770.   If I < 1
  1771.    Then
  1772.     Begin
  1773.      Syntax;
  1774.      Exit;
  1775.     End;
  1776.   ZipName := ExtractWord (1, PrmLine, [Spacer] ) {ParamStr(1)} ;
  1777.   ZipName := StrUpCase(ZipName);
  1778.   {FOR I := 1 TO LENGTH (ZipName) DO
  1779.   ZipName [I] := UPCASE (ZipName [I] );}
  1780.   If Pos ('.', ZipName) = 0 Then ZipName := ZipName  + '.ZIP';
  1781.   MaxSpecs := 0;
  1782.   OutPath := '';
  1783.   I := 1;
  1784. //  Showmessage(Prmline); {*****}
  1785.   While I < WordCount (PrmLine, [Spacer] ) {ParamCount} Do
  1786.    Begin
  1787.     Inc (I);
  1788.     Name := Trim(ExtractWord (I, PrmLine, [Spacer] )) {ParamStr(I)} ;
  1789.     If Name [Length (Name) ] = '\' Then Delete (Name, Length (Name), 1);
  1790.     {U adresß°e se odstranφ koncovΘ lomφtko}
  1791.     {Change specification for disk only example A:\ or Z:\ on entry        JB}
  1792.     If (I=2) And ((Name[1] In ['A'..'Z']) And (Name[2]=':')
  1793.       And (Length(Name)=2))              {JB}
  1794.     Then OutPath:=Name+'\'                        {JB}
  1795.      // pokud je jen jmeno disku, lomφtko se naopak doplnφ a definuje se OutPath.
  1796.     Else  //jinak se zjistuje, zda jde o soubor nebo adresar
  1797.      Begin                                                            {JB}
  1798.       If SysUtils.FindFirst (Name, faDirectory, SearchRec)=0
  1799.        Then //jmeno bylo spravne nalezeno jako adresar
  1800.         Begin { outpath spec? }
  1801.           If (SearchRec. Attr And faDirectory) <> 0
  1802.            Then  // je to adresar
  1803.             Begin   { yup }
  1804.               OutPath := Name;
  1805.               If OutPath [Length (OutPath) ] <> '\'
  1806.                Then OutPath := OutPath + '\';
  1807.             End {then}
  1808.            Else   // je to soubor
  1809.             Begin
  1810.               If MaxSpecs < MAXNAMES
  1811.                Then
  1812.                 Begin            // tak jej ulozim do InFileSpecs
  1813.                   Inc (MaxSpecs);  {sem se uklßdajφ dalÜφ parametry}
  1814.                   InFileSpecs [MaxSpecs] := Name;
  1815.                 End {if} ;
  1816.             End {if} ;
  1817.         End {then}
  1818.        Else // jmeno nebylo spravne nalezeno jako adresar
  1819.         Begin
  1820.           If MaxSpecs < MAXNAMES
  1821.            Then
  1822.              Begin // tak budu predpokladat, ze je to jmeno souboru
  1823.               Inc (MaxSpecs);
  1824.               InFileSpecs [MaxSpecs] := Name;
  1825.              End {if} ;
  1826.         End; {if}
  1827.        SysUtils.FindClose(SearchRec);
  1828.      End;                                                                  {JB}
  1829.    End {while} ;
  1830.  
  1831.   If MaxSpecs = 0 Then
  1832.    Begin
  1833.     MaxSpecs := 1;
  1834.     InFileSpecs [1] := '*.*';
  1835.    End {if} ;
  1836.   Result:=True;
  1837. End {Load_Parms} ;
  1838.  
  1839. { --------------------------------------------------------------------------- }
  1840.  
  1841. Function Initialize:Boolean;
  1842. //Var
  1843. //  Code : Smallint;
  1844. Begin
  1845.   ZipBuf:=Nil;
  1846.   ExtBuf:=Nil;
  1847.   Result := False;
  1848. // predelal IvanP
  1849.   try
  1850.     GetMem(ZipBuf,SizeOf (ZipBuf^))
  1851.   except
  1852.   on EOutOfMemory do
  1853.     begin
  1854.       MessageDlg('Not enough memory to allocate LZW data structures!',
  1855.                  mtError,[mbAbort], 0);
  1856.       Exit;
  1857.     end;
  1858.   end;
  1859.   try
  1860.     GetMem(ExtBuf,SizeOf (ExtBuf^))
  1861.   except
  1862.   on EOutOfMemory do
  1863.     begin
  1864.       MessageDlg('Not enough memory to allocate LZW data structures!',
  1865.                  mtError,[mbAbort], 0);
  1866.       FreeMem(ZipBuf,SizeOf (ZipBuf^));
  1867.       Exit;
  1868.     end;
  1869.   end;
  1870. //  If MaxAvail > SizeOf (ZipBuf^) Then GetMem(ZipBuf,SizeOf (ZipBuf^))
  1871. //  Else Exit;
  1872. //  If MaxAvail > SizeOf (ExtBuf^) Then GetMem(ExtBuf,SizeOf (ExtBuf^))
  1873. //  Else Begin
  1874. //    FreeMem(ZipBuf,SizeOf (ZipBuf^));
  1875. //    Exit;
  1876. //  End;
  1877.   Result := True;
  1878. End {Initialize} ;
  1879.  
  1880. Procedure Finalize;
  1881. Begin
  1882.   If ZipBuf<>Nil Then FreeMem(ZipBuf,SizeOf (ZipBuf^));
  1883.   If ExtBuf<>Nil Then FreeMem(ExtBuf,SizeOf (ExtBuf^));
  1884. End;
  1885.  
  1886. { --------------------------------------------------------------------------- }
  1887.  
  1888. { Converted to Turbo Pascal (tm) V4.0 March, 1988 by J.R.Louvau               }
  1889. { COPYRIGHT (C) 1986 Gary S. Brown.  You may use this program, or             }
  1890. { code or tables extracted from it, as desired without restriction.           }
  1891. {                                                                             }
  1892. { First, the polynomial itself and its table of feedback terms.  The          }
  1893. { polynomial is                                                               }
  1894. { X^32+X^26+X^23+X^22+X^16+X^12+X^11+X^10+X^8+X^7+X^5+X^4+X^2+X^1+X^0         }
  1895. {                                                                             }
  1896. { Note that we take it "backwards" and put the highest-order term in          }
  1897. { the lowest-order bit.  The X^32 term is "implied"; the LSB is the           }
  1898. { X^31 term, etc.  The X^0 term (usually shown as "+1") results in            }
  1899. { the MSB being 1.                                                            }
  1900. {                                                                             }
  1901. { Note that the usual hardware shift register implementation, which           }
  1902. { is what we're using (we're merely optimizing it by doing eight-bit          }
  1903. { chunks at a time) shifts bits into the lowest-order term.  In our           }
  1904. { implementation, that means shifting towards the right.  Why do we           }
  1905. { do it this way?  Because the calculated CRC must be transmitted in          }
  1906. { order from highest-order term to lowest-order term.  UARTs transmit         }
  1907. { characters in order from LSB to MSB.  By storing the CRC this way,          }
  1908. { we hand it to the UART in the order low-byte to high-byte; the UART         }
  1909. { sends each low-bit to hight-bit; and the result is transmission bit         }
  1910. { by bit from highest- to lowest-order term without requiring any bit         }
  1911. { shuffling on our part.  Reception works similarly.                          }
  1912. {                                                                             }
  1913. { The feedback terms table consists of 256, 32-bit entries.  Notes:           }
  1914. {                                                                             }
  1915. {     The table can be generated at runtime if desired; code to do so         }
  1916. {     is shown later.  It might not be obvious, but the feedback              }
  1917. {     terms simply represent the results of eight shift/xor opera-            }
  1918. {     tions for all combinations of data and CRC register values.             }
  1919. {                                                                             }
  1920. {     The values must be right-shifted by eight bits by the "updcrc"          }
  1921. {     logic; the shift must be unsigned (bring in zeroes).  On some           }
  1922. {     hardware you could probably optimize the shift in assembler by          }
  1923. {     using byte-swap instructions.                                           }
  1924. {     polynomial $edb88320                                                    }
  1925. {                                                                             }
  1926.  
  1927. Function UpdC32 (Octet: Byte; Crc: LongInt) : LongInt;
  1928. Var
  1929.   L : LongInt;
  1930.   W : Array [1..4] Of Byte Absolute L;
  1931. Begin
  1932.   Result := CRC_32_TAB [Byte (Crc XOr LongInt (Octet) ) ] XOr ( (Crc ShR 8) And $00FFFFFF);
  1933. End {UpdC32} ;
  1934.  
  1935. { --------------------------------------------------------------------------- }
  1936.  
  1937. Procedure Read_Zip_Block;
  1938. Begin
  1939.   BlockRead (ZipFile, ZipBuf^, BufSize, ZipCount);
  1940.   If ZipCount = 0 Then EndFile := True;
  1941.   ZipPtr := 1;
  1942. End {Read_Zip_Block} ;
  1943.  
  1944. { --------------------------------------------------------------------------- }
  1945.  
  1946. Procedure Write_Ext_Block;
  1947. Begin
  1948.   If ExtPtr > 1 Then Begin
  1949.     BlockWrite (ExtFile, ExtBuf^, Pred (ExtPtr) );
  1950.     If Not IO_Test Then {Halt};
  1951.     ExtPtr := 1;
  1952.   End {if} ;
  1953. End {Write_Ext_Block} ;
  1954.  
  1955. { --------------------------------------------------------------------------- }
  1956.  
  1957. Procedure Open_Zip;
  1958. Begin
  1959.   AssignFile (ZipFile, ZipName);
  1960.   FileMode := 64;  {fmShareDenyNone or fmOpenRead}
  1961.   {$I-} Reset (ZipFile, 1) {$I+} ;
  1962.   If Not IO_Test Then {Halt};
  1963.   EndFile := False;
  1964.   Read_Zip_Block;
  1965. End {Open_Zip} ;
  1966.  
  1967. { --------------------------------------------------------------------------- }
  1968.  
  1969. Function Open_Ext : Boolean;
  1970. Begin
  1971.   AssignFile (ExtFile, OutPath + Hdr_FileName);
  1972.   FileMode := 66;  {fmShareDenyNone or fmOpenReadWrite}
  1973.   {$I-} Rewrite (ExtFile, 1) {$I+} ;
  1974.   If Not IO_Test Then Result := False
  1975.   Else Begin
  1976.     ExtPtr := 1;
  1977.     Result := True;
  1978.   End {if} ;
  1979. End {Open_Ext} ;
  1980.  
  1981. { --------------------------------------------------------------------------- }
  1982.  
  1983. Function Get_Zip : Smallint;
  1984. Begin
  1985.   If ZipPtr > ZipCount Then Read_Zip_Block;
  1986.   If EndFile Then Result := - 1
  1987.   Else Begin
  1988.     Result := ZipBuf^ [ZipPtr];
  1989.     Inc (ZipPtr);
  1990.   End {if} ;
  1991. End {Get_Zip} ;
  1992.  
  1993. { --------------------------------------------------------------------------- }
  1994.  
  1995. Procedure Put_Ext (C : Byte);
  1996. Begin
  1997.   Crc32Val := UpdC32 (C, Crc32Val);
  1998.   ExtBuf^ [ExtPtr] := C;
  1999.   Inc (ExtPtr);
  2000.   Inc (ExtCount);
  2001.   If ExtPtr > BufSize Then Write_Ext_Block;
  2002. End {Put_Ext} ;
  2003.  
  2004. { --------------------------------------------------------------------------- }
  2005.  
  2006. Procedure Close_Zip;
  2007. Begin
  2008.   {$I-} CloseFile (Zipfile) {$I+} ;
  2009.   If IO_Test Then ;
  2010. End {Close_Zip} ;
  2011.  
  2012. { --------------------------------------------------------------------------- }
  2013.  
  2014. Procedure Close_Ext;
  2015. Type
  2016.   TimeDateRec = Record
  2017.     Time : Word;
  2018.     Date : Word;
  2019.   End {record} ;
  2020. Var
  2021.   TimeDate      : TimeDateRec;
  2022.   TimeDateStamp : LongInt Absolute TimeDate;
  2023. Begin
  2024.   Write_Ext_Block;
  2025.   TimeDate. Time := LocalHdr. Last_Mod_Time;
  2026.   TimeDate. Date := LocalHdr. Last_Mod_Date;
  2027.   {SetFileTime (ExtFile, TimeDateStamp);}
  2028.   FileSetDate(TFileRec(ExtFile).Handle, TimeDateStamp);
  2029.   {$I-} System.Close (ExtFile) {$I+} ;
  2030.   If IO_Test Then ;
  2031. End {Close_Ext} ;
  2032.  
  2033. { --------------------------------------------------------------------------- }
  2034.  
  2035. Procedure FSkip (Offset : LongInt);
  2036. Var
  2037.   Rec : LongInt;
  2038. Begin
  2039.   If (Offset + ZipPtr) <= ZipCount Then Inc (ZipPtr, Offset)
  2040.   Else Begin
  2041.     Rec := FilePos (ZipFile) + (Offset - (ZipCount - ZipPtr) - 1);
  2042.     {$I-} Seek (ZipFile, Rec) {$I+} ;
  2043.     If Not IO_Test Then {Halt};
  2044.     Read_Zip_Block;
  2045.   End {if} ;
  2046. End {FSkip} ;
  2047.  
  2048. { --------------------------------------------------------------------------- }
  2049.  
  2050. Procedure FReadOld (Var Buf; RecLen : Word);
  2051. Var
  2052.   I  :  Word;
  2053.   B  :  Array [1..MaxInt] Of Byte Absolute Buf;
  2054. Begin
  2055.   For I := 1 To RecLen Do B [I] := Get_Zip;
  2056. End {FRead} ;
  2057.  
  2058. Procedure FRead (Var Buf; RecLen : Word);
  2059. Type   TB  =  Array [1..MaxInt] Of Byte;
  2060. Var
  2061.   I  :  Word;
  2062.   pB :  ^TB;
  2063. Begin
  2064.   pB:=@Buf;
  2065.   For I := 1 To RecLen Do begin pB^[i]:= Get_Zip; end;
  2066. End {FRead} ;
  2067.  
  2068. Procedure FReadStr (Var Buf :string; RecLen : Word);
  2069. Var
  2070.   I  :  Word;
  2071.   ch :  char;
  2072. Begin
  2073.   Buf:='';
  2074.   For I := 1 To RecLen Do
  2075.    begin
  2076.       ch:=chr(Get_Zip);
  2077.       if i<=255 then Buf:=Buf + ch;
  2078.    end;   
  2079. End {FRead} ;
  2080.  
  2081. { --------------------------------------------------------------------------- }
  2082.  
  2083. Function Read_Local_Hdr : Boolean;
  2084. Var
  2085.    Sig : LongInt;
  2086. Begin
  2087.   If EndFile Then Result := False
  2088.   Else Begin
  2089.     FRead (Sig, SizeOf (Sig) );
  2090.     If Sig = CENTRAL_FILE_HEADER_SIGNATURE Then Begin
  2091.       Result := False;
  2092.       EndFile        := True;
  2093.     End {then}
  2094.     Else Begin
  2095.       If Sig <> LOCAL_FILE_HEADER_SIGNATURE Then
  2096.         Abort ('Hlava chybφ nebo je poÜkozena u ' + ZipName);
  2097.       FRead (LocalHdr, SizeOf (LocalHdr) );
  2098.       With LocalHdr Do
  2099.        Begin
  2100.         If LocalHdr.FileName_Length > 255 Then
  2101.           Abort ({$IFNDEF English}'JmΘno je chybnΘ !'{$ELSE}'Invalid file name !'{$ENDIF});
  2102.         FReadStr (Hdr_FileName, LocalHdr.FileName_Length);
  2103.         If LocalHdr.Extra_Field_Length > 255 Then
  2104.           Abort ({$IFNDEF English}'JmΘno je chybnΘ !'{$ELSE}'Invalid file name !'{$ENDIF});
  2105.         FReadStr (Hdr_ExtraField, LocalHdr.Extra_Field_Length);
  2106.        End {with} ;
  2107.       Result := True;
  2108.     End {if} ;
  2109.   End {if} ;
  2110. End {Read_Local_Hdr} ;
  2111.  
  2112. { --------------------------------------------------------------------------- }
  2113.  
  2114. Function Get_Compressed : Smallint;
  2115. Var
  2116.   PctDone : Smallint;
  2117.   {Smsg : String;}
  2118. Begin
  2119.   If Bytes_To_Go = 0 Then Result := - 1
  2120.   Else Begin
  2121.     Result := Get_Zip;
  2122.     {If Bytes_To_Go Mod TenPercent = 0 Then }Begin
  2123.       PctDone := 100 - Round ( 100 * (Bytes_To_Go / LocalHdr. Compressed_Size) );
  2124.       {zde je volana udalost pro upravu nejakeho meridla}
  2125.       If AsSigned(FOnProgress) Then
  2126.         FOnProgress(Self,PctDone);
  2127.       {Smsg := PadCh (CharStr (' ', (PctDone+10) Div 10), ' ', 10);}
  2128.     End {if} ;
  2129.     Dec (Bytes_To_Go);
  2130.   End {if} ;
  2131. End {Get_Compressed} ;
  2132.  
  2133. { --------------------------------------------------------------------------- }
  2134.  
  2135. Function LZW_Init : Boolean;
  2136. Var
  2137. //   RC       :  Word;
  2138.    I        :  Word;
  2139. Begin
  2140.   { Initialize LZW Table }
  2141.   try
  2142.     GetMem(LZW_Table, SizeOf (LZW_Table^))
  2143.   except
  2144.   on EOutOfMemory do
  2145.   Begin
  2146.     Result := False;
  2147.     Exit;
  2148.   End {if} ;
  2149.   end;
  2150.  
  2151. //  If MaxAvail > SizeOf (LZW_Table^) Then GetMem(LZW_Table, SizeOf (LZW_Table^))
  2152. //  Else Begin
  2153. //    Result := False;
  2154. //    Exit;
  2155. //  End {if} ;
  2156.   For I := 0 To LZW_TABLE_SIZE Do With LZW_Table^ [I] Do Begin
  2157.     Prefix     := - 1;
  2158.     If I < 256 Then Suffix  := I Else Suffix  := 0;
  2159.     ChildCount := 0;
  2160.   End {with-for} ;
  2161.  
  2162. // predelal IvanP
  2163.   try
  2164.     GetMem(FreeList, SizeOf (FreeList^))
  2165.   except
  2166.   on EOutOfMemory do
  2167.   Begin
  2168.     {pripadne alokovanou tabulku uvolni}
  2169.     FreeMem(LZW_Table, SizeOf (LZW_Table^));
  2170.     Exit;
  2171.   End {if} ;
  2172.   end;
  2173. //  If MaxAvail > SizeOf (FreeList^) Then GetMem(FreeList, SizeOf (FreeList^))
  2174. //  Else Begin
  2175. //    Result := False;
  2176. //    {pripadne alokovanou tabulku uvolni}
  2177. //    FreeMem(LZW_Table, SizeOf (LZW_Table^));
  2178. //    Exit;
  2179. //  End {if} ;
  2180.  
  2181.   For I := FIRSTFREE To LZW_TABLE_SIZE Do FreeList^ [I] := I;
  2182.   NextFree := FIRSTFREE;
  2183.   { Initialize the LZW Character Stack }
  2184.  
  2185. // Dodelal  IvanP
  2186.   try
  2187.     GetMem(LZW_Stack,SizeOf(LZW_Stack^))
  2188.   except
  2189.   on EOutOfMemory do
  2190.   Begin
  2191.     {pripadne alokovanou tabulku uvolni}
  2192.     FreeMem(LZW_Table, SizeOf (LZW_Table^));
  2193.     FreeMem(FreeList, SizeOf (FreeList^));
  2194.     Exit;
  2195.   End {if} ;
  2196.   end;
  2197.  
  2198. //  If MaxAvail > SizeOf (LZW_Stack^) Then GetMem(LZW_Stack,SizeOf(LZW_Stack^))
  2199. //  Else Begin
  2200. //    Result := False;
  2201. //    {pripadne alokovanou tabulku uvolni}
  2202. //    FreeMem(LZW_Table, SizeOf (LZW_Table^));
  2203. //    FreeMem(FreeList, SizeOf (FreeList^));
  2204. //    Exit;
  2205. //  End {if} ;
  2206.   StackIdx := 0;
  2207.   Result := True;
  2208. End {LZW_Init} ;
  2209.  
  2210. { --------------------------------------------------------------------------- }
  2211.  
  2212. Procedure LZW_Cleanup;
  2213. //Var
  2214. //   Code : Word;
  2215. Begin
  2216.   FreeMem(LZW_Table,SizeOf (LZW_Table^));
  2217.   FreeMem(FreeList,SizeOf (FreeList^));
  2218.   FreeMem(LZW_Stack,SizeOf (LZW_Stack^));
  2219. End {LZW_Cleanup} ;
  2220.  
  2221. { --------------------------------------------------------------------------- }
  2222.  
  2223. Procedure Clear_LZW_Table;
  2224. Var
  2225.    I      :  Word;
  2226. Begin
  2227.   StackIdx := 0;
  2228.   For I := FIRSTFREE To LZW_TABLE_SIZE Do Begin      { Find all leaf nodes }
  2229.     If LZW_Table^ [I].ChildCount = 0 Then Begin
  2230.       LZW_Stack^ [StackIdx] := I;                   { and put each on stack }
  2231.       Inc (StackIdx);
  2232.     End {if} ;
  2233.   End {for} ;
  2234.   NextFree := Succ (LZW_TABLE_SIZE);
  2235.   While StackIdx > 0 Do Begin                        { clear all leaf nodes }
  2236.     Dec (StackIdx);
  2237.     I := LZW_Stack^ [StackIdx];
  2238.     With LZW_Table^ [I] Do Begin
  2239.       If LZW_Table^ [I].Prefix <> - 1 Then
  2240.         Dec (LZW_Table^ [Prefix].ChildCount);
  2241.       Prefix     := - 1;
  2242.       Suffix     :=  0;
  2243.       ChildCount :=  0;
  2244.     End {with} ;
  2245.     Dec (NextFree);                         { add cleared nodes to freelist }
  2246.     FreeList^ [NextFree] := I;
  2247.   End {while} ;
  2248. End {Clear_LZW_Table} ;
  2249.  
  2250. { --------------------------------------------------------------------------- }
  2251.  
  2252. Procedure Add_To_LZW_Table (Prefix : Smallint; Suffix : Byte);
  2253. Var
  2254.   I  :  Word;
  2255. Begin
  2256.   If NextFree <= LZW_TABLE_SIZE Then Begin
  2257.     I := FreeList^ [NextFree];
  2258.     Inc (NextFree);
  2259.     LZW_Table^ [I].Prefix     := Prefix;
  2260.     LZW_Table^ [I].Suffix     := Suffix;
  2261.     Inc (LZW_Table^ [Prefix].ChildCount);
  2262.   End {if} ;
  2263. End {Add_To_LZW_Table} ;
  2264.  
  2265. { --------------------------------------------------------------------------- }
  2266.  
  2267. Function GetCode (CodeSize : Byte) : Smallint;
  2268. Const
  2269.   Mask : Array [1..8] Of Byte = ($01,$03,$07,$0F,$1F,$3F,$7F,$FF);
  2270.   TmpInt : Smallint = 0;
  2271. Var
  2272.   BitsNeeded : Byte;
  2273.   HowMany    : Byte;
  2274.   HoldCode   : Smallint;
  2275. Label
  2276.   Exit;
  2277. Begin
  2278.   If FirstCh Then Begin                  { If first time through ...         }
  2279.     TmpInt := Get_Compressed;            { ... then prime the code buffer    }
  2280.     If TmpInt = - 1 Then Begin           { If EOF on fill attempt ...        }
  2281.       GetCode := - 1;                    { ... then return EOF indicator ... }
  2282.       Goto Exit;                         { ... and return to caller.         }
  2283.     End {if} ;
  2284.     SaveByte := TmpInt;
  2285.     BitsLeft := 8;                       { there's now 8 bits in our buffer  }
  2286.     FirstCh  := False;
  2287.   End {if} ;
  2288.   BitsNeeded := CodeSize;
  2289.   HoldCode   := 0;
  2290.   While (BitsNeeded > 0) And (TmpInt <> - 1) Do Begin
  2291.     If BitsNeeded >= BitsLeft Then HowMany := BitsLeft{ HowMany <-- Min(BitsLeft, BitsNeeded) }
  2292.     Else HowMany := BitsNeeded;
  2293.     HoldCode := HoldCode Or ( (SaveByte And Mask [HowMany] ) ShL (CodeSize - BitsNeeded) );
  2294.     SaveByte := SaveByte ShR HowMany;
  2295.     Dec (BitsNeeded, HowMany);
  2296.     Dec (BitsLeft, HowMany);
  2297.     If BitsLeft <= 0 Then Begin          { If no bits left in buffer ...     }
  2298.       TmpInt := Get_Compressed;          { ... then attempt to get 8 more.   }
  2299.       If TmpInt = - 1 Then
  2300.         Goto Exit;
  2301.       SaveByte := TmpInt;
  2302.       BitsLeft := 8;
  2303.     End {if} ;
  2304.   End {while} ;
  2305.   Exit:
  2306.   If (BitsNeeded = 0) Then                  { If we got what we came for ... }
  2307.     GetCode := HoldCode                     { ... then return it             }
  2308.   Else
  2309.     GetCode := - 1;                         { ... Otherwise, return EOF      }
  2310. End {GetCode} ;
  2311.  
  2312. { --------------------------------------------------------------------------- }
  2313.  
  2314. Procedure UnShrink;
  2315. Var
  2316. //  CH       :  Char;
  2317.   CodeSize :  Byte;          { Current size (in bits) of codes coming in  }
  2318.   CurrCode :  Smallint;
  2319.   SaveCode :  Smallint;
  2320.   PrevCode :  Smallint;
  2321.   BaseChar :  Byte;
  2322. Begin
  2323.   CodeSize := MINCODESIZE;               { Start with the smallest code size }
  2324.   PrevCode := GetCode (CodeSize);        { Get first code from file          }
  2325.   If PrevCode = - 1 Then                 { If EOF already, then ...          }
  2326.     Exit;                                { ... just exit without further ado }
  2327.   BaseChar := PrevCode;
  2328.   Put_Ext (BaseChar);                    { Unpack the first character        }
  2329.   CurrCode := GetCode (CodeSize);        { Get next code to prime the while loop }
  2330.   While CurrCode <> - 1 Do Begin         { Repeat for all compressed bytes   }
  2331.     If CurrCode = SPECIAL Then Begin     { If we've got a "special" code ... }
  2332.       CurrCode := GetCode (CodeSize);
  2333.       Case CurrCode Of
  2334.         1: Begin                         { ... and if followed by a 1 ...    }
  2335.           Inc (CodeSize);                { ... then increase code size       }
  2336.         End {1} ;
  2337.         2: Begin                         { ... and if followed by a 2 ...    }
  2338.           Clear_LZW_Table;               { ... clear leaf nodes in the table }
  2339.         End {2} ;
  2340.         Else  Begin                      { ... if neither 1 or 2, discard    }
  2341.           Abort('K≤d Üpatn∞ navazuje ! PokraΦujem...');
  2342.         End {else} ;
  2343.       End {case} ;
  2344.     End {then}
  2345.     Else Begin                          { Not a "special" code              }
  2346.       SaveCode := CurrCode;            { Save this code someplace safe...  }
  2347.       If CurrCode > LZW_TABLE_SIZE Then
  2348.         Abort('K≤d se jevφ chybn² !');
  2349.       If (CurrCode >= FIRSTFREE) And (LZW_Table^ [CurrCode].Prefix = - 1) Then Begin
  2350.         If StackIdx > LZW_STACK_SIZE Then Begin
  2351.           Write_Ext_Block;
  2352.           Abort('Promi≥te, p°etekl mi zßsobnφk ('+Long2Str(StackIdx)+')!');
  2353.           Exit;{musis vystoupit}
  2354.         End {if} ;
  2355.         LZW_Stack^ [StackIdx] := BaseChar;
  2356.         Inc (StackIdx);
  2357.         CurrCode := PrevCode;
  2358.       End {if} ;
  2359.       While CurrCode >= FIRSTFREE Do Begin
  2360.         If StackIdx > LZW_STACK_SIZE Then Begin
  2361.           Write_Ext_Block;
  2362.           Abort('Promi≥te, p°etekl mi zßsobnφk ('+Long2Str(StackIdx)+')!');
  2363.           Exit;{musis vystoupit}
  2364.         End {if} ;
  2365.         LZW_Stack^ [StackIdx] := LZW_Table^ [CurrCode].Suffix;
  2366.         Inc (StackIdx);
  2367.         CurrCode := LZW_Table^ [CurrCode].Prefix;
  2368.       End {while} ;
  2369.       BaseChar := LZW_Table^ [CurrCode].Suffix;   { Get last character ...   }
  2370.       Put_Ext (BaseChar);
  2371.       While (StackIdx > 0) Do Begin
  2372.         Dec (StackIdx);
  2373.         Put_Ext (LZW_Stack^ [StackIdx] );
  2374.       End {while} ;                      { ... until there are none left     }
  2375.       Add_to_LZW_Table (PrevCode, BaseChar);   { Add new entry to table      }
  2376.  
  2377.       PrevCode := SaveCode;
  2378.  
  2379.     End {if} ;
  2380.  
  2381.     CurrCode := GetCode (CodeSize);      { Get next code from input stream   }
  2382.  
  2383.   End {while} ;
  2384.  
  2385. End {UnShrink} ;
  2386.  
  2387. { --------------------------------------------------------------------------- }
  2388.  
  2389. Function Init_UnReduce : Boolean;
  2390. //Var
  2391. //   Code : Word;
  2392. Begin
  2393. // Dodelal IvanP
  2394.   Result := False;
  2395.   try
  2396.     GetMem(Followers, SizeOf (Followers^))
  2397.   except
  2398.   on EOutOfMemory do
  2399.   Begin
  2400.     Exit;
  2401.   End {if} ;
  2402.   end;
  2403.  
  2404.   DictSize := 4096;
  2405.  
  2406.   try
  2407.     GetMem(Dictionary,DictSize)
  2408.   except
  2409.   on EOutOfMemory do
  2410.   Begin
  2411.     {uvolni jiz alokovane tabulky}
  2412.     FreeMem(Followers, SizeOf (Followers^));
  2413.     Exit;
  2414.   End {if} ;
  2415.   end;
  2416.  
  2417. //  If MaxAvail > SizeOf (Followers^) Then GetMem(Followers, SizeOf (Followers^))
  2418. //  Else Begin
  2419. //    Result := False;
  2420. //    Exit;
  2421. //  End {if} ;
  2422. //
  2423. //  DictSize := 4096;
  2424. //  If MaxAvail > DictSize Then GetMem(Dictionary,DictSize)
  2425. //  Else Begin
  2426. //    Result := False;
  2427. //    {uvolni jiz alokovane tabulky}
  2428. //    FreeMem(Followers, SizeOf (Followers^));
  2429. //    Exit;
  2430. //  End {if} ;
  2431.  
  2432.   Result := True;
  2433. End {Init_UnReduce} ;
  2434.  
  2435. { --------------------------------------------------------------------------- }
  2436.  
  2437. Procedure Cleanup_UnReduce;
  2438. //Var
  2439. //  Code : Word;
  2440. Begin
  2441.   FreeMem(Followers,SizeOf (Followers^));
  2442.   FreeMem(Dictionary,DictSize);
  2443. End {Cleanup_UnReduce} ;
  2444.  
  2445. { --------------------------------------------------------------------------- }
  2446.  
  2447. Function D (X, Y : Byte) : Word;
  2448. Var
  2449.   tmp : LongInt;
  2450. Begin
  2451.   X := X ShR (8 - Pred (LocalHdr. Compress_Method) );
  2452.   Tmp := X * 256;
  2453.   D := Tmp + Y + 1;
  2454. End {D} ;
  2455.  
  2456. { --------------------------------------------------------------------------- }
  2457.  
  2458. Function F (X : Word) : Byte;
  2459. Const
  2460.   TestVal : Array [1..4] Of Byte = (127, 63, 31, 15);
  2461. Begin
  2462.   If X = TestVal [Pred (LocalHdr. Compress_Method) ] Then F := 2 Else F := 3;
  2463. End {F} ;
  2464.  
  2465. { --------------------------------------------------------------------------- }
  2466.  
  2467. Function L (X : Byte) : Byte;
  2468. Const
  2469.    Mask : Array [1..4] Of Byte = ($7F, $3F, $1F, $0F);
  2470. Begin
  2471.   L := X And Mask [Pred (LocalHdr. Compress_Method) ];
  2472. End {L} ;
  2473.  
  2474. { --------------------------------------------------------------------------- }
  2475.  
  2476. Procedure UpdateDictionary (C : Byte);
  2477. Begin
  2478.   Put_Ext (C);
  2479.   Dictionary^ [DictIdx] := C;
  2480.   DictIdx := Succ (DictIdx) Mod DictSize;
  2481. End {UpdateDictionary} ;
  2482.  
  2483. { --------------------------------------------------------------------------- }
  2484.  
  2485. Procedure DictionaryInit;
  2486. Begin
  2487.   State := 0;
  2488.   FillChar (Dictionary^ [0], DictSize, $00);
  2489.   DictIdx := 0;
  2490. End {DictionaryInit} ;
  2491.  
  2492. { --------------------------------------------------------------------------- }
  2493.  
  2494. Procedure UnScrnch (C : Byte);
  2495. Const
  2496.    DLE   =  $90;
  2497. Var
  2498.    S           :  Smallint;
  2499.    Count       :  Word;
  2500.    OneByte     :  Byte;
  2501.    Tmp1        :  LongInt;
  2502. Begin
  2503.   Case State Of
  2504.     0:If C = DLE Then State := 1 Else UpdateDictionary (C);
  2505.     1: Begin
  2506.       If C = 0 Then Begin
  2507.         UpdateDictionary (DLE);
  2508.         State := 0;
  2509.       End {then}
  2510.       Else Begin
  2511.         V     := C;
  2512.         Len   := L (V);
  2513.         State := F (Len);
  2514.       End {if} ;
  2515.     End {1} ;
  2516.     2: Begin
  2517.       Inc (Len, C);
  2518.       State := 3;
  2519.     End {2} ;
  2520.     3: Begin
  2521.       Tmp1 := D (V, C);
  2522.       S    := DictIdx - Tmp1;
  2523.       If S < 0 Then
  2524.         S := S + DictSize;
  2525.       Count := Len + 3;
  2526.       While Count > 0 Do Begin
  2527.         OneByte := Dictionary^ [S];
  2528.         UpdateDictionary (OneByte);
  2529.         S := Succ (S) Mod DictSize;
  2530.         Dec (Count);
  2531.       End {while} ;
  2532.       State := 0;
  2533.     End {3} ;
  2534.   End {case} ;
  2535. End {UnScrnch} ;
  2536.  
  2537. { --------------------------------------------------------------------------- }
  2538.  
  2539. Function MinBits (Val : Byte) : Byte;
  2540. Begin
  2541.   Dec (Val);
  2542.   Case Val Of
  2543.     0..1  : MinBits := 1;
  2544.     2..3  : MinBits := 2;
  2545.     4..7  : MinBits := 3;
  2546.     8..15 : MinBits := 4;
  2547.     16..31: MinBits := 5;
  2548.   Else
  2549.     MinBits := 6;
  2550.   End {case} ;
  2551. End {MinBits} ;
  2552.  
  2553. { --------------------------------------------------------------------------- }
  2554.  
  2555. Procedure UnReduce;
  2556. Var
  2557.   LastChar    :  Byte;
  2558.   N           :  Byte;
  2559.   I, J        :  Word;
  2560.   Code        :  Smallint;
  2561. //  CH          :  Char;
  2562. Begin
  2563.   For I := 255 Downto 0 Do Begin          { Load follower sets }
  2564.     N := GetCode (6);                { Get size of 1st set }
  2565.     Followers^ [I].SetSize := N;
  2566.     If N > 0 Then
  2567.       For J := 0 To Pred (N) Do
  2568.         Followers^ [I].FSet [J] := GetCode (8);
  2569.   End {for} ;
  2570.   DictionaryInit;
  2571.   LastChar := 0;
  2572.   Repeat
  2573.     If Followers^ [LastChar].SetSize = 0 Then Begin
  2574.       Code := GetCode (8);
  2575.       UnScrnch (Code);
  2576.       LastChar := Code;
  2577.     End {then}
  2578.     Else Begin
  2579.       Code := GetCode (1);
  2580.       If Code <> 0 Then Begin
  2581.         Code := GetCode (8);
  2582.         UnScrnch (Code);
  2583.         LastChar := Code;
  2584.       End {then}
  2585.       Else Begin
  2586.         I := MinBits (Followers^ [LastChar].SetSize);
  2587.         Code := GetCode (I);
  2588.         UnScrnch (Followers^ [LastChar].FSet [Code] );
  2589.         LastChar := Followers^ [LastChar].FSet [Code];
  2590.       End {if} ;
  2591.     End {if} ;
  2592.   Until (ExtCount = LocalHdr. Uncompressed_Size);
  2593.   FreeMem(Followers,SizeOf (Followers^))
  2594.   {Code := Dalloc (Followers);}
  2595. End {UnReduce} ;
  2596.  
  2597. { --------------------------------------------------------------------------- }
  2598.  
  2599. Function Init_Explode: Boolean;
  2600. { Get ready to unimplode }
  2601. //Var
  2602. //  RC      : Word;
  2603. Begin
  2604.   Result := False;
  2605.   { Extract pertinent info from the general purpose bit flag                 }
  2606.   DictSize    := ( ( (LocalHdr. Bit_Flag ShR 1) And $01) * 4096) + 4096;
  2607.   NumOfTrees  := ( ( LocalHdr. Bit_Flag ShR 2) And $01) + 2;
  2608.   MinMatchLen := NumOfTrees;
  2609.   { Allocate memory for the Length & Distance Shannon-Fano trees             }
  2610. // Dodelal IvanP
  2611.   try
  2612.     GetMem(SF_Length,SizeOf(SF_Length^))
  2613.   except
  2614.   on EOutOfMemory do exit
  2615.   end;
  2616.   try
  2617.     GetMem(SF_Distance,SizeOf(SF_Distance^))
  2618.   except
  2619.   on EOutOfMemory do
  2620.   Begin
  2621.     FreeMem(SF_Length,SizeOf(SF_Length^)); {uvolni jiz alokovane tabulky}
  2622.     Exit;
  2623.   End;
  2624.   end;
  2625. //  If MaxAvail > SizeOf(SF_Length^) Then GetMem(SF_Length,SizeOf(SF_Length^))
  2626. //  Else Exit;
  2627. //  If MaxAvail > SizeOf(SF_Distance^) Then GetMem(SF_Distance,SizeOf(SF_Distance^))
  2628. //  Else Begin
  2629. //    {uvolni jiz alokovane tabulky}
  2630. //    FreeMem(SF_Length,SizeOf(SF_Length^));
  2631. //    Exit;
  2632. //  End;
  2633.  
  2634.   { Initialize Length & Distance nodes to all -1's and set the Next Free     }
  2635.   { Node pointers for each                                                   }
  2636.   FillChar (SF_Length^,   SizeOf (SF_Length^),   $FF);
  2637.   NextFreeLength   := Pred (LENGTH_TREE_ROOT);
  2638.   FillChar (SF_Distance^, SizeOf (SF_Distance^), $FF);
  2639.   NextFreeDistance := Pred (DISTANCE_TREE_ROOT);
  2640.   { If we need a literal tree, then allocate the memory , initialize the     }
  2641.   { nodes to all -1's, and set the Next Free Node pointer                    }
  2642.   SF_Literal:=Nil;{indikace nepouziti}
  2643.   If NumOfTrees = 3 Then Begin
  2644. // Dodelal IvanP
  2645.   try
  2646.     GetMem(SF_Literal,SizeOf(SF_Literal^))
  2647.   except
  2648.   on EOutOfMemory do
  2649.    Begin
  2650.       {uvolni jiz alokovane tabulky}
  2651.       FreeMem(SF_Length,SizeOf(SF_Length^));
  2652.       FreeMem(SF_Distance,SizeOf(SF_Distance^));
  2653.       Exit;
  2654.     End;
  2655.   end;
  2656.     FillChar (SF_Literal^, SizeOf (SF_Literal^), $FF);
  2657.     NextFreeLiteral := Pred (LITERAL_TREE_ROOT);
  2658.   End {if} ;
  2659.  
  2660. //    If MaxAvail > SizeOf(SF_Literal^) Then GetMem(SF_Literal,SizeOf(SF_Literal^))
  2661. //    Else Begin
  2662. //      {uvolni jiz alokovane tabulky}
  2663. //      FreeMem(SF_Length,SizeOf(SF_Length^));
  2664. //      FreeMem(SF_Distance,SizeOf(SF_Distance^));
  2665. //      Exit;
  2666. //    End;
  2667.  
  2668.   { Allocate memory for the sliding dictionary                               }
  2669. // Dodelal IvanP
  2670.   try
  2671.     GetMem(Dictionary,DictSize)
  2672.   except
  2673.   on EOutOfMemory do
  2674.   Begin
  2675.     {uvolni jiz alokovane tabulky}
  2676.     FreeMem(SF_Length,SizeOf(SF_Length^));
  2677.     FreeMem(SF_Distance,SizeOf(SF_Distance^));
  2678.     If SF_Literal<>Nil Then FreeMem(SF_Literal,SizeOf(SF_Literal^));
  2679.     Exit;
  2680.   End;
  2681.   end;
  2682.  
  2683. //  If MaxAvail > DictSize Then GetMem(Dictionary,DictSize)
  2684. //  Else Begin
  2685. //    {uvolni jiz alokovane tabulky}
  2686. //    FreeMem(SF_Length,SizeOf(SF_Length^));
  2687. //    FreeMem(SF_Distance,SizeOf(SF_Distance^));
  2688. //    If SF_Literal<>Nil Then FreeMem(SF_Literal,SizeOf(SF_Literal^));
  2689. //    Exit;
  2690. //  End;
  2691.  
  2692.   {RC := Malloc (Dictionary,  DictSize);
  2693.   Failure := Failure OR (RC <> 0);}
  2694.  
  2695.   { Allocate memory for the array used in building the SF-Trees              }
  2696. // Dodelal IvanP
  2697.   try
  2698.     GetMem(SF_Build,SizeOf(SF_Build^))
  2699.   except
  2700.   on EOutOfMemory do
  2701.   Begin
  2702.     {uvolni jiz alokovane tabulky}
  2703.     FreeMem(SF_Length,SizeOf(SF_Length^));
  2704.     FreeMem(SF_Distance,SizeOf(SF_Distance^));
  2705.     If SF_Literal<>Nil Then FreeMem(SF_Literal,SizeOf(SF_Literal^));
  2706.     FreeMem(Dictionary,DictSize);
  2707.     Exit;
  2708.   End;
  2709.   end;
  2710. //  If MaxAvail > SizeOf(SF_Build^) Then GetMem(SF_Build,SizeOf(SF_Build^))
  2711. //  Else Begin
  2712. //    {uvolni jiz alokovane tabulky}
  2713. //    FreeMem(SF_Length,SizeOf(SF_Length^));
  2714. //    FreeMem(SF_Distance,SizeOf(SF_Distance^));
  2715. //    If SF_Literal<>Nil Then FreeMem(SF_Literal,SizeOf(SF_Literal^));
  2716. //    FreeMem(Dictionary,DictSize);
  2717. //    Exit;
  2718. //  End;
  2719.  
  2720.   { If any memory allocations failed, deallocate any memory that may have    }
  2721.   { been successfully allocated.                                             }
  2722.   { Return either success or failure }
  2723.   Result := True;
  2724. End { Init_Explode } ;
  2725.  
  2726. { --------------------------------------------------------------------------- }
  2727.  
  2728. Procedure Cleanup_Explode;
  2729. { Clean things up after unimploding a file }
  2730. //Var
  2731. //  RC :  Word;
  2732. Begin
  2733.   FreeMem(SF_Length,SizeOf(SF_Length^));
  2734.   FreeMem(SF_Distance,SizeOf(SF_Distance^));
  2735.   If SF_Literal<>Nil Then FreeMem(SF_Literal,SizeOf(SF_Literal^));
  2736.   FreeMem(Dictionary,DictSize);
  2737.   FreeMem(SF_Build,SizeOf(SF_Build^))
  2738. End { Cleanup_Explode } ;
  2739.  
  2740. { --------------------------------------------------------------------------- }
  2741.  
  2742. Procedure Bad_SF_Tree;
  2743. Begin
  2744.   {Chybn² Shannon-Fano dek≤dovacφ strom !}
  2745.   Abort ('Chybn² dek≤dovacφ strom !');
  2746. End { Bad_SF_Tree } ;
  2747.  
  2748. { --------------------------------------------------------------------------- }
  2749.  
  2750. Procedure Add_SF_SubTree ( Var SF_Tree;
  2751.                            Var SF_NextFree    : Word;
  2752.                               SF_Root         : Word;
  2753.                               SF_Code         : Word;
  2754.                               SF_Code_Length  : Byte;
  2755.                               SF_Value        : Byte );
  2756. { Add the subtree defined by SF_Code to a Shannon-Fano tree                   }
  2757. Var
  2758.   SF_Array :  Array [0..MAX_SF_TREE_SIZE] Of SF_Node Absolute SF_Tree;
  2759.   CurrNode :  Word;
  2760.   LastLeaf :  Word;
  2761.   I        :  Byte;
  2762. Begin
  2763.   { The Shannon-Fano tree is implemented as an array of records. Each        }
  2764.   { record contains both left and right pointers (ie. this is a binary       }
  2765.   { tree).  The root of the tree is the last array element. The first N      }
  2766.   { elements (0..N-1) are defined to be the "leaves" of the tree (ie. they   }
  2767.   { represent the characters that the decode algorithm will generate).  N    }
  2768.   { may be 64 (for the length tree), 128 (for the distance tree), or 256     }
  2769.   { (for the Literal tree). The remaining elements of the array are used to  }
  2770.   { represent the non-leaf and non-root nodes of the tree.                   }
  2771.   CurrNode := SF_Root;
  2772.   LastLeaf := Pred (Succ (SF_Root) Div 2);
  2773.   { All bits in the code except the least significant define non-leaf nodes  }
  2774.   { in the tree.  Process these first.                                       }
  2775.   For I := Pred (SF_Code_Length) Downto 1 Do Begin
  2776.     If CurrNode <= LastLeaf Then Bad_SF_Tree;
  2777.     If Boolean ( (SF_Code ShR I) And $0001) Then Begin   { if the bit is a 1  }
  2778.       If SF_Array [CurrNode].RChild = - 1 Then Begin    { no RChild yet      }
  2779.         SF_Array [CurrNode].RChild := SF_NextFree;
  2780.         Dec (SF_NextFree);
  2781.       End {if} ;
  2782.       CurrNode := SF_Array [CurrNode].RChild;       { on 1 bits, follow the }
  2783.       { right subtree         }
  2784.     End { then }
  2785.     Else Begin                                         { the bit is a 0     }
  2786.       If SF_Array [CurrNode].LChild = - 1 Then Begin    { no LChild yet      }
  2787.         SF_Array [CurrNode].LChild := SF_NextFree;
  2788.         Dec (SF_NextFree);
  2789.       End {if} ;
  2790.       CurrNode := SF_Array [CurrNode].LChild;       { on 0 bits, follow the }
  2791.       { left subtree          }
  2792.     End { if } ;
  2793.   End { for } ;
  2794.   { All that's left now is to process the least significant bit of the code. }
  2795.   { This will define a leaf node.  The leaf node to be linked is defined by  }
  2796.   { the SF_Value that is passed to the procedure.                            }
  2797.   If Boolean (SF_Code And $0001) Then
  2798.     If SF_Array [CurrNode].RChild <> - 1 Then
  2799.       Bad_SF_Tree
  2800.     Else
  2801.       SF_Array [CurrNode].RChild := SF_Value
  2802.   Else
  2803.     If SF_Array [CurrNode].LChild <> - 1 Then
  2804.       Bad_SF_Tree
  2805.     Else
  2806.       SF_Array [CurrNode].LChild := SF_Value;
  2807. End { Add_SF_SubTree } ;
  2808.  
  2809. { --------------------------------------------------------------------------- }
  2810.  
  2811. Procedure Sort_SF_Build_Array ( Count : Word );
  2812.  
  2813.    Procedure Exchange (Var Node1, Node2 : SF_BuildRec);
  2814.    Var
  2815.       Node3 : SF_BuildRec;
  2816.    Begin
  2817.      Node3.Len  := Node1.Len;
  2818.      Node3.Val  := Node1.Val;
  2819.      { Node3.Code := Node1.Code; }   { the Code field is irrelevant at this point }
  2820.      Node1.Len  := Node2.Len;
  2821.      Node1.Val  := Node2.Val;
  2822.      { Node1.Code := Node2.Code; }   { ditto }
  2823.      Node2.Len  := Node3.Len;
  2824.      Node2.Val  := Node3.Val;
  2825.      { Node2.Code := Node3.Code; }   { ditto again }
  2826.    End { Exchange } ;
  2827.  
  2828.    Function ShouldSwap ( P1, P2 : SF_BuildRec ) : Boolean;
  2829.    Begin
  2830.      ShouldSwap := (P1.Len>P2.Len) Or ((P1.Len=P2.Len) And (P1.Val>P2.Val))
  2831.    End { ShouldSwap } ;
  2832.  
  2833.    Procedure Sort (lb, ub : Smallint);
  2834.  
  2835.    (***** BUBBLE SORT **************************************************)
  2836.  
  2837.    (*  The list is scanned repeatedly, and adjacent items that are out of
  2838.        order are swapped.  When a pass occurs with no swaps, the list is
  2839.        sorted.  *)
  2840.  
  2841.    Var
  2842.      swapped : Boolean;
  2843.      cell    : Smallint;
  2844.    Begin
  2845.      Repeat
  2846.        swapped := False;
  2847.        For cell := lb To ub - 1 Do Begin
  2848.          If ShouldSwap (SF_Build^ [cell], SF_Build^ [cell + 1] ) Then Begin
  2849.            Exchange (SF_Build^ [cell], SF_Build^ [cell + 1] );
  2850.            swapped := True;
  2851.          End;
  2852.        End;
  2853.      Until (swapped = False);
  2854.    End;
  2855.  
  2856. Begin
  2857.   Sort (0, Count);
  2858. End { Sort_SF_Build_Array } ;
  2859.  
  2860. { --------------------------------------------------------------------------- }
  2861.  
  2862. Procedure Build_SF_Trees;
  2863. { Extract SF data from an imploded file and build the required SF trees }
  2864. Var
  2865.   OneByte              :  Byte;    { These "misc" variables are also used in }
  2866.   CodeLen              :  Byte;    { building the SF trees                   }
  2867.   CodeCount            :  Byte;
  2868.   SF_Table_Codes       :  Word;    { # of bytes representing SF tree data - 1}
  2869.   BuildCount           :  Word;    { total entries in SF_Build array         }
  2870.   Code                 :  Word;    { These three variables used in           }
  2871.   CodeIncrement        :  Word;    { constructing the Shannon-Fano codes     }
  2872.   LastBitLength        :  Word;    { that will be used to build the SF trees }
  2873.   WhichTree            :  Word;    { Counter indicating which SF tree is     }
  2874.                                    {   currently under construction          }
  2875.   SF_Tree              :  Pointer;
  2876.   SF_NextFree          :  Word;
  2877.   SF_Root              :  Word;
  2878.   I, J                 :  Word;    { Generic loop counter                    }
  2879. Begin
  2880.   For WhichTree := 1 To NumOfTrees Do Begin
  2881.     { Before we go any further, determine which subtree-add procedure       }
  2882.     { parameters will be needed on the call to Add_SF_SubTree               }
  2883.     Case NumOfTrees Of
  2884.       2:
  2885.         Case WhichTree Of
  2886.           1: Begin
  2887.             SF_Tree     := SF_Length;
  2888.             SF_NextFree := NextFreeLength;
  2889.             SF_Root     := LENGTH_TREE_ROOT;
  2890.           End { 1 } ;
  2891.           2: Begin
  2892.             SF_Tree     := SF_Distance;
  2893.             SF_NextFree := NextFreeDistance;
  2894.             SF_Root     := DISTANCE_TREE_ROOT;
  2895.           End { 2 } ;
  2896.         End { case whichtree } ;
  2897.       3:
  2898.         Case WhichTree Of
  2899.           1: Begin
  2900.             SF_Tree     := SF_Literal;
  2901.             SF_NextFree := NextFreeLiteral;
  2902.             SF_Root     := LITERAL_TREE_ROOT;
  2903.           End { 1 } ;
  2904.           2: Begin
  2905.             SF_Tree     := SF_Length;
  2906.             SF_NextFree := NextFreeLength;
  2907.             SF_Root     := LENGTH_TREE_ROOT;
  2908.           End { 2 } ;
  2909.           3: Begin
  2910.             SF_Tree     := SF_Distance;
  2911.             SF_NextFree := NextFreeDistance;
  2912.             SF_Root     := DISTANCE_TREE_ROOT;
  2913.           End { 3 } ;
  2914.         End { case whichtree } ;
  2915.     End { case numoftrees } ;
  2916.     { Build the Shannon-Fano tree                                           }
  2917.     SF_Build_Idx   := 0;
  2918.     BuildCount     := 0;
  2919.     SF_Table_Codes := GetCode (8);
  2920.     For I := 0 To SF_Table_Codes Do Begin
  2921.       { Load the SF_Build array with data from the compressed file         }
  2922.       OneByte     := GetCode (8);
  2923.       CodeLen     := (OneByte And $0F) + 1;
  2924.       CodeCount   := (OneByte ShR 4);
  2925.       For J := 0 To CodeCount Do Begin
  2926.         SF_Build^ [SF_Build_Idx].Len  := CodeLen;
  2927.         SF_Build^ [SF_Build_Idx].Val  := SF_Build_Idx;
  2928.         Inc (SF_Build_Idx);
  2929.       End { for J } ;
  2930.     End { for I } ;
  2931.     BuildCount := Pred (SF_Build_Idx);
  2932.     { Sort the SF_Build Array based on the Len field                        }
  2933.     Sort_SF_Build_Array (BuildCount);
  2934.     { Generate the SF codes that will be used to grow the SF tree using the }
  2935.     { algorithm outlined in the AppNote.Txt file (as distributed within the }
  2936.     { PKZip v1.0 self extracting ZIP archive).                              }
  2937.     Code           := 0;
  2938.     CodeIncrement  := 0;
  2939.     LastBitLength  := 0;
  2940.     For I := BuildCount Downto 0 Do Begin
  2941.       Inc (Code, CodeIncrement);
  2942.       If SF_Build^ [I].Len <> LastBitLength Then Begin
  2943.         LastBitLength := SF_Build^ [I].Len;
  2944.         CodeIncrement := 1 ShL (16 - LastBitLength);
  2945.       End {if} ;
  2946.       SF_Build^ [I].Code := Code ShR (16 - SF_Build^ [I].Len);
  2947.       { Ok, we've got a value and a code.  This represents a subtree in    }
  2948.       { the Shannon-Fano tree structure.  Add it to the appropriate tree.  }
  2949.       Add_SF_SubTree(SF_Tree^,SF_NextFree,SF_Root,SF_Build^[I].Code,
  2950.         SF_Build^[I].Len,SF_Build^[I].Val);
  2951.     End { for buildcount } ;
  2952.   End { for whichtree } ;
  2953. End { Build_SF_Trees } ;
  2954.  
  2955. { --------------------------------------------------------------------------- }
  2956.  
  2957. Procedure Bad_SF_Data;
  2958. Begin
  2959.   {Chybn² Shannon-Fano k≤d !}
  2960.   Abort ('┌pln∞ chybnΘ k≤dovßnφ !');
  2961. End { Bad_SF_Tree } ;
  2962.  
  2963. { --------------------------------------------------------------------------- }
  2964.  
  2965. Function Decode_SF_Data(Var SF_Tree;SF_Root : Word ) : Byte;
  2966. { Read bits from the input file and decode them using one of the 3 possible   }
  2967. { Shannon-Fano trees.  The method is idential to that used in decoding files  }
  2968. { encoded with the Huffman method (popularaly known as "squeezing") in that   }
  2969. { the tree is traced from the root to either the right or left depending on   }
  2970. { the last bit read until finally, one encounteres a leaf node.               }
  2971. Var
  2972.   SF_Array :  Array [0..MAX_SF_TREE_SIZE] Of SF_Node Absolute SF_Tree;
  2973.   OneBit   :  Byte;
  2974.   CurrNode :  Word;
  2975.   LastLeaf :  Word;
  2976. Begin
  2977.   CurrNode := SF_Root; { We start traversing the tree from it's root node    }
  2978.   LastLeaf := Pred (Succ (SF_Root) Div 2);
  2979.   While CurrNode > LastLeaf Do Begin
  2980.     { Walk the tree until you hit a leaf node                               }
  2981.     OneBit := GetCode (1);
  2982.     If Boolean (OneBit And $01) Then        { if the bit is a 1 ...          }
  2983.       If SF_Array [CurrNode].RChild = - 1 Then
  2984.         Bad_SF_Data
  2985.       Else
  2986.         CurrNode := SF_Array [CurrNode].RChild
  2987.     Else
  2988.       If SF_Array [CurrNode].LChild = - 1 Then
  2989.         Bad_SF_Data
  2990.       Else
  2991.         CurrNode := SF_Array [CurrNode].LChild
  2992.   End { while } ;
  2993.   Decode_SF_Data := CurrNode;
  2994. End { Decode_SF_Data } ;
  2995.  
  2996. { --------------------------------------------------------------------------- }
  2997.  
  2998. Procedure Explode;
  2999. Var
  3000.   OneByte     :  Byte;
  3001.   Literal     :  Byte;
  3002.   Length      :  Word;
  3003.   DistVal     :  Word;
  3004.   Distance    :  Word;
  3005.   DictStart   :  Smallint;
  3006. Begin
  3007.   Build_SF_Trees;
  3008.   DictionaryInit;
  3009.   Repeat
  3010.     OneByte := GetCode (1);
  3011.     If OneByte <> 0 Then Begin
  3012.       { This is literal data ... no dictionary lookup involved          }
  3013.       If NumOfTrees = 3 Then
  3014.         Literal := Decode_SF_Data (SF_Literal^, LITERAL_TREE_ROOT)
  3015.       Else
  3016.         Literal := GetCode (8);
  3017.       UpdateDictionary (Literal);
  3018.     End { then }
  3019.     Else Begin
  3020.       { Data for output will come from the sliding dictionary           }
  3021.       If DictSize = 8192 Then Begin
  3022.         Distance := GetCode (7);
  3023.         DistVal  := Decode_SF_Data (SF_Distance^, DISTANCE_TREE_ROOT);
  3024.         Distance := (Distance Or (DistVal ShL 7) ) And $1FFF;
  3025.       End {then}
  3026.       Else Begin
  3027.         Distance := GetCode (6);
  3028.         DistVal  := Decode_SF_Data (SF_Distance^, DISTANCE_TREE_ROOT);
  3029.         Distance := (Distance Or (DistVal ShL 6) ) And $0FFF;
  3030.       End {if} ;
  3031.       Length   := Decode_SF_Data ( SF_Length^, LENGTH_TREE_ROOT );
  3032.       If Length = 63 Then
  3033.         Length := Length + GetCode (8);
  3034.       Length := Length + MinMatchLen;
  3035.       DictStart := DictIdx - (Distance + 1);
  3036.       If DictStart < 0 Then
  3037.         DictStart := DictStart + DictSize;
  3038.       While Length > 0 Do Begin
  3039.         UpdateDictionary (Dictionary^ [DictStart] );
  3040.         DictStart := Succ (DictStart) Mod DictSize;
  3041.         Dec (Length);
  3042.       End {while} ;
  3043.     End {if} ;
  3044.   Until (ExtCount >= LocalHdr. Uncompressed_Size);
  3045. End { Explode } ;
  3046.  
  3047. { --------------------------------------------------------------------------- }
  3048.  
  3049. Procedure UnShrinkProc;
  3050. Begin
  3051.   If Not LZW_Init Then Begin
  3052.     Abort('Nenφ dost pam∞ti k rozmrsknutφ ! P°ekraΦuji ...');
  3053.     FSkip (LocalHdr. Compressed_Size);
  3054.     Crc32Val := Not LocalHdr. Crc32;
  3055.     Exit;
  3056.   End;
  3057.   Try
  3058.     UnShrink
  3059.   Finally
  3060.     LZW_Cleanup;
  3061.   End;
  3062. End;
  3063.  
  3064. Procedure UnReduceProc;
  3065. Begin
  3066.   If Not Init_UnReduce Then Begin
  3067.     Abort('Nenφ dost pam∞ti k rozvinutφ ! P°ekraΦuji ...');
  3068.     FSkip (LocalHdr. Compressed_Size);
  3069.     Crc32Val := Not LocalHdr. Crc32;
  3070.     Exit;
  3071.   End;
  3072.   Try
  3073.     UnReduce
  3074.   Finally
  3075.     Cleanup_UnReduce;
  3076.   End;
  3077. End;
  3078.  
  3079. Procedure UnExplodeProc;
  3080. Begin
  3081.   If Not Init_Explode Then Begin
  3082.     Abort('Nenφ dost pam∞ti k rozpnutφ ! P°ekraΦuji ...');
  3083.     FSkip (LocalHdr. Compressed_Size);
  3084.     Crc32Val := Not LocalHdr. Crc32;
  3085.     Exit;
  3086.   End;
  3087.   Try
  3088.     Explode
  3089.   Finally
  3090.     Cleanup_Explode;
  3091.   End;
  3092. End;
  3093.  
  3094. Procedure UnZipex;
  3095. //Var
  3096. //   C  :  Smallint;
  3097. //   PP :  Pointer;
  3098. Begin
  3099.   Crc32Val    := $FFFFFFFF;
  3100.   Bytes_To_Go := LocalHdr. Compressed_Size;
  3101.   FirstCh     := True;
  3102.   ExtCount    := 0;
  3103.   TenPercent := LocalHdr. Compressed_Size{ Div 10};
  3104.   {If TenPercent = 0 Then TenPercent := 1;}
  3105.   Case LocalHdr. Compress_Method Of
  3106.     0: Begin
  3107.       While Bytes_to_go > 0 Do
  3108.         Put_Ext (Get_Compressed);
  3109.     End {0 = Stored} ;
  3110.     1: Begin
  3111.       UnShrinkProc
  3112.     End {1 = shrunk} ;
  3113.     2..5  : Begin
  3114.       UnReduceProc
  3115.     End {2..5} ;
  3116.     6  : Begin
  3117.       UnExplodeProc
  3118.     End {6} ;
  3119.     Else     Begin
  3120.       Abort('Neznßmß svinovacφ metoda u₧itß na '+'['+ZipName+']: '+Hdr_FileName+'. P°ekraΦuji ...');
  3121.       FSkip (LocalHdr. Compressed_Size);
  3122.       Crc32Val := Not LocalHdr. Crc32;
  3123.     End {else} ;
  3124.   End {case} ;
  3125.   Crc32Val := Not Crc32Val;
  3126.   If Crc32Val <> LocalHdr. Crc32 Then Begin
  3127.     Abort('Soubor '+ OutPath + Hdr_FileName +' mß chybnΘ CRC ! Ulo₧en² CRC = '+
  3128.       HexLInt (LocalHdr. Crc32)+' VypoΦten² CRC = '+HexLInt (Crc32Val))
  3129.   End {if} ;
  3130. End {UnZipex} ;
  3131.  
  3132. { --------------------------------------------------------------------------- }
  3133.  
  3134. Procedure Extract_File(OverWrite:Boolean);
  3135. Var
  3136. //  YesNo  : Char;
  3137.   DosDTA : TSearchRec;
  3138. Begin
  3139.   If SysUtils.FindFirst (OutPath + Hdr_FileName, faAnyFile, DosDTA)= 0 Then Begin
  3140.     If Not OverWrite Then Begin
  3141.       FSkip (LocalHdr. Compressed_Size);
  3142.       Exit;
  3143.     End {if} ;
  3144.   End {if} ;
  3145.   If Open_Ext Then Begin
  3146.     UnZipex;
  3147.     Close_Ext;
  3148.   End {then}
  3149.   Else Begin
  3150.     FSkip (LocalHdr. Compressed_Size);
  3151.   End {If} ;
  3152. End {Extract_File} ;
  3153.  
  3154. { --------------------------------------------------------------------------- }
  3155.  
  3156. Procedure Extract_Zip;
  3157. Var
  3158.   Match : Boolean;
  3159.   I     : Word;
  3160. Begin
  3161.   Open_Zip;
  3162.   While Read_Local_Hdr Do Begin
  3163.     Match := False;
  3164.     I := 1;
  3165.     Repeat
  3166.       If SameFile (ExpandFileName(InFileSpecs [I]), ExpandFileName(Hdr_FileName)) Then Match := True;
  3167.       Inc (I);
  3168.     Until Match Or (I > MaxSpecs);
  3169.     If Match Then
  3170.       Extract_File(True) {tj. prepis vsechny}
  3171.     Else
  3172.       FSkip (LocalHdr. Compressed_Size);
  3173.   End {while} ;
  3174.   Close_Zip;
  3175. End;
  3176.  
  3177. { --------------------------------------------------------------------------- }
  3178.  
  3179. Begin
  3180.   {If Signum <> '' Then SignWork:=Signum;}
  3181.  { Showmessage(Prmline);    {*****}
  3182.   If Not Load_Parms (PrmLine) Then Exit;   { get command line parameters }
  3183.   If Not Initialize Then Exit;   { one-time initialization }
  3184.   Try
  3185.     Extract_Zip;  { de-arc the file }
  3186.   Finally
  3187.     Finalize
  3188.   End
  3189. End;
  3190.  
  3191. constructor TZip.Create(AOwner: TComponent);
  3192. begin
  3193.   inherited Create(AOwner);
  3194. end;
  3195.  
  3196. destructor TZip.Destroy;
  3197. begin
  3198.   inherited Destroy;
  3199. end;
  3200.  
  3201. Procedure TZip.SetFName(Name:String);
  3202. Begin
  3203.   FName := Name;
  3204. End;
  3205. Procedure TZip.SetParameters(Prm:String);
  3206. Begin
  3207.   FParam:=Prm;
  3208. End;
  3209.  
  3210. Function TZip.Execute:Boolean;
  3211. Begin
  3212.   {Screen.Cursor:=crHourGlass;}
  3213.   Crunch(FName+Spacer+FParam);
  3214.   {Screen.Cursor:=crDefault;}
  3215. End;
  3216.  
  3217. {-----------------------------------------------------------------}
  3218.  
  3219. constructor TUnZip.Create(AOwner: TComponent);
  3220. begin
  3221.   inherited Create(AOwner);
  3222. end;
  3223.  
  3224. destructor TUnZip.Destroy;
  3225. begin
  3226.   inherited Destroy;
  3227. end;
  3228. Procedure TUnZip.SetFName(Name:String);
  3229. Begin
  3230.   FName := Name;
  3231. End;
  3232. Procedure TUnZip.SetExtrPath(Path:String);
  3233. Begin
  3234.   FExtrPath:=Path;
  3235.   If FExtrPath<>'' Then
  3236.     If FExtrPath[Length(FExtrPath)]<>'\' Then
  3237.       FExtrPath := FExtrPath +'\';
  3238. End;
  3239. Procedure TUnZip.SetParameters(Prm:String);
  3240. Begin
  3241.   FParam:=Prm;
  3242. End;
  3243.  
  3244. Function TUnZip.Execute:Boolean;
  3245. //var O : smallint;
  3246. //    i : Smallint;
  3247. //    s : string;
  3248. Begin
  3249.   Result := True;
  3250.   Try
  3251.   {Screen.Cursor:=crHourGlass;}
  3252.   UnCrunch(FName+Spacer+FExtrPath+Spacer+FParam);
  3253.   {Screen.Cursor:=crDefault;}
  3254.   Except
  3255.     Result := False
  3256.   End;
  3257. End;
  3258.  
  3259. Procedure TUnZip.GetZipList(Const iFileName:String;Var A:TStringList);
  3260. {ve stringlistu je navracen seznam souboru ze zipu}
  3261. {volani Zip.GetZipList(Zip.FName,FList);}
  3262. Const
  3263.   lf_signature = $4034b50;
  3264.   f_signature  = $2014b50;
  3265.   e_signature  = $6054b50;
  3266. Type
  3267.  
  3268.   L_f_head = Packed Record                 {  A.  Local file header:}
  3269.     Signature : LongInt;  { local file header signature     4 bytes }
  3270.     { (0x04034b50) }
  3271.     Unp_ver,              { version needed to extract       2 bytes }
  3272.     Gen_pur,              { general purpose bit flag        2 bytes }
  3273.     Compr_met,            { compression method              2 bytes }
  3274.     File_time,            { last mod file time              2 bytes }
  3275.     File_date : Word;     { last mod file date              2 bytes }
  3276.     CRC,                  { crc-32                          4 bytes }
  3277.     Comp_size,            { compressed size                 4 bytes }
  3278.     full_size : LongInt;  { uncompressed size               4 bytes }
  3279.     Name_len,             { filename length                 2 bytes }
  3280.     Eks_len   : Word;     { extra field length              2 bytes }
  3281.  
  3282.     { filename (variable size)                }
  3283.     { extra field (variable size)             }
  3284.   End;
  3285.  
  3286.  
  3287.   {  B.  Central directory structure: }
  3288.  
  3289.   { [file header] . . .  end of central dir record }
  3290.  
  3291.  
  3292.   F_header = Packed Record                 { File header: }
  3293.     Signature : LongInt;  { central file header signature   4 bytes }
  3294.     { (0x02014b50) }
  3295.     Com_ver,              { version made by                 2 bytes }
  3296.     Unp_ver,              { version needed to extract       2 bytes }
  3297.     Gen_pur,              { general purpose bit flag        2 bytes }
  3298.     compr_met,            { compression method              2 bytes }
  3299.     File_time,            { last mod file time              2 bytes }
  3300.     File_date : Word;     { last mod file date              2 bytes }
  3301.     CRC,                  { crc-32                          4 bytes }
  3302.     Comp_size,            { compressed size                 4 bytes }
  3303.     full_size : LongInt;  { uncompressed size               4 bytes }
  3304.     Name_len,             { filename length                 2 bytes }
  3305.     Eks_len,              { extra field length              2 bytes }
  3306.     Com_len,              { file comment length             2 bytes }
  3307.     Disk_start,           { disk number start               2 bytes }
  3308.     Int_att   : Word;     { internal file attributes        2 bytes }
  3309.     ext_att,              { external file attributes        4 bytes }
  3310.     L_h_ofs   : LongInt;  { relative offset of local header 4 bytes }
  3311.  
  3312.     { filename (variable size)                }
  3313.     { extra field (variable size)             }
  3314.     { file comment (variable size)            }
  3315.   End;
  3316.  
  3317.  
  3318.   End_cd = Packed Record                   { End of central dir record: }
  3319.     Signature   : LongInt;  { end of central dir signature 4 bytes    }
  3320.                             { (0x06054b50) }
  3321.     Disk_nr,                { number of this disk             2 bytes }
  3322.                             { number of the disk with the             }
  3323.     Start_nr,               { start of the central directory  2 bytes }
  3324.                             { total number of entries in              }
  3325.     CD_entrys,              { the central dir on this disk    2 bytes }
  3326.                             { total number of entries in              }
  3327.     Tot_cd_ent  : Word;     { the central dir                 2 bytes }
  3328.     CD_size,                { size of the central directory   4 bytes }
  3329.                             { offset of start of central              }
  3330.                             { directory with respect to               }
  3331.     CD_start_ofs: LongInt;  { the starting disk number        4 bytes }
  3332.     Com_leng    : Word      { zipfile comment length          2 bytes }
  3333.                             { zipfile comment (variable size)         }
  3334.   End;
  3335.   Streng    = String [80];
  3336.   P_l_head  = Packed Record
  3337.     zip_head : L_f_head;
  3338.     Name,
  3339.     comment  : streng;
  3340.   End;
  3341.  
  3342. Const
  3343.   buffsize = 2*4095;{14.2.1996}
  3344. Var
  3345.   fil    : File;
  3346.   Buffer  : ^Word;
  3347.   laest    : Word;
  3348.   hoved    : p_l_head;
  3349.  
  3350.  
  3351. Function read_headder ( Var head : P_l_head) : Boolean;
  3352. Var
  3353.   //i : Word;
  3354.   ok      : Boolean;
  3355.   l, len:Integer;
  3356. Begin
  3357.   ok:=True;
  3358.   With head Do Begin
  3359.     If laest<SizeOf(zip_head) Then Begin
  3360.       l:=SizeOf(zip_head);
  3361.       BlockRead(fil,Pointer(LongInt(Buffer)+laest)^,l,len);
  3362.       ok:= (len=(SizeOf(zip_head)-laest));
  3363.       Inc(laest,len);
  3364.     End;
  3365.     Move(Buffer^,zip_head,SizeOf(zip_head));
  3366.     ok:=ok And (zip_head.signature=lf_signature);
  3367.     If ok Then Begin
  3368.       BlockRead(fil,Name[1],zip_head.name_len,len);
  3369.       Name[0]:=Chr(len);
  3370.       BlockRead(fil,comment,zip_head.eks_len,len);
  3371.       comment[0]:=Chr(len);
  3372.       ok:= (len=zip_head.eks_len) And (zip_head.signature=lf_signature);
  3373.     End;
  3374.   End;
  3375.   read_headder:=ok;
  3376. End;
  3377.  
  3378. Function    skip ( leng : LongInt) : Boolean;
  3379. Var
  3380.   len     : Integer;
  3381.   ok    : Boolean;
  3382. Begin
  3383.   ok:=True;
  3384.   Repeat
  3385.     If (leng>buffsize) Then Begin
  3386.       BlockRead(fil,Buffer^,buffsize,len);
  3387.       Dec(leng,buffsize);
  3388.       If len<buffsize Then ok:=False;
  3389.     End
  3390.     Else Begin
  3391.       len:=leng;
  3392.       BlockRead(fil,Buffer^,len,len);
  3393.       If len<leng Then ok:=False;
  3394.     End;
  3395.   Until Not ok Or (leng<buffsize);
  3396.   skip:=ok;
  3397.   laest:=0;
  3398. End;
  3399.  
  3400. Function timestring ( tiden : LongInt) : streng;
  3401.     {$IfDef USEjbDTM}
  3402.   Var
  3403.     date,time:LongInt;
  3404.   Begin
  3405.     {tohle je pro prizpusobeni pri konverzich na D-T modul a konfiguraci}
  3406.     ConvertFDate(tiden, Date, Time);
  3407.     With Cfgr^.Fi Do
  3408.       result:=Date2StrDate('dd'+FiDateChar+'mm'+FiDateChar+'yyyy',Date)+#9+
  3409.         Time2StrTime('hh'+FiTimeChar+'mm'+FiTimeChar+'ss',Time);
  3410.     {$Else}
  3411.   Var DT:TDateTime;
  3412.   Begin
  3413.     {tohle je klasicky}
  3414.     DT := FileDateToDateTime(tiden);
  3415.     Result := FormatDateTime('dd'+DateSeparator+'mm'+DateSeparator+'yyyy"'+#9+'"hh'+TimeSeparator+'mm'+TimeSeparator+'ss',DT)
  3416.     {$EndIf}
  3417. End;
  3418.  
  3419. Const maxpollin=100;{maxpollin}
  3420. Var
  3421.   ok: Boolean;
  3422.   t_len,t_size: LongInt;
  3423.   antal: Word;
  3424.   {temp,}navn: streng;
  3425.   stamp,latest: LongInt;
  3426.   S: String[60];
  3427.   pocet:Word;
  3428.   Procedure Init;
  3429.   Begin
  3430.     laest:=0; antal:=0;
  3431.     t_size:=0; t_len:=0;
  3432.     latest:=0;stamp:=0;
  3433.     ok:=True;
  3434.   End;
  3435. Begin { Zipview }
  3436.   GetMem(Buffer,buffsize);
  3437.   try
  3438.     navn:=iFileName;
  3439.     Init;
  3440.     Assignfile(fil,navn);
  3441.     Reset(fil,1);
  3442.     try
  3443.       pocet := 0;
  3444.       While ok And read_headder(hoved) Do With hoved,zip_head Do 
  3445.       Begin
  3446.         Inc(pocet);
  3447.         ok:= skip(zip_head.comp_size);
  3448.         Inc(t_len,full_size);
  3449.         Inc(t_size,comp_size);
  3450.         If stamp>latest Then latest:=stamp;
  3451.       End;
  3452.       Init;
  3453.       Reset(fil,1);
  3454.       While ok And read_headder(hoved) Do With hoved,zip_head Do Begin
  3455.         Inc(antal);
  3456.  
  3457.         S := Name;
  3458.         stamp:=LongInt(zip_head.file_date) ShL 16 Or zip_head.file_time;
  3459.         S := S+#9+Long2Str(full_size)+#9+Long2Str(comp_size)+#9+
  3460.           Trim(Real2Str(-1*(100-(comp_size/full_size*100)),5,0))+'%'+#9+timestring(stamp);
  3461.  
  3462.         A.Add(S);{<----- vlozi retezec do seznamu}
  3463.  
  3464.         ok:= skip(zip_head.comp_size);
  3465.         Inc(t_len,full_size);
  3466.         Inc(t_size,comp_size);
  3467.         If stamp>latest Then latest:=stamp;
  3468.       End;
  3469.     finally
  3470.       Close(fil);
  3471.     end;
  3472.   finally
  3473.     FreeMem(Buffer,buffsize);
  3474.   end;
  3475. End;
  3476. procedure Register;
  3477. begin
  3478.   RegisterComponents('Library', [TZip,TUnZip]);
  3479. end;
  3480.  
  3481. end.
  3482.