' ÛßßßßßßßßßßßßßßÛ Programmed by: ' Û PACKER.BAS Û John Wilbert Villamor ' ÛÜÜÜÜÜÜÜÜÜÜÜÜÜÜÛ November 9, 2010 ' CopyLeft 2008 - 2010 Crap Systems Inc. ' This is a simple yet very effective file packing\unpacking program ' that is very easy to convert into a QuickLibrary if you want to since i was ' planning to release this as a QuickLibrary but still need some work to do. ' This source code is not well commented but if you analyze this code ' accurately then you will know how this program is used. ' If you found problems like data curruption or incorrect data retrieved ' then your welcome to send an e-mail to 'Jobert.Villamor@Yahoo.com'. 'ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß DEFINT A-Z '$DYNAMIC ' SUB Declarations DECLARE SUB PKR.ResetPack () DECLARE SUB PKR.GetContents (GetType%) DECLARE SUB PKR.ClosePack () ' FUNCTION Delclarations DECLARE FUNCTION PKR.NumberOfFiles% () DECLARE FUNCTION PKR.RemovePath$ (Path$) DECLARE FUNCTION PKR.AddFile% (AddFile$) DECLARE FUNCTION PKR.GetFile% (GetFile$) DECLARE FUNCTION PKR.OpenPack% (PackFile$, NewPack%) ' User types TYPE ContentType FileName AS STRING * 12 FileDate AS STRING * 10 FileSize AS LONG FileLocation AS LONG END TYPE ' Constants CONST TRUE = -1 CONST FALSE = 0 CONST GETFIRST = -1 CONST GETNEXT = 0 ' Global variables COMMON SHARED PackHandle AS INTEGER COMMON SHARED Content AS ContentType COLOR 7, 1: CLS Menu: IF OpenedPack$ <> "" THEN PRINT CHR$(13); "Currently opened pack file: "; OpenedPack$ PRINT CHR$(13); "What do you want to do?" IF OpenedPack$ <> "" THEN COLOR 8 PRINT "1. Open a pack file." COLOR 7 IF OpenedPack$ = "" THEN COLOR 8 PRINT "2. Pack a file." PRINT "3. Unpack a file." PRINT "4. List the contents of the pack." PRINT "5. Close the pack file." COLOR 7 PRINT "6. Quit." DO Press$ = INKEY$ IF Press$ = "1" AND OpenedPack$ = "" THEN GOSUB OpenPack: GOTO Menu IF Press$ = "2" AND OpenedPack$ <> "" THEN GOSUB PackFile: GOTO Menu IF Press$ = "3" AND OpenedPack$ <> "" THEN GOSUB UnpackFile: GOTO Menu IF Press$ = "4" AND OpenedPack$ <> "" THEN GOSUB ListPack: GOTO Menu IF Press$ = "5" AND OpenedPack$ <> "" THEN GOSUB ClosePack: GOTO Menu IF Press$ = "6" THEN GOTO Quit LOOP OpenPack: PRINT INPUT "Enter pack name: ", OpenedPack$ IF OpenedPack$ = "" THEN RETURN IF PKR.OpenPack(OpenedPack$, FALSE) THEN PRINT "File does not exist. Create? " WHILE P$ = "": P$ = UCASE$(INKEY$): WEND IF P$ = "Y" THEN Crap = PKR.OpenPack(OpenedPack$, TRUE) ELSE OpenedPack$ = "" END IF RETURN PackFile: PRINT INPUT "Enter file name to pack: ", FileToPack$ IF FileToPack$ = "" THEN RETURN PRINT "Packing "; FileToPack$; "..."; SELECT CASE PKR.AddFile(FileToPack$) CASE 0: PRINT "Done!" CASE 1: PRINT "File not found." CASE 2: PRINT "File bank is full." CASE 3: PRINT "File already exists in the pack." END SELECT RETURN UnpackFile: PRINT INPUT "Enter file name to unpack: ", FileToGet$ IF FileToGet$ = "" THEN RETURN PRINT "Unpacking "; FileToGet$; "..."; SELECT CASE PKR.GetFile(FileToGet$) CASE 0: PRINT "Done!" CASE 1: PRINT "File not found in pack file." END SELECT RETURN ListPack: NumberOfFiles = PKR.NumberOfFiles PRINT CHR$(13); "There are"; NumberOfFiles; "file(s) in the pack." PKR.GetContents GETFIRST Printed = 0 FOR P = 1 TO NumberOfFiles PRINT "File name: "; Content.FileName; " "; PRINT "Date: "; Content.FileDate; " "; PRINT " Size:"; Content.FileSize; STRING$(10 - LEN(STR$(Content.FileSize)), " "); PRINT " Location:"; Content.FileLocation PKR.GetContents GETNEXT Printed = Printed + 1 IF Printed = 22 THEN PRINT "Press any key to continue...": WHILE INKEY$ = "": WEND: Printed = 0 NEXT P PKR.ResetPack PRINT "Press any key to continue..." WHILE INKEY$ = "": WEND RETURN ClosePack: PKR.ClosePack OpenedPack$ = "" RETURN Quit: IF OpenedPack$ <> "" THEN PKR.ClosePack END REM $STATIC FUNCTION PKR.AddFile (AddFile$) ' Description: ' Adds a file to the currently opened pack. ' Returns: ' 0 - Ok. ' 1 - File to pack not found. ' 2 - File bank is full. ' 3 - File already exists in the pack. IF PackHandle = 0 THEN EXIT FUNCTION ' DIM a few arrays DIM FileName(255) AS STRING * 12 DIM FileDate(255) AS STRING * 10 DIM FileSize(255) AS LONG DIM FileLocation(255) AS LONG ' Find it before we pack it CheckFile$ = PKR.RemovePath(AddFile$) SEEK #PackHandle, 1 GET #PackHandle, , NOF FOR F = 1 TO NOF GET #PackHandle, , FileName(0) GET #PackHandle, , FileDate(0) GET #PackHandle, , FileSize(0) GET #PackHandle, , FileLocation(0) IF RTRIM$(FileName(0)) = CheckFile$ THEN Found = TRUE: EXIT FOR NEXT SEEK #PackHandle, 1 IF Found THEN PKR.AddFile = 3: EXIT FUNCTION ' Open up the file to add AddHandle = FREEFILE OPEN AddFile$ FOR BINARY AS AddHandle IF LOF(AddHandle) = 0 THEN CLOSE #AddHandle: KILL AddFile$ PKR.AddFile = 1 END IF ' Back-up the old information GET #PackHandle, 1, NOF FOR G = 1 TO NOF IF NOF = 0 THEN EXIT FOR GET #PackHandle, , FileName(G) GET #PackHandle, , FileDate(G) GET #PackHandle, , FileSize(G) GET #PackHandle, , FileLocation(G) NEXT ' Now add new data NOF = NOF + 1 IF NOF = 256 THEN PKR.AddFile = 2: CLOSE #AddHandle: SEEK #PackHandle, 1: EXIT FUNCTION PUT #PackHandle, 1, NOF FOR P = 1 TO NOF - 1 IF NOF - 1 = 0 THEN EXIT FOR PUT #PackHandle, , FileName(P) PUT #PackHandle, , FileDate(P) PUT #PackHandle, , FileSize(P) PUT #PackHandle, , FileLocation(P) NEXT FileName(NOF) = UCASE$(PKR.RemovePath$(AddFile$)) FileDate(NOF) = DATE$ FileSize(NOF) = LOF(AddHandle) IF NOF - 1 = 0 THEN FileLocation(NOF) = 5108 ELSE FileLocation(NOF) = LOF(PackHandle) + 8 PUT #PackHandle, , FileName(NOF) PUT #PackHandle, , FileDate(NOF) PUT #PackHandle, , FileSize(NOF) PUT #PackHandle, , FileLocation(NOF) ' Start packing SEEK #PackHandle, FileLocation(NOF) DO Buffer$ = INPUT$(8192, AddHandle) PUT #PackHandle, , Buffer$ LOOP UNTIL EOF(AddHandle) CLOSE #AddHandle SEEK #PackHandle, 1 END FUNCTION SUB PKR.ClosePack ' Description: ' Closes a currently opened pack file. IF PackHandle = 0 THEN EXIT SUB CLOSE #PackHandle PackHandle = 0 END SUB SUB PKR.GetContents (GetType) ' Description: ' Retrieves the file data in the currently opened pack file. ' Notes: ' You need to get the data in the following variables: ' Content.FileName - 12 character string containing the file name. ' Content.FileDate - 10 character string containing the date when the file was packed. ' Content.FileSize - Long integer of the original file size ' Content.FileLocation - Long integer of the byte location on where the raw data was stored. IF PackHandle = 0 THEN EXIT SUB IF GetType = GETFIRST THEN SEEK #PackHandle, 3 GET #PackHandle, , Content.FileName GET #PackHandle, , Content.FileDate GET #PackHandle, , Content.FileSize GET #PackHandle, , Content.FileLocation END IF IF GetType = GETNEXT THEN GET #PackHandle, , Content.FileName GET #PackHandle, , Content.FileDate GET #PackHandle, , Content.FileSize GET #PackHandle, , Content.FileLocation END IF END SUB FUNCTION PKR.GetFile (GetFile$) ' Description: ' Gets (unpacks) a file in the pack (SLOW!). ' Returns: ' 0 - Ok ' 1 - File to get not found IF PackHandle = 0 THEN EXIT FUNCTION ' DIM variables for some reason DIM FileName AS STRING * 12 DIM FileDate AS STRING * 10 DIM FileSize AS LONG DIM FileLocation AS LONG ' Now find it GetFile$ = UCASE$(GetFile$) GET #PackHandle, , NOF FOR F = 1 TO NOF GET #PackHandle, , FileName GET #PackHandle, , FileDate GET #PackHandle, , FileSize GET #PackHandle, , FileLocation IF RTRIM$(FileName) = GetFile$ THEN Found = TRUE: EXIT FOR NEXT ' If its not found IF Found = FALSE THEN SEEK #PackHandle, 1 PKR.GetFile = 1 EXIT FUNCTION END IF ' Now unpack it GetHandle = FREEFILE OPEN GetFile$ FOR BINARY AS #GetHandle SEEK #PackHandle, FileLocation DO Buffer$ = INPUT$(4, PackHandle) PUT #GetHandle, , Buffer$ LOOP UNTIL LOF(GetHandle) > FileSize - 1 CLOSE #GetHandle SEEK #PackHandle, 1 END FUNCTION FUNCTION PKR.NumberOfFiles ' Description: ' A function that returns the number of files in the currently opened pack ' file. IF PackHandle = 0 THEN EXIT FUNCTION OldLocation& = LOC(PackHandle) IF OldLocation& < 1 THEN OldLocation& = 1 GET #PackHandle, 1, Num SEEK #PackHandle, OldLocation& PKR.NumberOfFiles = Num END FUNCTION FUNCTION PKR.OpenPack (PackFile$, NewPack) ' Description: ' Opens a pack file. ' Notes: ' You need to specify TRUE or FALSE for NewPack if you want to create a new ' pack or not. ' Returns: ' 0 - Ok. ' 1 - Pack file not found (use TRUE to create). FileNum = FREEFILE OPEN PackFile$ FOR BINARY AS FileNum IF LOF(FileNum) = 0 AND NewPack = FALSE THEN CLOSE #FileNum: KILL PackFile$ PKR.OpenPack = 1: EXIT FUNCTION END IF PackHandle = FileNum END FUNCTION FUNCTION PKR.RemovePath$ (Path$) ' Description: ' Converts a string containing the path of file file and spits out the file ' name with the path removed. FOR R = 1 TO LEN(Path$) IF LEFT$(RIGHT$(Path$, R), 1) = "\" THEN EXIT FOR NEXT OutPut$ = RIGHT$(Path$, R - 1) PKR.RemovePath$ = OutPut$ END FUNCTION SUB PKR.ResetPack ' Description: ' Sets the currently opened pack file's byte location to 1. Use this after ' retrieving the file names. IF PackHandle = 0 THEN EXIT SUB SEEK #PackHandle, 1 END SUB