ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/UTILITY/ARCHIVE/HYPER25.ZIP/HYPTV.PAS

Pascal/Delphi Source File | 1990-09-27 | 12.2 KB | 437 lines

{$A+,B-,F-,I-,O-,R-,S-,V-}
{$M 16384,0,0}
Program HypTv;
{ HypTv - view directory of HYP archives
  <your copyright>
  portions copyright (c) 1990 P. Sawatzki and K.P. Nischke
                         BitNet: IN307@DHAFEU11
}
Uses
  Dos;

Type
  LH = Record
         L, H : Word
       End;
  Header_Pointer = ^Header;
  CompressionId = Word;
  Header_Name = (Only_Name, Expanded);
  {-Definition of the Hyper Archive Header}
  Header = Record
             CtrlZ : Char;
             id : CompressionId;
             Version : Byte;
             ArchiveSize,         {Size of Archive including the header}
             OriginSize,          {Size of origin file}
             FDateTime,           {Date and Time of origin file}
             ChkSum : LongInt;    {CheckSum of origin data file}
             FAttr : Byte;        {Attributes of origin file}
             fn: String;          {dynamic!}
           End;

Const
  {-undynamic size of every header}
  FixHeaderSize = SizeOf(Char)
                 +SizeOf(CompressionId)
                 +SizeOf(Byte)
                 +4*SizeOf(LongInt)
                 +SizeOf(Byte)
                 +1;

Const
  ThisVersion = $25;
  CRLF = #13#10;
  Attention = '! ';
  Name = 'HypTV';
  DefaultArchiveExtension = '.HYP';
  VersionName = Name+' - Utility '+Char(ThisVersion Shr 4+Ord('0'))+
                               '.'+Char(ThisVersion And $F+Ord('0'));
  CopyRight = '<your copyright>'+CRLF+
              'Copyright (c) 1990 P. Sawatzki and K.P. Nischke';

  UsageText =
  'Usage: '+Name+' HYP-file'+CRLF+
  CRLF+
  '  fn     = HYP archive.  Default extension is '+DefaultArchiveExtension+CRLF;
Type
  StringPtr = ^String;
  CompressionType = (Stored, Hyper, UnKnown);
Const
  StoredId = Byte('S')+Swap(Byte('T'));
  HyperId  = Byte('H')+Swap(Byte('P'));

  {-messages}
  NothingToDo = 'nothing to do!';
  SayError = 'Error';
  SayNothing = '';

Const
  normal_exit   = 0;
  nothing_to_do = 1;
  ArchiveError  = 2;
  eCompression  = 3;
  Memory_Error  = 4;
  eCheckSum     = 5;
  eDiskFull     = 14;
  eCreatArc     = 98;
  Input_Error   = 101;
{ output_error  = 102; !!! used in Hyper}
  ctrlc_pressed = 255;

  wUsage = 10;

  ArchiveName : PathStr = '';
  ArchiveOffset : LongInt = 0;
Var
  Hyperfile: File;

  CurrentDrive : Char;

  Procedure OpenArchive(fname : String);
  Begin
    Assign(Hyperfile, fname);
    Reset(Hyperfile, 1);
    If IoResult <> 0 Then Halt(ArchiveError)
  End;

  Procedure CloseArchive;
  Begin
    Close(Hyperfile);
    If IoResult <> 0 Then Halt(Input_Error)
  End;

  Function L2S(L : LongInt; size : Byte) : String;
  Var
    s : String;
  Begin
    Str(L:size, s); L2S := s
  End;

  Procedure Hypermessage(MsgType : String; Msg : String);
  Begin
    Write(CRLF+#13+Name+': ');
    If MsgType <> SayNothing Then Write(Attention, MsgType, ' ');
    WriteLn(Msg)
  End;

  Function CompressionRatio(OriginSize, ArchiveSize : LongInt) : Integer;
  Begin
    If (OriginSize = 0) Or (OriginSize = ArchiveSize) Then
      CompressionRatio := 0
    Else
      If LH(ArchiveSize).H > 327 Then {ArchiveSize > 2^31/100}
        CompressionRatio := 100-ArchiveSize Div (OriginSize Div 100)
    Else
      CompressionRatio := 100-(ArchiveSize*100) Div OriginSize
  End;

  Function GetCompression(Var H : Header) : CompressionType;
  Begin
    Case H.id Of
      StoredId : GetCompression := Stored;
      HyperId : GetCompression := Hyper;
    Else
      Halt(eCompression)
    End
  End;

Const
  CompressionMethod : Array[CompressionType] Of Array[1..6] Of Char =
  ('Stored','Hyper ','??????');

  Function StUpCase(s : String) : String;
  Var
    i : Byte;
  Begin
    For i := 1 To Length(s) Do
      StUpCase[i] := Upcase(s[i]);
    StUpCase[0] := s[0]
  End;

  Procedure CheckSfx(SfxName : PathStr);
  {-check for self-extracting archive}
  {-if Sfx Exe: set ArchiveName and ArchiveOffset}
  Var ImageInfo : Record
                    ExeId : Array[0..1] Of Char;
                    Remainder,
                    size : Word
                  End;
    SfxExe : File;
    H : Header;
    rd : Word;
    Err : Boolean;
    AOffset : LongInt;
    ExeId : Array[0..1] Of Char;

  Begin Assign(SfxExe, SfxName); Reset(SfxExe, 1);
    If IoResult > 0 Then Exit;

    BlockRead(SfxExe, ImageInfo, SizeOf(ImageInfo));
    If ImageInfo.ExeId <> 'MZ' Then Exit;
    AOffset := LongInt(ImageInfo.size-1)*512+ImageInfo.Remainder;
    Seek(SfxExe, AOffset);
    If IoResult > 0 Then Exit;

    BlockRead(SfxExe, H, SizeOf(H), rd);
    Err := (IoResult > 0) Or (rd < SizeOf(Header));
    Close(SfxExe);
    If Err Then Exit;
    If H.CtrlZ <> ^Z Then Exit;

    ArchiveName := SfxName;
    ArchiveOffset := AOffset
  End;

  {  Primitiva für Datei-Header  }

  Function Header_Size(Var H : Header) : Word;
  Begin
    With H Do
      Header_Size := FixHeaderSize+Length(fn)
  End;

  Procedure Read_Header(Var H : Header; Var f : File);
  Var
    rd : Integer;
  Begin
    BlockRead(f, H, FixHeaderSize, rd);
    If rd <> FixHeaderSize Then Halt(Input_Error);
    With H Do Begin
      BlockRead(f,fn[1], Length(fn), rd);
      If rd <> Length(fn) Then Halt(Input_Error)
    End
  End;

  {-Allozieren von Speicherplatz  }
Var
  Low_Address, High_Address : LongInt;

  Procedure MemCheck(nBytes : LongInt);
  Begin
    If High_Address-Low_Address < nBytes Then Halt(Memory_Error)
  End;                            (* MemCheck *)

  Function lPtr(L : LongInt) : Pointer;
  { Ptr(l Shr 4,l And $F) }
  Inline(
    $58/                          {  pop ax}
    $89/$C2/                      {  mov dx,ax}
    $25/$0F/$00/                  {  and ax,$F}
    $B1/$04/                      {  mov cl,4}
    $D3/$EA/                      {  shr dx,cl}
    $5B/                          {  pop bx}
    $D2/$E3/                      {  shl bl,cl}
    $00/$DE);                     {  add dh,bl}

  Function GetHighMem(nBytes : Word) : Pointer;
  Begin
    Dec(High_Address, nBytes);
    MemCheck(0);
    GetHighMem := lPtr(High_Address)
  End;

  Procedure Alloc_Mem;
  Const
    seg0 : Word = 0;
    nSegs : Word = 0;
  Begin
    Inline($BB/$FF/$FF/       { mov bx,$FFFF    }
           $B4/$48/           { mov ah,$48      }
           $CD/$21/           { int $21         }
           $89/$1E/>nSegs/    { mov [>nsegs],bx }
           $B4/$48/           { mov ah,$48      }
           $CD/$21/           { int $21         }
           $A3/>seg0);        { mov [>seg0],ax  }
    Low_Address := 16*LongInt(seg0+2*4096);
    High_Address := 16*LongInt(seg0+nSegs);
    MemCheck(0)
  End;                            (* Alloc_Mem *)

Var
  archive_header_base : LongInt;
  archive_header_number : Integer;

  Procedure Initialize_Archive_Headers;
  Begin
    archive_header_base := High_Address;
    archive_header_number := 0
  End;

  Procedure Get_Archive_Headers(Var archive : File);
  Var
    hPtr : Header_Pointer;
    HeadPos : LongInt;
  Begin
    HeadPos := FilePos(archive);
    While Not EoF(archive) Do Begin
      hPtr := GetHighMem(SizeOf(Header));
      Read_Header(hPtr^, archive);
      Inc(HeadPos, hPtr^.ArchiveSize+Header_Size(hPtr^));
      Seek(archive, HeadPos);
      Dec(archive_header_number) (* !!! *)
    End
  End;

  Function archive_header_address(hNumber : Integer) : Header_Pointer;
    {-Gibt einen Zeiger auf den "hnumber"-ten Archive-Header zurück.  }
    {-Vorbedingung: archive_header_number ≤ hnumber ≤ -1              }
  Begin
    archive_header_address := lPtr(archive_header_base+LongInt(hNumber)*SizeOf(Header))
  End;                            (* archive_header_address *)

  Procedure Free_Archive_Headers;

  Begin High_Address := archive_header_base;
    archive_header_number := 0
  End;                            (* Free_Archive_Headers *)

  Procedure ViewFilesInArchive(ArchiveName : String);
  Var
    Fcnt : Word;
    SOriginSize, SArchiveSize : LongInt;
    hn : Integer;
    p : Header_Pointer;

    Procedure WriteByte(b : Byte);
    Begin
      If b < 10 Then Write('0');
      Write(b)
    End;

    Procedure WriteDateTime(dt : LongInt);
      {-Write Date&Time to Output}
    Begin
      With LH(dt) Do Begin
        WriteByte(H And $1F);
        Write('-'); WriteByte((H And $1FF) Shr 5);
        Write('-'); WriteByte((H Shr 9+80));
        Write(' '); WriteByte(L Shr 11);
        Write(':'); WriteByte((L And $7FF) Shr 5);
        Write(' ')
      End
    End;

    Procedure WriteAttr(Attr : Byte);
    Const
      AttrSign : Array[0..2] Of Array[Boolean] Of Char = (' r', ' h', ' s');
    Begin
      Write(AttrSign[0, Attr And ReadOnly > 0],
            AttrSign[1, Attr And Hidden > 0],
            AttrSign[2, Attr And SysFile > 0],
            ' ')
    End;

  Begin
    If archive_header_number = 0 Then
      WriteLn('No files in archive.')
    Else Begin
      SOriginSize := 0;
      SArchiveSize := 0;
      Fcnt := 0;

      WriteLn(CRLF+'Archive: '+ArchiveName+
              CRLF+'Length   Method   Size   Ratio   Date   Time      Name'+
              CRLF+'-------  ------   ------ -----   ----   ----      ----');

      For hn := -1 Downto archive_header_number Do
        Begin
          p := archive_header_address(hn);
          With p^ Do Begin
              Inc(Fcnt);
              Inc(SOriginSize, OriginSize);
              Inc(SArchiveSize, ArchiveSize);

              Write(OriginSize:7,
                    '  ', CompressionMethod[GetCompression(p^)],
                    ArchiveSize:9,
                    CompressionRatio(OriginSize, ArchiveSize):4, '%  ');
              WriteDateTime(FDateTime);
              WriteAttr(FAttr);
              WriteLn(fn)
            End;
        End;
      WriteLn('-------          -------  ---                     --------');
      WriteLn(SOriginSize:7,
              SArchiveSize:17,
              CompressionRatio(SOriginSize, SArchiveSize):4, '%',
              '':22, Fcnt:3);
      WriteLn;
    End
  End;

  Procedure DoIt;
  Var
    sr : SearchRec;
    Cdir : DirStr;
    Cname : NameStr;
    Cext : ExtStr;
  Begin
    Fsplit(StUpCase(ArchiveName), Cdir, Cname, Cext);
    If Cext = '' Then Cext := DefaultArchiveExtension;
    FindFirst(Cdir+Cname+Cext, ReadOnly Or Hidden Or SysFile Or archive, sr);
    If DosError <> 0 Then Halt(nothing_to_do);

    While DosError = 0 Do Begin
      ArchiveName := FExpand(Cdir+sr.Name);
      CheckSfx(ArchiveName);      {-Check for EXE-archive}
      OpenArchive(ArchiveName);
      If ArchiveOffset <> 0 Then Seek(Hyperfile, ArchiveOffset);
      Get_Archive_Headers(Hyperfile);
      CloseArchive;

      ViewFilesInArchive(ArchiveName);
      Free_Archive_Headers;
      FindNext(sr)
    End
  End;

Var
  ExitSave : Pointer;

  (*$F+*)
  Procedure ErrorExit;
  Begin ExitProc := ExitSave;
    Case ExitCode Of
      normal_exit : ;
      wUsage : WriteLn(CRLF+UsageText);
      ArchiveError : Hypermessage(SayError, 'in archive, use '+Name+'fix');
      Input_Error : Hypermessage(SayError, 'reading input file');
      eDiskFull : Hypermessage(SayError, 'writing output file. Disk full?');
      Memory_Error : Hypermessage(SayError, 'not enough memory');
      {-------}
      eCompression : Hypermessage(SayError, 'unknown compression method');
      eCreatArc : Hypermessage(SayError, 'creating archive');
      {-------}
      nothing_to_do : Begin Hypermessage(SayNothing, NothingToDo);
                        ExitCode := 0
                      End;
      eCheckSum : Hypermessage(SayError, 'bad checksum');
      ctrlc_pressed : Hypermessage('^C', 'CTRL-C pressed');
    Else Hypermessage(SayError, 'unknown error (code '+L2S(ExitCode, 0)+')')
    End;
    ErrorAddr := Nil
  End;
  (*$F-*)

  Procedure Get_Drive;
  Var
    st : String;
  Begin
    GetDir(0, st); CurrentDrive := st[1]
  End;

Begin
  ExitSave:= ExitProc;
  ExitProc := @ErrorExit;
  Alloc_Mem;
  Initialize_Archive_Headers;
  Get_Drive;
  ArchiveName:= ParamStr(1);

  WriteLn(VersionName+CRLF+
          CopyRight);
  If ArchiveName = '' Then
    Halt(wUsage);
  DoIt
End.