'===========================================================================
' Subject: PACK/UNPACK V1.0                   Date: 09-12-97 (12:55)       
'  Author: Sami Kyostila                      Code: QB, QBasic, PDS        
'  Origin: hiteck@mail.freenet.hut.fi       Packet: MISC.ABC
'===========================================================================
'----------------------------------------------------------------------------
'               Pack/UnPack v1.0 by Sami Ky”stil„ - 1997
'----------------------------------------------------------------------------
'        You may use this program freely, but give me some credit
'  I take no responsibility for any possible damage this program may cause.
'----------------------------------------------------------------------------
'
' Here is a useful program that archives files into a single file, so you
' don't have to mess with hundreds of data files. It can run in "NoPrint"-
' mode, so you can use it in your programs without the user noticing anything.
'
' A single archive can hold a maximum of 999 files, each one up to
' 999,999,999,999 bytes in size. See sub Pack for the archive structure
' description.
'
' Use FUNCTION Pack to add files to an archive/create new archive and FUNCTION
' UnPack to extract files from archives. Extracting each file everytime
' you need it in your programs can be very slow, so I've included FUNCTION
' PackOffset, which returns the start byte offset of a file in an archive,
' so you can read the file directly from the archive without having to
' extract it first.
'----------------------------------------------------------------------------



DECLARE FUNCTION FixFileName$ (File$, Extension$)
DEFINT A-Z
DECLARE FUNCTION PackList% (Archive$)
DECLARE FUNCTION PackOffset! (Archive$, Filename$, Length!)
DECLARE FUNCTION Pack (Archive$, Filename$, NoPrint)
DECLARE FUNCTION Unpack (Archive$, Filename$, NoPrint)
DECLARE FUNCTION Exist% (File$)



CLS
COLOR 8
PRINT STRING$(80, CHR$(196))
COLOR 10
PRINT "                   Pack/UnPack v1.0 by Sami Ky”stil„ - 1997"
COLOR 8
PRINT STRING$(80, CHR$(196))
PRINT "          You may use this program freely, but give me some credit"
COLOR 12
PRINT "  I take no responsibility for any possible damage this program may cause."
COLOR 8
PRINT STRING$(80, CHR$(196))
PRINT
COLOR 7
PRINT " Here is a useful program that archives files into a single file, so you"
PRINT " don't have to mess with hundreds of data files. It can run in NoPrint-"
PRINT " mode, so you can use it in your programs without the user noticing anything."
PRINT
PRINT " A single archive can hold a maximum of";
COLOR 14: PRINT 999; : COLOR 7
PRINT "files, each one up to";
COLOR 14: PRINT " 999,999,999,999 ";
COLOR 7
PRINT "bytes in size. See sub Pack for the archive structure"
PRINT " description."
PRINT
PRINT " Use ";
COLOR 14
PRINT "FUNCTION Pack";
COLOR 7
PRINT " to add files to an archive/create new archive and";
COLOR 14
PRINT " FUNCTION"
PRINT " UnPack ";
COLOR 7
PRINT "to extract files from archives. Extracting each file everytime"
PRINT " you need it in your programs can be very slow, so I've included ";
COLOR 14
PRINT "FUNCTION"
PRINT " PackOffset";
COLOR 7
PRINT ", which returns the start byte offset of a file in an archive,"
PRINT " so you can read the file directly from the archive without having to"
PRINT " extract it first."
PRINT
COLOR 9
PRINT "                                         Press any key to continue"
DO: LOOP UNTIL INKEY$ <> ""
CLS
COLOR 7
PRINT " Enter a temporary archive filename to be used in this demo:"
PRINT " If the file exists, it will be overwritten. The default extension"
PRINT " is .PAK"
PRINT
COLOR 14
INPUT "> ", Archive$
IF LTRIM$(RTRIM$(Archive$)) = "" THEN END
LOCATE 5, 3
PRINT FixFileName$(Archive$, "PAK")
COLOR 7

PRINT
PRINT " Enter an existing filename to be used in this demo:"
PRINT " The file can be a binary or a plain ASCII one."
PRINT
PRINT
COLOR 14
INPUT "> ", File1$
IF LTRIM$(RTRIM$(File1$)) = "" THEN END
COLOR 7

PRINT
PRINT " Enter a second existing filename to be used in this demo:"
PRINT " The file can be a binary or a plain ASCII one."
PRINT
COLOR 14
INPUT "> ", File2$
IF LTRIM$(RTRIM$(File2$)) = "" THEN END
COLOR 7



ON ERROR GOTO OhGreat

CONST True = 1
CONST False = NOT True

TYPE PakHeader
  Version AS STRING * 5             'Version
  Total AS STRING * 3               'Total files in archive
END TYPE

DIM SHARED CurrentVersion AS STRING * 5
CurrentVersion = "Pak10"            'Current version signature


IF Exist(Archive$) = True THEN KILL Archive$

ErrorFlag = Pack(Archive$, File1$, 0)               'Add file 1 to archive
IF ErrorFlag <> 0 THEN PRINT " Error"; ErrorFlag: END

ErrorFlag = Pack(Archive$, File2$, 0)               'Add file 2 to archive
IF ErrorFlag <> 0 THEN PRINT " Error"; ErrorFlag: END

ErrorFlag = PackList(Archive$)                      'View contents
IF ErrorFlag <> 0 THEN PRINT " Error"; ErrorFlag: END
SLEEP

ErrorFlag = Unpack(Archive$, "*", 0)                'Extract both files
IF ErrorFlag <> 0 THEN PRINT " Error"; ErrorFlag: END

IF Exist(Archive$) = True THEN KILL Archive$


END


OhGreat:
CLS
PRINT " - Error number";
COLOR 14
PRINT ERR;
COLOR 7
PRINT "has occured."
PRINT "   Program execution";
COLOR 14
PRINT " aborted."
END

FUNCTION Exist% (File$)
'----------------------------------------------------------------------------
'                  Checks if a file exists - Sami Ky”stil„ 1997
'----------------------------------------------------------------------------
'
'    File$ - File to check
'
'----------------------------------------------------------------------------
'  Returns True if file exists, else False
'----------------------------------------------------------------------------


IF File$ = "" THEN Exist = False: EXIT FUNCTION
Checkfile = FREEFILE
OPEN File$ FOR BINARY AS #Checkfile
IF LOF(Checkfile) = 0 THEN
  Exist = False
  CLOSE #Checkfile
  KILL File$
ELSE
  Exist = True
  CLOSE #Checkfile
END IF

END FUNCTION

FUNCTION FixFileName$ (File$, Extension$)
'----------------------------------------------------------------------------
'                  Fixes the filename extension
'----------------------------------------------------------------------------
'
'      File$ - Filename
' Extension$ - Extension
'
'----------------------------------------------------------------------------
'
' If File$'s extension is different than Extension$, then it will be changed
'
' Example:
'
'   File$ = "c:\temp\temp.abc"
'   Extension$ = "exe"
'   Returns: "c:\temp\temp.exe"
'
'----------------------------------------------------------------------------



IF INSTR(File$, ".") > 0 AND INSTR(File$, ".") < LEN(File$) THEN
  IF RIGHT$(UCASE$(File$), LEN(Extension$)) <> UCASE$(Extension$) THEN
    File$ = LEFT$(File$, INSTR(File$, ".")) + Extension$
  END IF
ELSEIF INSTR(File$, ".") = LEN(File$) THEN
  File$ = File$ + Extension$
ELSE
  File$ = File$ + "." + Extension$
END IF

FixFileName$ = File$

END FUNCTION

FUNCTION Pack (Archive$, Filename$, NoPrint)
'----------------------------------------------------------------------------
'   Packs files into an archive, binary or plain text - Sami Ky”stil„ 1997
'----------------------------------------------------------------------------
'
'  Archive$ - Filename of the archive, if the archive exists, then it will
'             be appended. (Max number of files in an archive is 999)
' Filename$ - File to be added to archive. May include a path, but it will
'             be stored without the path. (Max file size 999,999,999,999
'             bytes, should be enough :)
'   NoPrint - If 1, then no text will be printed
'
'----------------------------------------------------------------------------
'                        Returned error codes
'----------------------------------------------------------------------------
'
' 1 = Input file not found
' 2 = Input file is already in archive
'
'----------------------------------------------------------------------------
'                           Archive structure
'----------------------------------------------------------------------------
'
' Header:
'
'   Version (5 bytes)                    - "Pak10"
'   Number of files in archive (3 bytes) - "001"
'
' Data:
'
'   Filename (12 bytes)                  - "MYFILE.EXE  "
'   File size (12 bytes)                 - "000000001234"
'   ...
'   Data area (length indicated above)
'   ...
'
' Next file data (header not repeated)
'
'----------------------------------------------------------------------------


DIM Buffer AS STRING * 1000
BufferSize = LEN(Buffer)

DIM byte AS STRING * 1
DIM Pak AS PakHeader


IF NoPrint = 0 THEN
  CLS
  COLOR 8
  PRINT STRING$(80, CHR$(196))
  COLOR 7
  PRINT "                 Pack/UnPack Freeware by ";
  COLOR 15
  PRINT "Sami Ky”stil„ ";
  COLOR 7
  PRINT "- 1997"
  PRINT "                        Version signature: ";
  COLOR 14
  PRINT CurrentVersion
  COLOR 4
  PRINT "             Use this program as you wish, but give me some credit."
  COLOR 8
  PRINT STRING$(80, CHR$(196))
  COLOR 7
  PRINT
END IF

IF Exist(Filename$) = False THEN Pack = 1: EXIT FUNCTION
IF Exist(Archive$) = False THEN
  new = 1
  f1 = FREEFILE
  OPEN Archive$ FOR BINARY AS #f1
  PUT #f1, 1, CurrentVersion
  Dummy$ = "000"
  PUT #f1, , Dummy$
  CLOSE #f1
  new = 1
ELSE
  new = 0
END IF


f1 = FREEFILE
OPEN Archive$ FOR BINARY AS #f1
f2 = FREEFILE
OPEN Filename$ FOR BINARY AS #f2
Row = CSRLIN + 1

FOR i = LEN(Filename$) TO 1 STEP -1
  IF MID$(Filename$, i, 1) = "\" THEN Filename$ = MID$(Filename$, i + 1, 255)
NEXT
Filename$ = UCASE$(Filename$)


  IF NoPrint = 0 THEN
    IF new = 0 THEN PRINT " "; CHR$(254); " Appending to archive "; Archive$; " at position"; : COLOR 14: PRINT ; LOF(f1): COLOR 7
    IF new = 1 THEN PRINT " "; CHR$(254); " Creating archive "; Archive$: COLOR 7
  END IF

  IF PackOffset(Archive$, Filename$, -1) <> -1 THEN
    IF NoPrint = 0 THEN PRINT " "; CHR$(254); " "; Filename$; " is already in archive "; Archive$
    Pack = 2
    CLOSE #f1
    CLOSE #f2
    EXIT FUNCTION
  END IF

  GET #f1, 1, Pak
  TotalFiles = VAL(Pak.Total)
  TotalFiles = TotalFiles + 1
  Total$ = STRING$(3 - LEN(LTRIM$(RTRIM$(STR$(TotalFiles)))), "0") + LTRIM$(RTRIM$(STR$(TotalFiles)))

  IF NoPrint = 0 THEN PRINT "   Adding "; Filename$; "...";

  PUT #f1, 6, Total$

  Length$ = STRING$(12 - LEN(LTRIM$(RTRIM$(STR$(LOF(f2))))), "0") + LTRIM$(RTRIM$(STR$(LOF(f2))))
  File2$ = Filename$ + STRING$(12 - LEN(Filename$), " ")

  CLOSE f1
  OPEN Archive$ FOR BINARY AS #f1

  SEEK #f1, LOF(f1)

  PUT #f1, SEEK(f1) + 1, File2$
  PUT #f1, , Length$
  PPos = POS(0)
  COLOR 14

  FOR i! = 1 TO LOF(f2) STEP BufferSize
    GET #f2, , Buffer
    Clip! = LOF(f2) + 1 - i!
    IF Clip! <= BufferSize THEN
      Buffer2$ = LEFT$(Buffer, LOF(f2) + 1 - i!)
      PUT #f1, , Buffer2$
    ELSE
      PUT #f1, , Buffer
    END IF
    IF NoPrint = 0 THEN
      IF i! \ BufferSize MOD 50 = 0 THEN LOCATE Row, PPos: PRINT LTRIM$(RTRIM$(STR$(INT((i! / LOF(f2)) * 100)))); "%"
    END IF
  NEXT


  IF NoPrint = 0 THEN LOCATE Row, PPos: COLOR 14: PRINT LTRIM$(STR$(LOF(f2))); : COLOR 7: PRINT " bytes"
  CLOSE #f1
  CLOSE #f2

END FUNCTION

FUNCTION PackList (Archive$)
'----------------------------------------------------------------------------
'              List contents of an archive - Sami Ky”stil„ 1997
'----------------------------------------------------------------------------
'
' Archive$ - The archive to be scanned
'
'----------------------------------------------------------------------------
'                        Returned error codes
'----------------------------------------------------------------------------
'
' 1 - Archive not found
'
'----------------------------------------------------------------------------

DIM Pak AS PakHeader


CLS
COLOR 8
PRINT STRING$(80, CHR$(196))
COLOR 7
PRINT "                 Pack/UnPack Freeware by ";
COLOR 15
PRINT "Sami Ky”stil„ ";
COLOR 7
PRINT "- 1997"
PRINT "                        Version signature: ";
COLOR 14
PRINT CurrentVersion
COLOR 4
PRINT "             Use this program as you wish, but give me some credit."
COLOR 8
PRINT STRING$(80, CHR$(196))
COLOR 7
PRINT

IF Exist(Archive$) = False THEN PackList = 1: EXIT FUNCTION
f1 = FREEFILE
OPEN Archive$ FOR BINARY AS #f1
DIM byte AS STRING * 1


GET #f1, 1, Pak

DIM File AS STRING * 12
DIM FileLen AS STRING * 12


offset! = 9
CFile = 1

IF NoPrint = 0 THEN
  PRINT " - Archive version signature: ",
  COLOR 14
  PRINT Pak.Version
  COLOR 7
  PRINT " - Total files in archive: ", ,
  COLOR 14
  PRINT VAL(Pak.Total)
  COLOR 7
  PRINT " - Archive size:",
  COLOR 14
  PRINT USING " ###,###,###,###,###"; LOF(f1);
  PRINT " bytes"
  COLOR 7
  PRINT " "; CHR$(254); " Contents of archive "; Archive$
END IF

COLOR 9
PRINT "   File          Length       Start         End"
COLOR 7

DO
  GET #f1, , File
  GET #f1, , FileLen
  offset! = offset! + 24

  PRINT "   "; File; CHR$(179); VAL(FileLen), ; CHR$(179); SEEK(f1), ; CHR$(179); SEEK(f1) + VAL(FileLen)

  CFile = CFile + 1
  offset! = offset! + VAL(FileLen)
  SEEK #f1, offset!
  IF CFile > VAL(Pak.Total) THEN EXIT DO
LOOP
CLOSE #f1

END FUNCTION

FUNCTION PackOffset! (Archive$, Filename$, Length!)
'----------------------------------------------------------------------------
' Returns the offset of a file in an archive created by Pack - Sami Ky”stil„
' Use this to find out where a file starts in an archive, so you can read it
' without extracting it first.
'----------------------------------------------------------------------------
'
'  Archive$ - Filename of the archive
' Filename$ - Filename to search for
'    Length - Returns the length of the file
'
'----------------------------------------------------------------------------
'                           Returned error codes
'----------------------------------------------------------------------------
'
' If returns -1, then the file has not been found in the archive
'
'----------------------------------------------------------------------------

Filename$ = UCASE$(LTRIM$(RTRIM$(Filename$)))

IF Exist(Archive$) = False THEN EXIT FUNCTION
DIM Pak AS PakHeader

f1 = FREEFILE
OPEN Archive$ FOR BINARY AS #f1

DIM byte AS STRING * 1
DIM File AS STRING * 12
DIM FileLen AS STRING * 12

GET #f1, , Pak

offset! = 9
CFile = 1

DO
  GET #f1, , File
  GET #f1, , FileLen
  offset! = offset! + 24

  IF Filename$ = RTRIM$(File) THEN EXIT DO
  CFile = CFile + 1
  offset! = offset! + VAL(FileLen)
  SEEK #f1, offset!
  IF CFile > VAL(Pak.Total) THEN offset! = -1: EXIT DO
LOOP

CLOSE #f1

PackOffset! = offset!
Length! = VAL(FileLen)

END FUNCTION

FUNCTION Unpack (Archive$, Filename$, NoPrint)
'----------------------------------------------------------------------------
'   UnPacks files from an archive created by Pack - Sami Ky”stil„ 1997
'----------------------------------------------------------------------------
'
'  Archive$ - Filename of the archive
' Filename$ - File to extracted from the archive. If includes a "*", then
'             all files are extracted
'   NoPrint - If 1, then no text will be printed and if a file exists, the
'             process will be aborted automatically.
'
'----------------------------------------------------------------------------
'                        Returned error codes
'----------------------------------------------------------------------------
'
' 1 = File exists and NoPrint-mode on
' 2 = User abort
' 3 = Archive not found
'
'----------------------------------------------------------------------------

DIM Buffer AS STRING * 1000
BufferSize = LEN(Buffer)


IF NoPrint = 0 THEN
  CLS
  COLOR 8
  PRINT STRING$(80, CHR$(196))
  COLOR 7
  PRINT "                 Pack/UnPack Freeware by ";
  COLOR 15
  PRINT "Sami Ky”stil„ ";
  COLOR 7
  PRINT "- 1997"
  PRINT "                        Version signature: ";
  COLOR 14
  PRINT CurrentVersion
  COLOR 4
  PRINT "             Use this program as you wish, but give me some credit."
  COLOR 8
  PRINT STRING$(80, CHR$(196))
  COLOR 7
  PRINT
END IF

IF Exist(Archive$) = False THEN Unpack = 3: EXIT FUNCTION
f1 = FREEFILE
OPEN Archive$ FOR BINARY AS #f1
DIM byte AS STRING * 1
GlobalYes = 0


IF INSTR(Filename$, "*") > 0 THEN All = 1 ELSE All = 0

DIM Pak AS PakHeader


GET #f1, 1, Pak

DIM File AS STRING * 12
DIM FileLen AS STRING * 12


offset! = 9
CFile = 1

IF NoPrint = 0 THEN
  PRINT " - Archive version signature: ",
  COLOR 14
  PRINT Pak.Version
  COLOR 7
  PRINT " - Total files in archive: ", ,
  COLOR 14
  PRINT VAL(Pak.Total)
  COLOR 7
  PRINT " - Archive size:",
  COLOR 14
  PRINT USING " ###,###,###,###,###"; LOF(f1);
  PRINT " bytes"
  COLOR 7
  PRINT " "; CHR$(254); " Unpacking archive "; Archive$
END IF


IF All = 1 THEN
  DO
    GET #f1, , File
    GET #f1, , FileLen
    offset! = offset! + 24

    IF Exist(RTRIM$(File)) = True THEN
      IF NoPrint = 1 THEN CLOSE #f1: CLOSE #f2: Unpack = 1: EXIT FUNCTION
      COLOR 4
      PRINT "     Overwrite "; RTRIM$(File); "? [Yes/No/All/Quit] ";
      COLOR 12
      IF GlobalYes = 1 THEN PRINT "Yes": GOTO ProcessFile
Again:
      k$ = UCASE$(INPUT$(1))
      IF k$ <> "Y" AND k$ <> "N" AND k$ <> "Q" AND k$ <> "A" THEN GOTO Again
      IF k$ = "Q" THEN PRINT "Quit": CLOSE #f1: CLOSE #f2: Unpack = 2: EXIT FUNCTION
      IF k$ = "A" THEN PRINT "Yes": GlobalYes = 1: KILL RTRIM$(File)
      IF k$ = "Y" THEN PRINT "Yes": KILL RTRIM$(File)
      IF k$ = "N" THEN PRINT "No": GOTO NextFile
    END IF

ProcessFile:
    Row = CSRLIN
    f2 = FREEFILE
    OPEN RTRIM$(File) FOR BINARY AS #f2
    
    IF NoPrint = 0 THEN
      LOCATE Row, 1
      COLOR 7
      PRINT "   "; CHR$(250); " Extracting file "; RTRIM$(File); "...";
    END IF

    PPos = POS(0)
    COLOR 14

    FOR i! = 1 TO VAL(FileLen) STEP BufferSize
      GET #f1, , Buffer
      Clip! = VAL(FileLen) + 1 - i!
      IF Clip! <= BufferSize THEN
        Buffer2$ = LEFT$(Buffer, VAL(FileLen) + 1 - i!)
        PUT #f2, , Buffer2$
      ELSE
        PUT #f2, , Buffer
      END IF
      IF NoPrint = 0 THEN
        IF i! \ BufferSize MOD 50 = 0 THEN LOCATE Row, PPos: PRINT LTRIM$(RTRIM$(STR$(INT((i! / VAL(FileLen)) * 100)))); "%"
      END IF
    NEXT

    CLOSE f2

    IF NoPrint = 0 THEN
      COLOR 14
      LOCATE Row, PPos
      PRINT VAL(FileLen);
      COLOR 7
      PRINT "bytes"
    END IF

NextFile:
    CFile = CFile + 1
    offset! = offset! + VAL(FileLen)
    SEEK #f1, offset!
    IF CFile > VAL(Pak.Total) THEN EXIT DO
  LOOP
ELSE
  File = UCASE$(Filename$)
  IF Exist(RTRIM$(File)) = True THEN
    IF NoPrint = 1 THEN CLOSE #f1: Unpack = 1: EXIT FUNCTION
    COLOR 4
    PRINT "     Overwrite "; RTRIM$(File); "? [Yes/No/Quit] ";
    COLOR 12
Again2:
    k$ = UCASE$(INPUT$(1))
    IF k$ <> "Y" AND k$ <> "N" AND k$ <> "Q" THEN GOTO Again2
    IF k$ = "Q" THEN PRINT "Quit": CLOSE #f1: CLOSE #f2: Unpack = 2: EXIT FUNCTION
    IF k$ = "Y" THEN PRINT "Yes": KILL RTRIM$(File)
    IF k$ = "N" THEN PRINT "No": CLOSE #f1: CLOSE #f2: Unpack = 2: EXIT FUNCTION
  END IF

  Row = CSRLIN
  f2 = FREEFILE
  OPEN RTRIM$(File) FOR BINARY AS #f2
  SEEK #f1, PackOffset(Archive$, Filename$, Length!)
  IF NoPrint = 0 THEN
    LOCATE Row, 1
    COLOR 7
    PRINT "   "; CHR$(250); " Extracting file "; RTRIM$(File); "...";
  END IF
   
  PPos = POS(0)
  COLOR 14


  FOR i! = 1 TO Length! STEP BufferSize
    GET #f1, , Buffer
    Clip! = Length! + 1 - i!
    IF Clip! <= BufferSize THEN
      Buffer2$ = LEFT$(Buffer, Length! + 1 - i!)
      PUT #f2, , Buffer2$
    ELSE
      PUT #f2, , Buffer
    END IF
    IF NoPrint = 0 THEN
      IF i! \ BufferSize MOD 50 = 0 THEN LOCATE Row, PPos: PRINT LTRIM$(RTRIM$(STR$(INT((i! / Length!) * 100)))); "%"
    END IF
  NEXT

  CLOSE f2

  IF NoPrint = 0 THEN
    COLOR 14
    LOCATE Row, PPos
    PRINT Length!;
    COLOR 7
    PRINT "bytes"
  END IF

END IF


CLOSE #f1

END FUNCTION