home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / CHFLZ100.ZIP / LZ.DPR < prev    next >
Text File  |  1996-09-05  |  14KB  |  536 lines
  1. {
  2. SAMPLE PROGRAM TO DEMONSTRATE THE USE OF THE CHIEFLZ v1.00 PACKAGE.
  3. THIS PROGRAM WILL COMPILE FOR THE FOLLOWING PLATFORMS;
  4.      Dos Real mode - TP7, BP7
  5.      Dos DPMI      - BP7, BPW
  6.      Win16         - BPW, TPW, Delphi 1.x
  7.      Win32         - Delphi 2.0x
  8. }
  9.  
  10.  
  11. Program LZ;
  12.  
  13. {$I LZDefine.inc}
  14.  
  15. {this (aDLL) is now defined (or not) in LZDEFINE.INC}
  16. {$ifdef aDLL}
  17.   {$define ExplicitLink}  {use explicit linking of DLL}
  18. {$endif aDLL}
  19.  
  20. {$ifdef Windows}
  21. {$ifdef Win32}
  22.   {$MINSTACKSIZE $00004000}
  23.   {$MAXSTACKSIZE $00100000}
  24.   {$IMAGEBASE    $00400000}
  25.   {$APPTYPE      Console}
  26. {$else Win32}
  27.   {$M 20000, 1024}
  28.   {$F+}        { Force Far-Calls }
  29.   {$K+}        { Use smart call-backs for LZReport, etc. }
  30. {$endif Win32}
  31. {$endif Windows}
  32.  
  33. {$ifdef Delphi}
  34. {
  35.   Link in the Delphi-generated resource file ...
  36. }
  37.   {$R *.RES}
  38. {$endif Delphi}
  39.  
  40. Uses
  41. {$ifdef Win32}
  42.  {$ifdef aDLL}
  43.   ShareMem,                   { ChiefLZ.DLL exports long-strings ...!!! }
  44.   {$ifdef ExplicitLink}
  45.   LZExplic in 'LZExplic.pas',
  46.   {$else ExplicitLink}
  47.   LZImplic in 'LZImplic.pas',
  48.   {$endif ExplicitLink}
  49.   {$else aDLL}
  50.   ChiefLZ in 'ChiefLZ.pas',
  51.   {$endif aDLL}
  52. {$else Win32}
  53.  {$ifdef aDLL}
  54.   {$ifdef ExplicitLink}
  55.   LZExplic,
  56.   {$else ExplicitLink}
  57.   LZImplic,
  58.   {$endif ExplicitLink}
  59.  {$else aDLL}
  60.   ChiefLZ,
  61.  {$endif aDLL}
  62. {$endif Win32}
  63.  
  64. {$ifdef Delphi}
  65.   SysUtils,
  66. {$endif Delphi}
  67. {$ifdef Win32}
  68.   Windows,
  69. {$else Win32}
  70. {$ifdef Windows}
  71. {$ifndef DPMI}
  72.   WinCRT,
  73. {$endif DPMI}
  74. {$ifndef Delphi}
  75.   WinDOS, Strings,
  76. {$endif Delphi}
  77. {$else Windows}
  78.   Dos, Strings,
  79. {$endif Windows}
  80. {$endif Win32}
  81.   ChfTypes,
  82.   ChfUtils;
  83.  
  84. VAR
  85. AutoReplaceAll: boolean;
  86.  
  87. {$ifdef Win32}
  88. procedure FlushInputBuffer;
  89. begin
  90.   FlushConsoleInputBuffer(GetStdHandle(STD_INPUT_HANDLE))
  91. end;
  92.  
  93. function ReadKey32: Char;
  94. var
  95.   NumRead:       Integer;
  96.   HConsoleInput: THandle;
  97.   InputRec:      TInputRecord;
  98. begin
  99.   HConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
  100.   while not ReadConsoleInput(HConsoleInput,
  101.                              InputRec,
  102.                              1,
  103.                              NumRead) or
  104.            (InputRec.EventType <> KEY_EVENT) do;
  105.   Result := InputRec.KeyEvent.AsciiChar
  106. end;
  107. {$endif Win32}
  108.  
  109. {$ifdef Delphi}
  110. function TimeToStr(const l: LongInt): string;
  111. begin
  112.   Result := FormatDateTime('dd/mm/yy  hh:nna/p',FileDateToDateTime(l))
  113. end;
  114. {$else}
  115. Function TimeToStr(Const L : Longint):String;
  116. Type
  117.   ElementStr = String[10];
  118.  
  119. procedure FormatElement(Num: word; var EStr: ElementStr);
  120. begin
  121.   Str(Num:2, EStr);
  122.   if Num < 10 then
  123.     EStr[1] := '0'
  124. end;
  125.  
  126. Var
  127. Result : String[25];
  128. {$ifdef Windows}
  129. Var
  130. T : TDateTime;
  131. {$else}
  132. Var
  133. T : DateTime;
  134. {$endif Windows}
  135. Var
  136. Dd,Mm,Yy,
  137. Hr,Min : ElementStr;
  138.  
  139. Begin
  140.    UnpackTime(L, T);
  141.    FormatElement(T.Day, Dd);
  142.    FormatElement(T.Month, Mm);
  143.    Str(T.Year:4, Yy);
  144.    FormatElement(T.Hour, Hr);
  145.    FormatElement(T.Min, Min);
  146.    Result := Dd+'/'+Mm+'/'+Yy+'  '+Hr+':'+Min{+':'+Sec};
  147.    TimeToStr := Result;
  148. End;
  149. {$endif Delphi}
  150. {------------------------------------------------------------}
  151.  
  152. {///////////////////////////////////////////}
  153. Function Confirm(const fRec: TLZReportRec; Const aDest:String):TLZReply;
  154. {$IFDEF Win16} {$ifdef aDLL} export {$else} far {$endif}; {$ENDIF}
  155. {procedure to ask question if target file exists already}
  156. Var
  157. Ch:Char;
  158. Begin
  159.   if AutoReplaceAll then
  160.     begin
  161.       Confirm := LZYes;
  162.       Exit
  163.     end;
  164.  
  165.   With fRec
  166.   do begin
  167.     Writeln('Target File Exists!!!');
  168.     Writeln('File Name : ',Names);
  169.     Writeln('File Date : ',TimeToStr(Times));
  170.  
  171.     Writeln('Compressed: ',Sizes);
  172.     Writeln('Real Size : ',uSizes);
  173.     Writeln('Version   : ',FileVersion);
  174.   End;
  175.  
  176.   Repeat
  177.     Write('OVERWRITE FILE : ', aDest, ' ? (Yes/No/All/Quit) [Y/N/A/Q] : ');
  178.     Readln(Ch);
  179.   Until Upcase(Ch) in ['Y','N','A','Q'];
  180.   Case UpCase(Ch) of
  181.   'A' : begin
  182.           Confirm := LZYes;
  183.           AutoReplaceAll := True {overwrite all others}
  184.         end;
  185.   'N' : begin
  186.            Confirm := LZNo;
  187.            Writeln('Skipping file  : ',aDest)
  188.         end;
  189.   'Q' : Confirm := LZQuit { stop all processing and Exit }
  190.   else
  191.     Confirm := LZYes { Ch = 'Y' }
  192.   End; {Case}
  193. End;
  194. {///////////////////////////////////////////}
  195.  
  196. Procedure DeMyRep(Const aName: TLZReportRec{String}; Const aSize: Longint);
  197. {$IFDEF Win16} {$ifdef aDLL} export {$else} far {$endif}; {$ENDIF}
  198. {procedure to show progress}
  199. Begin
  200.    if (Length(aName.Names) > 0) and (aSize=-1) then
  201.      Write('Processing file: ',aName.Names,' ')
  202.    else if (asize=-2) then
  203.      Writeln
  204.    else if aSize > 0 then
  205.      Write('.')
  206. End;
  207.  
  208. {-----------------------------------------------}
  209. function MyRename(var FName: string): boolean;
  210. {$ifdef Win16} {$ifdef aDLL} export {$else} far {$endif}; {$endif}
  211. var
  212.   Ch: Char;
  213. {$ifndef Delphi}
  214. var Result: boolean;
  215. {$endif}
  216. begin
  217.   Write( 'Cannot overwrite ', FName, ' - Rename? [Y/N]' );
  218.   Readln(Ch);
  219.   Result := UpCase(Ch) = 'Y';
  220.   if Result then
  221.     begin
  222.       Write( 'New name: ' );
  223.       Readln(FName)
  224.     end;
  225. {$ifndef Delphi}
  226.   MyRename := Result
  227. {$endif}
  228. end;
  229.  
  230. {-----------------------------------------------}
  231. Procedure Syntax;
  232. Begin
  233.   Writeln('LZSS Compressor: by Dr A Olowofoyeku (the African Chief), and Chris Rankin.');
  234.   writeln;
  235.   WriteLn('Usage: LZ <InSpec> [OutSpec] [[/U /A[/R[1]] /X /V]]');
  236.   Writeln;
  237.   Writeln('no switch  =  compress a single file (InSpec) to OutSpec');
  238.   Writeln('e.g.          LZ BIG.EXE SMALL.LZZ');
  239.   Writeln;
  240.   Writeln(' /U        =  decompress a single file (InSpec) to OutSpec');
  241.   Writeln(' e.g.         LZ SMALL.LZZ BIG.EXE /U');
  242.   Writeln('');
  243.  
  244.   Writeln(' /A        =  compress and archive the files (InSpec) into archive (OutSpec)');
  245.   Writeln('e.g.          LZ C:\TEMP\*.* TEMP.LZZ /A');
  246.   Writeln('              Max = ' + {$ifdef Win32} '2048'
  247.                                    {$else}        '600'
  248.                                    {$endif} + ' files in archive');
  249.   Writeln;
  250.  
  251.   Writeln(' /R        =  recurse through directory structure (for archives)');
  252.   Writeln(' /R1       =  recurse into 1st level directories (for archives)');
  253.   Writeln('e.g.          LZ C:\TEMP\*.* TEMP.LZZ /A /R');
  254.   Writeln;
  255.  
  256.   Writeln(' /X        =  decompress an LZ archive (InSpec) into directory (OutSpec)');
  257.   Writeln('e.g.          LZ TEMP.LZZ C:\TEMP /X');
  258.   Writeln;
  259.  
  260.  
  261.   Writeln(' /V        =  show contents of an LZ archive (InSpec)');
  262.   Writeln('e.g.          LZ TEMP.LZZ /V');
  263.  
  264.   {$ifdef Windows}
  265.    {$ifdef Win32}
  266. {
  267.     FlushInputBuffer;  // Use these if running within IDE to
  268.     ReadKey32;         // prevent console window from disappearing
  269. }
  270.    {$else}
  271.    {$ifndef DPMI}
  272.     ReadKey;
  273.     DoneWincrt;
  274.     {$endif DPMI}
  275.    {$endif Win32}
  276.   {$endif Windows}
  277.  
  278.   Halt(1);
  279. End;
  280.  
  281. {-----------------------------------------------}
  282. {$ifNdef aDLL}
  283. {example of using the LZ object}
  284. Procedure UseObj;
  285. Var
  286. o:LZObj;
  287. l:longint;
  288. Param:string;
  289. Begin
  290.    o {$ifdef Delphi} := LZObj.Create
  291.      {$else} .Init
  292.      {$endif}(ParamStr(1),ParamStr(2));
  293.    {$ifdef Delphi}
  294.    try
  295.    o.QuestionProc := Confirm;
  296.    o.ReportProc := DeMyRep;
  297.    {$else}
  298.    o.SetQuestionProc(Confirm);
  299.    o.SetReportProc(DeMyRep);
  300.    {$endif}
  301.    Param := Uppercase(ParamStr(3));
  302.    if (Param='/U') or (Param='-U') then
  303.      l:=o.Decompress
  304.    else
  305.      l:=o.Compress;
  306.  {$ifdef Delphi}
  307.    finally
  308.      o.Free
  309.    end;
  310.  {$else}
  311.    o.Done;
  312.  {$endif}
  313.    Writeln(l);
  314.    Halt;
  315. End;
  316. {$Endif aDLL}
  317.  
  318. {///////////////////////////////////////////}
  319. function GetCompressionRatio(const Comp, Orig: LongInt): LongInt;
  320. begin
  321.   if Orig = 0 then
  322.     GetCompressionRatio := 0  { 0%, on the grounds that the file }
  323.   else                        { is still its original size ...   }
  324.     GetCompressionRatio := 100 - ( (100*Comp) div Orig )
  325. end;
  326.  
  327. {///////////////////////////////////////////}
  328. {///////////////////////////////////////////}
  329. {///////////////////////////////////////////}
  330. {///////////////////////////////////////////}
  331.  
  332. var
  333.   ReadProc,WriteProc,UserParam: TLZPathStr;
  334.   p: {$ifdef Win32} string;
  335.      {$else}        array[0..79] of Char;
  336.      {$endif}
  337.   i:integer;
  338.   j,k:longint;
  339.   X:PChiefLZArchiveHeader;
  340.   LZRecurseDirs: TLZRecurse;
  341.  
  342. Begin
  343.   {$ifdef Windows}
  344.    {$ifndef Win32}
  345.    {$ifndef DPMI}
  346.     StrPCopy(WindowTitle, 'Sample ChiefLZ program ');
  347.     ScreenSize.x:=80;
  348.     ScreenSize.y:=250;
  349.     WindowOrg.x := 1;
  350.     WindowOrg.y := 1;
  351.     {$endif DPMI}
  352.    {$endif Win32}
  353.   {$endif Windows}
  354.  
  355.   if ParamCount < 2 then
  356.   begin
  357.     Syntax;
  358.   end;
  359.   
  360.   {$ifdef ExplicitLink}
  361.      {$ifdef Win32}
  362.        if not LoadChiefLZDLL('') then
  363.          begin
  364.            Writeln('ChiefLZ Error : cannot load ChiefLZ.DLL');
  365.            Halt
  366.          end;
  367.      {$else Win32}
  368.        i := LoadChiefLZDLL(''{'MYDLL.DLL'});
  369.        if i <> 0 then begin
  370.          Writeln('ChiefLZ Error : cannot load ChiefLZ.DLL');
  371.          Writeln('Error Code : ',i);
  372.          Halt;
  373.        end;
  374.      {$endif Win32}
  375.        Writeln('ChiefLZ DLL loaded successfully. Its DLL handle is: ',GetChiefLZDLLHandle);
  376.        Writeln('Working now ... ');
  377.   {$endif ExplicitLink}
  378.  
  379. {
  380.   UseObj;
  381.   Halt;
  382. }  
  383.   ReadProc := ParamStr(1);
  384.   WriteProc := ParamStr(2);
  385.   UserParam := Uppercase(ParamStr(3));
  386.   AutoReplaceAll := False; {confirm for each file}
  387.  
  388.   if (Uppercase(ParamStr(2))='-V') or
  389.      (Uppercase(ParamStr(2))='/V') then begin
  390.  
  391.     if not IsChiefLZArchive({$ifdef Win32} ReadProc
  392.                             {$else}       @ReadProc[1]
  393.                             {$endif})
  394.     then begin
  395.         Writeln(ReadProc,' is not a ChiefLZ archive!');
  396.         {$ifdef ExplicitLink}
  397.         If UnloadChiefLZDLL
  398.         then Writeln('I have unloaded the ChiefLZ.DLL');
  399.         {$endif ExplicitLink}
  400.         Halt;
  401.     end;
  402.     New(X);
  403.   {$ifdef Win32}
  404.     try
  405.   {$endif}
  406.     GetChiefLZArchiveInfo({$ifdef Win32} ReadProc
  407.                           {$else Win32}  Str2PChar(ReadProc)
  408.                           {$endif Win32}, X^);
  409.     j:=0;k:=0;
  410.  
  411.     Writeln('ChiefLZ archive file: ',ReadProc);
  412.     Writeln('ChiefLZ archive size: ',
  413.               GetChiefLZArchiveSize({$ifdef Win32} ReadProc
  414.                                     {$else Win32}  Str2PChar(ReadProc)
  415.                                     {$endif Win32}),
  416.             ' bytes');
  417.  
  418.     Writeln('  Real Size   LZ Size  Ratio   Date      Time    Version   FileName');
  419.     Writeln('------------------------------------------------------------------');
  420.     for i := 1 to X^.Count do
  421.       with X^.Files[i] do
  422.         begin
  423.           inc(j, Sizes);
  424.           inc(k, uSizes);
  425.           If IsDir then
  426.             Write({ Names:13,}
  427.                    '<DIR>':10,
  428.                    0:10,
  429.                    0:6 )
  430.           else
  431.             Write( {Names:13,}
  432.                    uSizes:10,
  433.                    Sizes:10,
  434.                    GetCompressionRatio(Sizes,uSizes):6 );
  435.           Write( '%  ',
  436.                   TimeToStr(Times),
  437.                   '  ', FileVersion:8,
  438.                   '   ',GetFullLZName(X^,i) );
  439.           if IsDir then
  440.             Writeln('\')
  441.           else
  442.             Writeln
  443.  
  444.         end {for i};
  445.  
  446.       Writeln;
  447.       Writeln('Number of Files   = ',X^.Count);
  448.       Writeln('Compressed Size   = ',j,' bytes');
  449.       Writeln('Expanded Size     = ',k,' bytes');
  450.       Writeln('Compression Ratio = ', GetCompressionRatio(j,k),'%');
  451.  
  452.   {$ifdef Win32}
  453.     finally
  454.   {$endif}
  455.     Dispose(X);
  456.   {$ifdef Win32}
  457.     end
  458.   {$endif}
  459.   end
  460.  else
  461.   if (UserParam = '/X') or (UserParam = '-X') then begin
  462.      writeln(LZDearchive({$ifdef Win32} ReadProc, WriteProc,
  463.                          {$else}        Str2PChar(ReadProc), Str2PChar(WriteProc),
  464.                          {$endif} Confirm, DeMyRep, MyRename))
  465.   end else
  466.   if (UserParam = '/A') or (UserParam = '-A') then begin
  467.   
  468.      UserParam := Uppercase(ParamStr(ParamCount));
  469.      if (UserParam = '-R') or (UserParam = '/R') then
  470.        LZRecurseDirs := LZFullRecurse
  471.      else if (UserParam = '-R1') or (UserParam = '/R1') then
  472.        LZRecurseDirs := LZRecurseOnce
  473.      else
  474.        LZRecurseDirs := LZNoRecurse;
  475.  
  476.      writeln(LZArchive({$ifdef Win32} ReadProc, WriteProc
  477.                        {$else}        Str2PChar(ReadProc), Str2PChar(WriteProc)
  478.                        {$endif}, LZRecurseDirs, DeMyRep))
  479.   end else
  480.   if (UserParam = '/U') or (UserParam = '-U') then
  481.   begin
  482.      writeln(LZDecompress({$ifdef Win32} ReadProc, WriteProc,
  483.                           {$else}        Str2PChar(ReadProc), Str2PChar(WriteProc),
  484.                           {$endif} Confirm, DemyRep));
  485.      {$ifdef Win32} p := GetChiefLZFileName(ReadProc);
  486.      {$else}        GetChiefLZFileName(Str2PChar(ReadProc), p);
  487.      {$endif}
  488.      Writeln('Filename in header: ',p);
  489.      writeln('FileSize in header: ',
  490.                   GetChiefLZFileSize({$ifdef Win32} ReadProc
  491.                                      {$else}        Str2PChar(ReadProc)
  492.                                      {$endif}) );
  493.   end
  494.   else
  495.   if ParamStr(2)= '/1' then begin
  496.     LZCompressEx({$ifdef Win32} ReadProc,
  497.                  {$else}        Str2PChar(ReadProc),
  498.                  {$endif} Confirm,DeMyRep);
  499.   end else
  500.   if ParamStr(2)= '/2' then begin
  501.     LZDecompressEx({$ifdef Win32} ReadProc,
  502.                    {$else}        Str2PChar(ReadProc),
  503.                    {$endif} Confirm,DeMyRep);
  504.   end
  505.   else begin
  506.      writeln(LZCompress({$ifdef Win32} ReadProc, WriteProc,
  507.                         {$else}        Str2PChar(ReadProc), Str2PChar(WriteProc),
  508.                         {$endif} Confirm, DeMyRep));
  509.   end;
  510.  
  511.   {$ifdef ExplicitLink}
  512.     Writeln;
  513.     If UnloadChiefLZDLL then
  514.       Writeln('I have successfully unloaded the ChiefLZ DLL')
  515.     else
  516.       Writeln('Error trying to unloaded the ChiefLZ DLL');
  517.     Writeln('Its DLL handle is: ',GetChiefLZDLLHandle);
  518.  
  519.   {$endif ExplicitLink}
  520.  
  521.   {$ifdef Windows}
  522.    {$ifdef Win32}
  523. {
  524.     FlushInputBuffer;  // Use these if running within the IDE
  525.     ReadKey32;         // to prevent console window disappearing
  526. }
  527.    {$else}
  528.    {$ifndef DPMI}
  529.     ReadKey;
  530.     DoneWincrt;
  531.     {$endif DPMI}
  532.    {$endif Win32}
  533.   {$endif Windows}
  534. End.
  535.  
  536.