1 (* Copyright (C) Doom 2D: Forever Developers
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, version 3 of the License ONLY.
7 * This program is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10 * GNU General Public License for more details.
12 * You should have received a copy of the GNU General Public License
13 * along with this program. If not, see <http://www.gnu.org/licenses/>.
15 {$INCLUDE ../shared/a_modes.inc}
18 (** Based on WadCvt tool **)
22 uses SysUtils
, Classes
;
28 pkofs
: Int64; // offset of file header
34 constructor Create ();
37 function ZipOne (ds
: TStream
; fname
: AnsiString; st
: TStream
; dopack
: Boolean=true): TFileInfo
;
38 procedure writeCentralDir (ds
: TStream
; files
: array of TFileInfo
);
42 uses utils
, xstreams
, crc
, paszlib
, e_log
;
45 uni2wint
: array [128..255] of Word = (
46 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
47 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
48 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
49 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
50 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
51 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
52 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
53 $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
56 constructor TFileInfo
.Create
;
62 crc
:= crc32(0, nil, 0);
66 function toUtf8 (const s
: AnsiString): AnsiString;
72 GetMem(uc
, length(s
)*8);
73 GetMem(xdc
, length(s
)*8);
75 FillChar(uc
^, length(s
)*8, 0);
76 FillChar(xdc
^, length(s
)*8, 0);
78 for f
:= 1 to length(s
) do
80 if ord(s
[f
]) < 128 then
81 uc
[pos
] := UnicodeChar(ord(s
[f
]))
83 uc
[pos
] := UnicodeChar(uni2wint
[ord(s
[f
])]);
86 FillChar(xdc
^, length(s
)*8, 0);
87 f
:= UnicodeToUtf8(xdc
, length(s
)*8, uc
, pos
);
88 while (f
> 0) and (xdc
[f
-1] = #0) do Dec(f
);
90 Move(xdc
^, result
[1], f
);
98 function zpack (ds
: TStream
; ss
: TStream
; var aborted
: Boolean): LongWord;
109 dstp
, srcsize
: Int64;
112 //aborted := true; exit;
114 crc
:= crc32(0, nil, 0);
122 zst
.avail_out
:= OBSize
;
125 err
:= deflateInit2(zst
, Z_BEST_COMPRESSION
, Z_DEFLATED
, -15, 9, 0);
126 if err
<> Z_OK
then raise Exception
.Create(zerror(err
));
130 if zst
.avail_in
= 0 then
132 // read input buffer part
133 rd
:= ss
.read(ib
^, IBSize
);
134 if rd
< 0 then raise Exception
.Create('reading error');
135 //writeln(' read ', rd, ' bytes');
137 if rd
<> 0 then begin crc
:= crc32(crc
, Pointer(ib
), rd
); result
:= crc
; end;
141 // now process the whole input
142 while zst
.avail_in
> 0 do
144 err
:= deflate(zst
, Z_NO_FLUSH
);
145 if err
<> Z_OK
then raise Exception
.Create(zerror(err
));
146 if zst
.avail_out
< OBSize
then
148 //writeln(' written ', OBSize-zst.avail_out, ' bytes');
149 if ds
.position
+(OBSize
-zst
.avail_out
)-dstp
>= srcsize
then
151 // this will be overwritten anyway
155 ds
.writeBuffer(ob
^, OBSize
-zst
.avail_out
);
157 zst
.avail_out
:= OBSize
;
165 err
:= deflate(zst
, Z_FINISH
);
166 if (err
<> Z_OK
) and (err
<> Z_STREAM_END
) then raise Exception
.Create(zerror(err
));
167 if zst
.avail_out
< OBSize
then
169 //writeln(' .written ', OBSize-zst.avail_out, ' bytes');
170 if ds
.position
+(OBSize
-zst
.avail_out
)-dstp
>= srcsize
then
172 // this will be overwritten anyway
176 ds
.writeBuffer(ob
^, OBSize
-zst
.avail_out
);
178 zst
.avail_out
:= OBSize
;
180 if err
<> Z_OK
then break
;
182 // succesfully flushed?
183 if (err
<> Z_STREAM_END
) then raise Exception
.Create(zerror(err
));
193 // this will write "extra field length" and extra field itself
198 TByteArray
= array of Byte;
200 function buildUtfExtra (fname
: AnsiString): TByteArray
;
207 if fu
= fname
then begin result
:= nil; exit
; end; // no need to write anything
208 crc
:= crc32(0, @fname
[1], length(fname
));
209 sz
:= 2+2+1+4+length(fu
);
210 SetLength(result
, sz
);
211 result
[0] := ord('u');
212 result
[1] := ord('p');
214 result
[2] := sz
and $ff;
215 result
[3] := (sz
shr 8) and $ff;
217 result
[5] := crc
and $ff;
218 result
[6] := (crc
shr 8) and $ff;
219 result
[7] := (crc
shr 16) and $ff;
220 result
[8] := (crc
shr 24) and $ff;
221 Move(fu
[1], result
[9], length(fu
));
224 const UtfFlags
= (1 shl 10); // bit 11
227 function ZipOne (ds
: TStream
; fname
: AnsiString; st
: TStream
; dopack
: Boolean=true): TFileInfo
;
229 oldofs
, nfoofs
, pkdpos
, rd
: Int64;
230 sign
: packed array [0..3] of Char;
233 aborted
: Boolean = false;
238 result
:= TFileInfo
.Create();
239 result
.pkofs
:= ds
.position
;
240 result
.size
:= st
.size
;
241 if result
.size
> 0 then result
.method
:= 8 else result
.method
:= 0;
245 result
.pksize
:= result
.size
;
248 result
.name
:= fname
;
249 ef
:= buildUtfExtra(result
.name
);
251 result
.name
:= toUtf8(fname
);
253 // write local header
255 ds
.writeBuffer(sign
, 4);
256 writeInt(ds
, Word($0A10)); // version to extract
257 writeInt(ds
, Word(UtfFlags
)); // flags
258 writeInt(ds
, Word(result
.method
)); // compression method
259 writeInt(ds
, Word(0)); // file time
260 writeInt(ds
, Word(0)); // file date
261 nfoofs
:= ds
.position
;
262 writeInt(ds
, LongWord(result
.crc
)); // crc32
263 writeInt(ds
, LongWord(result
.pksize
)); // packed size
264 writeInt(ds
, LongWord(result
.size
)); // unpacked size
265 writeInt(ds
, Word(length(fname
))); // name length
267 writeInt(ds
, Word(length(ef
))); // extra field length
269 writeInt(ds
, Word(0)); // extra field length
271 ds
.writeBuffer(fname
[1], length(fname
));
273 if length(ef
) > 0 then ds
.writeBuffer(ef
[0], length(ef
));
277 // now write packed data
278 if result
.size
> 0 then
280 pkdpos
:= ds
.position
;
282 result
.crc
:= zpack(ds
, st
, aborted
);
283 result
.pksize
:= ds
.position
-pkdpos
;
284 if {result.pksize >= result.size} aborted
then
286 // there's no sence to pack this file, so just store it
288 ds
.position
:= result
.pkofs
;
291 result
:= ZipOne(ds
, fname
, st
, false);
297 oldofs
:= ds
.position
;
298 ds
.position
:= nfoofs
;
299 writeInt(ds
, LongWord(result
.crc
)); // crc32
300 writeInt(ds
, LongWord(result
.pksize
)); // crc32
301 ds
.position
:= oldofs
;
311 result
.crc
:= crc32(0, nil, 0);
313 while result
.pksize
< result
.size
do
315 rd
:= result
.size
-result
.pksize
;
316 if rd
> bufsz
then rd
:= bufsz
;
317 st
.readBuffer(buf
^, rd
);
318 ds
.writeBuffer(buf
^, rd
);
319 Inc(result
.pksize
, rd
);
320 result
.crc
:= crc32(result
.crc
, buf
, rd
);
326 oldofs
:= ds
.position
;
327 ds
.position
:= nfoofs
;
328 writeInt(ds
, LongWord(result
.crc
)); // crc32
329 ds
.position
:= oldofs
;
335 procedure writeCentralDir (ds
: TStream
; files
: array of TFileInfo
);
338 sign
: packed array [0..3] of Char;
344 cdofs
:= ds
.position
;
345 for f
:= 0 to high(files
) do
348 ef
:= buildUtfExtra(files
[f
].name
);
351 ds
.writeBuffer(sign
, 4);
352 writeInt(ds
, Word($0A10)); // version made by
353 writeInt(ds
, Word($0010)); // version to extract
354 writeInt(ds
, Word(UtfFlags
)); // flags
355 writeInt(ds
, Word(files
[f
].method
)); // compression method
356 writeInt(ds
, Word(0)); // file time
357 writeInt(ds
, Word(0)); // file date
358 writeInt(ds
, LongWord(files
[f
].crc
));
359 writeInt(ds
, LongWord(files
[f
].pksize
));
360 writeInt(ds
, LongWord(files
[f
].size
));
361 writeInt(ds
, Word(length(files
[f
].name
))); // name length
363 writeInt(ds
, Word(length(ef
))); // extra field length
365 writeInt(ds
, Word(0)); // extra field length
367 writeInt(ds
, Word(0)); // comment length
368 writeInt(ds
, Word(0)); // disk start
369 writeInt(ds
, Word(0)); // internal attributes
370 writeInt(ds
, LongWord(0)); // external attributes
371 writeInt(ds
, LongWord(files
[f
].pkofs
)); // header offset
372 ds
.writeBuffer(files
[f
].name
[1], length(files
[f
].name
));
374 if length(ef
) > 0 then ds
.writeBuffer(ef
[0], length(ef
));
377 cdend
:= ds
.position
;
378 // write end of central dir
380 ds
.writeBuffer(sign
, 4);
381 writeInt(ds
, Word(0)); // disk number
382 writeInt(ds
, Word(0)); // disk with central dir
383 writeInt(ds
, Word(length(files
))); // number of files on this dist
384 writeInt(ds
, Word(length(files
))); // number of files total
385 writeInt(ds
, LongWord(cdend
-cdofs
)); // size of central directory
386 writeInt(ds
, LongWord(cdofs
)); // central directory offset
387 writeInt(ds
, Word(0)); // archive comment length