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, either version 3 of the License, or
6 * (at your option) any later version.
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
16 {$INCLUDE ../shared/a_modes.inc}
19 (** Based on WadCvt tool **)
23 uses SysUtils
, Classes
;
29 pkofs
: Int64; // offset of file header
35 constructor Create ();
38 function ZipOne (ds
: TStream
; fname
: AnsiString; st
: TStream
; dopack
: Boolean=true): TFileInfo
;
39 procedure writeCentralDir (ds
: TStream
; files
: array of TFileInfo
);
43 uses utils
, xstreams
, crc
, paszlib
, e_log
;
46 uni2wint
: array [128..255] of Word = (
47 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
48 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
49 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
50 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
51 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
52 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
53 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
54 $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
57 constructor TFileInfo
.Create
;
63 crc
:= crc32(0, nil, 0);
67 function toUtf8 (const s
: AnsiString): AnsiString;
73 GetMem(uc
, length(s
)*8);
74 GetMem(xdc
, length(s
)*8);
76 FillChar(uc
^, length(s
)*8, 0);
77 FillChar(xdc
^, length(s
)*8, 0);
79 for f
:= 1 to length(s
) do
81 if ord(s
[f
]) < 128 then
82 uc
[pos
] := UnicodeChar(ord(s
[f
]))
84 uc
[pos
] := UnicodeChar(uni2wint
[ord(s
[f
])]);
87 FillChar(xdc
^, length(s
)*8, 0);
88 f
:= UnicodeToUtf8(xdc
, length(s
)*8, uc
, pos
);
89 while (f
> 0) and (xdc
[f
-1] = #0) do Dec(f
);
91 Move(xdc
^, result
[1], f
);
99 function zpack (ds
: TStream
; ss
: TStream
; var aborted
: Boolean): LongWord;
110 dstp
, srcsize
: Int64;
113 //aborted := true; exit;
115 crc
:= crc32(0, nil, 0);
123 zst
.avail_out
:= OBSize
;
126 err
:= deflateInit2(zst
, Z_BEST_COMPRESSION
, Z_DEFLATED
, -15, 9, 0);
127 if err
<> Z_OK
then raise Exception
.Create(zerror(err
));
131 if zst
.avail_in
= 0 then
133 // read input buffer part
134 rd
:= ss
.read(ib
^, IBSize
);
135 if rd
< 0 then raise Exception
.Create('reading error');
136 //writeln(' read ', rd, ' bytes');
138 if rd
<> 0 then begin crc
:= crc32(crc
, Pointer(ib
), rd
); result
:= crc
; end;
142 // now process the whole input
143 while zst
.avail_in
> 0 do
145 err
:= deflate(zst
, Z_NO_FLUSH
);
146 if err
<> Z_OK
then raise Exception
.Create(zerror(err
));
147 if zst
.avail_out
< OBSize
then
149 //writeln(' written ', OBSize-zst.avail_out, ' bytes');
150 if ds
.position
+(OBSize
-zst
.avail_out
)-dstp
>= srcsize
then
152 // this will be overwritten anyway
156 ds
.writeBuffer(ob
^, OBSize
-zst
.avail_out
);
158 zst
.avail_out
:= OBSize
;
166 err
:= deflate(zst
, Z_FINISH
);
167 if (err
<> Z_OK
) and (err
<> Z_STREAM_END
) then raise Exception
.Create(zerror(err
));
168 if zst
.avail_out
< OBSize
then
170 //writeln(' .written ', OBSize-zst.avail_out, ' bytes');
171 if ds
.position
+(OBSize
-zst
.avail_out
)-dstp
>= srcsize
then
173 // this will be overwritten anyway
177 ds
.writeBuffer(ob
^, OBSize
-zst
.avail_out
);
179 zst
.avail_out
:= OBSize
;
181 if err
<> Z_OK
then break
;
183 // succesfully flushed?
184 if (err
<> Z_STREAM_END
) then raise Exception
.Create(zerror(err
));
194 // this will write "extra field length" and extra field itself
199 TByteArray
= array of Byte;
201 function buildUtfExtra (fname
: AnsiString): TByteArray
;
208 if fu
= fname
then begin result
:= nil; exit
; end; // no need to write anything
209 crc
:= crc32(0, @fname
[1], length(fname
));
210 sz
:= 2+2+1+4+length(fu
);
211 SetLength(result
, sz
);
212 result
[0] := ord('u');
213 result
[1] := ord('p');
215 result
[2] := sz
and $ff;
216 result
[3] := (sz
shr 8) and $ff;
218 result
[5] := crc
and $ff;
219 result
[6] := (crc
shr 8) and $ff;
220 result
[7] := (crc
shr 16) and $ff;
221 result
[8] := (crc
shr 24) and $ff;
222 Move(fu
[1], result
[9], length(fu
));
225 const UtfFlags
= (1 shl 10); // bit 11
228 function ZipOne (ds
: TStream
; fname
: AnsiString; st
: TStream
; dopack
: Boolean=true): TFileInfo
;
230 oldofs
, nfoofs
, pkdpos
, rd
: Int64;
231 sign
: packed array [0..3] of Char;
234 aborted
: Boolean = false;
239 result
:= TFileInfo
.Create();
240 result
.pkofs
:= ds
.position
;
241 result
.size
:= st
.size
;
242 if result
.size
> 0 then result
.method
:= 8 else result
.method
:= 0;
246 result
.pksize
:= result
.size
;
249 result
.name
:= fname
;
250 ef
:= buildUtfExtra(result
.name
);
252 result
.name
:= toUtf8(fname
);
254 // write local header
256 ds
.writeBuffer(sign
, 4);
257 writeInt(ds
, Word($0A10)); // version to extract
258 writeInt(ds
, Word(UtfFlags
)); // flags
259 writeInt(ds
, Word(result
.method
)); // compression method
260 writeInt(ds
, Word(0)); // file time
261 writeInt(ds
, Word(0)); // file date
262 nfoofs
:= ds
.position
;
263 writeInt(ds
, LongWord(result
.crc
)); // crc32
264 writeInt(ds
, LongWord(result
.pksize
)); // packed size
265 writeInt(ds
, LongWord(result
.size
)); // unpacked size
266 writeInt(ds
, Word(length(fname
))); // name length
268 writeInt(ds
, Word(length(ef
))); // extra field length
270 writeInt(ds
, Word(0)); // extra field length
272 ds
.writeBuffer(fname
[1], length(fname
));
274 if length(ef
) > 0 then ds
.writeBuffer(ef
[0], length(ef
));
278 // now write packed data
279 if result
.size
> 0 then
281 pkdpos
:= ds
.position
;
283 result
.crc
:= zpack(ds
, st
, aborted
);
284 result
.pksize
:= ds
.position
-pkdpos
;
285 if {result.pksize >= result.size} aborted
then
287 // there's no sence to pack this file, so just store it
289 ds
.position
:= result
.pkofs
;
292 result
:= ZipOne(ds
, fname
, st
, false);
298 oldofs
:= ds
.position
;
299 ds
.position
:= nfoofs
;
300 writeInt(ds
, LongWord(result
.crc
)); // crc32
301 writeInt(ds
, LongWord(result
.pksize
)); // crc32
302 ds
.position
:= oldofs
;
312 result
.crc
:= crc32(0, nil, 0);
314 while result
.pksize
< result
.size
do
316 rd
:= result
.size
-result
.pksize
;
317 if rd
> bufsz
then rd
:= bufsz
;
318 st
.readBuffer(buf
^, rd
);
319 ds
.writeBuffer(buf
^, rd
);
320 Inc(result
.pksize
, rd
);
321 result
.crc
:= crc32(result
.crc
, buf
, rd
);
327 oldofs
:= ds
.position
;
328 ds
.position
:= nfoofs
;
329 writeInt(ds
, LongWord(result
.crc
)); // crc32
330 ds
.position
:= oldofs
;
336 procedure writeCentralDir (ds
: TStream
; files
: array of TFileInfo
);
339 sign
: packed array [0..3] of Char;
345 cdofs
:= ds
.position
;
346 for f
:= 0 to high(files
) do
349 ef
:= buildUtfExtra(files
[f
].name
);
352 ds
.writeBuffer(sign
, 4);
353 writeInt(ds
, Word($0A10)); // version made by
354 writeInt(ds
, Word($0010)); // version to extract
355 writeInt(ds
, Word(UtfFlags
)); // flags
356 writeInt(ds
, Word(files
[f
].method
)); // compression method
357 writeInt(ds
, Word(0)); // file time
358 writeInt(ds
, Word(0)); // file date
359 writeInt(ds
, LongWord(files
[f
].crc
));
360 writeInt(ds
, LongWord(files
[f
].pksize
));
361 writeInt(ds
, LongWord(files
[f
].size
));
362 writeInt(ds
, Word(length(files
[f
].name
))); // name length
364 writeInt(ds
, Word(length(ef
))); // extra field length
366 writeInt(ds
, Word(0)); // extra field length
368 writeInt(ds
, Word(0)); // comment length
369 writeInt(ds
, Word(0)); // disk start
370 writeInt(ds
, Word(0)); // internal attributes
371 writeInt(ds
, LongWord(0)); // external attributes
372 writeInt(ds
, LongWord(files
[f
].pkofs
)); // header offset
373 ds
.writeBuffer(files
[f
].name
[1], length(files
[f
].name
));
375 if length(ef
) > 0 then ds
.writeBuffer(ef
[0], length(ef
));
378 cdend
:= ds
.position
;
379 // write end of central dir
381 ds
.writeBuffer(sign
, 4);
382 writeInt(ds
, Word(0)); // disk number
383 writeInt(ds
, Word(0)); // disk with central dir
384 writeInt(ds
, Word(length(files
))); // number of files on this dist
385 writeInt(ds
, Word(length(files
))); // number of files total
386 writeInt(ds
, LongWord(cdend
-cdofs
)); // size of central directory
387 writeInt(ds
, LongWord(cdofs
)); // central directory offset
388 writeInt(ds
, Word(0)); // archive comment length