Platforms to show: All Mac Windows Linux Cross-Platform

/Compression/RBZ Library version 1.1/rbz
Function:
Required plugins for this example: MBS Compression Plugin
You find this example project in your Plugins Download as a Xojo project file within the examples folder: /Compression/RBZ Library version 1.1/rbz
This example is the version from Tue, 16th Sep 2019.
Project "rbz.xojo_binary_project"
Class App Inherits Application
Const kEditClear = "&Delete"
Const kFileQuit = "&Quit"
Const kFileQuitShortcut = ""
End Class
Class winMain Inherits Window
Control btnAddDirectory Inherits PushButton
ControlInstance btnAddDirectory Inherits PushButton
EventHandler Sub Action() prgProgress.Maximum = 0 source = selectfolder thrAddDirectory.Run End EventHandler
End Control
Control btnAddFile Inherits PushButton
ControlInstance btnAddFile Inherits PushButton
EventHandler Sub Action() prgProgress.Maximum = 0 source = GetOpenFolderItem("") thrAddFile.Run End EventHandler
End Control
Control btnOpenArchive Inherits PushButton
ControlInstance btnOpenArchive Inherits PushButton
EventHandler Sub Action() dim f as folderitem = GetOpenFolderItem(ZipArchive.getFileType) if f = nil then return archive = f.openAsZipArchive refreshList End EventHandler
End Control
Control btnNewArchive Inherits PushButton
ControlInstance btnNewArchive Inherits PushButton
EventHandler Sub Action() dim f as folderitem = GetSaveFolderItem(ZipArchive.getFileType,"archive.zip") if f = nil then return archive = f.createAsZipArchive refreshList End EventHandler
End Control
Control lstArchive Inherits Listbox
ControlInstance lstArchive Inherits Listbox
EventHandler Sub ExpandRow(row As Integer) dim item as Zipitem = me.celltag(row,0) if item.isDirectory then dim children() as ZipItem = item.getChildren for i as integer = 0 to ubound(children) if children(i).isDirectory then lstArchive.AddFolder children(i).getName else lstArchive.AddRow children(i).getName end lstArchive.CellTag(lstArchive.LastIndex,0) = children(i) next end End EventHandler
End Control
Control btnDelete Inherits PushButton
ControlInstance btnDelete Inherits PushButton
EventHandler Sub Action() prgProgress.Maximum = 0 thrDelete.run End EventHandler
End Control
Control btnExpand Inherits PushButton
ControlInstance btnExpand Inherits PushButton
EventHandler Sub Action() prgProgress.Maximum = 0 destination = selectfolder thrExpand.run End EventHandler
End Control
Control thrAddDirectory Inherits Thread
ControlInstance thrAddDirectory Inherits Thread
EventHandler Sub Run() if archive = nil then return if source = nil then return dim item as ZipItem if lstArchive.ListIndex = -1 or lstArchive.ListCount = 0 then item = archive else item = lstArchive.CellTag(lstArchive.ListIndex,0) if not item.isDirectory then item = item.getParent end item.addChild source, self refreshList End EventHandler
End Control
Control prgProgress Inherits ProgressBar
ControlInstance prgProgress Inherits ProgressBar
End Control
Control thrAddFile Inherits Thread
ControlInstance thrAddFile Inherits Thread
EventHandler Sub Run() if archive = nil then return if source = nil then return dim item as ZipItem if lstArchive.ListIndex = -1 or lstArchive.ListCount = 0 then item = archive else item = lstArchive.CellTag(lstArchive.ListIndex,0) if not item.isDirectory then item = item.getParent end item.addChild source, self refreshList End EventHandler
End Control
Control thrExpand Inherits Thread
ControlInstance thrExpand Inherits Thread
EventHandler Sub Run() if archive = nil then return if destination = nil then return dim item as ZipItem if lstArchive.ListIndex = -1 or lstArchive.ListCount = 0 then item = archive else item = lstArchive.CellTag(lstArchive.ListIndex,0) end item.expand destination, self End EventHandler
End Control
Control thrDelete Inherits Thread
ControlInstance thrDelete Inherits Thread
EventHandler Sub Run() if archive = nil then return dim item as ZipItem if lstArchive.ListIndex = -1 or lstArchive.ListCount = 0 then item = archive else item = lstArchive.CellTag(lstArchive.ListIndex,0) end item.delete self refreshList End EventHandler
End Control
Private Sub refreshList() lstArchive.DeleteAllRows if archive = nil then return dim children() as ZipItem = archive.getChildren for i as integer = 0 to ubound(children) if children(i).isDirectory then lstArchive.AddFolder children(i).getName else lstArchive.AddRow children(i).getName end lstArchive.CellTag(lstArchive.LastIndex,0) = children(i) next End Sub
Sub update(complete as double) // Part of the ProgressMonitor interface. prgProgress.maximum = 1000 prgProgress.Value = prgProgress.Maximum * complete End Sub
Property Private archive As ZipArchive
Property Private destination As FolderItem
Property Private source As FolderItem
End Class
MenuBar MenuBar1
MenuItem FileMenu = "&File"
MenuItem FileQuit = "#App.kFileQuit"
MenuItem EditMenu = "&Edit"
MenuItem EditUndo = "&Undo"
MenuItem UntitledMenu1 = "-"
MenuItem EditCut = "Cu&t"
MenuItem EditCopy = "&Copy"
MenuItem EditPaste = "&Paste"
MenuItem EditClear = "#App.kEditClear"
MenuItem UntitledMenu0 = "-"
MenuItem EditSelectAll = "Select &All"
End MenuBar
Interface StreamReader
Function eof() As boolean
Function getPosition() As uint64
Function readAll(encoding as TextEncoding = nil) As String
Function readCString(encoding as TextEncoding = nil) As String
Function readInt16() As int16
Function readInt32() As int32
Function readInt64() As int64
Function readInt8() As int8
Function readPString(encoding as TextEncoding = nil) As String
Function readString(bytes as uint64, encoding as TextEncoding = nil) As String
Function readUInt16() As Uint16
Function readUInt32() As Uint32
Function readUInt64() As Uint64
Function readUInt8() As Uint8
Sub skip(bytes as uint64)
End Interface
Interface StreamWriter
Sub flush()
Function getPosition() As uint64
Sub rewind(bytes as uint64)
Sub skip(bytes as uint64)
Sub writeCString(text as string)
Sub writeInt16(value as int16)
Sub writeInt32(value as int32)
Sub writeInt64(value as Int64)
Sub writeInt8(value as int8)
Sub writePString(text as string)
Sub writeString(text as string)
Sub writeUInt16(value as Uint16)
Sub writeUInt32(value as Uint32)
Sub writeUInt64(value as Uint64)
Sub writeUInt8(value as Uint8)
End Interface
Class FileStream
Function Read(Count As Integer, encoding As TextEncoding = Nil) As String // Part of the Readable interface. return stream.read(count,encoding) End Function
Function ReadError() As Boolean // Part of the Readable interface. return stream.ReadError End Function
Sub Rewind(bytes as Uint64) stream.Position = stream.Position - bytes End Sub
Sub Write(text As String) // Part of the Writeable interface. stream.Write(text) End Sub
Function WriteError() As Boolean // Part of the Writeable interface. return stream.WriteError End Function
Sub constructor(b as binaryStream) stream = b End Sub
Sub constructor(file as folderItem, type as filetype = nil) if not file.Exists then if type = nil then stream = file.CreateBinaryFile("") else stream = file.CreateBinaryFile(type) end else stream = file.OpenAsBinaryFile(true) end End Sub
Sub constructor(file as folderItem, type as filetype = nil, littleEndian as boolean) constructor (file, type) stream.LittleEndian = littleEndian End Sub
Function eof() As boolean // Part of the StreamReader interface. // Part of the Readable interface. return stream.EOF End Function
Sub flush() // Part of the StreamWriter interface. stream.Flush End Sub
Function getLength() As uint64 return stream.Length End Function
Function getPosition() As uint64 // Part of the StreamReader interface. // Part of the StreamWriter interface. return stream.Position End Function
Function getString() As String // Part of the StringProvider interface. dim pos as uint64 = stream.Position stream.Position = 0 dim text as string = stream.Read(stream.Length) stream.Position = pos return text End Function
Function readAll(encoding as textEncoding = nil) As string return readString(stream.Length-stream.Position,encoding) End Function
Function readCString(encoding as TextEncoding = nil) As String // Part of the StreamReader interface. End Function
Function readInt16() As int16 // Part of the StreamReader interface. return stream.ReadInt16 End Function
Function readInt32() As int32 // Part of the StreamReader interface. return stream.ReadInt32 End Function
Function readInt64() As int64 // Part of the StreamReader interface. return stream.ReadInt64 End Function
Function readInt8() As int8 // Part of the StreamReader interface. return stream.ReadInt8 End Function
Function readPString(encoding as TextEncoding = nil) As String // Part of the StreamReader interface. dim len as uint8 = readUInt8 return readString(len,encoding) End Function
Function readString(bytes as uint64, encoding as TextEncoding = nil) As String // Part of the StreamReader interface. return stream.Read(bytes,encoding) End Function
Function readUInt16() As Uint16 // Part of the StreamReader interface. return stream.ReadUInt16 End Function
Function readUInt32() As Uint32 // Part of the StreamReader interface. return stream.ReadUInt32 End Function
Function readUInt64() As Uint64 // Part of the StreamReader interface. return stream.ReadUInt64 End Function
Function readUInt8() As Uint8 // Part of the StreamReader interface. return stream.ReadUInt8 End Function
Sub setPosition(pos as uInt64) stream.Position = pos End Sub
Sub setString(Str As String) // Part of the StringInterface interface. stream.Position = 0 stream.Write str stream.Length = stream.Position End Sub
Sub skip(bytes as uint64) // Part of the StreamReader interface. // Part of the StreamWriter interface. stream.Position = stream.Position + bytes End Sub
Sub truncate() //truncate the file to the current position stream.Length = stream.Position End Sub
Sub writeCString(text as string) // Part of the StreamWriter interface. stream.Write(text) stream.WriteUInt8 0 End Sub
Sub writeInt16(value as int16) // Part of the StreamWriter interface. stream.WriteInt16 value End Sub
Sub writeInt32(value as int32) // Part of the StreamWriter interface. stream.WriteInt32 value End Sub
Sub writeInt64(value as Int64) // Part of the StreamWriter interface. stream.WriteInt64 value End Sub
Sub writeInt8(value as int8) // Part of the StreamWriter interface. stream.WriteInt8 value End Sub
Sub writePString(text as string) // Part of the StreamWriter interface. dim ln as UInt8 = min(text.lenb,255) stream.WriteInt8 ln stream.Write text.LeftB(ln) End Sub
Sub writeString(text as string) // Part of the StreamWriter interface. stream.Write text End Sub
Sub writeUInt16(value as Uint16) // Part of the StreamWriter interface. stream.WriteUInt16 value End Sub
Sub writeUInt32(value as Uint32) // Part of the StreamWriter interface. stream.WriteUInt32 value End Sub
Sub writeUInt64(value as Uint64) // Part of the StreamWriter interface. stream.WriteUInt64 value End Sub
Sub writeUInt8(value as Uint8) // Part of the StreamWriter interface. stream.WriteUInt8 value End Sub
Property Private stream As binaryStream
End Class
Module RBZ
Const FilesystemAcornRISCOS = 13
Const FilesystemAlternateMVS = 15
Const FilesystemAmiga = 1
Const FilesystemAtari = 5
Const FilesystemBeOS = 16
Const FilesystemCP_M = 9
Const FilesystemFAT = 0
Const FilesystemHPFS = 6
Const FilesystemMVS = 11
Const FilesystemMacintosh = 7
Const FilesystemNTFS = 10
Const FilesystemOSX = 19
Const FilesystemOS_400 = 18
Const FilesystemTandem = 17
Const FilesystemUnix = 3
Const FilesystemVFAT = 14
Const FilesystemVM = 4
Const FilesystemVMS = 2
Const FilesystemVSE = 12
Const FilesystemZSystem = 8
Const Version = 1.1
Enum CompressionMethod none deflate unsupported End Enum
Enum DeflateLevel maximum normal fast fastest End Enum
Function createAsZipArchive(extends archive as folderItem) As ZipArchive if archive.Exists then archive.Delete return new ZipArchive(archive) End Function
Function openAsZipArchive(extends archive as folderItem) As ZipArchive return new ZipArchive(archive) End Function
Sub unzip(extends archive as folderitem, destination as folderitem) dim z as new ZipArchive(archive) z.expand destination End Sub
Sub unzip(extends archive as folderitem, destination as folderitem, options as expansionOptions) dim z as new ZipArchive(archive) z.expand destination, options End Sub
Sub zip(extends source as folderitem, archive as folderitem, comment as string = "") dim z as new ZipArchive(archive) z.addChild source, comment End Sub
Sub zip(extends source as folderitem, archive as folderitem, comment as string = "", options as compressionOptions) dim z as new ZipArchive(archive) z.addChild source, comment, options End Sub
Structure CompressionOptions method as CompressionMethod deflateLevel as DeflateLevel deflateWindow as uint16 End Structure
Structure ExpansionOptions ignoreChecksum as boolean replaceFiles as boolean ignoreErrors as boolean End Structure
End Module
Class ZipItem
Sub addChild(item as folderitem, progress as ProgressMonitor) addChild item, "", progress End Sub
Sub addChild(item as folderitem, comment as string = "", options as CompressionOptions, progress as ProgressMonitor = nil) //set compression options compressionOptions = options //add child addChild item, comment, progress End Sub
Sub addChild(item as folderitem, comment as string = "", progress as ProgressMonitor = nil) //add an item to directory if not isDirectory then return // does nothing if item is not a directory if item.name = ".DS_Store" then return // don't store system files if item.Alias then return // don't store aliases dim zp as ZipProgress if progress <> nil then zp = new ZipProgress(z_precalculateSizes(item) + 1,progress) end z_addChild item, comment, zp //add to internal structure and write file record to archive z_writeFileHeaders //write central directory records if progress <> nil then zp.increment 1 //notify completion End Sub
Protected Sub constructor(parent as ZipItem = nil) if parent <> nil then //set parent z_setParent parent //set defaults compressionOptions = parent.compressionOptions expansionOptions = parent.expansionOptions end End Sub
Sub delete(progress as ProgressMonitor = nil) dim zp as ZipProgress if progress <> nil then zp = new ZipProgress(1,progress) end z_tagForDeletion //recursively mark self and children for deletion z_compact zp //compact the file z_delete //recursively delete self and children from archive z_writeFileHeaders //write central directory records if progress <> nil then zp.increment 1 //notify completion End Sub
Sub expand(destinationDirectory as folderItem, options as ExpansionOptions, progress as ProgressMonitor = nil) dim zp as ZipProgress if progress <> nil then zp = new ZipProgress(getCompressedSize + 1,progress) end z_expand destinationDirectory, zp, options if progress <> nil then zp.increment 1 //notify completion End Sub
Sub expand(destinationDirectory as folderItem, progress as ProgressMonitor = nil) //neccessary to duplicate this code due to a strange crash which //occurs if we attempt tp call other expand function dim zp as ZipProgress if progress <> nil then zp = new ZipProgress(getCompressedSize + 1,progress) end z_expand destinationDirectory, zp, expansionOptions if progress <> nil then zp.increment 1 //notify completion End Sub
Function getArchive() As zipArchive return archive End Function
Function getChildren() As ZipItem() //return clone of children array dim c() as ZipItem for i as integer = 0 to ubound(children) c.Append children(i) next return c End Function
Function getComment() As string return comment End Function
Function getCompressedSize() As uint64 if isDirectory and compressedSize = 0 then for i as integer = 0 to UBound(children) compressedSize = compressedSize + children(i).getCompressedSize next end return compressedSize End Function
Sub getCompressionOptions(byref options as CompressionOptions) options = compressionOptions End Sub
Sub getExpansionOptions(byref options as ExpansionOptions) options = expansionOptions End Sub
Function getModified() As date return modified End Function
Function getName() As string return name End Function
Function getParent() As ZipItem return parent End Function
Function getPath() As string dim path as string = me.path if path.leftb(1) = "/" then path = path.midb(2) if path <> "" and directory and path.rightb(1) <> "/" then path = path + "/" return path End Function
Function getUncompressedSize() As uint64 if isDirectory and uncompressedSize = 0 then for i as integer = 0 to UBound(children) uncompressedSize = uncompressedSize + children(i).getUncompressedSize next end return uncompressedSize End Function
Function isDirectory() As boolean return directory End Function
Sub setExpansionOptions(options as ExpansionOptions) expansionOptions = options End Sub
Protected Sub z_addChild(item as ZipItem) if not isDirectory then return //not permitted //compare paths dim mypath as string = getPath dim childPath as string = item.getPath if childPath.lenb <= myPath.lenb then return //something's gone wrong end if childPath.leftb(mypath.lenb) <> mypath then return //something's gone wrong end dim relativePath as string = childPath.midb(mypath.lenb) if relativePath.LeftB(1) = "/" then relativePath = relativePath.midb(2) //removing leading slash if relativePath.rightb(1) = "/" then relativePath = relativePath.leftb(relativePath.lenb-1) //removing trailing slash if relativePath = item.name then //place item directly into this directory children.Append item item.z_setParent me //set defaults item.compressionOptions.deflateWindow = me.compressionOptions.deflateWindow item.expansionOptions = me.expansionOptions else dim nextDirectory as string = nthfield(relativePath,"/",1) //name of next directory in the path for i as integer = 0 to ubound(children) if children(i).name = nextDirectory then //add to existing directory children(i).z_addChild(item) return end next //create a new directory item dim dir as new ZipItem(me) children.Append dir dir.name = nextDirectory //set directory name dir.directory = true //is a directory (obviously) dir.path = getPath + dir.name //add child to new item dir.z_addChild(item) end End Sub
Private Sub z_addChild(item as folderitem, comment as string = "", progress as ZipProgress) if not isDirectory then return //not permitted dim child as new ZipItem(me) child.name = z_cleanFileName(item.Name) //set file name child.path = path +"/" + child.name //set file path child.comment = comment.ConvertEncoding(Encodings.DOSLatinUS) //set file comment child.modified = item.ModificationDate //set modification date child.directory = item.Directory //set directory status child.uncompressedSize = item.Length //set uncompressed file size children.Append child // add to internal children array //handle children (do this before writing file records so we can tell if directories are empty) for i as integer = 1 to item.Count if item.item(i).name <> ".DS_Store" then child.z_addChild item.Item(i), progress //repeat for item contents next //write the file record if child.directory then child.z_writeFileRecord nil, progress // write the directory record else child.z_writeFileRecord new FileStream(item), progress // write the file record end End Sub
Private Function z_cleanFileName(name as string) As string //encode filename for dos compatibility dim cleaned as string = name.ConvertEncoding(Encodings.DOSLatinUS) cleaned = cleaned.ReplaceAllB("/",":") //avoid name clashes with siblings for i as integer = 0 to ubound(children) while children(i).name = cleaned cleaned = z_incrementName(cleaned) wend next return cleaned End Function
Protected Sub z_collateItems(offsets() as uint64, items() as ZipItem) if isDirectory and ubound(children) > -1 then //non-empty directories aren't stored in archive, so skip and deal with children for i as integer = 0 to ubound(children) children(i).z_collateItems offsets, items next else //insert in order of offset //binary insertion sort would be faster but speed of this function is unlikely to be a bottleneck if ubound(offsets) = -1 or relativeOffset > offsets(ubound(offsets)) then offsets.Append relativeOffset items.Append me else for i as integer = ubound(offsets) downto 0 if offsets(i) > relativeOffset then offsets.Insert i, relativeOffset items.Insert i, me return end next end end End Sub
Protected Sub z_compact(progress as ZipProgress) //write file data ZipItem(archive).z_compact progress End Sub
Protected Sub z_delete() //delete children //work on a duplicate of children array as //array is manipulated by deletion process dim children() as ZipItem = getChildren for i as integer = 0 to ubound(children) children(i).z_delete next //remove self from parent for i as integer = 0 to ubound(ZipItem(parent).children) if ZipItem(parent).children(i) = me then ZipItem(parent).children.Remove i exit end next End Sub
Protected Sub z_expand(destinationDirectory as folderItem, progress as ZipProgress, options as ExpansionOptions) //must be a valid destination directory if destinationDirectory = nil or not destinationDirectory.exists then return if not destinationDirectory.directory then return //handle name clashes dim name as string = me.name #if TargetMacOS name = name.ReplaceAllB(":","/") #endif if not options.replaceFiles then for i as integer = 1 to destinationDirectory.Count while destinationDirectory.item(i).name = name //rename file to avoid clash name = z_incrementName(name) wend next end if directory then //create directory dim dir as FolderItem = destinationDirectory.Child(name) dir.CreateAsFolder //handle children for i as integer = 0 to ubound(children) children(i).z_expand dir, progress, options next else //create file dim file as FolderItem = destinationDirectory.Child(name) z_writeFile new FileStream(file), options, progress //set file modification date if modified <> nil then file.ModificationDate = modified end End Sub
Protected Function z_incrementName(name as string) As string //increment a file name number to prevent name clashes //for example foo.txt becomes foo 1.txt, foo 1.txt becomes foo 2.txt, etc dim extension as string dim theName as string if CountFields(name,".") > 1 then extension = "." + NthField(name,".",CountFields(name,".")) theName = NthField(name,".",CountFields(name,".") - 1) else theName = name end dim number as string for i as integer = theName.LenB downto 1 dim char as string = theName.MidB(i,1) if AscB(char) < 48 or AscB(char) > 57 then if char <> " " then number = "" exit else number = char + number end next if number <> "" then return theName.LeftB(theName.LenB - number.LenB) + str(val(number) + 1) + extension else return theName + " 1" + extension end End Function
Private Function z_precalculateSizes(item as folderitem) As uint64 dim total as uint64 if item.Directory then //handle children for i as integer = 1 to item.Count if item.item(i).name <> ".DS_Store" then total = total + z_precalculateSizes(item.Item(i)) //repeat for item contents end next return total end return total + item.Length End Function
Protected Sub z_setParent(parent as ZipItem) //set parent and archive properties me.parent = parent if parent isa ZipArchive then archive = ZipArchive(parent) else archive = parent.archive end End Sub
Protected Sub z_tagForDeletion() //delete children for i as integer = 0 to ubound(children) children(i).z_tagForDeletion next //tag deleted = true End Sub
Protected Sub z_writeFile(sw as StreamWriter, item as ZipItem = nil, options as ExpansionOptions, progress as ZipProgress) //write file data ZipItem(archive).z_writeFile sw, me, options, progress End Sub
Protected Sub z_writeFileHeader(sw as StreamWriter, item as Zipitem = nil) //write file header for this item ZipItem(archive).z_writeFileHeader sw, me //handle children for i as integer = 0 to ubound(children) children(i).z_writeFileHeader sw next End Sub
Protected Sub z_writeFileHeaders() ZipItem(archive).z_writeFileHeaders End Sub
Protected Sub z_writeFileRecord(item as ZipItem = nil, data as FileStream, progress as ZipProgress) ZipItem(archive).z_writeFileRecord me, data, progress End Sub
Property Protected archive As ZipArchive
Property Protected children() As ZipItem
Property Protected comment As String
Property Protected compressedSize As uint64
Property Protected compressionOptions As CompressionOptions
Property Protected crc As uint32
Property Protected deleted As boolean
Property Protected directory As boolean
Property Protected expansionOptions As ExpansionOptions
Property Protected extraData As string
Property Protected modified As Date
Property Protected name As string
Property Protected parent As ZipItem
Property Protected path As string
Property Protected relativeOffset As uint64
Property Protected uncompressedSize As uint64
End Class
Class ZipArchive Inherits ZipItem
Const useMBS = true
Sub constructor(archive as folderitem) //only call once if archiveFile <> nil then return //get default settings z_setDefaultOptions archiveFile = archive //set archive file directory = true //archive is always a directory if archive.Exists then //open the archive dim sr as new FileStream(archive,true) //find end of central directory record //work backwards to find signature for i as integer = sr.getLength - 4 downto 0 sr.setPosition i dim signature as UInt32 = sr.readUInt32 if signature = &h06054b50 then exit next if sr.getPosition = 4 then //failed to find central directory - file may be corrupt or not a zip file at all return else sr.skip 6 //get number of directory entries dim entries as uint16 = sr.readUInt16 //find and go to start of central directory sr.skip 4 centralDirectoryStart = sr.readUInt32 sr.setPosition centralDirectoryStart //parse central directory file headers for i as integer = 1 to entries z_addChild z_readFileHeader(sr) next end end End Sub
Sub delete(progress as ProgressMonitor = nil) dim zp as ZipProgress if progress <> nil then zp = new ZipProgress(1,progress) end //tag children for deletion dim children() as ZipItem = getChildren for i as integer = 0 to ubound(children) children(i).z_tagForDeletion next //compact file z_compact zp //delete children for i as integer = 0 to ubound(children) children(i).z_delete next //write central directory records z_writeFileHeaders if progress <> nil then zp.increment 1 //notify completion End Sub
Function getArchive() As ZipArchive return me End Function
Function getFileCount() As uint32 return files End Function
Shared Function getFileType() As FileType dim f as new FileType f.Name = "zip" f.Extensions = ".zip" return f End Function
Function getName() As string return archiveFile.Name End Function
Function getParent() As ZipItem return nil End Function
Sub setCompressionOptions(options as CompressionOptions) compressionOptions = options End Sub
Protected Sub z_compact(progress as ZipProgress) //sort all items in archive by offset dim offsets() as uint64 dim items() as ZipItem z_collateItems offsets, items offsets.Append centralDirectoryStart if progress <> nil then //calculate amount of data that must be moved dim counterStarted as Boolean = false for i as integer = 0 to ubound(items) if items(i).deleted then counterStarted = true elseif counterStarted then progress.total = progress.total + offsets(i+1) - offsets(i) end next end dim shift as uint64 = offsets(0) // would normally be zero, but just in case... //open archive input stream and skip to data location dim fs as FileStream = new FileStream(archiveFile,true) for i as integer = 0 to ubound(items) dim offset as uint64 = offsets(i) dim length as UInt64 = offsets(i+1) - offset dim item as ZipItem = items(i) if item.deleted then //adjust shift shift = shift + length elseif shift > 0 then //shift offset item.relativeOffset = item.relativeOffset - shift //move data fs.setPosition offset dim total as uint64 = length while total > 0 dim chunk as uint16 = min(total,compressionOptions.deflateWindow) dim data as string = fs.readString(chunk) fs.setPosition offset - shift fs.writeString data total = total - chunk if progress <> nil then progress.increment chunk wend end next centralDirectoryStart = fs.getPosition fs.truncate End Sub
Private Function z_getCRC(previous as uint32 = 0, data as string) As uint32 #pragma BoundsChecking false #pragma NilObjectChecking false #pragma BackgroundTasks false #if useMBS static z as new ZLibCompressMBS //use mbs zlib crc function return z.CRC32(previous, data) #else //create crc table if crc32Table(0) = 0 then 'this is the official polynomial used by CRC32 in PKZip. 'often the polynomial is shown reversed (04C11DB7). dim dwPolynomial As Int32 = &hEDB88320 dim i as Integer, j as Integer dim dwCrc As int32 for i = 0 to 255 dwCrc = i for j = 8 downto 1 If ((dwCrc and 1) > 0) Then dwCrc = ((dwCrc and &hFFFFFFFE) \ 2) and &h7FFFFFFF dwCrc = dwCrc xor dwPolynomial Else dwCrc = (((dwCrc and &hFFFFFFFE) \ 2) and &h7FFFFFFF) End If next crc32Table(i) = dwCrc next end //get crc dim crc as uint32 = Bitwise.OnesComplement(previous) dim iLookup as uint64 dim size as uint32 = data.LenB for i as uint32 = 1 to size iLookup = (crc and &hFF) Xor data.MidB(i,1).Asc crc = ((crc and &hFFFFFF00) \ &h100) and 16777215 crc = crc or crc32Table(iLookup) next return Bitwise.OnesComplement(crc) #endif End Function
Private Function z_getCompressionBits(options as CompressionOptions) As uint16 if options.method <> CompressionMethod.deflate then //leave bits empty return &b0000000000000000 end select case options.deflateLevel case DeflateLevel.normal return &b0000000000000000 case DeflateLevel.maximum return &b0000000000000010 case DeflateLevel.fast return &b0000000000000100 case DeflateLevel.fastest return &b0000000000000110 else Raise new UnsupportedFormatException end End Function
Private Function z_getDeflateLevel(flags as uint16) As DeflateLevel flags = Bitwise.BitAnd(flags,&b0000000000000110) select case flags case 0 return DeflateLevel.normal case 1 return DeflateLevel.maximum case 2 return DeflateLevel.fast case 3 return DeflateLevel.fastest end End Function
Private Function z_getMBSCompressionLevel(level as DeflateLevel) As uint8 select case level case DeflateLevel.maximum return 9 case DeflateLevel.normal return 6 case DeflateLevel.fast return 3 case DeflateLevel.fastest return 0 else Raise new UnsupportedFormatException end End Function
Private Function z_getZLibHeader(item as ZipItem) As string #if useMBS //get zlib header return CompressZLibMBS("foo",z_getMBSCompressionLevel(item.compressionOptions.deflateLevel)).leftb(2) #endif End Function
Private Function z_readCompressionMethod(sr as StreamReader) As CompressionMethod select case sr.readUInt16 case 8 return CompressionMethod.deflate case 0 return CompressionMethod.none else return CompressionMethod.unsupported end End Function
Private Function z_readFileHeader(sr as StreamReader) As ZipItem dim item as new ZipItem //file header signature if sr.readUInt32<> &h02014b50 then return nil //possibly corrupt? //version call sr.readUInt8 //file system call sr.readUInt8 //required version if sr.readUInt16/10 > 2 then return nil //can't read it //general purpose bit flags dim flags as UInt16 = sr.readUInt16 'flags = flags + &b0000000000000001 //file is encrypted 'flags = flags + &b0000000000000110 //compression bits 'flags = flags + &b0000000000001000 //crc32 field blank 'flags = flags + &b0000000000010000 //reserved for method 8 'flags = flags + &b0000000000100000 //patch data 'flags = flags + &b0000000001000000 //strong encryption item.compressionOptions.deflateLevel = z_getDeflateLevel(flags) //compression method item.compressionOptions.method = z_readCompressionMethod(sr) //time and date item.modified = z_readTimeStamp(sr) //crc 32 item.crc = sr.readUInt32 //compressed size item.compressedSize = sr.readUInt32 //uncompressed size item.uncompressedSize = sr.readUInt32 //file name length dim pathLength as uint16= sr.readUInt16 //extra field length dim extraFieldLength as uint16= sr.readUInt16 //file comment length dim commentLength as uint16= sr.readUInt16 //disk number start call sr.readUInt16 //internal file attributes call sr.readUInt16 //external file attibutes call sr.readUInt32 //relative offset of local header item.relativeOffset = sr.readUInt32 //file name item.path = sr.readString(pathLength,encodings.DOSLatinUS) item.name = NthField(item.path,"/",CountFields(item.path,"/")) if item.name = "" then item.name = NthField(item.path,"/",CountFields(item.path,"/")-1) item.directory = true end //extra data call sr.readString(extraFieldLength) //file comment item.comment = sr.readString(commentLength) return item End Function
Private Function z_readTimeStamp(sr as StreamReader) As Date dim d as new Date // get time dim time as UInt16 = sr.readUInt16 d.Hour = Bitwise.BitAnd(time,63488) \ 2048 d.Minute = Bitwise.BitAnd(time,2016) \ 32 d.Second = Bitwise.BitAnd(time,31) * 2 // get date dim date as UInt16 = sr.readUInt16 d.Year = Bitwise.BitAnd(date,65024) \ 512 + 1980 d.Month = Bitwise.BitAnd(date,480) \ 32 d.Day = Bitwise.BitAnd(date,31) return d End Function
Private Sub z_setDefaultOptions() //compression options #if useMBS then compressionOptions.method = CompressionMethod.deflate #else compressionOptions.method = CompressionMethod.none #endif compressionOptions.deflateLevel = DeflateLevel.normal compressionOptions.deflateWindow = 32768 //decompression options expansionOptions.ignoreChecksum = false expansionOptions.ignoreErrors = false expansionOptions.replaceFiles = false End Sub
Private Sub z_writeCompressionMethod(sw as StreamWriter, method as CompressionMethod) select case method case CompressionMethod.deflate sw.writeUInt16 8 else sw.writeUInt16 0 end End Sub
Protected Sub z_writeFile(sw as StreamWriter, item as ZipItem = nil, options as ExpansionOptions, progress as ZipProgress) //open archive input stream and skip to data location dim sr as FileStream = new FileStream(archiveFile,true) sr.setPosition item.relativeOffset //local file header signature if sr.readUInt32 <> &h04034b50 then return //not a valid file record //required version dim version as single = sr.readUInt16/10 if version > 2 then return //incompatible version //general purpose bit flags call sr.readUInt16 //compression method call sr.readUInt16 //last modified time call sr.readUInt16 //last modified date call sr.readUInt16 //crc 32 call sr.readUInt32 //compressed size call sr.readUInt32 //uncompressed size call sr.readUInt32 //file name length dim pathLength as uint16= sr.readUInt16 //extra field length dim extraFieldLength as uint16= sr.readUInt16 //file name call sr.readString(pathLength,encodings.DOSLatinUS) //extra data call sr.readString(extraFieldLength) //file data if useMBS and item.compressionOptions.method = CompressionMethod.deflate then #if useMBS //deflate (requires mbs) dim total as uint64 = item.getCompressedSize dim z as new ZLibDecompressMBS z.InitZip call z.setInput z_getZLibHeader(item) do if z.OutputSize = 0 and z.InputAvail = 0 then dim chunk as UInt16 = min(total,compressionOptions.deflateWindow) call z.setInput sr.readString(chunk) total = total - chunk if progress <> nil then progress.increment chunk end z.ProcessZip sw.writeString z.GetOutput loop until z.OutputSize = 0 and z.InputAvail = 0 and total = 0 z.EndZip #endif else //no compression dim total as uint64 = item.getCompressedSize while total > 0 dim chunk as UInt16 = min(total,compressionOptions.deflateWindow) sw.writeString sr.readString(chunk) total = total - chunk if progress <> nil then progress.increment chunk wend end End Sub
Protected Sub z_writeFileHeader(sw as StreamWriter, item as Zipitem = nil) //get compression options dim compressionOptions as CompressionOptions = item.compressionOptions #if not useMBS compressionOptions.method = CompressionMethod.none #endif //only write files or empty directories if item.isDirectory then directories = directories + 1 if ubound(item.getChildren) > -1 then return compressionOptions.method = CompressionMethod.none emptyDirectories = emptyDirectories + 1 else files = files + 1 end //file header signature sw.writeUInt32 &h02014b50 //version sw.writeUInt8 2*10 + 1 //file system #if TargetWin32 //should check for other windows filesystem types sw.writeUInt8 FilesystemFAT #elseif TargetMacOS sw.writeUInt8 FilesystemOSX #elseif TargetLinux sw.writeUInt8 FilesystemUnix #endif //required version sw.writeUInt16 2*10 + 0 //general purpose bit flags dim flags as UInt16 'flags = flags + &b0000000000000001 //file is encrypted flags = flags + z_getCompressionBits(compressionOptions) //compression bits if compressionOptions.method = CompressionMethod.deflate then flags = flags + &b0000000000001000 //crc32 field blank end 'flags = flags + &b0000000000010000 //reserved for method 8 'flags = flags + &b0000000000100000 //patch data 'flags = flags + &b0000000001000000 //strong encryption sw.writeUInt16 flags //compression method z_writeCompressionMethod sw,compressionOptions.method //time and date z_writeTimeStamp sw,item.modified //crc 32 sw.writeUInt32 item.crc //compressed size sw.writeUInt32 item.getCompressedSize //uncompressed size sw.writeUInt32 item.getUncompressedSize //file name length sw.writeUInt16 item.getPath.LenB //extra field length sw.writeUInt16 item.extraData.LenB //file comment length sw.writeUInt16 item.getComment.LenB //disk number start sw.writeUInt16 0 //internal file attributes sw.writeUInt16 0 //external file attibutes sw.writeUInt32 &h81a44000 //temporary //relative offset of local header sw.writeUInt32 item.relativeOffset //file path sw.writeString item.getPath //extra field sw.writeString item.extraData //file comment sw.writeString item.getComment End Sub
Protected Sub z_writeFileHeaders() //reset counters files = 0 directories = 0 emptyDirectories = 0 //get output file stream dim sw as new FileStream(archiveFile,true) sw.skip centralDirectoryStart dim items() as ZipItem = getChildren for i as integer = 0 to ubound(items) items(i).z_writeFileHeader sw next //digital signature ------------ 'sw.writeUInt32 &h05054b50 //header signature 'sw.writeUInt16 0 //data size 'no data dim cdLength as uint32 = sw.getLength - centralDirectoryStart dim cdItems as uint32 = files + emptyDirectories //end of central directory record sw.writeUInt32 &h06054b50 // signature sw.writeUInt16 0 // disk number sw.writeUInt16 0 // number of disk with start of central directory sw.writeUInt16 cdItems // total number of file entries on this disk sw.writeUInt16 cdItems // total number of file entries in the central directory sw.writeUInt32 cdLength // central directory size sw.writeUInt32 centralDirectoryStart // central directory offset sw.writeUInt16 0 //comment length 'no comment //truncate file to this length sw.truncate End Sub
Protected Sub z_writeFileRecord(item as ZipItem = nil, data as FileStream, progress as ZipProgress) #pragma NilObjectChecking false #pragma BoundsChecking false //get compression options dim compressionOptions as CompressionOptions = item.compressionOptions #if not useMBS compressionOptions.method = CompressionMethod.none #endif if item.isDirectory then //only write files or empty directories if ubound(item.getChildren) > -1 then return //don't compress directories compressionOptions.method = CompressionMethod.none end if item.uncompressedSize = 0 then //don't compress empty files compressionOptions.method = CompressionMethod.none end //size of buffer used for copying data const bufferSize = 1048576 //1 megabyte //file type dim f as new FileType f.Name = "zip" f.Extensions = ".zip" //get output file stream dim sw as new FileStream(archiveFile,f,true) //skip to end of existing file records sw.skip centralDirectoryStart //set relative offset of file record item.relativeOffset = sw.getPosition sw.writeUInt32 &h04034b50 //local file header signature //required version sw.writeUInt16 2*10 + 0 //general purpose bit flags dim flags as UInt16 'flags = flags + &b0000000000000001 //file is encrypted flags = flags + z_getCompressionBits(compressionOptions) //compression bits if compressionOptions.method = CompressionMethod.deflate then flags = flags + &b0000000000001000 //crc32 field blank end 'flags = flags + &b0000000000010000 //reserved for method 8 'flags = flags + &b0000000000100000 //patch data 'flags = flags + &b0000000001000000 //strong encryption sw.writeUInt16 flags //compression method z_writeCompressionMethod sw,compressionOptions.method //time and date z_writeTimeStamp sw,item.modified //get crc for uncompressed data if data <> nil then if compressionOptions.method <> CompressionMethod.deflate then dim total as uint64 = item.uncompressedSize while total > 0 dim chunk as UInt16 = min(total,compressionOptions.deflateWindow) item.crc = z_getCRC(item.crc,data.readString(chunk)) total = total - chunk #if not useMBS if progress <> nil then progress.increment chunk*0.75 #endif wend data.setPosition 0 item.compressedSize = item.uncompressedSize end else item.crc = 0 item.compressedSize = 0 end if Bitwise.BitAnd(flags,&b0000000000001000) > 0 then //crc 32 sw.writeUInt32 0 //compressed size sw.writeUInt32 0 //uncompressed size sw.writeUInt32 0 else //crc 32 sw.writeUInt32 item.crc //compressed size sw.writeUInt32 item.getCompressedSize //uncompressed size sw.writeUInt32 item.getUncompressedSize end //file name length sw.writeUInt16 item.getPath.LenB //extra field length sw.writeUInt16 item.extraData.LenB //file name sw.writeString item.getPath //extra data sw.writeString item.extraData //output 'dim output as string if data <> nil then if useMBS and compressionOptions.method = CompressionMethod.deflate then //deflate (requires mbs) #if useMBS dim total as uint64 = item.uncompressedSize dim z as new ZLibCompressMBS dim stripHeader as boolean = true z.InitZip z_getMBSCompressionLevel(compressionOptions.deflateLevel) do if z.InputAvail = 0 then //add data to compression buffer dim chunk as UInt16 = min(total,compressionOptions.deflateWindow) dim block as string = data.readString(chunk) if not z.setInput(block) then beep end total = total - chunk if progress <> nil then progress.increment chunk end z.ProcessZip //process data if stripHeader then //remove 2 byte zlib header if z.OutputSize >= 2 then item.compressedSize = item.compressedSize + z.OutputSize - 2 sw.writeString z.GetOutput.midb(3) //write all except first 2 bytes stripHeader = false end else //write data chunk item.compressedSize = item.compressedSize + z.OutputSize sw.writeString z.GetOutput end loop until z.InputAvail = 0 and total = 0 z.EndZip item.compressedSize = item.compressedSize + z.OutputSize sw.writeString z.GetOutput sw.Rewind 4 //skip the last 4 bytes item.compressedSize = item.compressedSize - 4 sw.writeString "PK" + chrb(7) + chrb(8) //bomarchiver puts pkzip footer here, but seems to be optional #endif else //no compression dim total as uint64 = item.uncompressedSize while total > 0 dim chunk as UInt16 = min(total,compressionOptions.deflateWindow) sw.writeString data.readString(chunk) total = total - chunk #if useMBS if progress <> nil then progress.increment chunk #else if progress <> nil then progress.increment chunk*0.25 #endif wend end end if Bitwise.BitAnd(flags,&b0000000000001000) > 0 then //crc 32 sw.writeUInt32 item.crc //compressed size sw.writeUInt32 item.getCompressedSize //uncompressed size sw.writeUInt32 item.getUncompressedSize end //truncate file to this length centralDirectoryStart = sw.getPosition sw.truncate End Sub
Private Sub z_writeTimeStamp(sw as StreamWriter, date as Date) //if date not known, set to current time if date = nil then date = new date //time sw.writeUInt16 date.Hour * 2048 + date.Minute * 32 + date.Second \ 2 //date sw.writeUInt16 (max(date.Year,1980) - 1980) * 512 + date.Month * 32 + date.Day End Sub
Property Private archiveFile As folderitem
Property Private centralDirectoryStart As uint64
Property Private Shared crc32Table(255) As int32
Property Private directories As uint32
Property Private emptyDirectories As uint32
Property Private files As uint32
End Class
Class ZipProgress
Sub constructor(total as uint64, monitor as ProgressMonitor) me.total = total me.monitor = monitor End Sub
Sub increment(amount as uint64) complete = complete + amount monitor.update complete / total End Sub
Property Private complete As uint64
Property Private monitor As ProgressMonitor
Property total As uint64
End Class
Interface ProgressMonitor
Sub update(complete as double)
End Interface
End Project

Feedback, Comments & Corrections

The items on this page are in the following plugins: MBS Compression Plugin.

The biggest plugin in space...




Links
MBS Xojo Plugins