{ Default Compiler Directives}
{$S-,R-,V-,I-,N-,B-,F-}

{$IFNDEF Ver40}
  {Allow overlays}
  {$F+,O-,X+,A-}
{$ENDIF}

UNIT FASTDIR;

INTERFACE

USES Dos;

CONST

    MaxDirSize = 4096;

    Erased  : WORD = $09;
    Moved   : WORD = $0F;

    ShowFileType : BOOLEAN = FALSE;
    DoFullSearch : BOOLEAN = TRUE;  { used for FIND_FILEPATH to search all DIRS }
    NoShow       : WORD = Directory + Hidden + VolumeID;
    CurrentLess  : CHAR = 'n';
    SilentDirStr : PATHSTR = '';    { hidden directory ?? }

TYPE

    FileTypes = (fARC, fPAK, fZIP, fLZH, fARJ, fZOO, fLBR, fCOM, fEXE, fBAT,
                 fSFX, fDIR, fVOL, fOTHER, fERROR);

    DirPtr   = ^DirRec;
    DirRec   = RECORD
                 fType  : FILETYPES;
                 Attr   : WORD;
                 Time   : LONGINT;
                 PSize,
                 Size   : LONGINT;
                 Method,
                 Name   : STRING [12];
                 Path   : PathStr;
                 Tag    : BOOLEAN;
                 Next,
                 Prev   : DirPtr;
               END;

  LessFunc = FUNCTION (X, Y : DirPtr) : BOOLEAN;
  SortPPtr = ^Sortpage;
  SortPage = ARRAY [0..PRED(MaxDirSize)] OF DirPtr;

  DirList  = RECORD
             Root,
             Last,
             Current  : DirPtr;         { Points to Root,Last,Current items }
             Path     : PathStr;        { Dir Path Or Archive Name }
             Mask     : PathStr;        { Command Line or params }
             ArcType  : FILETYPES;      { DIR or Type of Archive }
             Recurse  : BOOLEAN;        { Include SUBS Too }
             Count,
             Tagged   : INTEGER;
             Space,
             TSpace   : LONGINT;
             Less     : LessFunc;       { Sort function }
             END;

  ExtractorRec = RECORD
                 Extract  : PathStr;
                 Compress : PathStr;
                 ListChar : Char;
                 END;

CONST

  Extractors : ARRAY [fARC .. fARJ] OF ExtractorRec = (

    (Extract  : 'ARC.EXE e';
     Compress : 'ARC.EXE a';
     ListChar : #32),

    (Extract  : 'PAK.EXE e /wa';
     Compress : 'PAK.EXE -a';
     ListChar : #32),

    (Extract  : 'PKUNZIP.EXE -o';
     Compress : 'PKZIP.EXE -ex';
     ListChar : '@'),

    (Extract  : 'LHARC.EXE -cm';
     Compress : 'LHARC.EXE a';
     ListChar : #32),

    (Extract  : 'ARJ.EXE e -y';
     Compress : 'ARJ.EXE a';
     ListChar : '!') );

FUNCTION  LessName (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessExt  (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessPath (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessSize (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessTime (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessAttr (X, Y : DirPtr) : BOOLEAN;

FUNCTION  FileTypePerExtension(fName : PathStr) : FileTypes;
FUNCTION  FileTypeString (FT : FileTypes) : STRING;
FUNCTION  GetArcType (FName : PathStr) : FileTypes;

PROCEDURE InitializeDir (VAR Dir : DirList);
PROCEDURE FindFiles (VAR Dir : DirList; SearchPath : PathStr);
PROCEDURE SortFiles (VAR Dir : DirList);
PROCEDURE ReleaseFiles (VAR Dir : DirList);
PROCEDURE SetLess (VAR Dir : DirList; LChar : CHAR);
PROCEDURE GetCommandLine (VAR Mask : PathStr);      { Get MASK from command line     }

PROCEDURE UpdateNextPrev (VAR Dir : DirList);
FUNCTION  NthDirItem (VAR Dir : DirList; Item : INTEGER) : DirPtr;

FUNCTION  IsDir(fName : PathStr) : BOOLEAN;
FUNCTION  IsArchive(fName : PathStr) : BOOLEAN;

PROCEDURE ZipView(VAR Dir : DirList; ZIPFile : String);  { handle ZIP File }
PROCEDURE ArjView(VAR Dir : DirList; ArjFile : String);  { handle ARJ File }
PROCEDURE LzhView(VAR Dir : DirList; LzhFile : String);  { handle LZH File }
PROCEDURE ArcView(VAR Dir : DirList; ArcName : PathStr); { handle ARC,PAK File }

PROCEDURE GetFiles(VAR Dir : DirList; Path,Mask : PathStr; Sort : LessFunc);

{ Interfaced for TEST program }
FUNCTION  PadR (InpStr : STRING; FieldLen : BYTE) : STRING;
FUNCTION  PadL(InpStr : STRING; Len : Byte) : STRING;
FUNCTION  FullPathname (Path, FileMask : PathStr) : PathStr;

IMPLEMENTATION

{ ?????????????????????????????????????????????????????????????????????????? }
{ ?                 STRING FUNCTIONS AND PROCEDURES                        ? }
{ ?????????????????????????????????????????????????????????????????????????? }


Procedure StrUpr(Var S: String); Assembler;
Asm
  push    ds              { Save DS on stack }
  lds     si, S           { Load DS:SI With Pointer to S }
  cld                     { Clear direction flag - String instr. Forward }
  lodsb                   { Load first Byte of S (String length Byte) }
  sub     ah, ah          { Clear high Byte of AX }
  mov     cx, ax          { Move AX in CX }
  jcxz    @Done           { Length = 0, done }
  mov     ax, ds          { Set ES to the value in DS through AX }
  mov     es, ax          { (can't move between two segment Registers) }
  mov     di, si          { DI and SI now point to the first Char. }
@UpCase:
  lodsb                   { Load Character }
  cmp     al, 'a'
  jb      @notLower       { below 'a' -- store as is }
  cmp     al, 'z'
  ja      @notLower       { above 'z' -- store as is }
  sub     al, ('a' - 'A') { convert Character in AL to upper Case }
@notLower:
  stosb                   { Store upCased Character in String }
  loop    @UpCase         { Decrement CX, jump if not zero }
@Done:
  pop     ds              { Restore DS from stack }
end;

FUNCTION Uppercase(S : STRING) : STRING;
BEGIN
StrUpr(S);
Uppercase := S;
END;

FUNCTION LoCase (InChar : CHAR) : CHAR;
BEGIN
   IF InChar IN ['A'..'Z'] THEN
      LoCase := CHR (ORD (Inchar) + 32)
   ELSE
      LoCase := InChar
END;

FUNCTION FixLen (AnyString : STRING; PadChar : CHAR; FldSize : WORD) : STRING;
                                                             assembler;
asm
        PUSH    DS              {Save Data Segment}
        CLD                     {Clear direction flag}
        LDS     SI, AnyString    {DS:SI-->AnyString}
        LES     DI, @Result      {ES:DI-->String to be returned}
        MOV     BX, DI           {Save DI value for later}
        LODSB                   {AL has Length(AnyString)}
        CBW                     {Make AL into word in AX}
        STOSB                   {Put the length into Result & Inc(DI)}
        MOV     CX, AX           {Length in CX}
        REP     MOVSB           {Pad=AnyString}
        MOV     CX, FldSize      {CX has FldSize}
        XOR     CH, CH           {Make FldSize=FldSize mod 256}
        MOV     ES : [BX], CL      {Make Length(Pad)=FldSize}
        SUB     CX, AX           {CX=FldSize-Length(AnyString)}
        JB      @1              {Return truncated string if CX<0}
        MOV     AL, PadChar      {else load character to pad}
        REP     STOSB           {and pad to FldSize}
@1 :                             {Go back}
        POP     DS              {Restore Data Segment}
END;


FUNCTION PadR (InpStr : STRING; FieldLen : BYTE) : STRING;
BEGIN
PadR := FixLen (InpStr, #32, FieldLen);
END;

Procedure RightJustify(Var S: String; Width: Byte); Assembler;
Asm
   push    ds              { Save DS }
   lds     si, S           { Load Pointer to String }
   mov     al, [si]        { Move length Byte  in AL }
   mov     ah, Width       { Move Width in AH }
   sub     ah, al          { Subtract }
   jbe     @Done           { if Length(S) >= Width then Done... }
   push    si              { Save SI on stack }
   mov     cl, al
   sub     ch, ch          { CX = length of the String }
   add     si, cx          { SI points to the last Character }
   mov     dx, ds
   mov     es, dx          { ES = DS }
   mov     di, si          { DI = SI }
   mov     dl, ah
   sub     dh, dh          { DX = number of spaces to padd }
   add     di, dx          { DI points to the new end of the String }
   std                     { String ops backward }
   rep     movsb           { Copy String to the new location }
   pop     si              { SI points to S }
   mov     di, si          { DI points to S }
   add     al, ah          { AL = new length Byte }
   cld                     { String ops Forward }
   stosb                   { Store new length Byte }
   mov     al, ' '
   mov     cx, dx          { CX = number of spaces }
   rep     stosb           { store spaces }
@Done:
   pop     ds              { Restore DS }
end;

FUNCTION PadL(InpStr : STRING; Len : Byte) : STRING;
BEGIN
RightJustify(InpStr,Len);
PadL := InpStr;
END;

FUNCTION TrimB (InpStr : STRING) : STRING;
BEGIN
while (InpStr[0] > #0) and (InpStr[Length(InpStr)] = #32) do
         Dec(InpStr[0]);  { trim left }
  while (InpStr[0] > #0) and (InpStr[1] = #32) do
  begin
    Move(InpStr[2], InpStr[1], Pred(Length(InpStr)));
    Dec(InpStr[0]);
  end;
  TrimB := InpStr;
END;

PROCEDURE Replace (VAR S : STRING; NowChar, ReplaceChar : CHAR);
VAR i    : BYTE;
    SLen : BYTE ABSOLUTE S;
BEGIN
FOR i := 1 TO SLen DO
    IF S [i] = NowChar THEN S [i] := ReplaceChar;
END;


FUNCTION GetStr (VAR InpStr : STRING; Delim : CHAR) : STRING;
VAR i : INTEGER;
BEGIN
   i := POS (Delim, InpStr);
   IF i = 0 THEN BEGIN
      GetStr := InpStr;
      InpStr := ''
      END
   ELSE BEGIN
      GetStr := COPY (InpStr, 1, i - 1);
      DELETE (InpStr, 1, i)
      END
END;

{ ?????????????????????????????????????????????????????????????????????????? }
{ ?                        PATH PROCEDURES AND FUNCTIONS                   ? }
{ ?????????????????????????????????????????????????????????????????????????? }

FUNCTION PathOnly (FileName : PathStr) : PathStr;
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   PathOnly := Dir;
END {PathOnly};

FUNCTION RootOnly (FileName : PathStr) : PathStr;
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   RootOnly := COPY (Dir, 1, 2) + '\';
END {RootOnly};

FUNCTION NameOnly (FileName : PathStr) : PathStr;
{ Strip any path information from a file specification }
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   NameOnly := Name + Ext;
END {NameOnly};

FUNCTION BaseNameOnly (FileName : PathStr) : PathStr;
{ Strip any path and extension from a file specification }
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   BaseNameOnly := Name;
END {BaseNameOnly};

FUNCTION ExtOnly (FileName : PathStr) : PathStr;
{ Strip the path and name from a file specification.  Return only the }
{ filename extension.                                                 }
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   IF POS ('.', Ext) <> 0 THEN
      DELETE (Ext, 1, 1);
   ExtOnly := Ext;
END {ExtOnly};

FUNCTION NameLessExt (FileName : PathStr) : PathStr;
{ Strip any extension from a file specification }
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   NameLessExt := Dir + Name;
END;

FUNCTION AddBackSlash(DirName : string) : string;
  {-Add a default backslash to a directory name}
begin
  if DirName[Length(DirName)] in ['\',':',#0] then
    AddBackSlash := DirName
  else
    AddBackSlash := DirName+'\';
end;


FUNCTION NoBackSlash (Path : PathStr) : PathStr;
{ Returns a path name that has its last backslash removed }
BEGIN
  IF (Path [LENGTH (Path) ] = '\') AND     { Last char of path is backslash }
     (Path <> '\') AND                    { Path is not a root directory }
     NOT ( (LENGTH (Path) = 3) AND (COPY (Path, 2, 2) = ':\') ) THEN
    DELETE (Path, LENGTH (Path), 1);                    { Delete backslash }
  NoBackSlash := Path;
END; { Nobackslash }

FUNCTION StripPathName (Path : PathStr) : PathStr;
{If path contains wildcard *.*,??? Then Strip away leaving only path}

VAR Temp, S : PathStr;
    Wild   : BYTE;

BEGIN
Path := NoBackSlash (Path);
S    := PathOnly(Path);
Temp := NameOnly(Path);
Wild := POS ('*', Temp) + POS ('?', Temp) + POS ('.', Temp);
IF Wild <> 0 THEN Path := S;
IF (LENGTH (Path) = 1) AND (UPCASE (Path [1]) IN ['A'..'Z']) THEN Path := Path + ':\';
IF Path [LENGTH (Path) ] <> '\' THEN Path := Path + '\';
StripPathName := Path;
END;


FUNCTION FullPathname (Path, FileMask : PathStr) : PathStr;
 BEGIN                     {FullPathname}
 Path     := TrimB (StripPathName (Path) );
 Filemask := TrimB (Filemask);
 IF POS (':', FileMask) + POS ('.', FileMask) > 0 THEN FileMask := NameOnly (FileMask);
 IF Path [LENGTH (Path) ] = '\' THEN
    DELETE (Path, LENGTH (Path), 1);        { Delete backslash }
 IF FileMask [1] = '\' THEN FileMask := COPY (FileMask, 2, LENGTH (FileMask) );
 FullPathName := FExpand (Path + '\' + FileMask);
 END;                      {FullPathname}

FUNCTION SameName (N1, N2 : STRING) : BOOLEAN;
{
  Function to compare filespecs.

  Wildcards allowed in either name.
  Filenames should be compared seperately from filename extensions by using
     seperate calls to this function
        e.g.  FName1.Ex1
              FName2.Ex2
              are they the same?
              they are if SameName(FName1, FName2) AND SameName(Ex1, Ex2)

  Wildcards work the way DOS should've let them work (eg. *XX.DAT doesn't
  match just any file...only those with 'XX' as the last two characters of
  the name portion and 'DAT' as the extension).

  This routine calls itself recursively to resolve wildcard matches.

}
VAR
   P1, P2 : INTEGER;
   Match  : BOOLEAN;
BEGIN
   P1    := 1;
   P2    := 1;
   Match := TRUE;

   IF (LENGTH (N1) = 0) AND (LENGTH (N2) = 0) THEN
      Match := TRUE
   ELSE
      IF LENGTH (N1) = 0 THEN
         IF N2 [1] = '*' THEN
            Match := TRUE
         ELSE
            Match := FALSE
      ELSE
         IF LENGTH (N2) = 0 THEN
            IF N1 [1] = '*' THEN
               Match := TRUE
            ELSE
               Match := FALSE;

   WHILE (Match = TRUE) AND (P1 <= LENGTH (N1) ) AND (P2 <= LENGTH (N2) ) DO
      IF (N1 [P1] = '?') OR (N2 [P2] = '?') THEN BEGIN
         INC (P1);
         INC (P2);
      END {then}
      ELSE
         IF N1 [P1] = '*' THEN BEGIN
            INC (P1);
            IF P1 <= LENGTH (N1) THEN BEGIN
               WHILE (P2 <= LENGTH (N2) ) AND NOT SameName (COPY (N1, P1, LENGTH (N1) - P1 + 1),COPY(N2,P2,LENGTH(N2)-P2+1)) DO
                  INC (P2);
               IF P2 > LENGTH (N2) THEN
                  Match := FALSE
               ELSE BEGIN
                  P1 := SUCC (LENGTH (N1) );
                  P2 := SUCC (LENGTH (N2) );
               END {if};
            END {then}
            ELSE
               P2 := SUCC (LENGTH (N2) );
         END {then}
         ELSE
            IF N2 [P2] = '*' THEN BEGIN
               INC (P2);
               IF P2 <= LENGTH (N2) THEN BEGIN
                  WHILE (P1 <= LENGTH (N1) ) AND NOT SameName (COPY (N1, P1, LENGTH (N1)-P1+1),COPY(N2, P2,LENGTH(N2)-P2+1)) DO
                     INC (P1);
                  IF P1 > LENGTH (N1) THEN
                     Match := FALSE
                  ELSE BEGIN
                     P1 := SUCC (LENGTH (N1) );
                     P2 := SUCC (LENGTH (N2) );
                  END {if};
               END {then}
               ELSE
                  P1 := SUCC (LENGTH (N1) );
            END {then}
            ELSE
               IF UPCASE (N1 [P1]) = UPCASE (N2 [P2]) THEN BEGIN
                  INC (P1);
                  INC (P2);
               END {then}
               ELSE
                  Match := FALSE;

   IF P1 > LENGTH (N1) THEN BEGIN
      WHILE (P2 <= LENGTH (N2) ) AND (N2 [P2] = '*') DO
         INC (P2);
      IF P2 <= LENGTH (N2) THEN
         Match := FALSE;
   END {if};

   IF P2 > LENGTH (N2) THEN BEGIN
      WHILE (P1 <= LENGTH (N1) ) AND (N1 [P1] = '*') DO
         INC (P1);
      IF P1 <= LENGTH (N1) THEN
         Match := FALSE;
   END {if};

   SameName := Match;

END {SameName};

FUNCTION Exist (FName : PathStr; GoodAttr : WORD) : BOOLEAN;
    {-Return true if file is found and attribute matches }
  VAR
    Regs : REGISTERS;
    FLen : BYTE ABSOLUTE FName;
  BEGIN
    {check for empty string}
    IF LENGTH (FName) = 0 THEN Exist := FALSE
    ELSE WITH Regs DO
    BEGIN
      IF IORESULT = 0 THEN ; {clear IoResult}
      INC (FLen);
      FName [FLen] := #0;
      AX := $4300;           {get file attribute}
      DS := SEG (FName);
      DX := OFS (FName [1]);
      MSDOS (Regs);
      Exist := (NOT ODD (Flags) ) AND (IORESULT = 0) AND
                   (CX AND GoodAttr <> 0);
    END;
  END;


{ ?????????????????????????????????????????????????????????????????????????? }
{ ?                           SORTING FUNCTIONS                            ? }
{ ?????????????????????????????????????????????????????????????????????????? }


FUNCTION LessName (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessName := X^.Name < Y^.Name;
END;

FUNCTION LessExt (X, Y : DirPtr) : BOOLEAN;
VAR P   : BYTE;
    E, E1 : STRING [3];
BEGIN
    P := POS ('.', X^.Name);
    IF P > 1 THEN E := COPY (X^.Name, P + 1, 3)
    ELSE E := '';

    P := POS ('.', Y^.Name);
    IF P > 1 THEN E1 := COPY (Y^.Name, P + 1, 3)
    ELSE E1 := '';
  LessExt := E < E1;
END;

FUNCTION LessPath (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessPath := X^.Path < Y^.Path;
END;

FUNCTION LessSize (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessSize := X^.Size < Y^.Size;
END;

FUNCTION LessTime (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessTime := X^.Time < Y^.Time;
END;

FUNCTION LessAttr (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessAttr := X^.Attr < Y^.Attr;
END;

PROCEDURE QuickSort (L, R : INTEGER; VAR Page : SortPage; Less : LessFunc);
VAR
  I, J : INTEGER;
  X    : DirPtr;

  PROCEDURE ExchangeStructs(var I, J; Size : Word);
    inline(
      $FC/                     {cld             ;go forward}
      $8C/$DA/                 {mov dx,ds       ;save DS}
      $59/                     {pop cx          ;CX = Size}
      $5E/                     {pop si}
      $1F/                     {pop ds          ;DS:SI => J}
      $5F/                     {pop di}
      $07/                     {pop es          ;ES:DI => I}
      $D1/$E9/                 {shr cx,1        ;move by words}
      $E3/$0C/                 {jcxz odd}
      $9C/                     {pushf}
                               {start:}
      $89/$F3/                 {mov bx,si}
      $26/$8B/$05/             {mov ax,es:[di]  ;exchange words}
      $A5/                     {movsw}
      $89/$07/                 {mov [bx],ax}
      $E2/$F6/                 {loop start      ;again?}
      $9D/                     {popf}
                               {odd:}
      $73/$07/                 {jnc exit}
      $8A/$04/                 {mov al,[si]     ;exchange the odd bytes}
      $26/$86/$05/             {xchg al,es:[di]}
      $88/$04/                 {mov [si],al}
                               {exit:}
      $8E/$DA);                {mov ds,dx       ;restore DS}

BEGIN
  I := L;
  J := R;
  X := Page [ (L + R) DIV 2];
  REPEAT
    WHILE Less (Page [I], X) DO INC (I);
    WHILE Less (X, Page [J]) DO DEC (J);
    IF I <= J THEN
    BEGIN
      ExchangeStructs (Page [I], Page [J], SIZEOF (DirPtr) );
      INC (I);
      DEC (J);
    END;
  UNTIL I > J;
  IF L < J THEN QuickSort (L, J, Page, Less);
  IF I < R THEN QuickSort (I, R, Page, Less);
END;

{ ?????????????????????????????????????????????????????????????????????????? }
{ ?                 INTERFACED PROCEDURES AND FUNCTIONS                    ? }
{ ?????????????????????????????????????????????????????????????????????????? }

FUNCTION FileTypePerExtension(fName : PathStr) : FileTypes;

VAR
     Ext : ExtStr;

BEGIN
   Ext := ExtOnly(Uppercase(fName));
   IF (fName = '.') OR (fName = '..') OR (fName = '\') OR
   (POS('\.',fName) + POS('..',fName) > 0) THEN
   FileTypePerExtension := fDIR ELSE
   IF (POS(Ext,'.ARC.PAK.ZIP.LZH.ARJ.ZOO.LBR.COM.EXE.BAT') = 0) THEN
   FileTypePerExtension := fOTHER ELSE
   FileTypePerExtension := FILETYPES(POS(Ext,'.ARC.PAK.ZIP.LZH.ARJ.ZOO.LBR.COM.EXE.BAT') div 4);
END;

FUNCTION FileTypeString (FT : FileTypes) : STRING;
BEGIN
CASE FT OF
    fARC   : FileTypeString := 'ARC';
    fPAK   : FileTypeString := 'PAK';
    fZIP   : FileTypeString := 'ZIP';
    fLBR   : FileTypeString := 'LBR';
    fZOO   : FileTypeString := 'ZOO';
    fLZH   : FileTypeString := 'LZH';
    fARJ   : FileTypeString := 'ARJ';
    fCOM   : FileTypeString := 'COM';
    fEXE   : FileTypeString := 'EXE';
    fBAT   : FileTypeString := 'BATCH';
    fSFX   : FileTypeString := 'SFX';
    fDIR   : FileTypeString := 'DIR';
    fVOL   : FileTypeString := 'VOLUME';
    fOTHER : FileTypeString := 'FILE';
    fERROR : FileTypeString := 'ERROR';
    ELSE FileTypeString := '';
    END;
END;

FUNCTION GetArcType (FName : PathStr) : FileTypes;
VAR
  ArcFile : FILE;
  i       : INTEGER;
  Gat     : FileTypes;
  c       : ARRAY [1..5] OF BYTE;
BEGIN
  ASSIGN (ArcFile, FName);
  RESET  (ArcFile,1);
  IF IORESULT <> 0 THEN
    Gat := fError
  ELSE
  IF FILESIZE (ArcFile) < 5 THEN
    Gat := fError
  ELSE
  BEGIN
    BLOCKREAD (ArcFile, c , 5);
    CLOSE (ArcFile);
    IF ( (c [1] = $50) AND (c [2] = $4B) ) THEN
      Gat := fZip
    ELSE
    IF ( (c [1] = $60) AND (c [2] = $EA) ) THEN
      Gat := fArj
    ELSE
    IF ( (c [4] = $6c) AND (c [5] = $68) ) THEN
      Gat := fLzh
    ELSE
    IF ( (c [1] = $5a) AND (c [2] = $4f) AND (c [3] = $4f) ) THEN
      Gat := fZoo
    ELSE
    IF ( (c [1] = $1a) AND (c [2] = $08) ) THEN
      Gat := fArc
    ELSE
    IF ( (c [1] = $1a) AND (c [2] = $0b) ) THEN
      Gat := fPak
    ELSE
      Gat := fOTHER;
  END;

  GetArcType := Gat;
END;

FUNCTION MethodString (Method : BYTE) : STRING;
CONST
    Stowage : ARRAY [0..12] OF STRING [9] =
      ('Stored', 'Shrunk', 'Stored', 'Packed', 'Squeezed', 'LZCrunch', 'LZCrunch',
      'LZW Pack', 'Crunched',