Platforms to show: All Mac Windows Linux Cross-Platform
/Compression/RBZ Library version 1.1/rbz
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 Sun, 5th Nov 2022.
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 EndOfFile() As Boolean
// Part of the StreamReader interface.
// Part of the Readable interface.
return stream.EOF
End Function
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
The items on this page are in the following plugins: MBS Compression Plugin.