Power-Programmierung/CD1.mdf/pascal/library/dos/packer/zip/pkpas/pkdemo1.pas

Pascal/Delphi Source File | 1993-10-16 | 9.8 KB | 369 lines

Program PkDemo1;

USES DOS,CRT, PKWareU;

 (***************************************************************

  First demo of PKware unit, showing use of the CentralFileHeadertype.

  Copyright Terry Sansom Oct, 1993.

  ***************************************************************)




CONST
     HexDigits : ARRAY[0..15] OF Char = '0123456789ABCDEF';


TYPE D2 = String[2];



VAR EntryCount: Byte;
    FileName: String;
    CFH:       CentralFileHeaderType;
    Error: Word;

{ //////////////////////////  Global routines \\\\\\\\\\\\\\\\\\\\\\\\\\\\ }

Function StrNum(I:Word):D2;
   var S:D2;
   begin
     Str(I,S);
     IF I < 10 then
        Insert('0',S,1);
     StrNum := S;
   end;

Function HexNum(L:LongInt):String;
{ Convert a longint type to HEX }
VAR T : String[8];
  BEGIN
    T[0] := #8;
    T[1] := HexDigits[L SHR 28];
    T[2] := HexDigits[(L SHR 24) AND $F];
    T[3] := HexDigits[(L SHR 20) AND $F];
    T[4] := HexDigits[(L SHR 16) AND $F];
    T[5] := HexDigits[(L SHR 12) AND $F];
    T[6] := HexDigits[(L SHR 8) AND $F];
    T[7] := HexDigits[(L SHR 4) AND $F];
    T[8] := HexDigits[L AND $F];
    HexNum := T;
end;

Procedure ShowError(I:Word);
begin
  Case I of
   0: Writeln('No Errors');
   1:Writeln('Signature indicates there is an error.');
   2:Writeln('Block read error.');
   3:Writeln('Sorry file not found...');
   Else Writeln('IO error.');
  end;
 IF I <> 3 then
   Close(ZipFile);
 Halt(1);
end;

Procedure Anykey;
VAR CH:Char;
begin
 HighVideo;
 Writeln('Press any key to continue Esc to stop.');
 NormVideo;
 Ch := Readkey;
 IF Ch = #27 then Halt;
end;

Function Confirm(im:String):Boolean;
VAr CH:Char;
begin
 HighVideo;
 Write(im + ' Y/N?' );
 NormVideo;
 Repeat
   Ch := UpCase(Readkey);
 Until CH IN ['Y','N'];
 Writeln(CH);
 Confirm := (Ch = 'Y');
end;

Procedure Welcome;
begin
  Clrscr;
  Writeln('---------------------------------------------------------------');
  HighVideo;
  Writeln('             PKWAREU Demo for PKWareU version 1.0a ');
  NormVideo;
  Writeln;
  Writeln(' A simple demonstration for reading PKzipped files for Turbo');
  Writeln(' Pascal version 5.x.  See README.TXT for details.');
  Writeln;
  Writeln(' 1:  Enter the Zipped file you wish to examine.');
  Writeln;
  Writeln(' 2:  If the file is found, a short summary of the Zip archive will');
  Writeln('     be displayed');
  Writeln;
  Writeln(' 3:  Each keystroke will show details of each file in the');
  Writeln('     archive.');
  Writeln;
  Writeln('---------------------------------------------------------------');
  AnyKey;
end;

Procedure GetZipFile;
 VAR
     Error: Word;
begin
  Filename := '';
  Write(' Enter the zipped file: ');
  Readln(Filename);
  If FileName = '' then ShowError(3);
  Assign(ZipFile, Filename);
  {$I-}
   Reset(ZipFile);
   Error := IOResult;
  {$I+}
  If Error <> 0 then
    ShowError(3);
end;


Function AttrStr(Attr:LongInt):String;
VAR S: String[4];
begin
 S := '';
 IF (Attr = Archive) then
    S := 'A';
 IF (Attr = Hidden) then
    S := S+'H';
 IF (Attr = ReadOnly ) then
    S := S + 'R';
 IF (Attr = SysFile ) then
    S := S +'S';
 AttrStr := S;
end;


Function TimeStr(D:LongInt):String;
VAR DT: DateTime;
begin
 UNpackTime(D,DT);
 With DT do
 begin
  TimeStr :=  StrNum(Month)+'-'+StrNum(Day)+'-'+StrNum(Year-1900)+' '+
              StrNum(Hour)+':'+StrNum(Min)+ ':' +StrNum(Sec);
 end;
end;

{ ///////////////////// Function O_Sys \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ }
 (*  Shows how to uses the Operating system field *)
Function O_Sys(OS: Word): String;
begin
 Case OS OF
  0 : O_Sys := 'MS-DOS or OS/2 ( F.A.T. file system )';
  1 : O_Sys := 'Amiga';
  2 : O_Sys := 'VAX/VMS';
  3 : O_Sys := '*nix';
  4 : O_Sys := 'VM/CMS';
  5 : O_Sys := 'Atari ST';
  6 : O_Sys := 'OS/2 H.P. File system.';
  7 : O_Sys := 'Macintosh';
  8 : O_Sys := 'Z-system';
  9 : O_Sys := 'CP/M';
  Else  O_Sys := 'un-defined operating system';
 End;
end;

{ ////////////////////// Procedure DecodeGenPurpose \\\\\\\\\\\\\\\\\\\\\\\}
            (* What the genral purpose bit is used for *)

Procedure DecodeGenPurpose;

{ Notes on the General purpose bit:

  bit 0 if set file is encryped.

   if method 6  - imploded
     if bit 1 is set an 8k sliding dictionary used, else 4K dictionary

     if bit 2 is set 3 Shannon-Fano trees where used to encode sliding dictionary,
     else 2 Shannon-Fano trees was used to encode sliding dictionary.

   if method 8 - deflating
   bit 2  bit 1
     0      0     Normal conpression           (-en)
     0      1     Maximum compression          (-ex)
     1      0     Fast compression option used (-ef)
     1      1     Super fast compression used  (-es)
     undefined if other compression method was used.
}

VAR GByte:Byte;

begin
 GByte := LO(CFH.GenPurp);

  IF (LO(GByte) and $01) = 1 then Write('Encrupted ');

  IF CFH.Compresion = 6 then     { imploding }
    begin
      IF LO(GByte) and $02 <>  0 then
          Write(' 8K sliding dictionary ')
      Else Write(' 4K sliding dictionary ');
      IF LO(GByte) and $04 <> 0 then
        Write('3 Shannon-Fano trees')
      Else Write('2 Shannon-Fano trees');
    end;

   IF CFH.Compresion = 8 then   { deflated }
    begin
      IF LO(GByte) AND ($04) <> 0  then
         begin
           IF LO(GByte) and $02 <> 0 then
              Write('Super fast compression ')
           ELSE Write('Fast compression ');
         end
      ELSE
          IF LO(GByte) and $02 <> 0 then
             Write('Maximum compression ')
         ELSE  Write('Normal compression ');
    end;
  Writeln;
end;

{////////////////////// SHowFileComment \\\\\\\\\\\\\\\\\\\\\\\\\\\}
    (* details correct use of Procedure GetZipComment *)

Procedure ShowFileComment;
{ Demo use of getZipComment routine }
VAR CommentP: CommentPtr;
    i,Size:Word;
begin
  Size := 0;
  IF Confirm('This file has a comment!  View the zipfile comment') Then
    GetZipComment(CommentP,Size);
     If Size <> 0 then
     begin
   {$R-}             { turn range checking off! }
     For I := 1 to Size do
       Write(CommentP^[I]);
    FreeMem(CommentP, Size);  { Restore the heap }
    end;
  {$R+}             { turn range checking on }
     Writeln;
    Writeln('-------------- End of comment --------------------');
end;


Procedure SHowZipStats;
begin
  Clrscr;
  With ZipStats Do
    begin
      Writeln;

      Writeln('    ---- Zip Stat`s before reading central directory ---');
      Write('             For file: ');
      HighVideo; Writeln(FileName); NormVideo;
      Writeln;
      Writeln('      End Signature           : ', HexNum(EndSig));
      Writeln('      Disk Number             : ', DiskNum);
      Writeln('      Disk num. with start    : ', DiskwStart);
      Writeln('      Number of entries       : ', NumEntries);
      Writeln('      Total number of entries : ', TNumEntries);
      Writeln('      Size of central dir.    : ', SizeCentral);
      Writeln('      Offset of central       : ', OffsetDirRelDiskNum);
      Writeln('      Size of comment         : ', CommentLen);
      Writeln;
   end;
   Writeln('    ---------------------------------------------------');
   Writeln;
   IF ZipStats.CommentLen > 0 then
      ShowFileComment;
end;

Procedure ShowExtra(E:ExtraData);
{ show the Extra data fields }
begin
  With E do
    Begin
      HighVideo;
      Write('          *');
      LowVideo;
      Write('Extra name       : ',ExtraName);
      Writeln(', ',ExtraLen,' bytes.');
    end;
end;

Procedure ShowCFH(VAR FH: CentralFileHeadertype);

 Procedure ShowCharArray( CA: CharArray; Len: Word);
 { writes out a CharArray }
 VAR I : Word;
 begin
  For I := 1 to LEN do
    Write(Ca[I]);
  Writeln;
 end;

begin
 Clrscr;
 With FH do
  begin
      Writeln(' File: ',PkDemo1.Filename);
      Writeln('           File Number: ',EntryCount,' of ',ZipStats.TNumEntries);
      Writeln('------------------------------------------------------');
      Writeln('           Signature        : ' ,HexNum(CentralSig));
      Writeln('           Operating system : ',O_Sys(HI(VerReq)));
      Writeln('           Pkware version   : ',(LO(VerReq) DIV 10),'.',LO(VerReq) Mod 10);
      Write('           General purpose  : ',GenPurp,' ');
      DecodeGenPurpose;
      Writeln('           Compression      : ',CompMethod[Compresion]);
      Writeln('           Time             : ',lastFTime);
      Writeln('           Date             : ',lastFdate);
      Writeln('           CRC 32           : ',HexNum(crc32)     );
      Writeln('           Compressed size  : ',Compsize  );
      Writeln('           Uncompressed size: ',UnCompSize);
      Writeln('           Ratio            : ',100 * (1 - CompSize/UnCompSize)  :2:0,'%');
      Writeln('           Name length      : ',NameLen   );
      Writeln('           Extra            : ', Extralen     );
      Writeln('           Commentlen       : ', ComentLen);
      Writeln('           FileName         : ',FileName );
      IF ExtraLen > 0 then
         ShowExtra(Extra);
      If ComentLen > 0 then
      begin
        Write('           File Comment     : ');
        ShowCharArray(FileComment, ComentLen);
      end;
      Writeln('           Attr             : ',AttrStr(ExternalAttr));
   end;
   Writeln('------------------------------------------------------');
end; { SHowCFH }

begin  { Main }
 Welcome;
 GetZipFile;
 Error := GetZipStats;
 If Error = 0 then
  begin
    ShowZipStats;
    AnyKey;
    For EntryCount := 1 to ZipStats.TNumEntries do
     begin
       Error := ReadFileHeader(Cfh);
       If Error = 0 then
         begin
           ShowCfh(Cfh);
           AnyKey;
         end
       Else ShowError(Error);
     end;
  end { if }
  Else ShowError(Error);
  ShowError(0);
end.