[Pkg] Squeak3.10bc: Compression-kph.10.mcz
squeak-dev-noreply at lists.squeakfoundation.org
squeak-dev-noreply at lists.squeakfoundation.org
Sat Dec 13 04:49:33 UTC 2008
A new version of Compression was added to project Squeak3.10bc:
http://www.squeaksource.com/310bc/Compression-kph.10.mcz
==================== Summary ====================
Name: Compression-kph.10
Author: kph
Time: 13 December 2008, 4:49:29 am
UUID: d3d681fb-4a10-4c28-a440-3da32786ebcb
Ancestors: Compression-edc.9
Saved from SystemVersion
==================== Snapshot ====================
SystemOrganization addCategory: #'Compression-Archives'!
SystemOrganization addCategory: #'Compression-Streams'!
ReadStream subclass: #InflateStream
instanceVariableNames: 'state bitBuf bitPos source sourcePos sourceLimit litTable distTable sourceStream crc'
classVariableNames: 'StateNoMoreData FixedDistCodes StateNewBlock BlockProceedBit BlockTypes FixedLitCodes MaxBits'
poolDictionaries: ''
category: 'Compression-Streams'!
!InflateStream commentStamp: '<historical>' prior: 0!
This class implements the Inflate decompression algorithm as defined by RFC1951 and used in PKZip, GZip and ZLib (and many, many more). It is a variant of the LZ77 compression algorithm described in
[LZ77] Ziv J., Lempel A., "A Universal Algorithm for Sequential Data Compression", IEEE Transactions on Information Theory", Vol. 23, No. 3, pp. 337-343.
[RFC1951] Deutsch. P, "DEFLATE Compressed Data Format Specification version 1.3"
For more information see the above mentioned RFC 1951 which can for instance be found at
http://www.leo.org/pub/comp/doc/standards/rfc/index.html
Huffman Tree Implementation Notes:
===========================================
The huffman tree used for decoding literal, distance and length codes in the inflate algorithm has been encoded in a single Array. The tree is made up of subsequent tables storing all entries at the current bit depth. Each entry in the table (e.g., a 32bit Integer value) is either a leaf or a non-leaf node. Leaf nodes store the immediate value in its low 16 bits whereas non-leaf nodes store the offset of the subtable in its low 16bits. The high 8 bits of non-leaf nodes contain the number of additional bits needed for the sub table (the high 8 bits of leaf-nodes are always zero). The first entry in each table is always a non-leaf node indicating how many bits we need to fetch initially. We can thus travel down the tree as follows (written in sort-of-pseudocode the actual implementation can be seen in InflateStream>>decodeValueFrom:):
table _ initialTable.
bitsNeeded _ high 8 bits of (table at: 1). "Determine initial bits"
table _ initialTable + (low 16 bits of (table at: 1)). "Determine start of first real table"
[bits _ fetch next bitsNeeded bits. "Grab the bits"
value _ table at: bits. "Lookup the value"
value has high 8 bit set] whileTrue:[ "Check if it's leaf"
table _ initialTable + (low 16 bits of value). "No - compute new sub table start"
bitsNeeded _ high 8 bit of value]. "Compute additional number of bits needed"
^value
!
InflateStream subclass: #FastInflateStream
instanceVariableNames: ''
classVariableNames: 'DistanceMap FixedLitTable FixedDistTable LiteralLengthMap'
poolDictionaries: ''
category: 'Compression-Streams'!
!FastInflateStream commentStamp: '<historical>' prior: 0!
This class adds the following optimizations to the basic Inflate decompression:
a) Bit reversed access
If we want to fetch the bits efficiently then we have them in the wrong bit order (e.g., when we should fetch 2r100 we would get 2r001). But since the huffman tree lookup determines the efficiency of the decompression, reversing the bits before traversal is expensive. Therefore the entries in each table are stored in REVERSE BIT ORDER. This is achieved by a reverse increment of the current table index in the huffman table construction phase (see method increment:bits:). According to my measures this speeds up the implementation by about 30-40%.
b) Inplace storage of code meanings and extra bits
Rather than looking up the meaning for each code during decompression of blocks we store the appropriate values directly in the huffman tables, using a pre-defined mapping. Even though this does not make a big difference in speed, it cleans up the code and allows easier translation into primitive code (which is clearly one goal of this implementation).
c) Precomputed huffman tables for fixed blocks
So we don't have to compute the huffman tables from scratch. The precomputed tables are not in our superclass to avoid double storage (and my superclass is more intended for documentation anyways).!
----- Method: FastInflateStream class>>initialize (in category 'class initialization') -----
initialize
"FastInflateStream initialize"
| low high |
"Init literal/length map"
low := #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258 ).
high := #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0 0).
LiteralLengthMap := WordArray new: 256 + 32.
1 to: 257 do:[:i| LiteralLengthMap at: i put: i-1].
1 to: 29 do:[:i| LiteralLengthMap at: 257+i put: (low at:i) + ( (high at: i) + 1 << 16)].
"Init distance map"
high := #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13).
low := #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769
1025 1537 2049 3073 4097 6145 8193 12289 16385 24577).
DistanceMap := WordArray new: 32.
1 to: 30 do:[:i| DistanceMap at: i put: (low at: i) + ( (high at: i) << 16)].
"Init fixed block huffman tables"
FixedLitTable := self basicNew
huffmanTableFrom: FixedLitCodes
mappedBy: LiteralLengthMap.
FixedDistTable := self basicNew
huffmanTableFrom: FixedDistCodes
mappedBy: DistanceMap.!
----- Method: FastInflateStream>>decompressBlock:with: (in category 'inflating') -----
decompressBlock: llTable with: dTable
"Process the compressed data in the block.
llTable is the huffman table for literal/length codes
and dTable is the huffman table for distance codes."
| value extra length distance oldPos oldBits oldBitPos |
<primitive: 'primitiveInflateDecompressBlock' module: 'ZipPlugin'>
[readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[
"Back up stuff if we're running out of space"
oldBits := bitBuf.
oldBitPos := bitPos.
oldPos := sourcePos.
value := self decodeValueFrom: llTable.
value < 256 ifTrue:[ "A literal"
collection byteAt: (readLimit := readLimit + 1) put: value.
] ifFalse:["length/distance or end of block"
value = 256 ifTrue:["End of block"
state := state bitAnd: StateNoMoreData.
^self].
"Compute the actual length value (including possible extra bits)"
extra := (value bitShift: -16) - 1.
length := value bitAnd: 16rFFFF.
extra > 0 ifTrue:[length := length + (self nextBits: extra)].
"Compute the distance value"
value := self decodeValueFrom: dTable.
extra := (value bitShift: -16).
distance := value bitAnd: 16rFFFF.
extra > 0 ifTrue:[distance := distance + (self nextBits: extra)].
(readLimit + length >= collection size) ifTrue:[
bitBuf := oldBits.
bitPos := oldBitPos.
sourcePos := oldPos.
^self].
collection
replaceFrom: readLimit+1
to: readLimit + length + 1
with: collection
startingAt: readLimit - distance + 1.
readLimit := readLimit + length.
].
].!
----- Method: FastInflateStream>>distanceMap (in category 'huffman trees') -----
distanceMap
^DistanceMap!
----- Method: FastInflateStream>>increment:bits: (in category 'huffman trees') -----
increment: value bits: nBits
"Increment value in reverse bit order, e.g.
for a 3 bit value count as follows:
000 / 100 / 010 / 110
001 / 101 / 011 / 111
See the class comment why we need this."
| result bit |
result := value.
"Test the lowest bit first"
bit := 1 << (nBits - 1).
"If the currently tested bit is set then we need to
turn this bit off and test the next bit right to it"
[(result bitAnd: bit) = 0] whileFalse:[
"Turn off current bit"
result := result bitXor: bit.
"And continue testing the next bit"
bit := bit bitShift: -1].
"Turn on the right-most bit that we haven't touched in the loop above"
^result bitXor: bit!
----- Method: FastInflateStream>>literalLengthMap (in category 'huffman trees') -----
literalLengthMap
^LiteralLengthMap!
----- Method: FastInflateStream>>nextSingleBits: (in category 'bit access') -----
nextSingleBits: n
"Fetch the bits all at once"
^self nextBits: n.!
----- Method: FastInflateStream>>processFixedBlock (in category 'inflating') -----
processFixedBlock
litTable := FixedLitTable.
distTable := FixedDistTable.
state := state bitOr: BlockProceedBit.
self proceedFixedBlock.!
FastInflateStream subclass: #ZLibReadStream
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Streams'!
----- Method: ZLibReadStream>>on:from:to: (in category 'initialize') -----
on: aCollection from: firstIndex to: lastIndex
"Check the header of the ZLib stream."
| method byte |
super on: aCollection from: firstIndex to: lastIndex.
crc := 1.
method := self nextBits: 8.
(method bitAnd: 15) = 8 ifFalse:[^self error:'Unknown compression method'].
(method bitShift: -4) + 8 > 15 ifTrue:[^self error:'Invalid window size'].
byte := self nextBits: 8.
(method bitShift: 8) + byte \\ 31 = 0 ifFalse:[^self error:'Incorrect header'].
(byte anyMask: 32) ifTrue:[^self error:'Need preset dictionary'].
!
----- Method: ZLibReadStream>>updateCrc:from:to:in: (in category 'crc') -----
updateCrc: oldCrc from: start to: stop in: aCollection
"Answer an updated CRC for the range of bytes in aCollection"
^ZLibWriteStream updateAdler32: oldCrc from: start to: stop in: aCollection.!
----- Method: ZLibReadStream>>verifyCrc (in category 'crc') -----
verifyCrc
| stored |
stored := 0.
24 to: 0 by: -8 do: [ :i |
sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ].
stored := stored + (self nextByte bitShift: i) ].
stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ].
^stored!
FastInflateStream subclass: #ZipReadStream
instanceVariableNames: 'expectedCrc'
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Streams'!
!ZipReadStream commentStamp: 'nk 3/7/2004 18:54' prior: 0!
ZipReadStream is intended for uncompressing the compressed contents of Zip archive members.
Since Zip archive members keep their expected CRC value separately in Zip headers, this class does not attempt to read the CRC from its input stream.
Instead, if you want the CRC verification to work you have to call #expectedCrc: with the expected CRC-32 value from the Zip member header.!
----- Method: ZipReadStream>>expectedCrc: (in category 'crc') -----
expectedCrc: aNumberOrNil
"If expectedCrc is set, it will be compared against the calculated CRC32 in verifyCrc.
This number should be the number read from the Zip header (which is the bitwise complement of my crc if all is working correctly)"
expectedCrc := aNumberOrNil!
----- Method: ZipReadStream>>on:from:to: (in category 'initialize') -----
on: aCollection from: firstIndex to: lastIndex
super on: aCollection from: firstIndex to: lastIndex.
crc := 16rFFFFFFFF.
expectedCrc := nil.!
----- Method: ZipReadStream>>updateCrc:from:to:in: (in category 'crc') -----
updateCrc: oldCrc from: start to: stop in: aCollection
^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection!
----- Method: ZipReadStream>>verifyCrc (in category 'crc') -----
verifyCrc
"Verify the CRC-32 checksum calculated from the input against the expected CRC-32, if any.
Answer the calculated CRC-32 in any case.
Note that the CRC-32 used in Zip files is actually the bit inverse of the calculated value, so that is what is returned."
| invertedCrc |
invertedCrc := crc bitXor: 16rFFFFFFFF.
(expectedCrc notNil and: [ expectedCrc ~= invertedCrc ])
ifTrue: [ ^ self crcError: ('Wrong CRC-32 (expected {1} got {2}) (proceed to ignore)' translated format: { expectedCrc printStringHex. invertedCrc printStringHex }) ].
^invertedCrc!
----- Method: InflateStream class>>initialize (in category 'class initialization') -----
initialize
"InflateStream initialize"
MaxBits := 16.
StateNewBlock := 0.
StateNoMoreData := 1.
BlockProceedBit := 8.
BlockTypes := #( processStoredBlock "New block in stored format"
processFixedBlock "New block with fixed huffman tables"
processDynamicBlock "New block with dynamic huffman tables"
errorBadBlock "Bad block format"
proceedStoredBlock "Continue block in stored format"
proceedFixedBlock "Continue block in fixed format"
proceedDynamicBlock "Continue block in dynamic format"
errorBadBlock "Bad block format").
"Initialize fixed block values"
FixedLitCodes := ((1 to: 144) collect:[:i| 8]),
((145 to: 256) collect:[:i| 9]),
((257 to: 280) collect:[:i| 7]),
((281 to: 288) collect:[:i| 8]).
FixedDistCodes := ((1 to: 32) collect:[:i| 5]).!
----- Method: InflateStream>>atEnd (in category 'testing') -----
atEnd
"Note: It is possible that we have a few bits left,
representing just the EOB marker. To check for
this we must force decompression of the next
block if at end of data."
super atEnd ifFalse:[^false]. "Primitive test"
(position >= readLimit and:[state = StateNoMoreData]) ifTrue:[^true].
"Force decompression, by calling #next. Since #moveContentsToFront
will never move data to the beginning of the buffer it is safe to
skip back the read position afterwards"
self next == nil ifTrue:[^true].
position := position - 1.
^false!
----- Method: InflateStream>>bitPosition (in category 'bit access') -----
bitPosition
"Return the current bit position of the source"
sourceStream == nil
ifTrue:[^sourcePos * 8 + bitPos]
ifFalse:[^sourceStream position + sourcePos * 8 + bitPos]!
----- Method: InflateStream>>close (in category 'accessing') -----
close
sourceStream ifNotNil:[sourceStream close].!
----- Method: InflateStream>>computeHuffmanValues:counts:from:to: (in category 'huffman trees') -----
computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits
"Assign numerical values to all codes.
Note: The values are stored according to the bit length"
| offsets values baseOffset codeLength |
offsets := Array new: maxBits.
offsets atAllPut: 0.
baseOffset := 1.
minBits to: maxBits do:[:bits|
offsets at: bits put: baseOffset.
baseOffset := baseOffset + (counts at: bits+1)].
values := WordArray new: aCollection size.
1 to: aCollection size do:[:i|
codeLength := aCollection at: i.
codeLength > 0 ifTrue:[
baseOffset := offsets at: codeLength.
values at: baseOffset put: i-1.
offsets at: codeLength put: baseOffset + 1]].
^values!
----- Method: InflateStream>>contents (in category 'accessing') -----
contents
^ self upToEnd!
----- Method: InflateStream>>crcError: (in category 'crc') -----
crcError: aString
^CRCError signal: aString!
----- Method: InflateStream>>createHuffmanTables:counts:from:to: (in category 'huffman trees') -----
createHuffmanTables: values counts: counts from: minBits to: maxBits
"Create the actual tables"
| table tableStart tableSize tableEnd
valueIndex tableStack numValues deltaBits maxEntries
lastTable lastTableStart tableIndex lastTableIndex |
table := WordArray new: ((4 bitShift: minBits) max: 16).
"Create the first entry - this is a dummy.
It gives us information about how many bits to fetch initially."
table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2"
"Create the first table from scratch."
tableStart := 2. "See above"
tableSize := 1 bitShift: minBits.
tableEnd := tableStart + tableSize.
"Store the terminal symbols"
valueIndex := (counts at: minBits+1).
tableIndex := 0.
1 to: valueIndex do:[:i|
table at: tableStart + tableIndex put: (values at: i).
tableIndex := self increment: tableIndex bits: minBits].
"Fill up remaining entries with invalid entries"
tableStack := OrderedCollection new: 10. "Should be more than enough"
tableStack addLast:
(Array
with: minBits "Number of bits (e.g., depth) for this table"
with: tableStart "Start of table"
with: tableIndex "Next index in table"
with: minBits "Number of delta bits encoded in table"
with: tableSize - valueIndex "Entries remaining in table").
"Go to next value index"
valueIndex := valueIndex + 1.
"Walk over remaining bit lengths and create new subtables"
minBits+1 to: maxBits do:[:bits|
numValues := counts at: bits+1.
[numValues > 0] whileTrue:["Create a new subtable"
lastTable := tableStack last.
lastTableStart := lastTable at: 2.
lastTableIndex := lastTable at: 3.
deltaBits := bits - (lastTable at: 1).
"Make up a table of deltaBits size"
tableSize := 1 bitShift: deltaBits.
tableStart := tableEnd.
tableEnd := tableEnd + tableSize.
[tableEnd > table size ]
whileTrue:[table := self growHuffmanTable: table].
"Connect to last table"
self assert:[(table at: lastTableStart + lastTableIndex) = 0]."Entry must be unused"
table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart.
lastTable at: 3 put: (self increment: lastTableIndex bits: (lastTable at: 4)).
lastTable at: 5 put: (lastTable at: 5) - 1.
self assert:[(lastTable at: 5) >= 0]. "Don't exceed tableSize"
"Store terminal values"
maxEntries := numValues min: tableSize.
tableIndex := 0.
1 to: maxEntries do:[:i|
table at: tableStart + tableIndex put: (values at: valueIndex).
valueIndex := valueIndex + 1.
numValues := numValues - 1.
tableIndex := self increment: tableIndex bits: deltaBits].
"Check if we have filled up the current table completely"
maxEntries = tableSize ifTrue:[
"Table has been filled. Back up to the last table with space left."
[tableStack isEmpty not and:[(tableStack last at: 5) = 0]]
whileTrue:[tableStack removeLast].
] ifFalse:[
"Table not yet filled. Put it back on the stack."
tableStack addLast:
(Array
with: bits "Nr. of bits in this table"
with: tableStart "Start of table"
with: tableIndex "Index in table"
with: deltaBits "delta bits of table"
with: tableSize - maxEntries "Unused entries in table").
].
].
].
^table copyFrom: 1 to: tableEnd-1!
----- Method: InflateStream>>decodeDynamicTable:from: (in category 'huffman trees') -----
decodeDynamicTable: nItems from: aHuffmanTable
"Decode the code length of the literal/length and distance table
in a block compressed with dynamic huffman trees"
| values index value repCount theValue |
values := Array new: nItems.
index := 1.
theValue := 0.
[index <= nItems] whileTrue:[
value := self decodeValueFrom: aHuffmanTable.
value < 16 ifTrue:[
"Immediate values"
theValue := value.
values at: index put: value.
index := index+1.
] ifFalse:[
"Repeated values"
value = 16 ifTrue:[
"Repeat last value"
repCount := (self nextBits: 2) + 3.
] ifFalse:[
"Repeat zero value"
theValue := 0.
value = 17
ifTrue:[repCount := (self nextBits: 3) + 3]
ifFalse:[value = 18
ifTrue:[repCount := (self nextBits: 7) + 11]
ifFalse:[^self error:'Invalid bits tree value']]].
0 to: repCount-1 do:[:i| values at: index+i put: theValue].
index := index + repCount].
].
^values!
----- Method: InflateStream>>decodeValueFrom: (in category 'inflating') -----
decodeValueFrom: table
"Decode the next value in the receiver using the given huffman table."
| bits bitsNeeded tableIndex value |
bitsNeeded := (table at: 1) bitShift: -24. "Initial bits needed"
tableIndex := 2. "First real table"
[bits := self nextSingleBits: bitsNeeded. "Get bits"
value := table at: (tableIndex + bits). "Lookup entry in table"
(value bitAnd: 16r3F000000) = 0] "Check if it is a non-leaf node"
whileFalse:["Fetch sub table"
tableIndex := value bitAnd: 16rFFFF. "Table offset in low 16 bit"
bitsNeeded := (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit"
bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']].
^value!
----- Method: InflateStream>>decompressAll (in category 'private') -----
decompressAll
"Profile the decompression speed"
[self atEnd] whileFalse:[
position := readLimit.
self next "Provokes decompression"
].!
----- Method: InflateStream>>decompressBlock:with: (in category 'inflating') -----
decompressBlock: llTable with: dTable
"Process the compressed data in the block.
llTable is the huffman table for literal/length codes
and dTable is the huffman table for distance codes."
| value extra length distance oldPos oldBits oldBitPos |
[readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[
"Back up stuff if we're running out of space"
oldBits := bitBuf.
oldBitPos := bitPos.
oldPos := sourcePos.
value := self decodeValueFrom: llTable.
value < 256 ifTrue:[ "A literal"
collection byteAt: (readLimit := readLimit + 1) put: value.
] ifFalse:["length/distance or end of block"
value = 256 ifTrue:["End of block"
state := state bitAnd: StateNoMoreData.
^self].
"Compute the actual length value (including possible extra bits)"
extra := #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0) at: value - 256.
length := #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258) at: value - 256.
extra > 0 ifTrue:[length := length + (self nextBits: extra)].
"Compute the distance value"
value := self decodeValueFrom: dTable.
extra := #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13) at: value+1.
distance := #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769
1025 1537 2049 3073 4097 6145 8193 12289 16385 24577) at: value+1.
extra > 0 ifTrue:[distance := distance + (self nextBits: extra)].
(readLimit + length >= collection size) ifTrue:[
bitBuf := oldBits.
bitPos := oldBitPos.
sourcePos := oldPos.
^self].
collection
replaceFrom: readLimit+1
to: readLimit + length + 1
with: collection
startingAt: readLimit - distance + 1.
readLimit := readLimit + length.
].
].!
----- Method: InflateStream>>distanceMap (in category 'huffman trees') -----
distanceMap
"This is used by the fast decompressor"
^nil!
----- Method: InflateStream>>getFirstBuffer (in category 'private') -----
getFirstBuffer
"Get the first source buffer after initialization has been done"
sourceStream == nil ifTrue:[^self].
source := sourceStream next: 1 << 16. "This is more than enough..."
sourceLimit := source size.!
----- Method: InflateStream>>getNextBlock (in category 'private') -----
getNextBlock
^self nextBits: 3!
----- Method: InflateStream>>growHuffmanTable: (in category 'huffman trees') -----
growHuffmanTable: table
| newTable |
newTable := table species new: table size * 2.
newTable replaceFrom: 1 to: table size with: table startingAt: 1.
^newTable!
----- Method: InflateStream>>huffmanTableFrom:mappedBy: (in category 'huffman trees') -----
huffmanTableFrom: aCollection mappedBy: valueMap
"Create a new huffman table from the given code lengths.
Map the actual values by valueMap if it is given.
See the class comment for a documentation of the huffman
tables used in this decompressor."
| counts values table minBits maxBits |
minBits := MaxBits + 1.
maxBits := 0.
"Count the occurences of each code length and compute minBits and maxBits"
counts := Array new: MaxBits+1.
counts atAllPut: 0.
aCollection do:[:length|
length > 0 ifTrue:[
length < minBits ifTrue:[minBits := length].
length > maxBits ifTrue:[maxBits := length].
counts at: length+1 put: (counts at: length+1)+1]].
maxBits = 0 ifTrue:[^nil]. "Empty huffman table"
"Assign numerical values to all codes."
values := self computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits.
"Map the values if requested"
self mapValues: values by: valueMap.
"Create the actual tables"
table := self createHuffmanTables: values counts: counts from: minBits to: maxBits.
^table!
----- Method: InflateStream>>increment:bits: (in category 'huffman trees') -----
increment: value bits: nBits
"Increment a value of nBits length.
The fast decompressor will do this differently"
^value+1!
----- Method: InflateStream>>literalLengthMap (in category 'huffman trees') -----
literalLengthMap
"This is used by the fast decompressor"
^nil!
----- Method: InflateStream>>mapValues:by: (in category 'huffman trees') -----
mapValues: values by: valueMap
| oldValue |
valueMap ifNil:[^values].
1 to: values size do:[:i|
oldValue := values at: i.
"Note: there may be nil values if not all values are used"
oldValue isNil
ifTrue:[^values]
ifFalse:[values at: i put: (valueMap at: oldValue+1)]].
!
----- Method: InflateStream>>moveContentsToFront (in category 'private') -----
moveContentsToFront
"Move the decoded contents of the receiver to the front so that we have enough space for decoding more data."
| delta |
readLimit > 32768 ifTrue:[
delta := readLimit - 32767.
collection
replaceFrom: 1
to: collection size - delta + 1
with: collection
startingAt: delta.
position := position - delta + 1.
readLimit := readLimit - delta + 1].!
----- Method: InflateStream>>moveSourceToFront (in category 'private') -----
moveSourceToFront
"Move the encoded contents of the receiver to the front so that we have enough space for decoding more data."
(sourceStream == nil or:[sourceStream atEnd]) ifTrue:[^self].
sourcePos > 10000 ifTrue:[
source
replaceFrom: 1
to: source size - sourcePos
with: source
startingAt: sourcePos + 1.
source := sourceStream
next: sourcePos
into: source
startingAt: source size - sourcePos + 1.
sourcePos := 0.
sourceLimit := source size].!
----- Method: InflateStream>>next (in category 'accessing') -----
next
"Answer the next decompressed object in the Stream represented by the
receiver."
<primitive: 65>
position >= readLimit
ifTrue: [^self pastEndRead]
ifFalse: [^collection at: (position := position + 1)]!
----- Method: InflateStream>>next: (in category 'accessing') -----
next: anInteger
"Answer the next anInteger elements of my collection. overriden for simplicity"
| newArray |
"try to do it the fast way"
position + anInteger < readLimit ifTrue: [
newArray := collection copyFrom: position + 1 to: position + anInteger.
position := position + anInteger.
^newArray
].
"oh, well..."
newArray := collection species new: anInteger.
1 to: anInteger do: [:index | newArray at: index put: (self next ifNil: [ ^newArray copyFrom: 1 to: index - 1]) ].
^newArray!
----- Method: InflateStream>>next:into:startingAt: (in category 'accessing') -----
next: n into: buffer startingAt: startIndex
"Read n objects into the given collection.
Return aCollection or a partial copy if less than
n elements have been read."
| c numRead count |
numRead := 0.
["Force decompression if necessary"
(c := self next) == nil
ifTrue:[^buffer copyFrom: 1 to: startIndex+numRead-1].
"Store the first value which provoked decompression"
buffer at: startIndex + numRead put: c.
numRead := numRead + 1.
"After collection has been filled copy as many objects as possible"
count := (readLimit - position) min: (n - numRead).
buffer
replaceFrom: startIndex + numRead
to: startIndex + numRead + count - 1
with: collection
startingAt: position+1.
position := position + count.
numRead := numRead + count.
numRead = n] whileFalse.
^buffer!
----- Method: InflateStream>>nextBits: (in category 'bit access') -----
nextBits: n
| bits |
[bitPos < n] whileTrue:[
bitBuf := bitBuf + (self nextByte bitShift: bitPos).
bitPos := bitPos + 8].
bits := bitBuf bitAnd: (1 bitShift: n)-1.
bitBuf := bitBuf bitShift: 0 - n.
bitPos := bitPos - n.
^bits!
----- Method: InflateStream>>nextByte (in category 'bit access') -----
nextByte
^source byteAt: (sourcePos := sourcePos + 1)!
----- Method: InflateStream>>nextSingleBits: (in category 'bit access') -----
nextSingleBits: n
| out |
out := 0.
1 to: n do:[:i| out := (out bitShift: 1) + (self nextBits: 1)].
^out!
----- Method: InflateStream>>on: (in category 'initialize') -----
on: aCollectionOrStream
aCollectionOrStream isStream
ifTrue:[ aCollectionOrStream binary.
sourceStream := aCollectionOrStream.
self getFirstBuffer]
ifFalse:[source := aCollectionOrStream].
^self on: source from: 1 to: source size.!
----- Method: InflateStream>>on:from:to: (in category 'initialize') -----
on: aCollection from: firstIndex to: lastIndex
bitBuf := bitPos := 0.
"The decompression buffer has a size of at 64k,
since we may have distances up to 32k back and
repetitions of at most 32k length forward"
collection := aCollection species new: 1 << 16.
readLimit := 0. "Not yet initialized"
position := 0.
source := aCollection.
sourceLimit := lastIndex.
sourcePos := firstIndex-1.
state := StateNewBlock.!
----- Method: InflateStream>>pastEndRead (in category 'private') -----
pastEndRead
"A client has attempted to read beyond the read limit.
Check in what state we currently are and perform
the appropriate action"
| blockType bp oldLimit |
state = StateNoMoreData ifTrue:[^nil]. "Get out early if possible"
"Check if we can move decoded data to front"
self moveContentsToFront.
"Check if we can fetch more source data"
self moveSourceToFront.
state = StateNewBlock ifTrue:[state := self getNextBlock].
blockType := state bitShift: -1.
bp := self bitPosition.
oldLimit := readLimit.
self perform: (BlockTypes at: blockType+1).
"Note: if bit position hasn't advanced then nothing has been decoded."
bp = self bitPosition
ifTrue:[^self primitiveFailed].
"Update crc for the decoded contents"
readLimit > oldLimit
ifTrue:[crc := self updateCrc: crc from: oldLimit+1 to: readLimit in: collection].
state = StateNoMoreData ifTrue:[self verifyCrc].
^self next!
----- Method: InflateStream>>proceedDynamicBlock (in category 'inflating') -----
proceedDynamicBlock
self decompressBlock: litTable with: distTable!
----- Method: InflateStream>>proceedFixedBlock (in category 'inflating') -----
proceedFixedBlock
self decompressBlock: litTable with: distTable!
----- Method: InflateStream>>proceedStoredBlock (in category 'inflating') -----
proceedStoredBlock
"Proceed decompressing a stored (e.g., uncompressed) block"
| length decoded |
"Literal table must be nil for a stored block"
litTable == nil ifFalse:[^self error:'Bad state'].
length := distTable.
[length > 0 and:[readLimit < collection size and:[sourcePos < sourceLimit]]]
whileTrue:[
collection at: (readLimit := readLimit + 1) put:
(source at: (sourcePos := sourcePos + 1)).
length := length - 1].
length = 0 ifTrue:[state := state bitAnd: StateNoMoreData].
decoded := length - distTable.
distTable := length.
^decoded!
----- Method: InflateStream>>processDynamicBlock (in category 'inflating') -----
processDynamicBlock
| nLit nDist nLen codeLength lengthTable bits |
nLit := (self nextBits: 5) + 257.
nDist := (self nextBits: 5) + 1.
nLen := (self nextBits: 4) + 4.
codeLength := Array new: 19.
codeLength atAllPut: 0.
1 to: nLen do:[:i|
bits := #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) at: i.
codeLength at: bits+1 put: (self nextBits: 3).
].
lengthTable := self huffmanTableFrom: codeLength mappedBy: nil.
"RFC 1951: In other words, all code lengths form a single sequence..."
codeLength := self decodeDynamicTable: nLit+nDist from: lengthTable.
litTable := self
huffmanTableFrom: (codeLength copyFrom: 1 to: nLit)
mappedBy: self literalLengthMap.
distTable := self
huffmanTableFrom: (codeLength copyFrom: nLit+1 to: codeLength size)
mappedBy: self distanceMap.
state := state bitOr: BlockProceedBit.
self proceedDynamicBlock.!
----- Method: InflateStream>>processFixedBlock (in category 'inflating') -----
processFixedBlock
litTable := self
huffmanTableFrom: FixedLitCodes
mappedBy: self literalLengthMap.
distTable := self
huffmanTableFrom: FixedDistCodes
mappedBy: self distanceMap.
state := state bitOr: BlockProceedBit.
self proceedFixedBlock.!
----- Method: InflateStream>>processStoredBlock (in category 'inflating') -----
processStoredBlock
| chkSum length |
"Skip to byte boundary"
self nextBits: (bitPos bitAnd: 7).
length := self nextBits: 16.
chkSum := self nextBits: 16.
(chkSum bitXor: 16rFFFF) = length
ifFalse:[^self error:'Bad block length'].
litTable := nil.
distTable := length.
state := state bitOr: BlockProceedBit.
^self proceedStoredBlock!
----- Method: InflateStream>>profile (in category 'private') -----
profile
"Profile the decompression speed"
MessageTally spyOn:[self decompressAll].!
----- Method: InflateStream>>reset (in category 'initialize') -----
reset
"Position zero - nothing decoded yet"
position := readLimit := 0.
sourcePos := 0.
bitBuf := bitPos := 0.
state := 0.!
----- Method: InflateStream>>size (in category 'accessing') -----
size
"This is a compressed stream - we don't know the size beforehand"
^self shouldNotImplement!
----- Method: InflateStream>>sourceLimit (in category 'accessing') -----
sourceLimit
^sourceLimit!
----- Method: InflateStream>>sourcePosition (in category 'accessing') -----
sourcePosition
^sourcePos!
----- Method: InflateStream>>sourceStream (in category 'accessing') -----
sourceStream
^sourceStream!
----- Method: InflateStream>>upTo: (in category 'accessing') -----
upTo: anObject
"Answer a subcollection from the current access position to the
occurrence (if any, but not inclusive) of anObject in the receiver. If
anObject is not in the collection, answer the entire rest of the receiver."
| newStream element |
newStream := WriteStream on: (collection species new: 100).
[self atEnd or: [(element := self next) = anObject]]
whileFalse: [newStream nextPut: element].
^newStream contents!
----- Method: InflateStream>>upToEnd (in category 'accessing') -----
upToEnd
"Answer a subcollection from the current access position through the last element of the receiver."
| newStream buffer |
buffer := collection species new: 1000.
newStream := WriteStream on: (collection species new: 100).
[self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)].
^ newStream contents!
----- Method: InflateStream>>updateCrc:from:to:in: (in category 'crc') -----
updateCrc: oldCrc from: start to: stop in: aCollection
"Answer an updated CRC for the range of bytes in aCollection.
Subclasses can implement the appropriate means for the check sum they wish to use."
^oldCrc!
----- Method: InflateStream>>verifyCrc (in category 'crc') -----
verifyCrc
"Verify the crc checksum in the input"!
Error subclass: #CRCError
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Streams'!
----- Method: CRCError>>isResumable (in category 'as yet unclassified') -----
isResumable
^true!
Object subclass: #Archive
instanceVariableNames: 'members'
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Archives'!
!Archive commentStamp: '<historical>' prior: 0!
This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.!
----- Method: Archive>>addDirectory: (in category 'archive operations') -----
addDirectory: aFileName
^self addDirectory: aFileName as: aFileName
!
----- Method: Archive>>addDirectory:as: (in category 'archive operations') -----
addDirectory: aFileName as: anotherFileName
| newMember |
newMember := self memberClass newFromDirectory: aFileName.
self addMember: newMember.
newMember localFileName: anotherFileName.
^newMember!
----- Method: Archive>>addFile: (in category 'archive operations') -----
addFile: aFileName
^self addFile: aFileName as: aFileName!
----- Method: Archive>>addFile:as: (in category 'archive operations') -----
addFile: aFileName as: anotherFileName
| newMember |
newMember := self memberClass newFromFile: aFileName.
self addMember: newMember.
newMember localFileName: anotherFileName.
^newMember!
----- Method: Archive>>addMember: (in category 'archive operations') -----
addMember: aMember
^members addLast: aMember!
----- Method: Archive>>addString:as: (in category 'archive operations') -----
addString: aString as: aFileName
| newMember |
newMember := self memberClass newFromString: aString named: aFileName.
self addMember: newMember.
newMember localFileName: aFileName.
^newMember!
----- Method: Archive>>addTree:match: (in category 'archive operations') -----
addTree: aFileNameOrDirectory match: aBlock
| nameSize |
nameSize := aFileNameOrDirectory isString
ifTrue: [aFileNameOrDirectory size]
ifFalse: [aFileNameOrDirectory pathName size].
^ self
addTree: aFileNameOrDirectory
removingFirstCharacters: nameSize + 1
match: aBlock!
----- Method: Archive>>addTree:removingFirstCharacters: (in category 'archive operations') -----
addTree: aFileNameOrDirectory removingFirstCharacters: n
^ self
addTree: aFileNameOrDirectory
removingFirstCharacters: n
match: [:e | true]!
----- Method: Archive>>addTree:removingFirstCharacters:match: (in category 'archive operations') -----
addTree: aFileNameOrDirectory removingFirstCharacters: n match: aBlock
| dir newMember fullPath relativePath |
dir := (aFileNameOrDirectory isString)
ifTrue: [ FileDirectory on: aFileNameOrDirectory ]
ifFalse: [ aFileNameOrDirectory ].
fullPath := dir pathName, dir slash.
relativePath := fullPath copyFrom: n + 1 to: fullPath size.
(dir entries select: [ :entry | aBlock value: entry])
do: [ :ea | | fullName |
fullName := fullPath, ea name.
newMember := ea isDirectory
ifTrue: [ self memberClass newFromDirectory: fullName ]
ifFalse: [ self memberClass newFromFile: fullName ].
newMember localFileName: relativePath, ea name.
self addMember: newMember.
ea isDirectory ifTrue: [ self addTree: fullName removingFirstCharacters: n match: aBlock].
].
!
----- Method: Archive>>canWriteToFileNamed: (in category 'archive operations') -----
canWriteToFileNamed: aFileName
"Catch attempts to overwrite existing zip file"
^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not.
!
----- Method: Archive>>contentsOf: (in category 'archive operations') -----
contentsOf: aMemberOrName
| member |
member := self member: aMemberOrName.
member ifNil: [ ^nil ].
^member contents!
----- Method: Archive>>extractMember: (in category 'archive operations') -----
extractMember: aMemberOrName
| member |
member := self member: aMemberOrName.
member ifNil: [ ^nil ].
member extractToFileNamed: member localFileName inDirectory: FileDirectory default.!
----- Method: Archive>>extractMember:toFileNamed: (in category 'archive operations') -----
extractMember: aMemberOrName toFileNamed: aFileName
| member |
member := self member: aMemberOrName.
member ifNil: [ ^nil ].
member extractToFileNamed: aFileName!
----- Method: Archive>>extractMemberWithoutPath: (in category 'archive operations') -----
extractMemberWithoutPath: aMemberOrName
self extractMemberWithoutPath: aMemberOrName inDirectory: FileDirectory default.!
----- Method: Archive>>extractMemberWithoutPath:inDirectory: (in category 'archive operations') -----
extractMemberWithoutPath: aMemberOrName inDirectory: dir
| member |
member := self member: aMemberOrName.
member ifNil: [ ^nil ].
member extractToFileNamed: (FileDirectory localNameFor: member localFileName) inDirectory: dir!
----- Method: Archive>>initialize (in category 'initialization') -----
initialize
members := OrderedCollection new.!
----- Method: Archive>>member: (in category 'private') -----
member: aMemberOrName
^(members includes: aMemberOrName)
ifTrue: [ aMemberOrName ]
ifFalse: [ self memberNamed: aMemberOrName ].!
----- Method: Archive>>memberClass (in category 'private') -----
memberClass
self subclassResponsibility!
----- Method: Archive>>memberNamed: (in category 'archive operations') -----
memberNamed: aString
"Return the first member whose zip name or local file name matches aString, or nil"
^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]!
----- Method: Archive>>memberNames (in category 'archive operations') -----
memberNames
^members collect: [ :ea | ea fileName ]!
----- Method: Archive>>members (in category 'archive operations') -----
members
^members!
----- Method: Archive>>membersMatching: (in category 'archive operations') -----
membersMatching: aString
^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]!
----- Method: Archive>>numberOfMembers (in category 'archive operations') -----
numberOfMembers
^members size!
----- Method: Archive>>removeMember: (in category 'archive operations') -----
removeMember: aMemberOrName
| member |
member := self member: aMemberOrName.
member ifNotNil: [ members remove: member ].
^member!
----- Method: Archive>>replaceMember:with: (in category 'archive operations') -----
replaceMember: aMemberOrName with: newMember
| member |
member := self member: aMemberOrName.
member ifNotNil: [ members replaceAll: member with: newMember ].
^member!
----- Method: Archive>>setContentsOf:to: (in category 'archive operations') -----
setContentsOf: aMemberOrName to: aString
| newMember oldMember |
oldMember := self member: aMemberOrName.
newMember := (self memberClass newFromString: aString named: oldMember fileName)
copyFrom: oldMember.
self replaceMember: oldMember with: newMember.!
----- Method: Archive>>writeTo: (in category 'archive operations') -----
writeTo: aStream
self subclassResponsibility!
----- Method: Archive>>writeToFileNamed: (in category 'archive operations') -----
writeToFileNamed: aFileName
| stream |
"Catch attempts to overwrite existing zip file"
(self canWriteToFileNamed: aFileName)
ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ].
stream := StandardFileStream forceNewFileNamed: aFileName.
self writeTo: stream.
stream close.!
Archive subclass: #TarArchive
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Archives'!
!TarArchive commentStamp: '<historical>' prior: 0!
This is a kind of archive that uses the TAR format (popular in Unix). It is here as a placeholder.!
----- Method: TarArchive>>memberClass (in category 'private') -----
memberClass
^TarArchiveMember!
Object subclass: #ArchiveMember
instanceVariableNames: 'fileName isCorrupt'
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Archives'!
!ArchiveMember commentStamp: '<historical>' prior: 0!
This is the abstract superclass for archive members, which are files or directories stored in archives.!
----- Method: ArchiveMember class>>newDirectoryNamed: (in category 'as yet unclassified') -----
newDirectoryNamed: aString
self subclassResponsibility!
----- Method: ArchiveMember class>>newFromFile: (in category 'as yet unclassified') -----
newFromFile: aFileName
self subclassResponsibility!
----- Method: ArchiveMember class>>newFromString: (in category 'as yet unclassified') -----
newFromString: aString
self subclassResponsibility!
----- Method: ArchiveMember>>close (in category 'initialization') -----
close
!
----- Method: ArchiveMember>>fileName (in category 'accessing') -----
fileName
^fileName!
----- Method: ArchiveMember>>fileName: (in category 'accessing') -----
fileName: aName
fileName := aName!
----- Method: ArchiveMember>>initialize (in category 'initialization') -----
initialize
fileName := ''.
isCorrupt := false.!
----- Method: ArchiveMember>>isCorrupt (in category 'accessing') -----
isCorrupt
^isCorrupt ifNil: [ isCorrupt := false ]!
----- Method: ArchiveMember>>isCorrupt: (in category 'accessing') -----
isCorrupt: aBoolean
"Mark this member as being corrupt."
isCorrupt := aBoolean!
----- Method: ArchiveMember>>localFileName: (in category 'accessing') -----
localFileName: aString
"Set my internal filename.
Returns the (possibly new) filename.
aString will be translated from local FS format into Unix format."
^fileName := aString copyReplaceAll: FileDirectory slash with: '/'.!
----- Method: ArchiveMember>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPut: $(;
nextPutAll: self fileName;
nextPut: $)!
----- Method: ArchiveMember>>usesFileNamed: (in category 'testing') -----
usesFileNamed: aFileName
"Do I require aFileName? That is, do I care if it's clobbered?"
^false!
ArchiveMember subclass: #TarArchiveMember
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Archives'!
Object subclass: #GZipSurrogateStream
instanceVariableNames: 'gZipStream zippedFileStream bufferStream positionThusFar'
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Streams'!
!GZipSurrogateStream commentStamp: '<historical>' prior: 0!
A pseudo stream that allows SmartRefStream to write directly to a gzipped file. There are some peculiarities of the project exporting process that require:
1. We ignore #close since the file is closed and may be reopened to continue writing. We implement #reallyClose for when we know that all writing is over.
2. We use a BitBlt to write WordArrayForSegment objects. Bit of a hack, but there it is.
| fileStream wa |
wa _ WordArrayForSegment new: 30000.
1 to: wa size do: [ :i | wa at: i put: i].
fileStream _ GZipSurrogateStream newFileNamed: 'xxx3.gz' inDirectory: FileDirectory default.
fileStream nextPutAll: 'this is a test'.
fileStream nextPutAll: wa.
fileStream reallyClose.
!
----- Method: GZipSurrogateStream class>>newFileNamed:inDirectory: (in category 'as yet unclassified') -----
newFileNamed: fName inDirectory: aDirectory
^self new newFileNamed: fName inDirectory: aDirectory!
----- Method: GZipSurrogateStream>>ascii (in category 'as yet unclassified') -----
ascii
self bufferStream ascii!
----- Method: GZipSurrogateStream>>binary (in category 'as yet unclassified') -----
binary
self bufferStream binary!
----- Method: GZipSurrogateStream>>bufferStream (in category 'as yet unclassified') -----
bufferStream
^bufferStream ifNil: [bufferStream := RWBinaryOrTextStream on: (ByteArray new: 5000)].
!
----- Method: GZipSurrogateStream>>close (in category 'as yet unclassified') -----
close
"we don't want to until user is really done"
!
----- Method: GZipSurrogateStream>>closed (in category 'as yet unclassified') -----
closed
^false!
----- Method: GZipSurrogateStream>>command: (in category 'as yet unclassified') -----
command: aString
"Overridden by HtmlFileStream to append commands directly without translation. 4/5/96 tk"
"We ignore any HTML commands. Do nothing"!
----- Method: GZipSurrogateStream>>cr (in category 'as yet unclassified') -----
cr
self bufferStream cr!
----- Method: GZipSurrogateStream>>fileOutClass:andObject: (in category 'as yet unclassified') -----
fileOutClass: extraClass andObject: theObject
"Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically."
| class srefStream |
self timeStamp.
extraClass ifNotNil: [
class := extraClass. "A specific class the user wants written"
class sharedPools size > 0 ifTrue: [
class shouldFileOutPools ifTrue: [class fileOutSharedPoolsOn: self]
].
class fileOutOn: self moveSource: false toFile: 0
].
"Append the object's raw data"
srefStream := SmartRefStream on: self.
srefStream nextPut: theObject. "and all subobjects"
srefStream close. "also closes me - well it thinks it does, anyway"
!
----- Method: GZipSurrogateStream>>flushBuffer (in category 'as yet unclassified') -----
flushBuffer
| data |
bufferStream ifNil: [^self].
data := bufferStream contents asByteArray.
gZipStream nextPutAll: data.
positionThusFar := positionThusFar + data size.
bufferStream := nil.
!
----- Method: GZipSurrogateStream>>header (in category 'as yet unclassified') -----
header
"ignore"!
----- Method: GZipSurrogateStream>>newFileNamed:inDirectory: (in category 'as yet unclassified') -----
newFileNamed: fName inDirectory: aDirectory
positionThusFar := 0.
zippedFileStream := aDirectory newFileNamed: fName.
zippedFileStream binary; setFileTypeToObject.
"Type and Creator not to be text, so can be enclosed in an email"
gZipStream := GZipWriteStream on: zippedFileStream.
!
----- Method: GZipSurrogateStream>>next (in category 'as yet unclassified') -----
next
^self bufferStream next!
----- Method: GZipSurrogateStream>>nextChunkPut: (in category 'as yet unclassified') -----
nextChunkPut: aString
self bufferStream nextChunkPut: aString!
----- Method: GZipSurrogateStream>>nextInt32Put: (in category 'as yet unclassified') -----
nextInt32Put: int32
^self bufferStream nextInt32Put: int32
!
----- Method: GZipSurrogateStream>>nextNumber:put: (in category 'as yet unclassified') -----
nextNumber: n put: v
^self bufferStream nextNumber: n put: v
!
----- Method: GZipSurrogateStream>>nextPut: (in category 'as yet unclassified') -----
nextPut: aByte
^self bufferStream nextPut: aByte
!
----- Method: GZipSurrogateStream>>nextPutAll: (in category 'as yet unclassified') -----
nextPutAll: aString
^aString writeOnGZIPByteStream: self
!
----- Method: GZipSurrogateStream>>nextPutAllBytes: (in category 'as yet unclassified') -----
nextPutAllBytes: aString
^self bufferStream nextPutAll: aString
!
----- Method: GZipSurrogateStream>>nextPutAllWordArray: (in category 'as yet unclassified') -----
nextPutAllWordArray: aWordArray
| ba hackwa hackba blt rowsAtATime sourceOrigin rowsRemaining |
self flag: #bob. "do we need to be concerned by bytesPerElement??"
ba := nil.
rowsAtATime := 2000. "or 8000 bytes"
hackwa := Form new hackBits: aWordArray.
sourceOrigin := 0 at 0.
[(rowsRemaining := hackwa height - sourceOrigin y) > 0] whileTrue: [
rowsAtATime := rowsAtATime min: rowsRemaining.
(ba isNil or: [ba size ~= (rowsAtATime * 4)]) ifTrue: [
ba := ByteArray new: rowsAtATime * 4.
hackba := Form new hackBits: ba.
blt := (BitBlt toForm: hackba) sourceForm: hackwa.
].
blt
combinationRule: Form over;
sourceOrigin: sourceOrigin;
destX: 0 destY: 0 width: 4 height: rowsAtATime;
copyBits.
self bufferStream nextPutAll: ba.
self flushBuffer.
sourceOrigin := sourceOrigin x @ (sourceOrigin y + rowsAtATime).
].
!
----- Method: GZipSurrogateStream>>nextStringPut: (in category 'as yet unclassified') -----
nextStringPut: s
"Append the string, s, to the receiver. Only used by DataStream. Max size of 64*256*256*256."
| length |
(length := s size) < 192
ifTrue: [self nextPut: length]
ifFalse:
[self nextPut: (length digitAt: 4)+192.
self nextPut: (length digitAt: 3).
self nextPut: (length digitAt: 2).
self nextPut: (length digitAt: 1)].
self nextPutAll: s.
^s!
----- Method: GZipSurrogateStream>>nextWordsPutAll: (in category 'as yet unclassified') -----
nextWordsPutAll: aCollection
"Write the argument a word-like object in big endian format on the receiver.
May be used to write other than plain word-like objects (such as ColorArray)."
^self nextPutAllWordArray: aCollection!
----- Method: GZipSurrogateStream>>originalContents (in category 'as yet unclassified') -----
originalContents
^'' "used only to determine if we are byte-structured"!
----- Method: GZipSurrogateStream>>padToEndWith: (in category 'as yet unclassified') -----
padToEndWith: aChar
"We don't have pages, so we are at the end, and don't need to pad."!
----- Method: GZipSurrogateStream>>position (in category 'as yet unclassified') -----
position
^self bufferStream position + positionThusFar!
----- Method: GZipSurrogateStream>>reallyClose (in category 'as yet unclassified') -----
reallyClose
self flushBuffer.
gZipStream close.
!
----- Method: GZipSurrogateStream>>reopen (in category 'as yet unclassified') -----
reopen
"ignore"!
----- Method: GZipSurrogateStream>>setFileTypeToObject (in category 'as yet unclassified') -----
setFileTypeToObject
"ignore"!
----- Method: GZipSurrogateStream>>setToEnd (in category 'as yet unclassified') -----
setToEnd
"ignore"!
----- Method: GZipSurrogateStream>>skip: (in category 'as yet unclassified') -----
skip: aNumber
^self bufferStream skip: aNumber
!
----- Method: GZipSurrogateStream>>timeStamp (in category 'as yet unclassified') -----
timeStamp
"Append the current time to the receiver as a String."
self bufferStream nextChunkPut: "double string quotes and !!s"
(String streamContents: [:s | SmalltalkImage current timeStamp: s]) printString.
self bufferStream cr!
----- Method: GZipSurrogateStream>>trailer (in category 'as yet unclassified') -----
trailer
"ignore"!
Object subclass: #ZipEncoderNode
instanceVariableNames: 'value frequency height bitLength code parent left right'
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Streams'!
!ZipEncoderNode commentStamp: '<historical>' prior: 0!
ZipEncoderNode represents a node in a huffman tree for encoding ZipStreams.
Instance variables:
value <Integer> - Encoded value
frequency <Integer> - Number of occurences of the encoded value
height <Integer> - Height of the node in the tree
bitLength <Integer> - bit length of the code
code <Integer> - Assigned code for this node
parent <ZipEncoderNode> - Parent of this node
left <ZipEncoderNode> - First child of this node
right <ZipEncoderNode> - Second child of this node
!
----- Method: ZipEncoderNode class>>value:frequency:height: (in category 'instance creation') -----
value: v frequency: f height: h
^self new setValue: v frequency: f height: h!
----- Method: ZipEncoderNode>>bitLength (in category 'accessing') -----
bitLength
^bitLength ifNil:[0]!
----- Method: ZipEncoderNode>>code (in category 'accessing') -----
code
^code ifNil:[0]!
----- Method: ZipEncoderNode>>code: (in category 'accessing') -----
code: aCode
self assert:[aCode >= 0 and:[(1 bitShift: bitLength) > aCode]].
code := aCode.!
----- Method: ZipEncoderNode>>computeHeight (in category 'private') -----
computeHeight
^self isLeaf
ifTrue:[height := 0]
ifFalse:[height := (left computeHeight max: right computeHeight) + 1].!
----- Method: ZipEncoderNode>>encodeBitLength:from: (in category 'encoding') -----
encodeBitLength: blCounts from: aTree
| index |
"Note: If bitLength is not nil then the tree must be broken"
bitLength == nil ifFalse:[self error:'Huffman tree is broken'].
parent = nil
ifTrue:[bitLength := 0]
ifFalse:[bitLength := parent bitLength + 1].
self isLeaf ifTrue:[
index := bitLength + 1.
blCounts at: index put: (blCounts at: index) + 1.
] ifFalse:[
left encodeBitLength: blCounts from: aTree.
right encodeBitLength: blCounts from: aTree.
].!
----- Method: ZipEncoderNode>>frequency (in category 'accessing') -----
frequency
^frequency!
----- Method: ZipEncoderNode>>frequency: (in category 'accessing') -----
frequency: aNumber
frequency := aNumber!
----- Method: ZipEncoderNode>>height (in category 'accessing') -----
height
^height!
----- Method: ZipEncoderNode>>isLeaf (in category 'testing') -----
isLeaf
^left == nil!
----- Method: ZipEncoderNode>>leafNodes (in category 'private') -----
leafNodes
self isLeaf
ifTrue:[^Array with: self]
ifFalse:[^left leafNodes, right leafNodes]!
----- Method: ZipEncoderNode>>left (in category 'accessing') -----
left
^left!
----- Method: ZipEncoderNode>>left: (in category 'accessing') -----
left: aNode
aNode parent: self.
left := aNode.!
----- Method: ZipEncoderNode>>parent (in category 'accessing') -----
parent
^parent!
----- Method: ZipEncoderNode>>parent: (in category 'accessing') -----
parent: aNode
parent := aNode!
----- Method: ZipEncoderNode>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPut:$(;
nextPutAll:'value = '; print: value;
nextPutAll:', freq = '; print: frequency;
nextPutAll:', bitLength = '; print: bitLength;
nextPutAll:', code = '; print: code;
nextPutAll:', height = '; print: height;
nextPut:$).!
----- Method: ZipEncoderNode>>right (in category 'accessing') -----
right
^right!
----- Method: ZipEncoderNode>>right: (in category 'accessing') -----
right: aNode
aNode parent: self.
right := aNode.!
----- Method: ZipEncoderNode>>rotateToHeight: (in category 'encoding') -----
rotateToHeight: maxHeight
"Rotate the tree to achieve maxHeight depth"
| newParent |
height < 4 ifTrue:[^self].
self left: (left rotateToHeight: maxHeight-1).
self right: (right rotateToHeight: maxHeight-1).
height := (left height max: right height) + 1.
height <= maxHeight ifTrue:[^self].
(left height - right height) abs <= 2 ifTrue:[^self].
left height < right height ifTrue:[
right right height >= right left height ifTrue:[
newParent := right.
self right: newParent left.
newParent left: self.
] ifFalse:[
newParent := right left.
right left: newParent right.
newParent right: right.
self right: newParent left.
newParent left: self.
].
] ifFalse:[
left left height >= left right height ifTrue:[
newParent := left.
self left: newParent right.
newParent right: self.
] ifFalse:[
newParent := left right.
left right: newParent left.
newParent left: left.
self left: newParent right.
newParent right: self.
].
].
parent computeHeight.
^parent!
----- Method: ZipEncoderNode>>setBitLengthTo: (in category 'private') -----
setBitLengthTo: bl
bitLength := bl!
----- Method: ZipEncoderNode>>setValue:frequency:height: (in category 'private') -----
setValue: v frequency: f height: h
value := v.
frequency := f.
height := h.!
----- Method: ZipEncoderNode>>value (in category 'accessing') -----
value
^value!
Object subclass: #ZipEncoderTree
instanceVariableNames: 'bitLengths codes maxCode'
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Streams'!
!ZipEncoderTree commentStamp: '<historical>' prior: 0!
ZipEncoderTree represents a huffman tree for encoding ZipStreams.
Instance variables:
bitLengths <WordArray> - Bit lengths of each generated code
codes <WordArray> - Codes for each value
maxCode <Integer> - Maximum value with non-zero frequency!
----- Method: ZipEncoderTree class>>buildTreeFrom:maxDepth: (in category 'instance creation') -----
buildTreeFrom: frequencies maxDepth: depth
^self new buildTreeFrom: frequencies maxDepth: depth!
----- Method: ZipEncoderTree>>bitLengthAt: (in category 'accessing') -----
bitLengthAt: index
^bitLengths at: index+1!
----- Method: ZipEncoderTree>>bitLengths (in category 'accessing') -----
bitLengths
"Return an array of all bitLength values for valid codes"
^bitLengths!
----- Method: ZipEncoderTree>>bitLengths:codes: (in category 'private') -----
bitLengths: blArray codes: codeArray
bitLengths := blArray as: WordArray.
codes := codeArray as: WordArray.
self assert:[(self bitLengthAt: maxCode) > 0].!
----- Method: ZipEncoderTree>>buildCodes:counts:maxDepth: (in category 'encoding') -----
buildCodes: nodeList counts: blCounts maxDepth: depth
"Build the codes for all nodes"
| nextCode code node length |
nextCode := WordArray new: depth+1.
code := 0.
1 to: depth do:[:bits|
code := (code + (blCounts at: bits)) << 1.
nextCode at: bits+1 put: code].
self assert:[(code + (blCounts at: depth+1) - 1) = (1 << depth - 1)].
0 to: maxCode do:[:n|
node := nodeList at: n+1.
length := node bitLength.
length = 0 ifFalse:[
code := nextCode at: length+1.
node code: (self reverseBits: code length: length).
nextCode at: length+1 put: code+1.
].
].!
----- Method: ZipEncoderTree>>buildHierarchyFrom: (in category 'encoding') -----
buildHierarchyFrom: aHeap
"Build the node hierarchy based on the leafs in aHeap"
| left right parent |
[aHeap size > 1] whileTrue:[
left := aHeap removeFirst.
right := aHeap removeFirst.
parent := ZipEncoderNode value: -1
frequency: (left frequency + right frequency)
height: (left height max: right height) + 1.
left parent: parent.
right parent: parent.
parent left: left.
parent right: right.
aHeap add: parent].
^aHeap removeFirst
!
----- Method: ZipEncoderTree>>buildTree:maxDepth: (in category 'encoding') -----
buildTree: nodeList maxDepth: depth
"Build either the literal or the distance tree"
| heap rootNode blCounts |
heap := Heap new: nodeList size // 3.
heap sortBlock: self nodeSortBlock.
"Find all nodes with non-zero frequency and add to heap"
maxCode := 0.
nodeList do:[:dNode|
dNode frequency = 0 ifFalse:[
maxCode := dNode value.
heap add: dNode]].
"The pkzip format requires that at least one distance code exists,
and that at least one bit should be sent even if there is only one
possible code. So to avoid special checks later on we force at least
two codes of non zero frequency."
heap size = 0 ifTrue:[
self assert:[maxCode = 0].
heap add: nodeList first.
heap add: nodeList second.
maxCode := 1].
heap size = 1 ifTrue:[
nodeList first frequency = 0
ifTrue:[heap add: nodeList first]
ifFalse:[heap add: nodeList second].
maxCode := maxCode max: 1].
rootNode := self buildHierarchyFrom: heap.
rootNode height > depth ifTrue:[
rootNode := rootNode rotateToHeight: depth.
rootNode height > depth ifTrue:[self error:'Cannot encode tree']].
blCounts := WordArray new: depth+1.
rootNode encodeBitLength: blCounts from: self.
self buildCodes: nodeList counts: blCounts maxDepth: depth.
self setValuesFrom: nodeList.!
----- Method: ZipEncoderTree>>buildTreeFrom:maxDepth: (in category 'encoding') -----
buildTreeFrom: frequencies maxDepth: depth
"Build the receiver from the given frequency values"
| nodeList |
nodeList := Array new: frequencies size.
1 to: frequencies size do:[:i|
nodeList at: i put: (ZipEncoderNode value: i-1 frequency: (frequencies at: i) height: 0)
].
self buildTree: nodeList maxDepth: depth.!
----- Method: ZipEncoderTree>>codeAt: (in category 'accessing') -----
codeAt: index
^codes at: index+1!
----- Method: ZipEncoderTree>>codes (in category 'accessing') -----
codes
"Return an array of all valid codes"
^codes!
----- Method: ZipEncoderTree>>maxCode (in category 'accessing') -----
maxCode
^maxCode!
----- Method: ZipEncoderTree>>maxCode: (in category 'accessing') -----
maxCode: aNumber
maxCode := aNumber.!
----- Method: ZipEncoderTree>>nodeSortBlock (in category 'encoding') -----
nodeSortBlock
^[:n1 :n2|
n1 frequency = n2 frequency
ifTrue:[n1 height <= n2 height]
ifFalse:[n1 frequency <= n2 frequency]].!
----- Method: ZipEncoderTree>>reverseBits:length: (in category 'private') -----
reverseBits: code length: length
"Bit reverse the given code"
| result bit bits |
result := 0.
bits := code.
1 to: length do:[:i|
bit := bits bitAnd: 1.
result := result << 1 bitOr: bit.
bits := bits >> 1].
^result!
----- Method: ZipEncoderTree>>setValuesFrom: (in category 'private') -----
setValuesFrom: nodeList
self bitLengths: (nodeList
collect: [:n | n bitLength]
from: 1
to: maxCode + 1)
codes: (nodeList
collect: [:n | n code]
from: 1
to: maxCode + 1)!
TestCase subclass: #ZipCrcTests
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Streams'!
----- Method: ZipCrcTests>>testInvalidGZipCrc (in category 'tests') -----
testInvalidGZipCrc
"See that a wrong CRC raises an appropriate error"
| reader writer bytes crcByte |
writer := GZipWriteStream on: String new.
writer nextPutAll: 'Hello World'.
writer close.
bytes := writer encodedStream contents.
crcByte := bytes byteAt: bytes size-5. "before the length"
bytes byteAt: bytes size-5 put: (crcByte + 1 bitAnd: 255).
reader := GZipReadStream on: bytes.
self should:[reader upToEnd] raise: CRCError.
reader := GZipReadStream on: bytes.
self should:[reader contents] raise: CRCError.
reader := GZipReadStream on: bytes.
self should:[reader next: 100] raise: CRCError.
!
----- Method: ZipCrcTests>>testInvalidZLibCrc (in category 'tests') -----
testInvalidZLibCrc
"See that a wrong CRC raises an appropriate error"
| reader writer bytes crcByte |
writer := ZLibWriteStream on: String new.
writer nextPutAll: 'Hello World'.
writer close.
bytes := writer encodedStream contents.
crcByte := bytes byteAt: bytes size-2.
bytes byteAt: bytes size-2 put: (crcByte + 1 bitAnd: 255).
reader := ZLibReadStream on: bytes.
self should:[reader upToEnd] raise: CRCError.
reader := ZLibReadStream on: bytes.
self should:[reader contents] raise: CRCError.
reader := ZLibReadStream on: bytes.
self should:[reader next: 100] raise: CRCError.
!
----- Method: ZipCrcTests>>testInvalidZipCrc (in category 'tests') -----
testInvalidZipCrc
"See that a wrong CRC raises an appropriate error"
| reader writer bytes |
writer := ZipWriteStream on: String new.
writer nextPutAll: 'Hello World'.
writer close.
bytes := writer encodedStream contents.
reader := ZipReadStream on: bytes.
reader expectedCrc: writer crc - 1.
self should:[reader upToEnd] raise: CRCError.
reader := ZipReadStream on: bytes.
reader expectedCrc: writer crc - 1.
self should:[reader contents] raise: CRCError.
reader := ZipReadStream on: bytes.
reader expectedCrc: writer crc - 1.
self should:[reader next: 100] raise: CRCError.
!
----- Method: ZipCrcTests>>testMissingGZipCrc (in category 'tests') -----
testMissingGZipCrc
"See that the lack of a CRC raises an appropriate error"
| reader writer bytes |
writer := GZipWriteStream on: String new.
writer nextPutAll: 'Hello World'.
writer close.
bytes := writer encodedStream contents.
bytes := bytes copyFrom: 1 to: bytes size-6.
reader := GZipReadStream on: bytes.
self should:[reader upToEnd] raise: CRCError.
reader := GZipReadStream on: bytes.
self should:[reader contents] raise: CRCError.
reader := GZipReadStream on: bytes.
self should:[reader next: 100] raise: CRCError.
!
----- Method: ZipCrcTests>>testMissingZLibCrc (in category 'tests') -----
testMissingZLibCrc
"See that the lack of a CRC raises an appropriate error"
| reader writer bytes |
writer := ZLibWriteStream on: String new.
writer nextPutAll: 'Hello World'.
writer close.
bytes := writer encodedStream contents.
bytes := bytes copyFrom: 1 to: bytes size-2.
reader := ZLibReadStream on: bytes.
self should:[reader upToEnd] raise: CRCError.
reader := ZLibReadStream on: bytes.
self should:[reader contents] raise: CRCError.
reader := ZLibReadStream on: bytes.
self should:[reader next: 100] raise: CRCError.
!
----- Method: ZipCrcTests>>testMissingZipCrc (in category 'tests') -----
testMissingZipCrc
"See that the lack of a CRC does not raise an error"
| reader writer bytes readBytes |
writer := ZipWriteStream on: String new.
writer nextPutAll: 'Hello World'.
writer close.
bytes := writer encodedStream contents.
reader := ZipReadStream on: bytes.
self shouldnt:[readBytes := reader upToEnd] raise: CRCError.
self assert: readBytes = 'Hello World'.
reader := ZipReadStream on: bytes.
self shouldnt:[reader contents] raise: CRCError.
reader := ZipReadStream on: bytes.
self shouldnt:[reader next: 100] raise: CRCError.
!
----- Method: ZipCrcTests>>testValidGZipCrc (in category 'tests') -----
testValidGZipCrc
| reader writer bytes |
writer := GZipWriteStream on: String new.
writer nextPutAll: 'Hello World'.
writer close.
bytes := writer encodedStream contents.
reader := GZipReadStream on: bytes.
self assert: reader upToEnd = 'Hello World'.!
----- Method: ZipCrcTests>>testValidZLibCrc (in category 'tests') -----
testValidZLibCrc
| reader writer bytes |
writer := ZLibWriteStream on: String new.
writer nextPutAll: 'Hello World'.
writer close.
bytes := writer encodedStream contents.
reader := ZLibReadStream on: bytes.
self assert: reader upToEnd = 'Hello World'.
bytes := writer encodedStream contents.
reader := ZLibReadStream on: bytes.
self assert: (reader next: 100) = 'Hello World'.!
----- Method: ZipCrcTests>>testValidZipCrc (in category 'tests') -----
testValidZipCrc
"See that a correct CRC does not raise an error and that we can read what we wrote."
| reader writer bytes readBytes |
writer := ZipWriteStream on: String new.
writer nextPutAll: 'Hello World'.
writer close.
bytes := writer encodedStream contents.
reader := ZipReadStream on: bytes.
reader expectedCrc: writer crc.
self shouldnt:[ readBytes := reader upToEnd] raise: CRCError.
self assert: readBytes = 'Hello World'.
reader := ZipReadStream on: bytes.
reader expectedCrc: writer crc.
self shouldnt:[ readBytes := reader contents] raise: CRCError.
self assert: readBytes = 'Hello World'.
reader := ZipReadStream on: bytes.
reader expectedCrc: writer crc.
self shouldnt:[ readBytes := reader next: 11 ] raise: CRCError.
self assert: readBytes = 'Hello World'.
reader := ZipReadStream on: bytes.
reader expectedCrc: writer crc.
self shouldnt:[ readBytes := reader next: 100 ] raise: CRCError.
self assert: readBytes = 'Hello World'.!
SharedPool subclass: #GZipConstants
instanceVariableNames: ''
classVariableNames: 'GZipCommentFlag GZipContinueFlag GZipNameFlag GZipMagic GZipExtraField GZipDeflated GZipEncryptFlag GZipAsciiFlag GZipReservedFlags'
poolDictionaries: ''
category: 'Compression-Streams'!
----- Method: GZipConstants class>>gzipMagic (in category 'pool initialization') -----
gzipMagic
^GZipMagic!
----- Method: GZipConstants class>>initialize (in category 'pool initialization') -----
initialize
"GZipConstants initialize"
GZipMagic := 16r8B1F. "GZIP magic number"
GZipDeflated := 8. "Compression method"
GZipAsciiFlag := 16r01. "Contents is ASCII"
GZipContinueFlag := 16r02. "Part of a multi-part archive"
GZipExtraField := 16r04. "Archive has extra fields"
GZipNameFlag := 16r08. "Archive has original file name"
GZipCommentFlag := 16r10. "Archive has comment"
GZipEncryptFlag := 16r20. "Archive is encrypted"
GZipReservedFlags := 16rC0. "Reserved" !
FastInflateStream subclass: #GZipReadStream
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: 'GZipConstants'
category: 'Compression-Streams'!
----- Method: GZipReadStream class>>fileIn: (in category 'fileIn/Out') -----
fileIn: fullFileName
"FileIn the contents of a gzipped file"
| zipped unzipped |
zipped := self on: (FileStream readOnlyFileNamed: fullFileName).
unzipped := MultiByteBinaryOrTextStream with: (zipped contents asString).
unzipped reset.
unzipped fileIn.
!
----- Method: GZipReadStream class>>fileIntoNewChangeSet: (in category 'fileIn/Out') -----
fileIntoNewChangeSet: fullFileName
"FileIn the contents of a gzipped file"
| zipped unzipped cs |
cs := Smalltalk at: #ChangesOrganizer ifAbsent: [ ^self ].
zipped := self on: (FileStream readOnlyFileNamed: fullFileName).
unzipped := MultiByteBinaryOrTextStream with: zipped contents asString.
unzipped reset.
cs newChangesFromStream: unzipped named: (FileDirectory localNameFor: fullFileName)
!
----- Method: GZipReadStream class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') -----
fileReaderServicesForFile: fullName suffix: suffix
| services |
(suffix = 'gz') | (suffix = '*')
ifFalse: [^ #()].
services := OrderedCollection new.
(suffix = '*') | (fullName asLowercase endsWith: '.cs.gz') | (fullName asLowercase endsWith: '.mcs.gz')
ifTrue: [services add: self serviceFileIn.
(Smalltalk includesKey: #ChangSet)
ifTrue: [services add: self serviceFileIntoNewChangeSet]].
services addAll: self services.
^ services!
----- Method: GZipReadStream class>>saveContents: (in category 'fileIn/Out') -----
saveContents: fullFileName
"Save the contents of a gzipped file"
| zipped buffer unzipped newName |
newName := fullFileName copyUpToLast: FileDirectory extensionDelimiter.
unzipped := FileStream newFileNamed: newName.
unzipped binary.
zipped := GZipReadStream on: (FileStream readOnlyFileNamed: fullFileName).
buffer := ByteArray new: 50000.
'Extracting ' , fullFileName
displayProgressAt: Sensor cursorPoint
from: 0
to: zipped sourceStream size
during:
[:bar |
[zipped atEnd]
whileFalse:
[bar value: zipped sourceStream position.
unzipped nextPutAll: (zipped nextInto: buffer)].
zipped close.
unzipped close].
^ newName!
----- Method: GZipReadStream class>>serviceDecompressToFile (in category 'fileIn/Out') -----
serviceDecompressToFile
^ FileModifyingSimpleServiceEntry
provider: self
label: 'decompress to file'
selector: #saveContents:
description: 'decompress to file'!
----- Method: GZipReadStream class>>serviceFileIn (in category 'fileIn/Out') -----
serviceFileIn
"Answer a service for filing in an entire file"
^ SimpleServiceEntry
provider: self
label: 'fileIn entire file'
selector: #fileIn:
description: 'file in the entire decompressed contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format'
buttonLabel: 'filein'
!
----- Method: GZipReadStream class>>serviceFileIntoNewChangeSet (in category 'fileIn/Out') -----
serviceFileIntoNewChangeSet
"Answer a service for filing in an entire file"
^ SimpleServiceEntry
provider: self
label: 'install into new change set'
selector: #fileIntoNewChangeSet:
description: 'install the decompressed contents of the file as a body of code in the image: create a new change set and file-in the selected file into it'
buttonLabel: 'install'!
----- Method: GZipReadStream class>>serviceViewDecompress (in category 'fileIn/Out') -----
serviceViewDecompress
^ SimpleServiceEntry
provider: self
label: 'view decompressed'
selector: #viewContents:
description: 'view decompressed'
!
----- Method: GZipReadStream class>>services (in category 'fileIn/Out') -----
services
^ Array
with: self serviceViewDecompress
with: self serviceDecompressToFile
!
----- Method: GZipReadStream class>>uncompressedFileName: (in category 'fileIn/Out') -----
uncompressedFileName: fullName
^((fullName endsWith: '.gz') and: [self confirm: ('{1}
appears to be a compressed file.
Do you want to uncompress it?' translated format:{fullName})])
ifFalse: [fullName]
ifTrue:[self saveContents: fullName]!
----- Method: GZipReadStream class>>unload (in category 'class initialization') -----
unload
FileList unregisterFileReader: self !
----- Method: GZipReadStream class>>viewContents: (in category 'fileIn/Out') -----
viewContents: fullFileName
"Open the decompressed contents of the .gz file with the given name. This method is only required for the registering-file-list of Squeak 3.3a and beyond, but does no harm in an earlier system"
(FileStream readOnlyFileNamed: fullFileName) ifNotNilDo:
[:aStream | aStream viewGZipContents]!
----- Method: GZipReadStream>>on:from:to: (in category 'initialize') -----
on: aCollection from: firstIndex to: lastIndex
"Check the header of the GZIP stream."
| method magic flags length |
super on: aCollection from: firstIndex to: lastIndex.
crc := 16rFFFFFFFF.
magic := self nextBits: 16.
(magic = GZipMagic)
ifFalse:[^self error:'Not a GZipped stream'].
method := self nextBits: 8.
(method = GZipDeflated)
ifFalse:[^self error:'Bad compression method'].
flags := self nextBits: 8.
(flags anyMask: GZipEncryptFlag)
ifTrue:[^self error:'Cannot decompress encrypted stream'].
(flags anyMask: GZipReservedFlags)
ifTrue:[^self error:'Cannot decompress stream with unknown flags'].
"Ignore stamp, extra flags, OS type"
self nextBits: 16; nextBits: 16. "stamp"
self nextBits: 8. "extra flags"
self nextBits: 8. "OS type"
(flags anyMask: GZipContinueFlag) "Number of multi-part archive - ignored"
ifTrue:[self nextBits: 16].
(flags anyMask: GZipExtraField) "Extra fields - ignored"
ifTrue:[ length := self nextBits: 16.
1 to: length do:[:i| self nextBits: 8]].
(flags anyMask: GZipNameFlag) "Original file name - ignored"
ifTrue:[[(self nextBits: 8) = 0] whileFalse].
(flags anyMask: GZipCommentFlag) "Comment - ignored"
ifTrue:[[(self nextBits: 8) = 0] whileFalse].
!
----- Method: GZipReadStream>>updateCrc:from:to:in: (in category 'crc') -----
updateCrc: oldCrc from: start to: stop in: aCollection
"Answer an updated CRC for the range of bytes in aCollection"
^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection.!
----- Method: GZipReadStream>>verifyCrc (in category 'crc') -----
verifyCrc
| stored |
stored := 0.
0 to: 24 by: 8 do: [ :i |
sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ].
stored := stored + (self nextByte bitShift: i) ].
stored := stored bitXor: 16rFFFFFFFF.
stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ].
^stored!
SharedPool subclass: #ZipConstants
instanceVariableNames: ''
classVariableNames: 'ExtraLengthBits DynamicBlock Repeat11To138 ExtraDistanceBits MaxDistCodes FixedLiteralTree DistanceCodes Repeat3To10 Repeat3To6 HashBits ExtraBitLengthBits NumLiterals MaxLiteralCodes MaxBitLengthBits MaxMatch HashMask MinMatch EndBlock FixedDistanceTree StoredBlock BaseLength HashShift FixedBlock WindowSize MaxBitLengthCodes BaseDistance WindowMask MatchLengthCodes MaxBits MaxLengthCodes MaxDistance BitLengthOrder'
poolDictionaries: ''
category: 'Compression-Streams'!
WriteStream subclass: #DeflateStream
instanceVariableNames: 'hashHead hashTail hashValue blockPosition blockStart'
classVariableNames: ''
poolDictionaries: 'ZipConstants'
category: 'Compression-Streams'!
----- Method: DeflateStream>>compare:with:min: (in category 'deflating') -----
compare: here with: matchPos min: minLength
"Compare the two strings and return the length of matching characters.
minLength is a lower bound for match lengths that will be accepted.
Note: here and matchPos are zero based."
| length |
"First test if we can actually get longer than minLength"
(collection at: here+minLength+1) = (collection at: matchPos+minLength+1)
ifFalse:[^0].
(collection at: here+minLength) = (collection at: matchPos+minLength)
ifFalse:[^0].
"Then test if we have an initial match at all"
(collection at: here+1) = (collection at: matchPos+1)
ifFalse:[^0].
(collection at: here+2) = (collection at: matchPos+2)
ifFalse:[^1].
"Finally do the real comparison"
length := 3.
[length <= MaxMatch and:[
(collection at: here+length) = (collection at: matchPos+length)]]
whileTrue:[length := length + 1].
^length - 1!
----- Method: DeflateStream>>deflateBlock (in category 'deflating') -----
deflateBlock
"Deflate the current contents of the stream"
| flushNeeded lastIndex |
(blockStart == nil) ifTrue:[
"One time initialization for the first block"
1 to: MinMatch-1 do:[:i| self updateHashAt: i].
blockStart := 0].
[blockPosition < position] whileTrue:[
(position + MaxMatch > writeLimit)
ifTrue:[lastIndex := writeLimit - MaxMatch]
ifFalse:[lastIndex := position].
flushNeeded := self deflateBlock: lastIndex-1
chainLength: self hashChainLength
goodMatch: self goodMatchLength.
flushNeeded ifTrue:[
self flushBlock.
blockStart := blockPosition].
"Make room for more data"
self moveContentsToFront].
!
----- Method: DeflateStream>>deflateBlock:chainLength:goodMatch: (in category 'deflating') -----
deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch
"Continue deflating the receiver's collection from blockPosition to lastIndex.
Note that lastIndex must be at least MaxMatch away from the end of collection"
| here matchResult flushNeeded hereMatch hereLength newMatch newLength hasMatch |
blockPosition > lastIndex ifTrue:[^false]. "Nothing to deflate"
hasMatch := false.
here := blockPosition.
[here <= lastIndex] whileTrue:[
hasMatch ifFalse:[
"Find the first match"
matchResult := self findMatch: here
lastLength: MinMatch-1
lastMatch: here
chainLength: chainLength
goodMatch: goodMatch.
self insertStringAt: here. "update hash table"
hereMatch := matchResult bitAnd: 16rFFFF.
hereLength := matchResult bitShift: -16].
"Look ahead if there is a better match at the next position"
matchResult := self findMatch: here+1
lastLength: hereLength
lastMatch: hereMatch
chainLength: chainLength
goodMatch: goodMatch.
newMatch := matchResult bitAnd: 16rFFFF.
newLength := matchResult bitShift: -16.
"Now check if the next match is better than the current one.
If not, output the current match (provided that the current match
is at least MinMatch long)"
(hereLength >= newLength and:[hereLength >= MinMatch]) ifTrue:[
self assert:[self validateMatchAt: here
from: hereMatch to: hereMatch + hereLength - 1].
"Encode the current match"
flushNeeded := self
encodeMatch: hereLength
distance: here - hereMatch.
"Insert all strings up to the end of the current match.
Note: The first string has already been inserted."
1 to: hereLength-1 do:[:i| self insertStringAt: (here := here + 1)].
hasMatch := false.
here := here + 1.
] ifFalse:[
"Either the next match is better than the current one or we didn't
have a good match after all (e.g., current match length < MinMatch).
Output a single literal."
flushNeeded := self encodeLiteral: (collection byteAt: (here + 1)).
here := here + 1.
(here <= lastIndex and:[flushNeeded not]) ifTrue:[
"Cache the results for the next round"
self insertStringAt: here.
hasMatch := true.
hereMatch := newMatch.
hereLength := newLength].
].
flushNeeded ifTrue:[blockPosition := here. ^true].
].
blockPosition := here.
^false!
----- Method: DeflateStream>>encodeLiteral: (in category 'encoding') -----
encodeLiteral: literal
"Encode the given literal.
Return true if the current block needs to be flushed."
^false!
----- Method: DeflateStream>>encodeMatch:distance: (in category 'encoding') -----
encodeMatch: matchLength distance: matchDistance
"Encode a match of the given length and distance.
Return true if the current block should be flushed."
^false!
----- Method: DeflateStream>>findMatch:lastLength:lastMatch:chainLength:goodMatch: (in category 'deflating') -----
findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch
"Find the longest match for the string starting at here.
If there is no match longer than lastLength return lastMatch/lastLength.
Traverse at most maxChainLength entries in the hash table.
Stop if a match of at least goodMatch size has been found."
| matchResult matchPos distance chainLength limit bestLength length |
"Compute the default match result"
matchResult := (lastLength bitShift: 16) bitOr: lastMatch.
"There is no way to find a better match than MaxMatch"
lastLength >= MaxMatch ifTrue:[^matchResult].
"Start position for searches"
matchPos := hashHead at: (self updateHashAt: here + MinMatch) + 1.
"Compute the distance to the (possible) match"
distance := here - matchPos.
"Note: It is required that 0 < distance < MaxDistance"
(distance > 0 and:[distance < MaxDistance]) ifFalse:[^matchResult].
chainLength := maxChainLength. "Max. nr of match chain to search"
here > MaxDistance "Limit for matches that are too old"
ifTrue:[limit := here - MaxDistance]
ifFalse:[limit := 0].
"Best match length so far (current match must be larger to take effect)"
bestLength := lastLength.
["Compare the current string with the string at match position"
length := self compare: here with: matchPos min: bestLength.
"Truncate accidental matches beyound stream position"
(here + length > position) ifTrue:[length := position - here].
"Ignore very small matches if they are too far away"
(length = MinMatch and:[(here - matchPos) > (MaxDistance // 4)])
ifTrue:[length := MinMatch - 1].
length > bestLength ifTrue:["We have a new (better) match than before"
"Compute the new match result"
matchResult := (length bitShift: 16) bitOr: matchPos.
bestLength := length.
"There is no way to find a better match than MaxMatch"
bestLength >= MaxMatch ifTrue:[^matchResult].
"But we may have a good, fast match"
bestLength > goodMatch ifTrue:[^matchResult].
].
(chainLength := chainLength - 1) > 0] whileTrue:[
"Compare with previous entry in hash chain"
matchPos := hashTail at: (matchPos bitAnd: WindowMask) + 1.
matchPos <= limit ifTrue:[^matchResult]. "Match position is too old"
].
^matchResult!
----- Method: DeflateStream>>flush (in category 'initialize-release') -----
flush
"Force compression"
self deflateBlock.!
----- Method: DeflateStream>>flushBlock (in category 'deflating') -----
flushBlock
"Flush a deflated block"!
----- Method: DeflateStream>>goodMatchLength (in category 'accessing') -----
goodMatchLength
"Return the length that is considered to be a 'good' match.
Higher values will result in better compression but take more time."
^MaxMatch "Best compression"!
----- Method: DeflateStream>>hashChainLength (in category 'accessing') -----
hashChainLength
"Return the max. number of hash chains to traverse.
Higher values will result in better compression but take more time."
^4096 "Best compression"!
----- Method: DeflateStream>>initialize (in category 'initialize-release') -----
initialize
blockStart := nil.
blockPosition := 0.
hashValue := 0.
self initializeHashTables.!
----- Method: DeflateStream>>initializeHashTables (in category 'initialize-release') -----
initializeHashTables
hashHead := WordArray new: 1 << HashBits.
hashTail := WordArray new: WindowSize.
!
----- Method: DeflateStream>>insertStringAt: (in category 'deflating') -----
insertStringAt: here
"Insert the string at the given start position into the hash table.
Note: The hash value is updated starting at MinMatch-1 since
all strings before have already been inserted into the hash table
(and the hash value is updated as well)."
| prevEntry |
hashValue := self updateHashAt: (here + MinMatch).
prevEntry := hashHead at: hashValue+1.
hashHead at: hashValue+1 put: here.
hashTail at: (here bitAnd: WindowMask)+1 put: prevEntry.!
----- Method: DeflateStream>>moveContentsToFront (in category 'private') -----
moveContentsToFront
"Move the contents of the receiver to the front"
| delta |
delta := (blockPosition - WindowSize).
delta <= 0 ifTrue:[^self].
"Move collection"
collection
replaceFrom: 1
to: collection size - delta
with: collection
startingAt: delta+1.
position := position - delta.
"Move hash table entries"
blockPosition := blockPosition - delta.
blockStart := blockStart - delta.
self updateHashTable: hashHead delta: delta.
self updateHashTable: hashTail delta: delta.!
----- Method: DeflateStream>>next:putAll:startingAt: (in category 'accessing') -----
next: bytes putAll: aCollection startingAt: startPos
(startPos = 1 and:[bytes = aCollection size])
ifTrue:[^self nextPutAll: aCollection].
^self nextPutAll: (aCollection copyFrom: startPos to: startPos + bytes - 1)!
----- Method: DeflateStream>>nextPutAll: (in category 'accessing') -----
nextPutAll: aCollection
| start count max |
aCollection species = collection species
ifFalse:[
aCollection do:[:ch| self nextPut: ch].
^aCollection].
start := 1.
count := aCollection size.
[count = 0] whileFalse:[
position = writeLimit ifTrue:[self deflateBlock].
max := writeLimit - position.
max > count ifTrue:[max := count].
collection replaceFrom: position+1
to: position+max
with: aCollection
startingAt: start.
start := start + max.
count := count - max.
position := position + max].
^aCollection!
----- Method: DeflateStream>>on: (in category 'initialize-release') -----
on: aCollection
self initialize.
super on: (aCollection species new: WindowSize * 2).!
----- Method: DeflateStream>>on:from:to: (in category 'initialize-release') -----
on: aCollection from: firstIndex to: lastIndex
"Not for DeflateStreams please"
^self shouldNotImplement!
----- Method: DeflateStream>>pastEndPut: (in category 'accessing') -----
pastEndPut: anObject
self deflateBlock.
^self nextPut: anObject!
----- Method: DeflateStream>>updateHash: (in category 'deflating') -----
updateHash: nextValue
"Update the running hash value based on the next input byte.
Return the new updated hash value."
^((hashValue bitShift: HashShift) bitXor: nextValue) bitAnd: HashMask.!
----- Method: DeflateStream>>updateHashAt: (in category 'deflating') -----
updateHashAt: here
"Update the hash value at position here (one based)"
^self updateHash: (collection byteAt: here)!
----- Method: DeflateStream>>updateHashTable:delta: (in category 'private') -----
updateHashTable: table delta: delta
| pos |
<primitive: 'primitiveDeflateUpdateHashTable' module: 'ZipPlugin'>
1 to: table size do:[:i|
"Discard entries that are out of range"
(pos := table at: i) >= delta
ifTrue:[table at: i put: pos - delta]
ifFalse:[table at: i put: 0]].!
----- Method: DeflateStream>>validateMatchAt:from:to: (in category 'deflating') -----
validateMatchAt: pos from: startPos to: endPos
| here |
here := pos.
startPos+1 to: endPos+1 do:[:i|
(collection at: i) = (collection at: (here := here + 1))
ifFalse:[^self error:'Not a match']].
^true!
DeflateStream subclass: #ZipWriteStream
instanceVariableNames: 'literals distances literalFreq distanceFreq litCount matchCount encoder crc crcPosition bytesWritten'
classVariableNames: 'CrcTable VerboseLevel'
poolDictionaries: 'ZipConstants'
category: 'Compression-Streams'!
ZipWriteStream subclass: #GZipWriteStream
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: 'GZipConstants'
category: 'Compression-Streams'!
----- Method: GZipWriteStream class>>compressFile: (in category 'file list services') -----
compressFile: fileName
"Create a compressed file from the file of the given name"
(FileStream readOnlyFileNamed: fileName) compressFile!
----- Method: GZipWriteStream class>>fileReaderServicesForFile:suffix: (in category 'file list services') -----
fileReaderServicesForFile: fullName suffix: suffix
"Don't offer to compress already-compressed files
sjc 3-May 2003-added jpeg extension"
^({ 'gz' . 'sar' . 'zip' . 'gif' . 'jpg' . 'jpeg'. 'pr'. 'png'} includes: suffix)
ifTrue: [ #() ]
ifFalse: [ self services ]
!
----- Method: GZipWriteStream class>>initialize (in category 'class initialization') -----
initialize
FileList registerFileReader: self!
----- Method: GZipWriteStream class>>serviceCompressFile (in category 'file list services') -----
serviceCompressFile
^ FileModifyingSimpleServiceEntry
provider: self
label: 'compress file'
selector: #compressFile:
description: 'compress file using gzip compression, making a new file'!
----- Method: GZipWriteStream class>>services (in category 'file list services') -----
services
^ { self serviceCompressFile }!
----- Method: GZipWriteStream class>>unload (in category 'class initialization') -----
unload
FileList unregisterFileReader: self!
----- Method: GZipWriteStream>>writeFooter (in category 'initialize-release') -----
writeFooter
"Write some footer information for the crc"
super writeFooter.
0 to: 3 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)].
0 to: 3 do:[:i| encoder nextBytePut: (bytesWritten >> (i*8) bitAnd: 255)].!
----- Method: GZipWriteStream>>writeHeader (in category 'initialize-release') -----
writeHeader
"Write the GZip header"
encoder nextBits: 16 put: GZipMagic.
encoder nextBits: 8 put: GZipDeflated.
encoder nextBits: 8 put: 0. "No flags"
encoder nextBits: 32 put: 0. "no time stamp"
encoder nextBits: 8 put: 0. "No extra flags"
encoder nextBits: 8 put: 0. "No OS type"
!
ZipWriteStream subclass: #ZLibWriteStream
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Streams'!
----- Method: ZLibWriteStream class>>updateAdler32:from:to:in: (in category 'crc') -----
updateAdler32: adler from: start to: stop in: aCollection
"Update crc using the Adler32 checksum technique from RFC1950"
"
unsigned long s1 = adler & 0xffff;
unsigned long s2 = (adler >> 16) & 0xffff;
int n;
for (n = 0; n < len; n++) {
s1 = (s1 + buf[n]) % BASE;
s2 = (s2 + s1) % BASE;
}
return (s2 << 16) + s1;
"
| s1 s2 |
s1 := adler bitAnd: 16rFFFF.
s2 := (adler bitShift: -16) bitAnd: 16rFFFF.
start to: stop do: [ :n | | b |
b := aCollection byteAt: n.
s1 := (s1 + b) \\ 65521.
s2 := (s2 + s1) \\ 65521. ].
^(s2 bitShift: 16) + s1!
----- Method: ZLibWriteStream>>on: (in category 'initialize-release') -----
on: aCollectionOrStream
super on: aCollectionOrStream.
crc := 1.!
----- Method: ZLibWriteStream>>updateCrc:from:to:in: (in category 'initialize-release') -----
updateCrc: adler from: start to: stop in: aCollection
"Update crc using the Adler32 checksum technique from RFC1950"
^self class updateAdler32: adler from: start to: stop in: aCollection!
----- Method: ZLibWriteStream>>writeFooter (in category 'initialize-release') -----
writeFooter
"Store the Adler32 checksum as the last 4 bytes."
3 to: 0 by: -1 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)].!
----- Method: ZLibWriteStream>>writeHeader (in category 'initialize-release') -----
writeHeader
"Write header information"
encoder nextBits: 8 put: 120. "deflate method with 15bit window size"
encoder nextBits: 8 put: 94. "checksum; no preset; fast (flevel=1) compression"!
----- Method: ZipWriteStream class>>baseDistance (in category 'accessing') -----
baseDistance
^BaseDistance!
----- Method: ZipWriteStream class>>baseLength (in category 'accessing') -----
baseLength
^BaseLength!
----- Method: ZipWriteStream class>>compressAndDecompress:using:stats: (in category 'regression test') -----
compressAndDecompress: aFile using: tempName stats: stats
| fileSize tempFile result |
aFile == nil ifTrue:[^nil].
fileSize := aFile size.
(fileSize < 1"00000" "or:[fileSize > 1000000]") ifTrue:[aFile close. ^nil].
Transcript cr; show:'Testing ', aFile name,' ... '.
tempFile := StandardFileStream new open: tempName forWrite: true.
'Compressing ', aFile name,'...' displayProgressAt: Sensor cursorPoint
from: 1 to: aFile size during:[:bar|
result := self regressionCompress: aFile into: tempFile notifiying: bar stats: stats].
result ifTrue:[
'Validating ', aFile name,'...' displayProgressAt: Sensor cursorPoint
from: 0 to: aFile size during:[:bar|
result := self regressionDecompress: aFile from: tempFile notifying: bar stats: stats]].
aFile close.
tempFile close.
FileDirectory default deleteFileNamed: tempName ifAbsent:[].
result ~~ false ifTrue:[
Transcript show:' ok (', (result * 100 truncateTo: 0.01) printString,')'].
^result!
----- Method: ZipWriteStream class>>crcTable (in category 'accessing') -----
crcTable
^CrcTable!
----- Method: ZipWriteStream class>>distanceCodes (in category 'accessing') -----
distanceCodes
^DistanceCodes!
----- Method: ZipWriteStream class>>extraDistanceBits (in category 'accessing') -----
extraDistanceBits
^ExtraDistanceBits!
----- Method: ZipWriteStream class>>extraLengthBits (in category 'accessing') -----
extraLengthBits
^ExtraLengthBits!
----- Method: ZipWriteStream class>>initialize (in category 'class initialization') -----
initialize
"ZipWriteStream initialize"
VerboseLevel := 0.
self initializeCrcTable.!
----- Method: ZipWriteStream class>>initializeCrcTable (in category 'class initialization') -----
initializeCrcTable
"ZipWriteStream initialize"
CrcTable := #(16r00000000 16r77073096 16rEE0E612C 16r990951BA 16r076DC419
16r706AF48F 16rE963A535 16r9E6495A3 16r0EDB8832 16r79DCB8A4
16rE0D5E91E 16r97D2D988 16r09B64C2B 16r7EB17CBD 16rE7B82D07
16r90BF1D91 16r1DB71064 16r6AB020F2 16rF3B97148 16r84BE41DE
16r1ADAD47D 16r6DDDE4EB 16rF4D4B551 16r83D385C7 16r136C9856
16r646BA8C0 16rFD62F97A 16r8A65C9EC 16r14015C4F 16r63066CD9
16rFA0F3D63 16r8D080DF5 16r3B6E20C8 16r4C69105E 16rD56041E4
16rA2677172 16r3C03E4D1 16r4B04D447 16rD20D85FD 16rA50AB56B
16r35B5A8FA 16r42B2986C 16rDBBBC9D6 16rACBCF940 16r32D86CE3
16r45DF5C75 16rDCD60DCF 16rABD13D59 16r26D930AC 16r51DE003A
16rC8D75180 16rBFD06116 16r21B4F4B5 16r56B3C423 16rCFBA9599
16rB8BDA50F 16r2802B89E 16r5F058808 16rC60CD9B2 16rB10BE924
16r2F6F7C87 16r58684C11 16rC1611DAB 16rB6662D3D 16r76DC4190
16r01DB7106 16r98D220BC 16rEFD5102A 16r71B18589 16r06B6B51F
16r9FBFE4A5 16rE8B8D433 16r7807C9A2 16r0F00F934 16r9609A88E
16rE10E9818 16r7F6A0DBB 16r086D3D2D 16r91646C97 16rE6635C01
16r6B6B51F4 16r1C6C6162 16r856530D8 16rF262004E 16r6C0695ED
16r1B01A57B 16r8208F4C1 16rF50FC457 16r65B0D9C6 16r12B7E950
16r8BBEB8EA 16rFCB9887C 16r62DD1DDF 16r15DA2D49 16r8CD37CF3
16rFBD44C65 16r4DB26158 16r3AB551CE 16rA3BC0074 16rD4BB30E2
16r4ADFA541 16r3DD895D7 16rA4D1C46D 16rD3D6F4FB 16r4369E96A
16r346ED9FC 16rAD678846 16rDA60B8D0 16r44042D73 16r33031DE5
16rAA0A4C5F 16rDD0D7CC9 16r5005713C 16r270241AA 16rBE0B1010
16rC90C2086 16r5768B525 16r206F85B3 16rB966D409 16rCE61E49F
16r5EDEF90E 16r29D9C998 16rB0D09822 16rC7D7A8B4 16r59B33D17
16r2EB40D81 16rB7BD5C3B 16rC0BA6CAD 16rEDB88320 16r9ABFB3B6
16r03B6E20C 16r74B1D29A 16rEAD54739 16r9DD277AF 16r04DB2615
16r73DC1683 16rE3630B12 16r94643B84 16r0D6D6A3E 16r7A6A5AA8
16rE40ECF0B 16r9309FF9D 16r0A00AE27 16r7D079EB1 16rF00F9344
16r8708A3D2 16r1E01F268 16r6906C2FE 16rF762575D 16r806567CB
16r196C3671 16r6E6B06E7 16rFED41B76 16r89D32BE0 16r10DA7A5A
16r67DD4ACC 16rF9B9DF6F 16r8EBEEFF9 16r17B7BE43 16r60B08ED5
16rD6D6A3E8 16rA1D1937E 16r38D8C2C4 16r4FDFF252 16rD1BB67F1
16rA6BC5767 16r3FB506DD 16r48B2364B 16rD80D2BDA 16rAF0A1B4C
16r36034AF6 16r41047A60 16rDF60EFC3 16rA867DF55 16r316E8EEF
16r4669BE79 16rCB61B38C 16rBC66831A 16r256FD2A0 16r5268E236
16rCC0C7795 16rBB0B4703 16r220216B9 16r5505262F 16rC5BA3BBE
16rB2BD0B28 16r2BB45A92 16r5CB36A04 16rC2D7FFA7 16rB5D0CF31
16r2CD99E8B 16r5BDEAE1D 16r9B64C2B0 16rEC63F226 16r756AA39C
16r026D930A 16r9C0906A9 16rEB0E363F 16r72076785 16r05005713
16r95BF4A82 16rE2B87A14 16r7BB12BAE 16r0CB61B38 16r92D28E9B
16rE5D5BE0D 16r7CDCEFB7 16r0BDBDF21 16r86D3D2D4 16rF1D4E242
16r68DDB3F8 16r1FDA836E 16r81BE16CD 16rF6B9265B 16r6FB077E1
16r18B74777 16r88085AE6 16rFF0F6A70 16r66063BCA 16r11010B5C
16r8F659EFF 16rF862AE69 16r616BFFD3 16r166CCF45 16rA00AE278
16rD70DD2EE 16r4E048354 16r3903B3C2 16rA7672661 16rD06016F7
16r4969474D 16r3E6E77DB 16rAED16A4A 16rD9D65ADC 16r40DF0B66
16r37D83BF0 16rA9BCAE53 16rDEBB9EC5 16r47B2CF7F 16r30B5FFE9
16rBDBDF21C 16rCABAC28A 16r53B39330 16r24B4A3A6 16rBAD03605
16rCDD70693 16r54DE5729 16r23D967BF 16rB3667A2E 16rC4614AB8
16r5D681B02 16r2A6F2B94 16rB40BBE37 16rC30C8EA1 16r5A05DF1B
16r2D02EF8D
).!
----- Method: ZipWriteStream class>>logProblem:for: (in category 'regression test') -----
logProblem: reason for: aFile
| errFile |
errFile := FileStream fileNamed:'problems.log'.
errFile position: errFile size.
errFile cr; nextPutAll: aFile name;
cr; nextPutAll: reason.
errFile close.
Transcript show:' failed (', reason,')'.
aFile close.
^false!
----- Method: ZipWriteStream class>>matchLengthCodes (in category 'accessing') -----
matchLengthCodes
^MatchLengthCodes!
----- Method: ZipWriteStream class>>maxDistanceCodes (in category 'accessing') -----
maxDistanceCodes
^MaxDistCodes!
----- Method: ZipWriteStream class>>maxLiteralCodes (in category 'accessing') -----
maxLiteralCodes
^MaxLiteralCodes!
----- Method: ZipWriteStream class>>printRegressionStats:from: (in category 'regression test') -----
printRegressionStats: stats from: fd
| raw compressed numFiles |
raw := stats at: #rawSize ifAbsent:[0].
raw = 0 ifTrue:[^self].
compressed := stats at: #compressedSize ifAbsent:[0].
numFiles := stats at: #numFiles ifAbsent:[0].
Transcript cr; nextPutAll: fd pathName.
Transcript crtab; nextPutAll:'Files compressed: ', numFiles asStringWithCommas.
Transcript crtab; nextPutAll:'Bytes compressed: ', raw asStringWithCommas.
Transcript crtab; nextPutAll:'Avg. compression ratio: ';
print: ((compressed / raw asFloat * 100.0) truncateTo: 0.01).
Transcript endEntry.!
----- Method: ZipWriteStream class>>regressionCompress:into:notifiying:stats: (in category 'regression test') -----
regressionCompress: aFile into: tempFile notifiying: progressBar stats: stats
"Compress aFile into tempFile"
| zip encoded buffer |
aFile binary.
aFile position: 0.
tempFile binary.
buffer := ByteArray new: 4096.
zip := self on: (ByteArray new: 10000).
encoded := zip encodedStream.
[aFile atEnd] whileFalse:[
progressBar value: aFile position.
zip nextPutAll: (aFile nextInto: buffer).
encoded position > 0 ifTrue:[
tempFile nextPutAll: encoded contents.
encoded position: 0]].
zip close.
tempFile nextPutAll: encoded contents.
^true!
----- Method: ZipWriteStream class>>regressionDecompress:from:notifying:stats: (in category 'regression test') -----
regressionDecompress: aFile from: tempFile notifying: progressBar stats: stats
"Validate aFile as decompressed from tempFile"
| unzip rawSize compressedSize buffer1 buffer2 |
rawSize := aFile size.
compressedSize := tempFile size.
aFile ascii.
aFile position: 0.
tempFile ascii.
tempFile position: 0.
buffer1 := String new: 4096.
buffer2 := buffer1 copy.
unzip := FastInflateStream on: tempFile.
[aFile atEnd] whileFalse:[
progressBar value: aFile position.
buffer1 := aFile nextInto: buffer1.
buffer2 := unzip nextInto: buffer2.
buffer1 = buffer2
ifFalse:[^self logProblem: 'contents ' for: aFile].
].
unzip next = nil ifFalse:[^self logProblem: 'EOF' for: aFile].
stats at: #rawSize put:
(stats at: #rawSize ifAbsent:[0]) + rawSize.
stats at: #compressedSize put:
(stats at: #compressedSize ifAbsent:[0]) + compressedSize.
^compressedSize asFloat / rawSize asFloat.!
----- Method: ZipWriteStream class>>regressionTest (in category 'regression test') -----
regressionTest "ZipWriteStream regressionTest"
"Compress and decompress everything we can
find to validate that compression works as expected."
self regressionTestFrom: (FileDirectory default).!
----- Method: ZipWriteStream class>>regressionTestFrom: (in category 'regression test') -----
regressionTestFrom: fd
"ZipWriteStream regressionTestFrom: FileDirectory default"
"ZipWriteStream regressionTestFrom: (FileDirectory on:'')"
"ZipWriteStream regressionTestFrom: (FileDirectory on:'C:')"
| tempName stats |
Transcript clear.
stats := Dictionary new.
tempName := FileDirectory default fullNameFor: '$$sqcompress$$'.
FileDirectory default deleteFileNamed: tempName.
self regressionTestFrom: fd using: tempName stats: stats.!
----- Method: ZipWriteStream class>>regressionTestFrom:using:stats: (in category 'regression test') -----
regressionTestFrom: fd using: tempName stats: stats
| files file fullName |
files := fd fileNames asSortedCollection.
files do:[:fName|
file := nil.
fullName := fd fullNameFor: fName.
fullName = tempName ifFalse:[
file := StandardFileStream new open: fullName forWrite: false].
self compressAndDecompress: file using: tempName stats: stats].
stats at: #numFiles put: (stats at: #numFiles ifAbsent:[0]) + files size.
files := nil.
self printRegressionStats: stats from: fd.
fd directoryNames asSortedCollection do:[:dName|
self regressionTestFrom: (fd directoryNamed: dName) using: tempName stats: stats.
].!
----- Method: ZipWriteStream class>>updateCrc:from:to:in: (in category 'crc') -----
updateCrc: oldCrc from: start to: stop in: aCollection
| newCrc |
<primitive: 'primitiveUpdateGZipCrc32' module: 'ZipPlugin'>
newCrc := oldCrc.
start to: stop do:[:i|
newCrc := (CrcTable at: ((newCrc bitXor: (aCollection byteAt: i))
bitAnd: 255) + 1) bitXor: (newCrc bitShift: -8).
].
^newCrc!
----- Method: ZipWriteStream>>close (in category 'initialize-release') -----
close
self deflateBlock.
self flushBlock: true.
encoder close.!
----- Method: ZipWriteStream>>crc (in category 'accessing') -----
crc
^crc!
----- Method: ZipWriteStream>>deflateBlock:chainLength:goodMatch: (in category 'deflating') -----
deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch
"^DeflatePlugin doPrimitive:#primitiveDeflateBlock"
<primitive: 'primitiveDeflateBlock' module: 'ZipPlugin'>
^super deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch!
----- Method: ZipWriteStream>>dynamicBlockSizeFor:and:using:and: (in category 'dynamic blocks') -----
dynamicBlockSizeFor: lTree and: dTree using: blTree and: blFreq
"Compute the length for the current block using dynamic huffman trees"
| bits index extra treeBits freq |
bits := 3 "block type" + 5 "literal codes length" + 5 "distance codes length".
"Compute the # of bits for sending the bit length tree"
treeBits := 4. "Max index for bit length tree"
index := MaxBitLengthCodes.
[index >= 4] whileTrue:[
(index = 4 or:[(blFreq at: (BitLengthOrder at: index)+1) > 0])
ifTrue:[treeBits := treeBits + (index * 3).
index := -1]
ifFalse:[index := index - 1]].
"Compute the # of bits for sending the literal/distance tree.
Note: The frequency are already stored in the blTree"
0 to: 15 do:[:i| "First, the non-repeating values"
freq := blFreq at: i+1.
freq > 0 ifTrue:[treeBits := treeBits + (freq * (blTree bitLengthAt: i))]].
"Now the repeating values"
(Repeat3To6 to: Repeat11To138) with: #(2 3 7) do:[:i :addl|
freq := blFreq at: i+1.
freq > 0 ifTrue:[
treeBits := treeBits + (freq * ((blTree bitLengthAt: i) + addl "addl bits"))]].
VerboseLevel > 1 ifTrue:[
Transcript show:'['; print: treeBits; show:' bits for dynamic tree]'].
bits := bits + treeBits.
"Compute the size of the compressed block"
0 to: NumLiterals do:[:i| "encoding of literals"
freq := literalFreq at: i+1.
freq > 0 ifTrue:[bits := bits + (freq * (lTree bitLengthAt: i))]].
NumLiterals+1 to: lTree maxCode do:[:i| "encoding of match lengths"
freq := literalFreq at: i+1.
extra := ExtraLengthBits at: i-NumLiterals.
freq > 0 ifTrue:[bits := bits + (freq * ((lTree bitLengthAt: i) + extra))]].
0 to: dTree maxCode do:[:i| "encoding of distances"
freq := distanceFreq at: i+1.
extra := ExtraDistanceBits at: i+1.
freq > 0 ifTrue:[bits := bits + (freq * ((dTree bitLengthAt: i) + extra))]].
^bits!
----- Method: ZipWriteStream>>encodeLiteral: (in category 'encoding') -----
encodeLiteral: lit
"Encode the given literal"
litCount := litCount + 1.
literals at: litCount put: lit.
distances at: litCount put: 0.
literalFreq at: lit+1 put: (literalFreq at: lit+1) + 1.
^self shouldFlush!
----- Method: ZipWriteStream>>encodeMatch:distance: (in category 'encoding') -----
encodeMatch: length distance: dist
"Encode the given match of length length starting at dist bytes ahead"
| literal distance |
dist > 0
ifFalse:[^self error:'Distance must be positive'].
length < MinMatch
ifTrue:[^self error:'Match length must be at least ', MinMatch printString].
litCount := litCount + 1.
matchCount := matchCount + 1.
literals at: litCount put: length - MinMatch.
distances at: litCount put: dist.
literal := (MatchLengthCodes at: length - MinMatch + 1).
literalFreq at: literal+1 put: (literalFreq at: literal+1) + 1.
dist < 257
ifTrue:[distance := DistanceCodes at: dist]
ifFalse:[distance := DistanceCodes at: 257 + (dist - 1 bitShift: -7)].
distanceFreq at: distance+1 put: (distanceFreq at: distance+1) + 1.
^self shouldFlush!
----- Method: ZipWriteStream>>encodedStream (in category 'accessing') -----
encodedStream
^encoder encodedStream!
----- Method: ZipWriteStream>>finish (in category 'initialize-release') -----
finish
"Finish pending operation. Do not close output stream."
self deflateBlock.
self flushBlock: true.
encoder flush.!
----- Method: ZipWriteStream>>fixedBlockSizeFor:and: (in category 'fixed blocks') -----
fixedBlockSizeFor: lTree and: dTree
"Compute the length for the current block using fixed huffman trees"
| bits extra |
bits := 3 "block type".
"Compute the size of the compressed block"
0 to: NumLiterals do:[:i| "encoding of literals"
bits := bits + ((literalFreq at: i+1) * (FixedLiteralTree bitLengthAt: i))].
NumLiterals+1 to: lTree maxCode+1 do:[:i| "Encoding of match lengths"
extra := ExtraLengthBits at: i-NumLiterals.
bits := bits + ((literalFreq at: i+1) * ((FixedLiteralTree bitLengthAt: i) + extra))].
0 to: dTree maxCode do:[:i| "encoding of distances"
extra := ExtraDistanceBits at: i+1.
bits := bits + ((distanceFreq at: i+1) * ((FixedDistanceTree bitLengthAt: i) + extra))].
^bits!
----- Method: ZipWriteStream>>flushBlock (in category 'encoding') -----
flushBlock
^self flushBlock: false!
----- Method: ZipWriteStream>>flushBlock: (in category 'encoding') -----
flushBlock: lastBlock
"Send the current block"
| lastFlag bitsRequired method bitsSent
storedLength fixedLength dynamicLength
blTree lTree dTree blBits blFreq |
lastFlag := lastBlock ifTrue:[1] ifFalse:[0].
"Compute the literal/length and distance tree"
lTree := ZipEncoderTree buildTreeFrom: literalFreq maxDepth: MaxBits.
dTree := ZipEncoderTree buildTreeFrom: distanceFreq maxDepth: MaxBits.
"Compute the bit length tree"
blBits := lTree bitLengths, dTree bitLengths.
blFreq := WordArray new: MaxBitLengthCodes.
self scanBitLengths: blBits into: blFreq.
blTree := ZipEncoderTree buildTreeFrom: blFreq maxDepth: MaxBitLengthBits.
"Compute the bit length for the current block.
Note: Most of this could be computed on the fly but it's getting
really ugly in this case so we do it afterwards."
storedLength := self storedBlockSize.
fixedLength := self fixedBlockSizeFor: lTree and: dTree.
dynamicLength := self dynamicBlockSizeFor: lTree and: dTree
using: blTree and: blFreq.
VerboseLevel > 1 ifTrue:[
Transcript cr; show:'Block sizes (S/F/D):';
space; print: storedLength // 8;
nextPut:$/; print: fixedLength // 8;
nextPut:$/; print: dynamicLength // 8; space; endEntry].
"Check which method to use"
method := self forcedMethod.
method == nil ifTrue:[
method := (storedLength < fixedLength and:[storedLength < dynamicLength])
ifTrue:[#stored]
ifFalse:[fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]].
(method == #stored and:[blockStart < 0]) ifTrue:[
"Cannot use #stored if the block is not available"
method := fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]].
bitsSent := encoder bitPosition. "# of bits sent before this block"
bitsRequired := nil.
(method == #stored) ifTrue:[
VerboseLevel > 0 ifTrue:[Transcript show:'S'].
bitsRequired := storedLength.
encoder nextBits: 3 put: StoredBlock << 1 + lastFlag.
self sendStoredBlock].
(method == #fixed) ifTrue:[
VerboseLevel > 0 ifTrue:[Transcript show:'F'].
bitsRequired := fixedLength.
encoder nextBits: 3 put: FixedBlock << 1 + lastFlag.
self sendFixedBlock].
(method == #dynamic) ifTrue:[
VerboseLevel > 0 ifTrue:[Transcript show:'D'].
bitsRequired := dynamicLength.
encoder nextBits: 3 put: DynamicBlock << 1 + lastFlag.
self sendDynamicBlock: blTree
literalTree: lTree
distanceTree: dTree
bitLengths: blBits].
bitsRequired = (encoder bitPosition - bitsSent)
ifFalse:[self error:'Bits size mismatch'].
lastBlock
ifTrue:[self release]
ifFalse:[self initializeNewBlock].!
----- Method: ZipWriteStream>>forcedMethod (in category 'accessing') -----
forcedMethod
"Return a symbol describing an enforced method or nil if the method should
be chosen adaptively. Valid symbols are
#stored - store blocks (do not compress)
#fixed - use fixed huffman trees
#dynamic - use dynamic huffman trees."
^nil!
----- Method: ZipWriteStream>>initialize (in category 'initialize-release') -----
initialize
super initialize.
literals := ByteArray new: WindowSize.
distances := WordArray new: WindowSize.
literalFreq := WordArray new: MaxLiteralCodes.
distanceFreq := WordArray new: MaxDistCodes.
self initializeNewBlock.
!
----- Method: ZipWriteStream>>initializeNewBlock (in category 'initialize-release') -----
initializeNewBlock
"Initialize the encoder for a new block of data"
literalFreq atAllPut: 0.
distanceFreq atAllPut: 0.
literalFreq at: EndBlock+1 put: 1.
litCount := 0.
matchCount := 0.!
----- Method: ZipWriteStream>>moveContentsToFront (in category 'private') -----
moveContentsToFront
"Need to update crc here"
self updateCrc.
super moveContentsToFront.
crcPosition := position + 1.!
----- Method: ZipWriteStream>>on: (in category 'initialize-release') -----
on: aCollectionOrStream
crc := 16rFFFFFFFF.
crcPosition := 1.
bytesWritten := 0.
encoder := ZipEncoder on: aCollectionOrStream.
encoder isBinary
ifTrue:[super on: ByteArray new]
ifFalse:[super on: String new].
self writeHeader.
!
----- Method: ZipWriteStream>>release (in category 'initialize-release') -----
release
"We're done with compression. Do some cleanup."
literals := distances := literalFreq := distanceFreq := nil.
self updateCrc.
encoder flushBits.
self writeFooter.!
----- Method: ZipWriteStream>>scanBitLength:repeatCount:into: (in category 'dynamic blocks') -----
scanBitLength: bitLength repeatCount: repeatCount into: anArray
"Update the frequency for the aTree based on the given values"
| count |
count := repeatCount.
bitLength = 0 ifTrue:[
[count >= 11] whileTrue:[
anArray at: Repeat11To138+1 put: (anArray at: Repeat11To138+1) + 1.
count := (count - 138) max: 0].
[count >= 3] whileTrue:[
anArray at: Repeat3To10+1 put: (anArray at: Repeat3To10+1) + 1.
count := (count - 10) max: 0].
count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count].
] ifFalse:[
anArray at: bitLength+1 put: (anArray at: bitLength+1) + 1.
count := count - 1.
[count >= 3] whileTrue:[
anArray at: Repeat3To6+1 put: (anArray at: Repeat3To6+1) + 1.
count := (count - 6) max: 0].
count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count].
].!
----- Method: ZipWriteStream>>scanBitLengths:into: (in category 'dynamic blocks') -----
scanBitLengths: bits into: anArray
"Scan the trees and determine the frequency of the bit lengths.
For repeating codes, emit a repeat count."
| lastValue lastCount value |
bits size = 0 ifTrue:[^self].
lastValue := bits at: 1.
lastCount := 1.
2 to: bits size do:[:i|
value := bits at: i.
value = lastValue
ifTrue:[lastCount := lastCount + 1]
ifFalse:[self scanBitLength: lastValue repeatCount: lastCount into: anArray.
lastValue := value.
lastCount := 1]].
self scanBitLength: lastValue repeatCount: lastCount into: anArray.!
----- Method: ZipWriteStream>>sendBitLength:repeatCount:tree: (in category 'dynamic blocks') -----
sendBitLength: bitLength repeatCount: repeatCount tree: aTree
"Send the given bitLength, repeating repeatCount times"
| count |
count := repeatCount.
bitLength = 0 ifTrue:[
[count >= 11] whileTrue:[
self sendBitLength: Repeat11To138 tree: aTree.
encoder nextBits: 7 put: (count min: 138) - 11.
count := (count - 138) max: 0].
[count >= 3] whileTrue:[
self sendBitLength: Repeat3To10 tree: aTree.
encoder nextBits: 3 put: (count min: 10) - 3.
count := (count - 10) max: 0].
count timesRepeat:[self sendBitLength: bitLength tree: aTree].
] ifFalse:[
self sendBitLength: bitLength tree: aTree.
count := count - 1.
[count >= 3] whileTrue:[
self sendBitLength: Repeat3To6 tree: aTree.
encoder nextBits: 2 put: (count min: 6) - 3.
count := (count - 6) max: 0].
count timesRepeat:[self sendBitLength: bitLength tree: aTree].
].!
----- Method: ZipWriteStream>>sendBitLength:tree: (in category 'dynamic blocks') -----
sendBitLength: bitLength tree: aTree
"Send the given bitLength"
encoder nextBits: (aTree bitLengthAt: bitLength)
put: (aTree codeAt: bitLength).!
----- Method: ZipWriteStream>>sendBitLengthTree: (in category 'dynamic blocks') -----
sendBitLengthTree: blTree
"Send the bit length tree"
| blIndex bitLength |
MaxBitLengthCodes to: 4 by: -1 do:[:maxIndex|
blIndex := BitLengthOrder at: maxIndex.
bitLength := blIndex <= blTree maxCode
ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0].
(maxIndex = 4 or:[bitLength > 0]) ifTrue:[
encoder nextBits: 4 put: maxIndex - 4.
1 to: maxIndex do:[:j|
blIndex := BitLengthOrder at: j.
bitLength := blIndex <= blTree maxCode
ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0].
encoder nextBits: 3 put: bitLength].
^self]].!
----- Method: ZipWriteStream>>sendCompressedBlock:with: (in category 'dynamic blocks') -----
sendCompressedBlock: litTree with: distTree
"Send the current block using the encodings from the given literal/length and distance tree"
| sum |
sum := encoder
sendBlock: (ReadStream on: literals from: 1 to: litCount)
with: (ReadStream on: distances from: 1 to: litCount)
with: litTree
with: distTree.
sum = (blockPosition - blockStart) ifFalse:[self error:'Wrong number of bytes'].!
----- Method: ZipWriteStream>>sendDynamicBlock:literalTree:distanceTree:bitLengths: (in category 'dynamic blocks') -----
sendDynamicBlock: blTree literalTree: lTree distanceTree: dTree bitLengths: bits
"Send a block using dynamic huffman trees"
self sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits.
self sendCompressedBlock: lTree with: dTree.!
----- Method: ZipWriteStream>>sendFixedBlock (in category 'fixed blocks') -----
sendFixedBlock
"Send a block using fixed huffman trees"
self sendCompressedBlock: FixedLiteralTree with: FixedDistanceTree.!
----- Method: ZipWriteStream>>sendLiteralTree:distanceTree:using:bitLengths: (in category 'dynamic blocks') -----
sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits
"Send all the trees needed for dynamic huffman tree encoding"
| lastValue lastCount value |
encoder nextBits: 5 put: (lTree maxCode - 256).
encoder nextBits: 5 put: (dTree maxCode).
self sendBitLengthTree: blTree.
bits size = 0 ifTrue:[^self].
lastValue := bits at: 1.
lastCount := 1.
2 to: bits size do:[:i|
value := bits at: i.
value = lastValue
ifTrue:[lastCount := lastCount + 1]
ifFalse:[self sendBitLength: lastValue repeatCount: lastCount tree: blTree.
lastValue := value.
lastCount := 1]].
self sendBitLength: lastValue repeatCount: lastCount tree: blTree.!
----- Method: ZipWriteStream>>sendStoredBlock (in category 'stored blocks') -----
sendStoredBlock
"Send an uncompressed block"
| inBytes |
inBytes := blockPosition - blockStart.
encoder flushBits. "Skip to byte boundary"
encoder nextBits: 16 put: inBytes.
encoder nextBits: 16 put: (inBytes bitXor: 16rFFFF).
encoder flushBits.
1 to: inBytes do:[:i|
encoder nextBytePut: (collection byteAt: blockStart+i)].!
----- Method: ZipWriteStream>>shouldFlush (in category 'encoding') -----
shouldFlush
"Check if we should flush the current block.
Flushing can be useful if the input characteristics change."
| nLits |
litCount = literals size ifTrue:[^true]. "We *must* flush"
(litCount bitAnd: 16rFFF) = 0 ifFalse:[^false]. "Only check every N kbytes"
matchCount * 10 <= litCount ifTrue:[
"This is basically random data.
There is no need to flush early since the overhead
for encoding the trees will add to the overall size"
^false].
"Try to adapt to the input data.
We flush if the ratio between matches and literals
changes beyound a certain threshold"
nLits := litCount - matchCount.
nLits <= matchCount ifTrue:[^false]. "whow!! so many matches"
^nLits * 4 <= matchCount!
----- Method: ZipWriteStream>>storedBlockSize (in category 'stored blocks') -----
storedBlockSize
"Compute the length for the current block when stored as is"
^3 "block type bits"
+ (8 - (encoder bitPosition + 3 bitAnd: 7) bitAnd: 7)"skipped bits to byte boundary"
+ 32 "byte length + chksum"
+ (blockPosition - blockStart * 8) "actual data bits".!
----- Method: ZipWriteStream>>updateCrc (in category 'private') -----
updateCrc
crcPosition <= position ifTrue:[
bytesWritten := bytesWritten + position - crcPosition + 1.
crc := self updateCrc: crc from: crcPosition to: position in: collection.
crcPosition := position + 1].!
----- Method: ZipWriteStream>>updateCrc:from:to:in: (in category 'private') -----
updateCrc: oldCrc from: start to: stop in: aCollection
^self class updateCrc: oldCrc from: start to: stop in: aCollection!
----- Method: ZipWriteStream>>writeFooter (in category 'initialize-release') -----
writeFooter
"Write footer information if necessary"
crc := crc bitXor: 16rFFFFFFFF.!
----- Method: ZipWriteStream>>writeHeader (in category 'initialize-release') -----
writeHeader
"Write header information if necessary"!
----- Method: ZipConstants class>>initialize (in category 'pool initialization') -----
initialize
"ZipConstants initialize"
self initializeDeflateConstants.
self initializeWriteStreamConstants.!
----- Method: ZipConstants class>>initializeDeflateConstants (in category 'pool initialization') -----
initializeDeflateConstants
WindowSize := 16r8000.
WindowMask := WindowSize - 1.
MaxDistance := WindowSize.
MinMatch := 3.
MaxMatch := 258.
HashBits := 15.
HashMask := (1 << HashBits) - 1.
HashShift := (HashBits + MinMatch - 1) // MinMatch.
!
----- Method: ZipConstants class>>initializeDistanceCodes (in category 'pool initialization') -----
initializeDistanceCodes
| dist |
BaseDistance := WordArray new: MaxDistCodes.
DistanceCodes := WordArray new: 512.
dist := 0.
1 to: 16 do:[:code|
BaseDistance at: code put: dist.
1 to: (1 bitShift: (ExtraDistanceBits at: code)) do:[:n|
dist := dist + 1.
DistanceCodes at: dist put: code-1]].
dist = 256 ifFalse:[self error:'Whoops?!!'].
dist := dist >> 7.
17 to: MaxDistCodes do:[:code|
BaseDistance at: code put: dist << 7.
1 to: (1 bitShift: (ExtraDistanceBits at: code)-7) do:[:n|
dist := dist + 1.
DistanceCodes at: 256 + dist put: code-1]].
!
----- Method: ZipConstants class>>initializeExtraBits (in category 'pool initialization') -----
initializeExtraBits
ExtraLengthBits :=
WordArray withAll: #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0).
ExtraDistanceBits :=
WordArray withAll: #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13).
ExtraBitLengthBits :=
WordArray withAll: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7).
BitLengthOrder :=
WordArray withAll: #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15).
!
----- Method: ZipConstants class>>initializeFixedTrees (in category 'pool initialization') -----
initializeFixedTrees
"ZipWriteStream initializeFixedTrees"
| counts nodes |
FixedLiteralTree := ZipEncoderTree new.
FixedLiteralTree maxCode: 287.
counts := WordArray new: MaxBits+1.
counts at: 7+1 put: 24.
counts at: 8+1 put: 144+8.
counts at: 9+1 put: 112.
nodes := Array new: 288.
1 to: 288 do:[:i| nodes at: i put: (ZipEncoderNode value: i-1 frequency: 0 height: 0)].
0 to: 143 do:[:i| (nodes at: i+1) setBitLengthTo: 8].
144 to: 255 do:[:i| (nodes at: i+1) setBitLengthTo: 9].
256 to: 279 do:[:i| (nodes at: i+1) setBitLengthTo: 7].
280 to: 287 do:[:i| (nodes at: i+1) setBitLengthTo: 8].
FixedLiteralTree buildCodes: nodes counts: counts maxDepth: MaxBits.
FixedLiteralTree setValuesFrom: nodes.
FixedDistanceTree := ZipEncoderTree new.
FixedDistanceTree maxCode: MaxDistCodes.
FixedDistanceTree
bitLengths: ((WordArray new: MaxDistCodes+1) atAllPut: 5)
codes: ((0 to: MaxDistCodes) collect:[:i| FixedDistanceTree reverseBits: i length: 5]).!
----- Method: ZipConstants class>>initializeLengthCodes (in category 'pool initialization') -----
initializeLengthCodes
| length |
BaseLength := WordArray new: MaxLengthCodes.
MatchLengthCodes := WordArray new: MaxMatch - MinMatch + 1.
length := 0.
1 to: MaxLengthCodes - 1 do:[:code|
BaseLength at: code put: length.
1 to: (1 bitShift: (ExtraLengthBits at: code)) do:[:n|
length := length + 1.
MatchLengthCodes at: length put: NumLiterals + code]].
!
----- Method: ZipConstants class>>initializeWriteStreamConstants (in category 'pool initialization') -----
initializeWriteStreamConstants
MaxBits := 15.
MaxBitLengthBits := 7.
EndBlock := 256.
StoredBlock := 0.
FixedBlock := 1.
DynamicBlock := 2.
NumLiterals := 256.
MaxLengthCodes := 29.
MaxDistCodes := 30.
MaxBitLengthCodes := 19.
MaxLiteralCodes := NumLiterals + MaxLengthCodes + 1. "+ End of Block"
Repeat3To6 := 16. "Repeat previous bit length 3-6 times (2 bits repeat count)"
Repeat3To10 := 17. "Repeat previous bit length 3-10 times (3 bits repeat count)"
Repeat11To138 := 18. "Repeat previous bit length 11-138 times (7 bits repeat count)"
self initializeExtraBits.
self initializeLengthCodes.
self initializeDistanceCodes.
self initializeFixedTrees.
!
WriteStream subclass: #ZipEncoder
instanceVariableNames: 'bitBuffer bitPosition encodedStream'
classVariableNames: ''
poolDictionaries: 'ZipConstants'
category: 'Compression-Streams'!
----- Method: ZipEncoder>>bitPosition (in category 'accessing') -----
bitPosition
^encodedStream position + position * 8 + bitPosition.!
----- Method: ZipEncoder>>close (in category 'initialize-release') -----
close
self flush.
encodedStream close.!
----- Method: ZipEncoder>>commit (in category 'initialize-release') -----
commit
encodedStream next: position putAll: collection.
position := readLimit := 0.!
----- Method: ZipEncoder>>encodedStream (in category 'accessing') -----
encodedStream
^encodedStream!
----- Method: ZipEncoder>>flush (in category 'initialize-release') -----
flush
self flushBits.
self commit.!
----- Method: ZipEncoder>>flushBits (in category 'initialize-release') -----
flushBits
"Flush currently unsent bits"
[bitPosition > 0] whileTrue:[
self nextBytePut: (bitBuffer bitAnd: 255).
bitBuffer := bitBuffer bitShift: -8.
bitPosition := bitPosition - 8].
bitPosition := 0.!
----- Method: ZipEncoder>>nextBits:put: (in category 'accessing') -----
nextBits: nBits put: value
"Store a value of nBits"
"self assert:[value >= 0 and:[(1 bitShift: nBits) > value]]."
bitBuffer := bitBuffer bitOr: (value bitShift: bitPosition).
bitPosition := bitPosition + nBits.
[bitPosition >= 8] whileTrue:[
self nextBytePut: (bitBuffer bitAnd: 255).
bitBuffer := bitBuffer bitShift: -8.
bitPosition := bitPosition - 8].!
----- Method: ZipEncoder>>nextBytePut: (in category 'accessing') -----
nextBytePut: anObject
"Primitive. Insert the argument at the next position in the Stream
represented by the receiver. Fail if the collection of this stream is not an
Array or a String. Fail if the stream is positioned at its end, or if the
position is out of bounds in the collection. Fail if the argument is not
of the right type for the collection. Optional. See Object documentation
whatIsAPrimitive."
<primitive: 66>
position >= writeLimit
ifTrue: [^ self pastEndPut: anObject]
ifFalse:
[position := position + 1.
^collection byteAt: position put: anObject]!
----- Method: ZipEncoder>>on: (in category 'initialize-release') -----
on: aCollectionOrStream
aCollectionOrStream isStream
ifTrue:[encodedStream := aCollectionOrStream]
ifFalse:[ encodedStream := WriteStream on: aCollectionOrStream].
encodedStream isBinary
ifTrue:[super on: (ByteArray new: 4096)]
ifFalse:[super on: (String new: 4096)].
bitPosition := bitBuffer := 0.!
----- Method: ZipEncoder>>pastEndPut: (in category 'private') -----
pastEndPut: anObject
"Flush the current buffer and store the new object at the beginning"
self commit.
^self nextBytePut: anObject asInteger!
----- Method: ZipEncoder>>privateSendBlock:with:with:with: (in category 'private') -----
privateSendBlock: literalStream with: distanceStream with: litTree with: distTree
"Send the current block using the encodings from the given literal/length and distance tree"
| lit dist code extra sum |
<primitive: 'primitiveZipSendBlock' module: 'ZipPlugin'>
sum := 0.
[lit := literalStream next.
dist := distanceStream next.
lit == nil] whileFalse:[
dist = 0 ifTrue:["lit is a literal"
sum := sum + 1.
self nextBits: (litTree bitLengthAt: lit)
put: (litTree codeAt: lit).
] ifFalse:["lit is match length"
sum := sum + lit + MinMatch.
code := (MatchLengthCodes at: lit + 1).
self nextBits: (litTree bitLengthAt: code)
put: (litTree codeAt: code).
extra := ExtraLengthBits at: code-NumLiterals.
extra = 0 ifFalse:[
lit := lit - (BaseLength at: code-NumLiterals).
self nextBits: extra put: lit.
].
dist := dist - 1.
dist < 256
ifTrue:[code := DistanceCodes at: dist + 1]
ifFalse:[code := DistanceCodes at: 257 + (dist bitShift: -7)].
"self assert:[code < MaxDistCodes]."
self nextBits: (distTree bitLengthAt: code)
put: (distTree codeAt: code).
extra := ExtraDistanceBits at: code+1.
extra = 0 ifFalse:[
dist := dist - (BaseDistance at: code+1).
self nextBits: extra put: dist.
].
].
].
^sum!
----- Method: ZipEncoder>>sendBlock:with:with:with: (in category 'block encoding') -----
sendBlock: literalStream with: distanceStream with: litTree with: distTree
"Send the current block using the encodings from the given literal/length and distance tree"
| result |
result := 0.
[literalStream atEnd] whileFalse:[
result := result + (self privateSendBlock: literalStream
with: distanceStream with: litTree with: distTree).
self commit.
].
self nextBits: (litTree bitLengthAt: EndBlock) put: (litTree codeAt: EndBlock).
^result!
DeflateStream subclass: #ZipWriteStream
instanceVariableNames: 'literals distances literalFreq distanceFreq litCount matchCount encoder crc crcPosition bytesWritten'
classVariableNames: 'CrcTable VerboseLevel'
poolDictionaries: 'ZipConstants'
category: 'Compression-Streams'!
SharedPool subclass: #ZipFileConstants
instanceVariableNames: ''
classVariableNames: 'CompressionStored FaUnix LocalFileHeaderSignature CompressionLevelNone IfaBinaryFile CompressionDeflated DeflatingCompressionNormal EndOfCentralDirectorySignature FaMsdos DefaultDirectoryPermissions DeflatingCompressionMaximum CompressionLevelDefault IfaTextFile DirectoryAttrib DefaultFilePermissions DeflatingCompressionSuperFast FileAttrib DataDescriptorLength CentralDirectoryFileHeaderSignature DeflatingCompressionFast'
poolDictionaries: ''
category: 'Compression-Archives'!
Archive subclass: #ZipArchive
instanceVariableNames: 'centralDirectorySize centralDirectoryOffsetWRTStartingDiskNumber zipFileComment writeCentralDirectoryOffset writeEOCDOffset'
classVariableNames: ''
poolDictionaries: 'ZipFileConstants'
category: 'Compression-Archives'!
!ZipArchive commentStamp: '<historical>' prior: 0!
A ZipArchive represents an archive that is read and/or written using the PKZIP file format.
ZipArchive instances know how to read and write such archives; their members are subinstances of ZipArchiveMember.!
----- Method: ZipArchive class>>compressionDeflated (in category 'constants') -----
compressionDeflated
^CompressionDeflated!
----- Method: ZipArchive class>>compressionLevelDefault (in category 'constants') -----
compressionLevelDefault
^CompressionLevelDefault!
----- Method: ZipArchive class>>compressionLevelNone (in category 'constants') -----
compressionLevelNone
^CompressionLevelNone !
----- Method: ZipArchive class>>compressionStored (in category 'constants') -----
compressionStored
^CompressionStored!
----- Method: ZipArchive class>>findEndOfCentralDirectoryFrom: (in category 'constants') -----
findEndOfCentralDirectoryFrom: stream
"Seek in the given stream to the end, then read backwards until we find the
signature of the central directory record. Leave the file positioned right
before the signature.
Answers the file position of the EOCD, or 0 if not found."
| data fileLength seekOffset pos maxOffset |
stream setToEnd.
fileLength := stream position.
"If the file length is less than 18 for the EOCD length plus 4 for the signature, we have a problem"
fileLength < 22 ifTrue: [^ self error: 'file is too short'].
seekOffset := 0.
pos := 0.
data := ByteArray new: 4100.
maxOffset := 40960 min: fileLength. "limit search range to 40K"
[
seekOffset := (seekOffset + 4096) min: fileLength.
stream position: fileLength - seekOffset.
data := stream next: (4100 min: seekOffset) into: data startingAt: 1.
pos := data lastIndexOfPKSignature: EndOfCentralDirectorySignature.
pos = 0 and: [seekOffset < maxOffset]
] whileTrue.
^ pos > 0
ifTrue: [ | newPos | stream position: (newPos := (stream position + pos - seekOffset - 1)). newPos]
ifFalse: [0]!
----- Method: ZipArchive class>>isZipArchive: (in category 'file format') -----
isZipArchive: aStreamOrFileName
"Answer whether the given filename represents a valid zip file."
| stream eocdPosition |
stream := aStreamOrFileName isStream
ifTrue: [aStreamOrFileName]
ifFalse: [StandardFileStream oldFileNamed: aStreamOrFileName].
stream ifNil: [^ false].
"nil happens sometimes somehow"
stream size < 22 ifTrue: [^ false].
stream binary.
eocdPosition := self findEndOfCentralDirectoryFrom: stream.
stream ~= aStreamOrFileName ifTrue: [stream close].
^ eocdPosition > 0!
----- Method: ZipArchive class>>validSignatures (in category 'constants') -----
validSignatures
"Return the valid signatures for a zip file"
^Array
with: LocalFileHeaderSignature
with: CentralDirectoryFileHeaderSignature
with: EndOfCentralDirectorySignature!
----- Method: ZipArchive>>addDeflateString:as: (in category 'archive operations') -----
addDeflateString: aString as: aFileName
"Add a verbatim string under the given file name"
| mbr |
mbr := self addString: aString as: aFileName.
mbr desiredCompressionMethod: CompressionDeflated.
^mbr!
----- Method: ZipArchive>>close (in category 'initialization') -----
close
self members do:[:m| m close].!
----- Method: ZipArchive>>extractAllTo: (in category 'archive operations') -----
extractAllTo: aDirectory
"Extract all elements to the given directory"
Utilities informUserDuring:[:bar|self extractAllTo: aDirectory informing: bar].!
----- Method: ZipArchive>>extractAllTo:informing: (in category 'archive operations') -----
extractAllTo: aDirectory informing: bar
"Extract all elements to the given directory"
^self extractAllTo: aDirectory informing: bar overwrite: false!
----- Method: ZipArchive>>extractAllTo:informing:overwrite: (in category 'archive operations') -----
extractAllTo: aDirectory informing: bar overwrite: allOverwrite
"Extract all elements to the given directory"
| dir overwriteAll response |
overwriteAll := allOverwrite.
self members do:[:entry|
entry isDirectory ifTrue:[
bar ifNotNil:[bar value: 'Creating ', entry fileName].
dir := (entry fileName findTokens:'/')
inject: aDirectory into:[:base :part| base directoryNamed: part].
dir assureExistence.
].
].
self members do:[:entry|
entry isDirectory ifFalse:[
bar ifNotNil:[bar value: 'Extracting ', entry fileName].
response := entry extractInDirectory: aDirectory overwrite: overwriteAll.
response == #retryWithOverwrite ifTrue:[
overwriteAll := true.
response := entry extractInDirectory: aDirectory overwrite: overwriteAll.
].
response == #abort ifTrue:[^self].
response == #failed ifTrue:[
(self confirm: 'Failed to extract ', entry fileName, '. Proceed?') ifFalse:[^self].
].
].
].
!
----- Method: ZipArchive>>hasMemberSuchThat: (in category 'accessing') -----
hasMemberSuchThat: aBlock
"Answer whether we have a member satisfying the given condition"
^self members anySatisfy: aBlock!
----- Method: ZipArchive>>initialize (in category 'initialization') -----
initialize
super initialize.
writeEOCDOffset := writeCentralDirectoryOffset := 0.
zipFileComment := ''.
!
----- Method: ZipArchive>>memberClass (in category 'private') -----
memberClass
^ZipArchiveMember!
----- Method: ZipArchive>>prependedDataSize (in category 'accessing') -----
prependedDataSize
"Answer the size of whatever data exists before my first member.
Assumes that I was read from a file or stream (i.e. the first member is a ZipFileMember)"
^members isEmpty
ifFalse: [ members first localHeaderRelativeOffset ]
ifTrue: [ centralDirectoryOffsetWRTStartingDiskNumber ]!
----- Method: ZipArchive>>readEndOfCentralDirectoryFrom: (in category 'private') -----
readEndOfCentralDirectoryFrom: aStream
"Read EOCD, starting from position before signature."
| signature zipFileCommentLength |
signature := self readSignatureFrom: aStream.
signature = EndOfCentralDirectorySignature ifFalse: [ ^self error: 'bad signature at ', aStream position printString ].
aStream nextLittleEndianNumber: 2. "# of this disk"
aStream nextLittleEndianNumber: 2. "# of disk with central dir start"
aStream nextLittleEndianNumber: 2. "# of entries in central dir on this disk"
aStream nextLittleEndianNumber: 2. "total # of entries in central dir"
centralDirectorySize := aStream nextLittleEndianNumber: 4. "size of central directory"
centralDirectoryOffsetWRTStartingDiskNumber := aStream nextLittleEndianNumber: 4. "offset of start of central directory"
zipFileCommentLength := aStream nextLittleEndianNumber: 2. "zip file comment"
zipFileComment := aStream next: zipFileCommentLength.
!
----- Method: ZipArchive>>readFrom: (in category 'reading') -----
readFrom: aStreamOrFileName
| stream name eocdPosition |
stream := aStreamOrFileName isStream
ifTrue: [name := aStreamOrFileName name. aStreamOrFileName]
ifFalse: [StandardFileStream readOnlyFileNamed: (name := aStreamOrFileName)].
stream binary.
eocdPosition := self class findEndOfCentralDirectoryFrom: stream.
eocdPosition <= 0 ifTrue: [self error: 'can''t find EOCD position'].
self readEndOfCentralDirectoryFrom: stream.
stream position: eocdPosition - centralDirectorySize.
self readMembersFrom: stream named: name!
----- Method: ZipArchive>>readMembersFrom:named: (in category 'private') -----
readMembersFrom: stream named: fileName
| newMember signature |
[
newMember := self memberClass newFromZipFile: stream named: fileName.
signature := self readSignatureFrom: stream.
signature = EndOfCentralDirectorySignature ifTrue: [ ^self ].
signature = CentralDirectoryFileHeaderSignature
ifFalse: [ self error: 'bad CD signature at ', (stream position - 4) printStringHex ].
newMember readFrom: stream.
newMember looksLikeDirectory ifTrue: [ newMember := newMember asDirectory ].
self addMember: newMember.
] repeat.!
----- Method: ZipArchive>>readSignatureFrom: (in category 'private') -----
readSignatureFrom: stream
"Returns next signature from given stream, leaves stream positioned afterwards."
| signatureData |
signatureData := ByteArray new: 4.
stream next: 4 into: signatureData.
({ CentralDirectoryFileHeaderSignature . LocalFileHeaderSignature . EndOfCentralDirectorySignature }
includes: signatureData)
ifFalse: [ ^self error: 'bad signature ', signatureData asString asHex, ' at position ', (stream position - 4) asString ].
^signatureData
!
----- Method: ZipArchive>>writeCentralDirectoryTo: (in category 'private') -----
writeCentralDirectoryTo: aStream
| offset |
offset := writeCentralDirectoryOffset.
members do: [ :member |
member writeCentralDirectoryFileHeaderTo: aStream.
offset := offset + member centralDirectoryHeaderSize.
].
writeEOCDOffset := offset.
self writeEndOfCentralDirectoryTo: aStream.
!
----- Method: ZipArchive>>writeEndOfCentralDirectoryTo: (in category 'private') -----
writeEndOfCentralDirectoryTo: aStream
aStream nextPutAll: EndOfCentralDirectorySignature.
aStream nextLittleEndianNumber: 2 put: 0. "diskNumber"
aStream nextLittleEndianNumber: 2 put: 0. "diskNumberWithStartOfCentralDirectory"
aStream nextLittleEndianNumber: 2 put: members size. "numberOfCentralDirectoriesOnThisDisk"
aStream nextLittleEndianNumber: 2 put: members size. "numberOfCentralDirectories"
aStream nextLittleEndianNumber: 4 put: writeEOCDOffset - writeCentralDirectoryOffset. "size of central dir"
aStream nextLittleEndianNumber: 4 put: writeCentralDirectoryOffset. "offset of central dir"
aStream nextLittleEndianNumber: 2 put: zipFileComment size. "zip file comment"
zipFileComment isEmpty ifFalse: [ aStream nextPutAll: zipFileComment ].
!
----- Method: ZipArchive>>writeTo: (in category 'writing') -----
writeTo: stream
stream binary.
members do: [ :member |
member writeTo: stream.
member endRead.
].
writeCentralDirectoryOffset := stream position.
self writeCentralDirectoryTo: stream.
!
----- Method: ZipArchive>>writeTo:prepending: (in category 'writing') -----
writeTo: stream prepending: aString
stream binary.
stream nextPutAll: aString.
members do: [ :member |
member writeTo: stream.
member endRead.
].
writeCentralDirectoryOffset := stream position.
self writeCentralDirectoryTo: stream.
!
----- Method: ZipArchive>>writeTo:prependingFileNamed: (in category 'writing') -----
writeTo: stream prependingFileNamed: aFileName
| prepended buffer |
stream binary.
prepended := StandardFileStream readOnlyFileNamed: aFileName.
prepended binary.
buffer := ByteArray new: (prepended size min: 32768).
[ prepended atEnd ] whileFalse: [ | bytesRead |
bytesRead := prepended readInto: buffer startingAt: 1 count: buffer size.
stream next: bytesRead putAll: buffer startingAt: 1
].
members do: [ :member |
member writeTo: stream.
member endRead.
].
writeCentralDirectoryOffset := stream position.
self writeCentralDirectoryTo: stream.
!
----- Method: ZipArchive>>writeToFileNamed:prepending: (in category 'writing') -----
writeToFileNamed: aFileName prepending: aString
| stream |
"Catch attempts to overwrite existing zip file"
(self canWriteToFileNamed: aFileName)
ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ].
stream := StandardFileStream forceNewFileNamed: aFileName.
self writeTo: stream prepending: aString.
stream close.!
----- Method: ZipArchive>>writeToFileNamed:prependingFileNamed: (in category 'writing') -----
writeToFileNamed: aFileName prependingFileNamed: anotherFileName
| stream |
"Catch attempts to overwrite existing zip file"
(self canWriteToFileNamed: aFileName)
ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ].
stream := StandardFileStream forceNewFileNamed: aFileName.
self writeTo: stream prependingFileNamed: anotherFileName.
stream close.!
----- Method: ZipArchive>>zipFileComment (in category 'accessing') -----
zipFileComment
^zipFileComment asString!
----- Method: ZipArchive>>zipFileComment: (in category 'accessing') -----
zipFileComment: aString
zipFileComment := aString!
ArchiveMember subclass: #ZipArchiveMember
instanceVariableNames: 'lastModFileDateTime fileAttributeFormat versionMadeBy versionNeededToExtract bitFlag compressionMethod desiredCompressionMethod desiredCompressionLevel internalFileAttributes externalFileAttributes cdExtraField localExtraField fileComment crc32 compressedSize uncompressedSize writeLocalHeaderRelativeOffset readDataRemaining'
classVariableNames: ''
poolDictionaries: 'ZipFileConstants'
category: 'Compression-Archives'!
!ZipArchiveMember commentStamp: '<historical>' prior: 0!
Subinstances of me are members in a ZipArchive.
They represent different data sources:
* ZipDirectoryMember -- a directory to be added to a zip file
* ZipFileMember -- a file or directory that is already in a zip file
* ZipNewFilemember -- a file that is to be added to a zip file
* ZipStringMember -- a string that is to be added to a zip file
They can write their data to another stream either copying, compressing,
or decompressing as desired.!
----- Method: ZipArchiveMember class>>newFromDirectory: (in category 'instance creation') -----
newFromDirectory: aFileName
^ZipDirectoryMember newNamed: aFileName!
----- Method: ZipArchiveMember class>>newFromFile: (in category 'instance creation') -----
newFromFile: aFileName
^ZipNewFileMember newNamed: aFileName!
----- Method: ZipArchiveMember class>>newFromString:named: (in category 'instance creation') -----
newFromString: aString named: aFileName
^ZipStringMember newFrom: aString named: aFileName!
----- Method: ZipArchiveMember class>>newFromZipFile:named: (in category 'instance creation') -----
newFromZipFile: stream named: fileName
^ZipFileMember newFrom: stream named: fileName!
----- Method: ZipArchiveMember>>asDirectory (in category 'private') -----
asDirectory
^ZipDirectoryMember new copyFrom: self!
----- Method: ZipArchiveMember>>centralDirectoryHeaderSize (in category 'accessing') -----
centralDirectoryHeaderSize
| systemFileName systemFileComment systemCdExtraField |
systemFileName := fileName asVmPathName.
systemFileComment := fileComment convertToSystemString.
systemCdExtraField := cdExtraField.
^ 46 + systemFileName size + systemCdExtraField size + systemFileComment size
!
----- Method: ZipArchiveMember>>clearExtraFields (in category 'accessing') -----
clearExtraFields
cdExtraField := ''.
localExtraField := ''.!
----- Method: ZipArchiveMember>>compressDataTo: (in category 'private-writing') -----
compressDataTo: aStream
"Copy my deflated data to the given stream."
| encoder startPos endPos |
encoder := ZipWriteStream on: aStream.
startPos := aStream position.
[ readDataRemaining > 0 ] whileTrue: [ | data |
data := self readRawChunk: (4096 min: readDataRemaining).
encoder nextPutAll: data asByteArray.
readDataRemaining := readDataRemaining - data size.
].
encoder finish. "not close!!"
endPos := aStream position.
compressedSize := endPos - startPos.
crc32 := encoder crc.
!
----- Method: ZipArchiveMember>>compressedSize (in category 'accessing') -----
compressedSize
"Return the compressed size for this member.
This will not be set for members that were constructed from strings
or external files until after the member has been written."
^compressedSize!
----- Method: ZipArchiveMember>>compressionMethod (in category 'accessing') -----
compressionMethod
"Returns my compression method. This is the method that is
currently being used to compress my data.
This will be CompressionStored for added string or file members,
or CompressionStored or CompressionDeflated (others are possible but not handled)"
^compressionMethod!
----- Method: ZipArchiveMember>>contentStream (in category 'accessing') -----
contentStream
"Answer my contents as a text stream.
Default is no conversion, since we don't know what the bytes mean."
| s |
s := MultiByteBinaryOrTextStream on: (String new: self uncompressedSize).
s converter: Latin1TextConverter new.
self extractTo: s.
s reset.
^ s.
!
----- Method: ZipArchiveMember>>contents (in category 'reading') -----
contents
"Answer my contents as a string."
| s |
s := RWBinaryOrTextStream on: (String new: self uncompressedSize).
self extractTo: s.
s text.
^s contents!
----- Method: ZipArchiveMember>>contentsFrom:to: (in category 'reading') -----
contentsFrom: start to: finish
"Answer my contents as a string."
| s |
s := RWBinaryOrTextStream on: (String new: finish - start + 1).
self extractTo: s from: start to: finish.
s text.
^s contents!
----- Method: ZipArchiveMember>>copyDataTo: (in category 'private-writing') -----
copyDataTo: aStream
compressionMethod = CompressionStored ifTrue: [ ^self copyDataWithCRCTo: aStream ].
self copyRawDataTo: aStream.!
----- Method: ZipArchiveMember>>copyDataWithCRCTo: (in category 'private-writing') -----
copyDataWithCRCTo: aStream
"Copy my data to aStream. Also set the CRC-32.
Only used when compressionMethod = desiredCompressionMethod = CompressionStored"
uncompressedSize := compressedSize := readDataRemaining.
crc32 := 16rFFFFFFFF.
[ readDataRemaining > 0 ] whileTrue: [ | data |
data := self readRawChunk: (4096 min: readDataRemaining).
aStream nextPutAll: data.
crc32 := ZipWriteStream updateCrc: crc32 from: 1 to: data size in: data.
readDataRemaining := readDataRemaining - data size.
].
crc32 := crc32 bitXor: 16rFFFFFFFF.
!
----- Method: ZipArchiveMember>>copyRawDataTo: (in category 'private-writing') -----
copyRawDataTo: aStream
[ readDataRemaining > 0 ] whileTrue: [ | data |
data := self readRawChunk: (4096 min: readDataRemaining).
aStream nextPutAll: data.
readDataRemaining := readDataRemaining - data size.
].
!
----- Method: ZipArchiveMember>>copyRawDataTo:from:to: (in category 'private-writing') -----
copyRawDataTo: aStream from: start to: finish
readDataRemaining := readDataRemaining min: finish - start + 1.
self readRawChunk: start - 1.
[ readDataRemaining > 0 ] whileTrue: [ | data |
data := self readRawChunk: (32768 min: readDataRemaining).
aStream nextPutAll: data.
readDataRemaining := readDataRemaining - data size.
].
!
----- Method: ZipArchiveMember>>crc32 (in category 'accessing') -----
crc32
^crc32!
----- Method: ZipArchiveMember>>crc32String (in category 'accessing') -----
crc32String
| hexString |
hexString := crc32 storeStringHex.
^('00000000' copyFrom: 1 to: 11 - (hexString size)) , (hexString copyFrom: 4 to: hexString size)!
----- Method: ZipArchiveMember>>desiredCompressionLevel (in category 'accessing') -----
desiredCompressionLevel
^desiredCompressionLevel!
----- Method: ZipArchiveMember>>desiredCompressionLevel: (in category 'accessing') -----
desiredCompressionLevel: aNumber
"Set my desiredCompressionLevel
This is the method that will be used to write.
Returns prior desiredCompressionLevel.
Valid arguments are 0 (CompressionLevelNone) through 9,
including 6 (CompressionLevelDefault).
0 (CompressionLevelNone) will change the desiredCompressionMethod
to CompressionStored. All other arguments will change the
desiredCompressionMethod to CompressionDeflated."
| old |
old := desiredCompressionLevel.
desiredCompressionLevel := aNumber.
desiredCompressionMethod := (aNumber > 0)
ifTrue: [ CompressionDeflated ]
ifFalse: [ CompressionStored ].
^old!
----- Method: ZipArchiveMember>>desiredCompressionMethod (in category 'accessing') -----
desiredCompressionMethod
"Get my desiredCompressionMethod.
This is the method that will be used to write"
^desiredCompressionMethod!
----- Method: ZipArchiveMember>>desiredCompressionMethod: (in category 'accessing') -----
desiredCompressionMethod: aNumber
"Set my desiredCompressionMethod
This is the method that will be used to write.
Answers prior desiredCompressionMethod.
Only CompressionDeflated or CompressionStored are valid arguments.
Changing to CompressionStored will change my desiredCompressionLevel
to CompressionLevelNone; changing to CompressionDeflated will change my
desiredCompressionLevel to CompressionLevelDefault."
| old |
old := desiredCompressionMethod.
desiredCompressionMethod := aNumber.
desiredCompressionLevel := (aNumber = CompressionDeflated)
ifTrue: [ CompressionLevelDefault ]
ifFalse: [ CompressionLevelNone ].
compressionMethod = CompressionStored ifTrue: [ compressedSize := uncompressedSize ].
^old.!
----- Method: ZipArchiveMember>>dosToUnixTime: (in category 'private') -----
dosToUnixTime: dt
"DOS years start at 1980, Unix at 1970, and Smalltalk at 1901.
So the Smalltalk seconds will be high by 69 years when used as Unix time:=t values.
So shift 1980 back to 1911..."
| year mon mday hour min sec date time |
year := (( dt bitShift: -25 ) bitAnd: 16r7F ) + 1911.
mon := (( dt bitShift: -21 ) bitAnd: 16r0F ).
mday := (( dt bitShift: -16 ) bitAnd: 16r1F ).
date := Date newDay: mday month: mon year: year.
hour := (( dt bitShift: -11 ) bitAnd: 16r1F ).
min := (( dt bitShift: -5 ) bitAnd: 16r3F ).
sec := (( dt bitShift: 1 ) bitAnd: 16r3E ).
time := ((( hour * 60 ) + min ) * 60 ) + sec.
^date asSeconds + time
!
----- Method: ZipArchiveMember>>endRead (in category 'private') -----
endRead
readDataRemaining := 0.!
----- Method: ZipArchiveMember>>extractInDirectory: (in category 'extraction') -----
extractInDirectory: dir
self extractToFileNamed: self localFileName inDirectory: dir
!
----- Method: ZipArchiveMember>>extractInDirectory:overwrite: (in category 'extraction') -----
extractInDirectory: aDirectory overwrite: overwriteAll
"Extract this entry into the given directory. Answer #okay, #failed, #abort, or #retryWithOverwrite."
| path fileDir file index localName |
path := fileName findTokens:'/'.
localName := path last.
fileDir := path allButLast inject: aDirectory into:[:base :part| base directoryNamed: part].
fileDir assureExistence.
file := [fileDir newFileNamed: localName] on: FileExistsException do:[:ex| ex return: nil].
file ifNil:[
overwriteAll ifFalse:[
[index := UIManager default chooseFrom: {
'Yes, overwrite'.
'No, don''t overwrite'.
'Overwrite ALL files'.
'Cancel operation'
} lines: #(2) title: fileName, ' already exists. Overwrite?'.
index == nil] whileTrue.
index = 4 ifTrue:[^#abort].
index = 3 ifTrue:[^#retryWithOverwrite].
index = 2 ifTrue:[^#okay].
].
file := [fileDir forceNewFileNamed: localName] on: Error do:[:ex| ex return].
file ifNil:[^#failed].
].
self extractTo: file.
file close.
^#okay!
----- Method: ZipArchiveMember>>extractTo: (in category 'extraction') -----
extractTo: aStream
| oldCompression |
self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ].
aStream binary.
oldCompression := self desiredCompressionMethod: CompressionStored.
self rewindData.
self writeDataTo: aStream.
self desiredCompressionMethod: oldCompression.
self endRead.!
----- Method: ZipArchiveMember>>extractTo:from:to: (in category 'extraction') -----
extractTo: aStream from: start to: finish
| oldCompression |
self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ].
aStream binary.
oldCompression := self desiredCompressionMethod: CompressionStored.
self rewindData.
self writeDataTo: aStream from: start to: finish.
self desiredCompressionMethod: oldCompression.
self endRead.!
----- Method: ZipArchiveMember>>extractToFileNamed: (in category 'extraction') -----
extractToFileNamed: aFileName
self extractToFileNamed: aFileName inDirectory: FileDirectory default.!
----- Method: ZipArchiveMember>>extractToFileNamed:inDirectory: (in category 'accessing') -----
extractToFileNamed: aLocalFileName inDirectory: dir
| stream fullName fullDir |
self isEncrypted ifTrue: [ ^self error: 'encryption unsupported' ].
fullName := dir fullNameFor: aLocalFileName.
fullDir := FileDirectory forFileName: fullName.
fullDir assureExistence.
self isDirectory ifFalse: [
stream := fullDir forceNewFileNamed: (FileDirectory localNameFor: fullName).
self extractTo: stream.
stream close.
] ifTrue: [ fullDir assureExistence ]
!
----- Method: ZipArchiveMember>>fileComment (in category 'accessing') -----
fileComment
^fileComment!
----- Method: ZipArchiveMember>>fileComment: (in category 'accessing') -----
fileComment: aString
fileComment := aString!
----- Method: ZipArchiveMember>>hasDataDescriptor (in category 'testing') -----
hasDataDescriptor
^ (bitFlag bitAnd: 8) ~= 0 "GPBF:=HAS:=DATA:=DESCRIPTOR:=MASK"!
----- Method: ZipArchiveMember>>initialize (in category 'initialization') -----
initialize
super initialize.
lastModFileDateTime := 0.
fileAttributeFormat := FaUnix.
versionMadeBy := 20.
versionNeededToExtract := 20.
bitFlag := 0.
compressionMethod := CompressionStored.
desiredCompressionMethod := CompressionDeflated.
desiredCompressionLevel := CompressionLevelDefault.
internalFileAttributes := 0.
externalFileAttributes := 0.
fileName := ''.
cdExtraField := ''.
localExtraField := ''.
fileComment := ''.
crc32 := 0.
compressedSize := 0.
uncompressedSize := 0.
self unixFileAttributes: DefaultFilePermissions.!
----- Method: ZipArchiveMember>>isDirectory (in category 'testing') -----
isDirectory
^false!
----- Method: ZipArchiveMember>>isEncrypted (in category 'testing') -----
isEncrypted
"Return true if this member is encrypted (this is unsupported)"
^ (bitFlag bitAnd: 1) ~= 0!
----- Method: ZipArchiveMember>>isTextFile (in category 'testing') -----
isTextFile
"Returns true if I am a text file.
Note that this module does not currently do anything with this flag
upon extraction or storage.
That is, bytes are stored in native format whether or not they came
from a text file."
^ (internalFileAttributes bitAnd: 1) ~= 0
!
----- Method: ZipArchiveMember>>isTextFile: (in category 'testing') -----
isTextFile: aBoolean
"Set whether I am a text file.
Note that this module does not currently do anything with this flag
upon extraction or storage.
That is, bytes are stored in native format whether or not they came
from a text file."
internalFileAttributes := aBoolean
ifTrue: [ internalFileAttributes bitOr: 1 ]
ifFalse: [ internalFileAttributes bitAnd: 1 bitInvert ]
!
----- Method: ZipArchiveMember>>lastModTime (in category 'accessing') -----
lastModTime
"Return my last modification date/time stamp,
converted to Squeak seconds"
^self unixToSqueakTime: (self dosToUnixTime: lastModFileDateTime)!
----- Method: ZipArchiveMember>>localFileName (in category 'accessing') -----
localFileName
"Answer my fileName in terms of the local directory naming convention"
| localName |
localName := fileName copyReplaceAll: '/' with: FileDirectory slash.
^(fileName first = $/)
ifTrue: [ FileDirectory default class makeAbsolute: localName ]
ifFalse: [ FileDirectory default class makeRelative: localName ]!
----- Method: ZipArchiveMember>>looksLikeDirectory (in category 'testing') -----
looksLikeDirectory
^false!
----- Method: ZipArchiveMember>>mapPermissionsFromUnix: (in category 'private') -----
mapPermissionsFromUnix: unixPerms
^ unixPerms bitShift: 16.!
----- Method: ZipArchiveMember>>mapPermissionsToUnix: (in category 'private') -----
mapPermissionsToUnix: dosPerms
^ dosPerms bitShift: -16.!
----- Method: ZipArchiveMember>>readRawChunk: (in category 'private') -----
readRawChunk: n
self subclassResponsibility!
----- Method: ZipArchiveMember>>refreshLocalFileHeaderTo: (in category 'private-writing') -----
refreshLocalFileHeaderTo: aStream
"Re-writes my local header to the given stream.
To be called after writing the data stream.
Assumes that fileName and localExtraField sizes didn't change since last written."
| here systemFileName |
here := aStream position.
systemFileName := fileName asVmPathName.
aStream position: writeLocalHeaderRelativeOffset.
aStream nextPutAll: LocalFileHeaderSignature.
aStream nextLittleEndianNumber: 2 put: versionNeededToExtract.
aStream nextLittleEndianNumber: 2 put: bitFlag.
aStream nextLittleEndianNumber: 2 put: desiredCompressionMethod.
aStream nextLittleEndianNumber: 4 put: lastModFileDateTime.
aStream nextLittleEndianNumber: 4 put: crc32.
aStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored
ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]).
aStream nextLittleEndianNumber: 4 put: uncompressedSize.
aStream nextLittleEndianNumber: 2 put: systemFileName size.
aStream nextLittleEndianNumber: 2 put: localExtraField size.
aStream position: here.
!
----- Method: ZipArchiveMember>>rewindData (in category 'private') -----
rewindData
readDataRemaining := (desiredCompressionMethod = CompressionDeflated
and: [ compressionMethod = CompressionDeflated ])
ifTrue: [ compressedSize ]
ifFalse: [ uncompressedSize ].
!
----- Method: ZipArchiveMember>>setLastModFileDateTimeFrom: (in category 'accessing') -----
setLastModFileDateTimeFrom: aSmalltalkTime
| unixTime |
unixTime := aSmalltalkTime - 2177424000. "PST?"
lastModFileDateTime := self unixToDosTime: unixTime!
----- Method: ZipArchiveMember>>splitFileName (in category 'accessing') -----
splitFileName
"Answer my name split on slash boundaries. A directory will have a trailing empty string."
^ fileName findTokens: '/'.!
----- Method: ZipArchiveMember>>uncompressedSize (in category 'accessing') -----
uncompressedSize
"Return the uncompressed size for this member."
^uncompressedSize!
----- Method: ZipArchiveMember>>unixFileAttributes (in category 'accessing') -----
unixFileAttributes
^self mapPermissionsToUnix: externalFileAttributes.!
----- Method: ZipArchiveMember>>unixFileAttributes: (in category 'accessing') -----
unixFileAttributes: perms
| oldPerms newPerms |
oldPerms := self mapPermissionsToUnix: externalFileAttributes.
newPerms := self isDirectory
ifTrue: [ (perms bitAnd: FileAttrib bitInvert) bitOr: DirectoryAttrib ]
ifFalse: [ (perms bitAnd: DirectoryAttrib bitInvert) bitOr: FileAttrib ].
externalFileAttributes := self mapPermissionsFromUnix: newPerms.
^oldPerms.!
----- Method: ZipArchiveMember>>unixToDosTime: (in category 'private') -----
unixToDosTime: unixTime
| dosTime dateTime secs |
secs := self unixToSqueakTime: unixTime. "Squeak time (PST?)"
dateTime := Time dateAndTimeFromSeconds: secs.
dosTime := (dateTime second seconds) bitShift: -1.
dosTime := dosTime + ((dateTime second minutes) bitShift: 5).
dosTime := dosTime + ((dateTime second hours) bitShift: 11).
dosTime := dosTime + ((dateTime first dayOfMonth) bitShift: 16).
dosTime := dosTime + ((dateTime first monthIndex) bitShift: 21).
dosTime := dosTime + (((dateTime first year) - 1980) bitShift: 25).
^dosTime
!
----- Method: ZipArchiveMember>>unixToSqueakTime: (in category 'private') -----
unixToSqueakTime: unixTime
^unixTime + 2177424000. "Squeak time (PST?)"!
----- Method: ZipArchiveMember>>writeCentralDirectoryFileHeaderTo: (in category 'private-writing') -----
writeCentralDirectoryFileHeaderTo: aStream
"C2 v3 V4 v5 V2"
| systemFileName systemFileComment systemCdExtraField |
systemFileName := fileName asVmPathName.
systemFileComment := fileComment convertToSystemString.
systemCdExtraField := cdExtraField.
aStream nextPutAll: CentralDirectoryFileHeaderSignature.
aStream nextLittleEndianNumber: 1 put: versionMadeBy.
aStream nextLittleEndianNumber: 1 put: fileAttributeFormat.
aStream nextLittleEndianNumber: 2 put: versionNeededToExtract.
aStream nextLittleEndianNumber: 2 put: bitFlag.
aStream nextLittleEndianNumber: 2 put: desiredCompressionMethod.
aStream nextLittleEndianNumber: 4 put: lastModFileDateTime.
"These next 3 should have been updated during the write of the data"
aStream nextLittleEndianNumber: 4 put: crc32.
aStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored
ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]).
aStream nextLittleEndianNumber: 4 put: uncompressedSize.
aStream nextLittleEndianNumber: 2 put: systemFileName size.
aStream nextLittleEndianNumber: 2 put: systemCdExtraField size.
aStream nextLittleEndianNumber: 2 put: systemFileComment size.
aStream nextLittleEndianNumber: 2 put: 0. "diskNumberStart"
aStream nextLittleEndianNumber: 2 put: internalFileAttributes.
aStream nextLittleEndianNumber: 4 put: externalFileAttributes.
aStream nextLittleEndianNumber: 4 put: writeLocalHeaderRelativeOffset.
aStream nextPutAll: systemFileName asByteArray.
aStream nextPutAll: systemCdExtraField asByteArray.
aStream nextPutAll: systemFileComment asByteArray.!
----- Method: ZipArchiveMember>>writeDataDescriptorTo: (in category 'private-writing') -----
writeDataDescriptorTo: aStream
"This writes a data descriptor to the given stream.
Assumes that crc32, writeOffset, and uncompressedSize are
set correctly (they should be after a write).
Further, the local file header should have the
GPBF:=HAS:=DATA:=DESCRIPTOR:=MASK (8) bit set."
aStream nextLittleEndianNumber: 4 put: crc32.
aStream nextLittleEndianNumber: 4 put: compressedSize.
aStream nextLittleEndianNumber: 4 put: uncompressedSize.!
----- Method: ZipArchiveMember>>writeDataTo: (in category 'private-writing') -----
writeDataTo: aStream
"Copy my (possibly inflated or deflated) data to the given stream.
This might do compression, decompression, or straight copying, depending
on the values of compressionMethod and desiredCompressionMethod"
uncompressedSize = 0 ifTrue: [ ^self ]. "nothing to do because no data"
(compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ])
ifTrue: [ ^self compressDataTo: aStream ].
(compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ])
ifTrue: [ ^self uncompressDataTo: aStream ].
self copyDataTo: aStream.!
----- Method: ZipArchiveMember>>writeDataTo:from:to: (in category 'private-writing') -----
writeDataTo: aStream from: start to: finish
"Copy my (possibly inflated or deflated) data to the given stream.
But only the specified byte range.
This might do decompression, or straight copying, depending
on the values of compressionMethod and desiredCompressionMethod"
uncompressedSize = 0 ifTrue: [ ^self ]. "nothing to do because no data"
start > finish ifTrue: [ ^self ].
start > uncompressedSize ifTrue: [ ^self ].
(compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ])
ifTrue: [ ^self error: 'only supports uncompression or copying right now' ].
(compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ])
ifTrue: [ ^self uncompressDataTo: aStream from: start to: finish ].
self copyRawDataTo: aStream from: start to: finish.!
----- Method: ZipArchiveMember>>writeLocalFileHeaderTo: (in category 'private-writing') -----
writeLocalFileHeaderTo: aStream
"Write my local header to a file handle.
Stores the offset to the start of the header in my
writeLocalHeaderRelativeOffset member."
| systemFileName |
systemFileName := fileName asVmPathName.
aStream nextPutAll: LocalFileHeaderSignature.
aStream nextLittleEndianNumber: 2 put: versionNeededToExtract.
aStream nextLittleEndianNumber: 2 put: bitFlag.
aStream nextLittleEndianNumber: 2 put: desiredCompressionMethod.
aStream nextLittleEndianNumber: 4 put: lastModFileDateTime.
aStream nextLittleEndianNumber: 4 put: crc32.
aStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored
ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]).
aStream nextLittleEndianNumber: 4 put: uncompressedSize.
aStream nextLittleEndianNumber: 2 put: systemFileName size.
aStream nextLittleEndianNumber: 2 put: localExtraField size.
aStream nextPutAll: systemFileName asByteArray.
aStream nextPutAll: localExtraField asByteArray.
!
----- Method: ZipArchiveMember>>writeTo: (in category 'writing') -----
writeTo: aStream
self rewindData.
writeLocalHeaderRelativeOffset := aStream position.
self writeLocalFileHeaderTo: aStream.
self writeDataTo: aStream.
self refreshLocalFileHeaderTo: aStream.!
ZipArchiveMember subclass: #ZipFileMember
instanceVariableNames: 'externalFileName stream localHeaderRelativeOffset dataOffset'
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Archives'!
!ZipFileMember commentStamp: '<historical>' prior: 0!
ZipNewFileMember instances are used to represent files that have been read from a ZipArchive.
Their data stays in the file on disk, so the original Zip file cannot be directly overwritten.!
ZipFileMember subclass: #ZipDirectoryMember
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Archives'!
!ZipDirectoryMember commentStamp: '<historical>' prior: 0!
ZipFileMember instances represent directories inside ZipArchives.
They don't do much other than hold names and permissions (and extra fields).
You can add files in subdirectories to a ZipArchive without using any ZipDirectoryMembers.!
----- Method: ZipDirectoryMember class>>newNamed: (in category 'as yet unclassified') -----
newNamed: aFileName
^(self new) localFileName: aFileName; yourself!
----- Method: ZipDirectoryMember>>asDirectory (in category 'private') -----
asDirectory
^self!
----- Method: ZipDirectoryMember>>desiredCompressionMethod: (in category 'accessing') -----
desiredCompressionMethod: aNumber!
----- Method: ZipDirectoryMember>>initialize (in category 'initialization') -----
initialize
super initialize.
super desiredCompressionMethod: CompressionStored.!
----- Method: ZipDirectoryMember>>isDirectory (in category 'testing') -----
isDirectory
^true!
----- Method: ZipDirectoryMember>>localFileName: (in category 'accessing') -----
localFileName: aString
| dir entry parent |
super localFileName: aString.
fileName last = $/ ifFalse: [ fileName := fileName, '/' ].
parent := FileDirectory default.
(parent directoryExists: fileName) ifTrue: [
dir := FileDirectory on: (parent fullNameFor: fileName).
entry := dir directoryEntry.
self setLastModFileDateTimeFrom: entry modificationTime
]
!
----- Method: ZipDirectoryMember>>rewindData (in category 'private') -----
rewindData!
----- Method: ZipDirectoryMember>>usesFileNamed: (in category 'testing') -----
usesFileNamed: aName
^false!
----- Method: ZipFileMember class>>newFrom:named: (in category 'as yet unclassified') -----
newFrom: stream named: fileName
^(self new) stream: stream externalFileName: fileName!
----- Method: ZipFileMember>>asDirectory (in category 'private') -----
asDirectory
^ZipDirectoryMember new copyFrom: self!
----- Method: ZipFileMember>>canonicalizeFileName (in category 'private-reading') -----
canonicalizeFileName
"For security reasons, make all paths relative and remove any ../ portions"
[fileName beginsWith: '/'] whileTrue: [fileName := fileName allButFirst].
fileName := fileName copyReplaceAll: '../' with: ''!
----- Method: ZipFileMember>>close (in category 'initialization') -----
close
stream ifNotNil:[stream close].!
----- Method: ZipFileMember>>copyDataTo: (in category 'private-writing') -----
copyDataTo: aStream
self copyRawDataTo: aStream.!
----- Method: ZipFileMember>>initialize (in category 'initialization') -----
initialize
super initialize.
crc32 := 0.
localHeaderRelativeOffset := 0.
dataOffset := 0.!
----- Method: ZipFileMember>>localHeaderRelativeOffset (in category 'private-writing') -----
localHeaderRelativeOffset
^localHeaderRelativeOffset!
----- Method: ZipFileMember>>looksLikeDirectory (in category 'testing') -----
looksLikeDirectory
^fileName last = $/
and: [ uncompressedSize = 0 ]!
----- Method: ZipFileMember>>readCentralDirectoryFileHeaderFrom: (in category 'private-reading') -----
readCentralDirectoryFileHeaderFrom: aStream
"Assumes aStream positioned after signature"
| fileNameLength extraFieldLength fileCommentLength |
versionMadeBy := aStream nextLittleEndianNumber: 1.
fileAttributeFormat := aStream nextLittleEndianNumber: 1.
versionNeededToExtract := aStream nextLittleEndianNumber: 2.
bitFlag := aStream nextLittleEndianNumber: 2.
compressionMethod := aStream nextLittleEndianNumber: 2.
lastModFileDateTime := aStream nextLittleEndianNumber: 4.
crc32 := aStream nextLittleEndianNumber: 4.
compressedSize := aStream nextLittleEndianNumber: 4.
uncompressedSize := aStream nextLittleEndianNumber: 4.
fileNameLength := aStream nextLittleEndianNumber: 2.
extraFieldLength := aStream nextLittleEndianNumber: 2.
fileCommentLength := aStream nextLittleEndianNumber: 2.
aStream nextLittleEndianNumber: 2. "disk number start"
internalFileAttributes := aStream nextLittleEndianNumber: 2.
externalFileAttributes := aStream nextLittleEndianNumber: 4.
localHeaderRelativeOffset := aStream nextLittleEndianNumber: 4.
fileName := (aStream next: fileNameLength) asString asSqueakPathName.
cdExtraField := (aStream next: extraFieldLength) asByteArray asString.
fileComment := (aStream next: fileCommentLength) asString convertFromSystemString.
self desiredCompressionMethod: compressionMethod!
----- Method: ZipFileMember>>readFrom: (in category 'private-reading') -----
readFrom: aStream
"assumes aStream positioned after CD header; leaves stream positioned after my CD entry"
self readCentralDirectoryFileHeaderFrom: aStream.
self readLocalDirectoryFileHeaderFrom: aStream.
self endRead.
self canonicalizeFileName.
!
----- Method: ZipFileMember>>readLocalDirectoryFileHeaderFrom: (in category 'private-reading') -----
readLocalDirectoryFileHeaderFrom: aStream
"Positions stream as necessary. Will return stream to its original position"
| fileNameLength extraFieldLength xcrc32 xcompressedSize xuncompressedSize sig oldPos |
oldPos := aStream position.
aStream position: localHeaderRelativeOffset.
sig := aStream next: 4.
sig = LocalFileHeaderSignature asByteArray
ifFalse: [ aStream position: oldPos.
^self error: 'bad LH signature at ', localHeaderRelativeOffset printStringHex ].
versionNeededToExtract := aStream nextLittleEndianNumber: 2.
bitFlag := aStream nextLittleEndianNumber: 2.
compressionMethod := aStream nextLittleEndianNumber: 2.
lastModFileDateTime := aStream nextLittleEndianNumber: 4.
xcrc32 := aStream nextLittleEndianNumber: 4.
xcompressedSize := aStream nextLittleEndianNumber: 4.
xuncompressedSize := aStream nextLittleEndianNumber: 4.
fileNameLength := aStream nextLittleEndianNumber: 2.
extraFieldLength := aStream nextLittleEndianNumber: 2.
fileName := (aStream next: fileNameLength) asString asSqueakPathName.
localExtraField := (aStream next: extraFieldLength) asByteArray.
dataOffset := aStream position.
"Don't trash these fields if we already got them from the central directory"
self hasDataDescriptor ifFalse: [
crc32 := xcrc32.
compressedSize := xcompressedSize.
uncompressedSize := xuncompressedSize.
].
aStream position: oldPos.!
----- Method: ZipFileMember>>readRawChunk: (in category 'private-reading') -----
readRawChunk: n
^stream next: n!
----- Method: ZipFileMember>>rewindData (in category 'private-reading') -----
rewindData
super rewindData.
(stream isNil or: [ stream closed ])
ifTrue: [ self error: 'stream missing or closed' ].
stream position: (localHeaderRelativeOffset + 4).
self skipLocalDirectoryFileHeaderFrom: stream.!
----- Method: ZipFileMember>>skipLocalDirectoryFileHeaderFrom: (in category 'private-reading') -----
skipLocalDirectoryFileHeaderFrom: aStream
"Assumes that stream is positioned after signature."
| extraFieldLength fileNameLength |
aStream next: 22.
fileNameLength := aStream nextLittleEndianNumber: 2.
extraFieldLength := aStream nextLittleEndianNumber: 2.
aStream next: fileNameLength.
aStream next: extraFieldLength.
dataOffset := aStream position.
!
----- Method: ZipFileMember>>stream:externalFileName: (in category 'initialization') -----
stream: aStream externalFileName: aFileName
stream := aStream.
externalFileName := aFileName.!
----- Method: ZipFileMember>>uncompressDataTo: (in category 'private-writing') -----
uncompressDataTo: aStream
| decoder buffer chunkSize crcErrorMessage |
decoder := ZipReadStream on: stream.
decoder expectedCrc: self crc32.
buffer := ByteArray new: (32768 min: readDataRemaining).
crcErrorMessage := nil.
[[ readDataRemaining > 0 ] whileTrue: [
chunkSize := 32768 min: readDataRemaining.
buffer := decoder next: chunkSize into: buffer startingAt: 1.
aStream next: chunkSize putAll: buffer startingAt: 1.
readDataRemaining := readDataRemaining - chunkSize.
]] on: CRCError do: [ :ex | crcErrorMessage := ex messageText. ex proceed ].
crcErrorMessage ifNotNil: [ self isCorrupt: true. CRCError signal: crcErrorMessage ]
!
----- Method: ZipFileMember>>uncompressDataTo:from:to: (in category 'private-writing') -----
uncompressDataTo: aStream from: start to: finish
| decoder buffer chunkSize |
decoder := FastInflateStream on: stream.
readDataRemaining := readDataRemaining min: finish - start + 1.
buffer := ByteArray new: (32768 min: readDataRemaining).
decoder next: start - 1.
[ readDataRemaining > 0 ] whileTrue: [
chunkSize := 32768 min: readDataRemaining.
buffer := decoder next: chunkSize into: buffer startingAt: 1.
aStream next: chunkSize putAll: buffer startingAt: 1.
readDataRemaining := readDataRemaining - chunkSize.
].
!
----- Method: ZipFileMember>>usesFileNamed: (in category 'testing') -----
usesFileNamed: aFileName
"Do I require aFileName? That is, do I care if it's clobbered?"
^(FileDirectory default fullNameFor: externalFileName) = (FileDirectory default fullNameFor: aFileName)!
ZipArchiveMember subclass: #ZipNewFileMember
instanceVariableNames: 'externalFileName stream'
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Archives'!
!ZipNewFileMember commentStamp: '<historical>' prior: 0!
ZipNewFileMember instances are used to represent files that are going to be written to a ZipArchive.
Their data comes from external file streams.!
----- Method: ZipNewFileMember class>>newNamed: (in category 'instance creation') -----
newNamed: aFileName
^(self new) from: aFileName!
----- Method: ZipNewFileMember>>close (in category 'initialization') -----
close
stream ifNotNil:[stream close].!
----- Method: ZipNewFileMember>>from: (in category 'initialization') -----
from: aFileName
| entry |
compressionMethod := CompressionStored.
"Now get the size, attributes, and timestamps, and see if the file exists"
stream := StandardFileStream readOnlyFileNamed: aFileName.
self localFileName: (externalFileName := stream name).
entry := stream directoryEntry.
compressedSize := uncompressedSize := entry fileSize.
desiredCompressionMethod := compressedSize > 0 ifTrue: [ CompressionDeflated ] ifFalse: [ CompressionStored ].
self setLastModFileDateTimeFrom: entry modificationTime
!
----- Method: ZipNewFileMember>>initialize (in category 'initialization') -----
initialize
super initialize.
externalFileName := ''.!
----- Method: ZipNewFileMember>>readRawChunk: (in category 'private') -----
readRawChunk: n
^stream next: n!
----- Method: ZipNewFileMember>>rewindData (in category 'private-writing') -----
rewindData
super rewindData.
readDataRemaining := stream size.
stream position: 0.!
----- Method: ZipNewFileMember>>usesFileNamed: (in category 'testing') -----
usesFileNamed: aFileName
"Do I require aFileName? That is, do I care if it's clobbered?"
^(FileDirectory default fullNameFor: externalFileName) = (FileDirectory default fullNameFor: aFileName)!
ZipArchiveMember subclass: #ZipStringMember
instanceVariableNames: 'contents stream'
classVariableNames: ''
poolDictionaries: ''
category: 'Compression-Archives'!
!ZipStringMember commentStamp: '<historical>' prior: 0!
ZipStringMember instances are used to represent files that are going to be written to a ZipArchive.
Their data comes from in-image strings, though.!
----- Method: ZipStringMember class>>newFrom:named: (in category 'as yet unclassified') -----
newFrom: aString named: aFileName
^(self new) contents: aString; localFileName: aFileName; yourself!
----- Method: ZipStringMember>>contents (in category 'initialization') -----
contents
^contents!
----- Method: ZipStringMember>>contents: (in category 'initialization') -----
contents: aString
contents := aString.
compressedSize := uncompressedSize := aString size.
"set the file date to now"
self setLastModFileDateTimeFrom: Time totalSeconds!
----- Method: ZipStringMember>>initialize (in category 'initialization') -----
initialize
super initialize.
self contents: ''.
compressionMethod := desiredCompressionMethod := CompressionStored.
!
----- Method: ZipStringMember>>readRawChunk: (in category 'private') -----
readRawChunk: n
^stream next: n!
----- Method: ZipStringMember>>rewindData (in category 'private-writing') -----
rewindData
super rewindData.
stream := ReadStream on: contents.
readDataRemaining := contents size.!
----- Method: ZipFileConstants class>>initialize (in category 'pool initialization') -----
initialize
"ZipFileConstants initialize"
FaMsdos := 0.
FaUnix := 3.
DeflatingCompressionNormal := 0.
DeflatingCompressionMaximum := 2.
DeflatingCompressionFast := 4.
DeflatingCompressionSuperFast := 6.
CompressionStored := 0.
CompressionDeflated := 8.
CompressionLevelNone := 0.
CompressionLevelDefault := 6.
IfaTextFile := 1.
IfaBinaryFile := 0.
DataDescriptorLength := 12.
"Unix permission bits"
DefaultDirectoryPermissions := 8r040755.
DefaultFilePermissions := 8r0100666.
DirectoryAttrib := 8r040000.
FileAttrib := 8r0100000.
CentralDirectoryFileHeaderSignature :=
(ByteArray with: 16r50 with: 16r4B with: 16r01 with: 16r02).
LocalFileHeaderSignature :=
(ByteArray with: 16r50 with: 16r4B with: 16r03 with: 16r04).
EndOfCentralDirectorySignature :=
(ByteArray with: 16r50 with: 16r4B with: 16r05 with: 16r06).!
More information about the Packages
mailing list