home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / paswiz15 / source / archives.pas next >
Encoding:
Pascal/Delphi Source File  |  1993-08-04  |  15.0 KB  |  529 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1993  Thomas G. Hanlin III         |
  4.     |             3544 E. Southern Ave. #104,  Mesa, AZ 85204              |
  5.     |                                                                      |
  6.     |                     The Pascal Wizard's Library                      |
  7.     |                                                                      |
  8.     +----------------------------------------------------------------------+
  9.  
  10.  
  11.  
  12. Archives:
  13.  
  14.    This collection of routines allows you to retrieve full directory
  15.    information from any popular archive format: ARC, ARJ, LZH, PAK, ZIP,
  16.    ZOO, or even self-extracting .EXEs.
  17.  
  18. }
  19.  
  20.  
  21.  
  22. UNIT Archives;
  23.  
  24.  
  25.  
  26. INTERFACE
  27.  
  28.  
  29.  
  30. PROCEDURE CloseA;
  31. FUNCTION GetCRCA: STRING;
  32. FUNCTION GetDateA: STRING;
  33. FUNCTION GetNameA: STRING;
  34. PROCEDURE GetSizeA (VAR OriginalSize: LONGINT; VAR CurrentSize: LONGINT);
  35. FUNCTION GetStoreA: STRING;
  36. FUNCTION GetTimeA: STRING;
  37. PROCEDURE FindNextA (VAR ErrCode: INTEGER);
  38. PROCEDURE FindFirstA (Archive, FileName: STRING; VAR ErrCode: INTEGER);
  39.  
  40.  
  41.  
  42. { --------------------------------------------------------------------------- }
  43.  
  44.  
  45.  
  46. IMPLEMENTATION
  47.  
  48. USES
  49.    Strings;
  50.  
  51.  
  52.  
  53. TYPE
  54.    BufferType = RECORD
  55.       CASE banana: BOOLEAN OF
  56.          FALSE: (junk: CHAR; buf: ARRAY[1..127] OF CHAR);
  57.          TRUE : (str: STRING[128]);
  58.    END;
  59.  
  60.  
  61.  
  62. VAR
  63.    ArcType:
  64.       INTEGER;
  65.    Handle:
  66.       FILE;
  67.    PatternFileName:
  68.       STRING;
  69.    Header:
  70.       BufferType;
  71.  
  72.  
  73.  
  74. FUNCTION StrF (x: WORD): STRING;
  75. VAR
  76.    st: STRING;
  77. BEGIN
  78.    Str(x, st);
  79.    StrF := st;
  80. END;
  81.  
  82.  
  83.  
  84. FUNCTION CVI (st: STRING): INTEGER;
  85. BEGIN
  86.    CVI := ORD(st[2]) SHL 8 + ORD(St[1]);
  87. END;
  88.  
  89.  
  90.  
  91. FUNCTION CVL (st: STRING): LONGINT;
  92. BEGIN
  93.    CVL := (ORD(st[4]) SHL 8 + ORD(St[3]) SHL 16)
  94.         + ORD(st[2]) SHL 8 + ORD(St[1]);
  95. END;
  96.  
  97.  
  98.  
  99. PROCEDURE CloseA;
  100. BEGIN
  101.    Close(Handle);
  102. END;
  103.  
  104.  
  105.  
  106. FUNCTION FileExists(FileName: STRING): BOOLEAN;
  107. VAR
  108.    Handle: FILE;
  109. BEGIN
  110.    {$I-}
  111.    Assign(Handle, FileName);
  112.    Reset(Handle);
  113.    Close(Handle);
  114.    {$I+}
  115.    FileExists := (IOResult = 0);
  116. END;
  117.  
  118.  
  119.  
  120. FUNCTION GetCRCA: STRING;
  121. VAR
  122.    CRC, Result: STRING;
  123.    tmp, Digit: WORD;
  124. BEGIN
  125.    CASE ArcType OF
  126.       1: CRC := Copy(Header.str, 24, 2) + CHR(0) + CHR(0);
  127.       2: CRC := Copy(Header.str, ORD(Header.str[22]) + 23, 2) + CHR(0) + CHR(0);
  128.       3: CRC := Copy(Header.str, 15, 4);
  129.       4: CRC := Copy(Header.str, 19, 2) + CHR(0) + CHR(0);
  130.       5: CRC := Copy(Header.str, 25, 4);
  131.    END;
  132.    CRC := CRC[4] + CRC[3] + CRC[2] + CRC[1];
  133.    Result := '';
  134.    FOR tmp := 1 TO 4 DO BEGIN
  135.       Digit := ORD(CRC[tmp]) SHR 4;
  136.       IF Digit < 10 THEN
  137.          Result := Result + CHR(Digit + 48)
  138.       ELSE
  139.          Result := Result + CHR(Digit + 55);
  140.       Digit := ORD(CRC[tmp]) AND $F;
  141.       IF Digit < 10 THEN
  142.          Result := Result + CHR(Digit + 48)
  143.       ELSE
  144.          Result := Result + CHR(Digit + 55);
  145.    END;
  146.    GetCRCA := Result;
  147. END;
  148.  
  149.  
  150.  
  151. FUNCTION GetDateA: STRING;
  152. VAR
  153.    Year, Month, Day: STRING;
  154.    tmp: LONGINT;
  155. BEGIN
  156.    CASE ArcType OF
  157.       1: tmp := CVL(Copy(Header.str, 20, 2) + CHR(0) + CHR(0));
  158.       2: tmp := CVL(Copy(Header.str, 18, 2) + CHR(0) + CHR(0));
  159.       3: tmp := CVL(Copy(Header.str, 13, 2) + CHR(0) + CHR(0));
  160.       4: tmp := CVL(Copy(Header.str, 15, 2) + CHR(0) + CHR(0));
  161.       5: tmp := CVL(Copy(Header.str, 15, 2) + CHR(0) + CHR(0));
  162.    END;
  163.    Year := Right('000' + StrF(tmp DIV 512 + 1980), 4);
  164.    Day := Right('0' + StrF(tmp AND $1F), 2);
  165.    Month := Right('0' + StrF(tmp DIV 32 AND $F), 2);
  166.    GetDateA := Month + '-' + Day + '-' + Year;
  167. END;
  168.  
  169.  
  170.  
  171. FUNCTION GetNameA: STRING;
  172. VAR
  173.    FileName, St: STRING;
  174.    FLen: WORD;
  175. BEGIN
  176.    CASE ArcType OF
  177.       1: BEGIN
  178.             St := Copy(Header.str, 3, 13);
  179.             FLen := Pos(CHR(0), St);
  180.             IF FLen = 0 THEN
  181.                FLen := 12
  182.             ELSE
  183.                DEC(FLen);
  184.             FileName := St;
  185.          END;
  186.       2: BEGIN
  187.             FLen := ORD(Header.str[22]);
  188.             FileName := Copy(Header.str, 23, FLen);
  189.          END;
  190.       3: BEGIN
  191.             FLen := ORD(Header.str[27]);
  192.             FileName := Copy(Header.str, 31, FLen);
  193.          END;
  194.       4: IF Header.str[31] = CHR(1) THEN
  195.             FLen := 0
  196.          ELSE BEGIN
  197.             FLen := Pos(CHR(0), Copy(Header.str, 39, 13)) - 1;
  198.             FileName := Copy(Header.str, 39, FLen);
  199.          END;
  200.       5: IF ORD(Header.str[11]) > 1 THEN
  201.             FLen := 0
  202.          ELSE BEGIN
  203.             St := Copy(Header.str, 35, 80);
  204.             Flen := Pos(CHR(0), St);
  205.             IF FLen > 0 THEN DEC(FLen);
  206.             FileName := St;
  207.          END;
  208.    END;
  209.    GetNameA := Copy(FileName, 1, FLen);
  210. END;
  211.  
  212.  
  213.  
  214. PROCEDURE GetSizeA (VAR OriginalSize: LONGINT; VAR CurrentSize: LONGINT);
  215. BEGIN
  216.    CASE ArcType OF
  217.       1: BEGIN
  218.             CurrentSize := CVL(Copy(Header.str, 16, 4));
  219.             IF ORD(Header.str[2]) = 1 THEN
  220.                OriginalSize := CurrentSize
  221.             ELSE
  222.                OriginalSize := CVL(Copy(Header.str, 26, 4));
  223.          END;
  224.       2: BEGIN
  225.             OriginalSize := CVL(Copy(Header.str, 12, 4));
  226.             CurrentSize := CVL(Copy(Header.str, 8, 4));
  227.          END;
  228.       3: BEGIN
  229.             OriginalSize := CVL(Copy(Header.str, 23, 4));
  230.             CurrentSize := CVL(Copy(Header.str, 19, 4));
  231.          END;
  232.       4: BEGIN
  233.             OriginalSize := CVL(Copy(Header.str, 21, 4));
  234.             CurrentSize := CVL(Copy(Header.str, 25, 4));
  235.          END;
  236.       5: BEGIN
  237.             OriginalSize := CVL(Copy(Header.str, 21, 4));
  238.             CurrentSize := CVL(Copy(Header.str, 17, 4));
  239.          END;
  240.    END;
  241. END;
  242.  
  243.  
  244.  
  245. FUNCTION GetStoreA: STRING;
  246. BEGIN
  247.    CASE ArcType OF
  248.       1: CASE ORD(Header.str[2]) OF
  249.             1, 2: GetStoreA := 'Stored';
  250.             3: GetStoreA := 'Packed';
  251.             4: GetStoreA := 'Squeezed';
  252.             5, 6: GetStoreA := 'crunched';
  253.             7, 8: GetStoreA := 'Crunched';
  254.             9: GetStoreA := 'Squashed';
  255.             10: GetStoreA := 'Crushed';
  256.             11: GetStoreA := 'Distill';
  257.             ELSE GetStoreA := '';
  258.          END;
  259.       2: GetStoreA := RTrim(Copy(Header.str, 3, 5));
  260.       3: CASE ORD(Header.str[9]) OF
  261.             0: GetStoreA := 'Stored';
  262.             1: GetStoreA := 'Shrunk';
  263.             2: GetStoreA := 'Reduce-1';
  264.             3: GetStoreA := 'Reduce-2';
  265.             4: GetStoreA := 'Reduce-3';
  266.             5: GetStoreA := 'Reduce-4';
  267.             6: GetStoreA := 'Imploded';
  268.             8: GetStoreA := 'Deflated';
  269.             ELSE GetStoreA := '';
  270.          END;
  271.       4: GetStoreA := '';
  272.       5: GetStoreA := CHR(ORD(Header.str[10]) + 48);
  273.    END;
  274. END;
  275.  
  276.  
  277.  
  278. FUNCTION GetTimeA: STRING;
  279. VAR
  280.    tmp: LONGINT;
  281.    Hour, Second, Minute: STRING;
  282. BEGIN
  283.    CASE ArcType OF
  284.       1: tmp := CVL(Copy(Header.str, 22, 2) + CHR(0) + CHR(0));
  285.       2: tmp := CVL(Copy(Header.str, 16, 2) + CHR(0) + CHR(0));
  286.       3: tmp := CVL(Copy(Header.str, 11, 2) + CHR(0) + CHR(0));
  287.       4: tmp := CVL(Copy(Header.str, 17, 2) + CHR(0) + CHR(0));
  288.       5: tmp := CVL(Copy(Header.str, 13, 2) + CHR(0) + CHR(0));
  289.    END;
  290.    Hour := Right('0' + StrF(tmp DIV 2048), 2);
  291.    Second := Right('0' + StrF((tmp AND $1F) * 2), 2);
  292.    Minute := Right('0' + StrF((tmp DIV 32) AND $3F), 2);
  293.    GetTimeA := Hour + ':' + Minute + ':' + Second;
  294. END;
  295.  
  296.  
  297.  
  298. PROCEDURE FindNextA (VAR ErrCode: INTEGER);
  299. VAR
  300.    CurFileName: STRING;
  301.    Found: BOOLEAN;
  302.    Chars, Posn: WORD;
  303. BEGIN
  304.    Found := FALSE;
  305.    WHILE NOT Found AND (ErrCode = 0) DO BEGIN
  306.       Posn := FilePos(Handle);
  307.       CASE ArcType OF
  308.          1: BEGIN
  309.                IF ORD(Header.str[2]) = 1 THEN
  310.                   INC(Posn, 25)
  311.                ELSE
  312.                   INC(Posn, 29);
  313.                INC(Posn, CVL(Copy(Header.str, 16, 4)));
  314.             END;
  315.          2: INC(Posn, LONGINT(ORD(Header.str[1])) + 2
  316.                       + CVL(Copy(Header.str, 8, 4)));
  317.          3: INC(Posn, 30 + LONGINT(CVI(Copy(Header.str, 27, 2)))
  318.                       + LONGINT(CVI(Copy(Header.str, 29, 2)))
  319.                       + CVL(Copy(Header.str, 19, 4)));
  320.          4: Posn := CVL(Copy(Header.str, 7, 4));
  321.          5: INC(Posn, LONGINT(CVI(Copy(Header.str, 3, 2)))
  322.                       + CVL(Copy(Header.str, 17, 4)) + 10);
  323.       END;
  324.       IF ErrCode = 0 THEN BEGIN
  325.          Seek(Handle, Posn);
  326.          ErrCode := IOResult;
  327.       END;
  328.       IF ErrCode = 0 THEN BEGIN
  329.          BlockRead(Handle, Header.buf, 128, Chars);
  330.          Header.str[0] := CHR(Chars);
  331.          ErrCode := IOResult;
  332.       END;
  333.       CASE ArcType OF
  334.          1: IF (ORD(Header.str[1]) <> 26) OR (ORD(Header.str[2]) = 0) THEN
  335.                ErrCode := 9999;
  336.          2: IF (Header.str[3] <> '-') OR (ORD(Header.str[1]) = 0) THEN
  337.                ErrCode := 9999;
  338.          3: IF Copy(Header.str, 1, 4) <> 'PK' + CHR(3) + CHR(4) THEN
  339.                ErrCode := 9999;
  340.          5: IF (Copy(Header.str, 1, 2) <> CHR($60) + CHR($EA)) OR (CVI(Copy(Header.str, 3, 2)) = 0) THEN
  341.                ErrCode := 9999;
  342.          ELSE ;
  343.       END;
  344.       IF ErrCode = 0 THEN BEGIN
  345.          Seek(Handle, Posn);
  346.          ErrCode := IOResult;
  347.       END;
  348.       IF ErrCode = 0 THEN BEGIN
  349.          CurFileName := GetNameA;
  350.          IF Length(CurFileName) > 0 THEN
  351.             Found := MatchFile(PatternFileName, CurFileName)
  352.          ELSE
  353.             Found := FALSE;
  354.       END;
  355.    END;
  356. END;
  357.  
  358.  
  359.  
  360. PROCEDURE FindFirstA (Archive, FileName: STRING; VAR ErrCode: INTEGER);
  361. VAR
  362.    CurFileName, St: STRING;
  363.    Posn: LONGINT;
  364.    Found: BOOLEAN;
  365.    Chars: WORD;
  366. BEGIN
  367.    ErrCode := 0;
  368.    Archive := UpperCase(Archive);
  369.    PatternFileName := UpperCase(FileName);
  370.  
  371.    IF Pos('.', Archive) = 0 THEN
  372.       IF FileExists(Archive + '.ZIP') THEN
  373.          Archive := Archive + '.ZIP'
  374.       ELSE IF FileExists(Archive + '.LZH') THEN
  375.          Archive := Archive + '.LZH'
  376.       ELSE IF FileExists(Archive + '.ARC') THEN
  377.          Archive := Archive + '.ARC'
  378.       ELSE IF FileExists(Archive + '.PAK') THEN
  379.          Archive := Archive + '.PAK'
  380.       ELSE IF FileExists(Archive + '.ZOO') THEN
  381.          Archive := Archive + '.ZOO'
  382.       ELSE IF FileExists(Archive + '.ARJ') THEN
  383.          Archive := Archive + '.ARJ'
  384.       ELSE IF FileExists(Archive + '.EXE') THEN
  385.          Archive := Archive + '.EXE'
  386.       ELSE IF FileExists(Archive + '.COM') THEN
  387.          Archive := Archive + '.COM'
  388.       ELSE
  389.          Archive := Archive + '.';
  390.  
  391.    St := Right(Archive, 3);
  392.    IF (St = 'ARC') OR (St = 'PAK') THEN
  393.       ArcType := 1
  394.    ELSE IF St = 'LZH' THEN
  395.       ArcType := 2
  396.    ELSE IF St = 'ZIP' THEN
  397.       ArcType := 3
  398.    ELSE IF St = 'ZOO' THEN
  399.       ArcType := 4
  400.    ELSE IF St = 'ARJ' THEN
  401.       ArcType := 5
  402.    ELSE IF (St = 'COM') OR (St = 'EXE') THEN
  403.       ArcType := -1
  404.    ELSE
  405.       ErrCode := 9999;
  406.  
  407.    Posn := 0;
  408.  
  409.    IF ErrCode = 0 THEN BEGIN
  410.       Assign(Handle, Archive);
  411.       Reset(Handle, 1);
  412.       ErrCode := IOResult;
  413.    END;
  414.    IF ErrCode = 0 THEN BEGIN
  415.       IF ArcType = -1 THEN BEGIN
  416.          BlockRead(Handle, Header.buf, 2, Chars);
  417.          Header.str[0] := CHR(Chars);
  418.          ErrCode := IOResult;
  419.          IF ErrCode = 0 THEN
  420.             IF Header.str <> 'MZ' THEN
  421.                ErrCode := 9999;
  422.          IF ErrCode = 0 THEN BEGIN
  423.             Seek(Handle, 1636);
  424.             ErrCode := IOResult;
  425.          END;
  426.          IF ErrCode = 0 THEN BEGIN
  427.             BlockRead(Handle, Header.buf, 8, Chars);
  428.             Header.str[0] := CHR(Chars);
  429.             ErrCode := IOResult;
  430.          END;
  431.          IF ErrCode = 0 THEN BEGIN
  432.             IF Copy(Header.str, 3, 3) = '-lh' THEN BEGIN
  433.                ArcType := 2;
  434.                Posn := 1636;
  435.                Seek(Handle, Posn);
  436.                ErrCode := IOResult;
  437.             END;
  438.          END;
  439.          IF (ErrCode = 0) AND (ArcType = -1) THEN BEGIN
  440.             Seek(Handle, 12784);
  441.             ErrCode := IOResult;
  442.             IF ErrCode = 0 THEN BEGIN
  443.                BlockRead(Handle, Header.buf, 4, Chars);
  444.                Header.str[0] := CHR(Chars);
  445.                ErrCode := IOResult;
  446.             END;
  447.             IF ErrCode = 0 THEN BEGIN
  448.                IF Copy(Header.str, 1, 4) = 'PK' + CHR(3) + CHR(4) THEN BEGIN
  449.                   ArcType := 3;
  450.                   Posn := 12784;
  451.                   Seek(Handle, Posn);
  452.                   ErrCode := IOResult;
  453.                END
  454.                ELSE
  455.                   ErrCode := 9999;
  456.             END;
  457.          END;
  458.          IF (ErrCode = 0) AND (ArcType = -1) THEN BEGIN
  459.             Seek(Handle, 14858);
  460.             BlockRead(Handle, Header.str, 2, Chars);
  461.             Header.str[0] := CHR(Chars);
  462.             IF Header.str = CHR($60) + CHR($EA) THEN BEGIN
  463.                ArcType := 5;
  464.                Posn := 14858;
  465.                Seek(Handle, Posn);
  466.             END;
  467.          END;
  468.          IF (ErrCode = 0) AND (ArcType = -1) THEN
  469.             ErrCode := 9999;
  470.       END;
  471.       IF ErrCode = 0 THEN BEGIN
  472.          BlockRead(Handle, Header.buf, 128, Chars);
  473.          Header.str[0] := CHR(Chars);
  474.          ErrCode := IOResult;
  475.       END;
  476.       CASE ArcType OF
  477.          1: IF (ORD(Header.str[1]) <> 26) OR (ORD(Header.str[2]) = 0) THEN
  478.                ErrCode := 9999;
  479.          2: IF Header.str[3] <> '-' THEN
  480.                ErrCode := 9999;
  481.          3: IF Copy(Header.str, 1, 4) <> 'PK' + CHR(3) + CHR(4) THEN
  482.                ErrCode := 9999;
  483.          4: IF Copy(Header.str, 21, 4) = CHR($DC) + CHR($A7) + CHR($C4) + CHR($FD) THEN BEGIN
  484.                Posn := CVL(Copy(Header.str, $19, 4));
  485.                Seek(Handle, Posn);
  486.                ErrCode := IOResult;
  487.                IF ErrCode = 0 THEN BEGIN
  488.                   BlockRead(Handle, Header.str, 128, Chars);
  489.                   Header.str[0] := CHR(Chars);
  490.                   ErrCode := IOResult;
  491.                END;
  492.             END
  493.             ELSE
  494.                ErrCode := 9999;
  495.          5: IF Copy(Header.str, 1, 2) <> CHR($60) + CHR($EA) THEN
  496.                ErrCode := 9999
  497.             ELSE BEGIN
  498.                Posn := LONGINT(CVI(Copy(Header.str, 3, 2))) + 10;
  499.                Seek(Handle, Posn);
  500.                ErrCode := IOResult;
  501.                IF ErrCode = 0 THEN BEGIN
  502.                   BlockRead(Handle, Header.buf, 128, Chars);
  503.                   Header.str[0] := CHR(Chars);
  504.                   ErrCode := IOResult;
  505.                END;
  506.             END;
  507.       END;
  508.       IF ErrCode = 0 THEN BEGIN
  509.          Seek(Handle, Posn);
  510.          ErrCode := IOResult;
  511.       END;
  512.       IF ErrCode = 0 THEN BEGIN
  513.          CurFileName := GetNameA;
  514.          IF Length(CurFileName) > 0 THEN
  515.             Found := MatchFile(PatternFileName, CurFileName)
  516.          ELSE
  517.             Found := FALSE;
  518.       END;
  519.       IF (ErrCode <> 0) OR NOT Found THEN
  520.          FindNextA(ErrCode);
  521.    END;
  522. END;
  523.  
  524.  
  525.  
  526. { ----------------------- initialization code --------------------------- }
  527. BEGIN
  528. END.
  529.