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 // grouping files with packing:
17 // zip, pk3: PKZIP-compatible archives (store, deflate)
18 // dfwad : D2D:F wad archives
20 {.$DEFINE SFS_DEBUG_ZIPFS}
21 {$INCLUDE ../shared/a_modes.inc}
29 SysUtils
, Classes
, Contnrs
, sfs
;
33 TSFSZipVolumeType
= (sfszvNone
, sfszvZIP
, sfszvDFWAD
);
35 TSFSZipVolume
= class(TSFSVolume
)
37 fType
: TSFSZipVolumeType
;
39 procedure ZIPReadDirectory ();
40 procedure DFWADReadDirectory ();
42 procedure ReadDirectory (); override;
45 function OpenFileByIndex (const index
: Integer): TStream
; override;
48 TSFSZipVolumeFactory
= class(TSFSVolumeFactory
)
50 function IsMyVolumePrefix (const prefix
: AnsiString
): Boolean; override;
51 function Produce (const prefix
, fileName
: AnsiString
; st
: TStream
): TSFSVolume
; override;
52 procedure Recycle (vol
: TSFSVolume
); override;
63 TSFSZipFileInfo
= class(TSFSFileInfo
)
65 fMethod
: Byte; // 0: store; 8: deflate; 255: other
66 fPackSz
: Int64; // can be -1
69 TZLocalFileHeader
= packed record
82 procedure readLFH (st
: TStream
; var hdr
: TZLocalFileHeader
);
83 {.$IFDEF ENDIAN_LITTLE}
85 hdr
.version
:= readByte(st
);
86 hdr
.hostOS
:= readByte(st
);
87 hdr
.flags
:= readWord(st
);
88 hdr
.method
:= readWord(st
);
89 hdr
.time
:= readLongWord(st
);
90 hdr
.crc
:= readLongWord(st
);
91 hdr
.packSz
:= readLongWord(st
);
92 hdr
.unpackSz
:= readLongWord(st
);
93 hdr
.fnameSz
:= readWord(st
);
94 hdr
.localExtraSz
:= readWord(st
);
98 function ZIPCheckMagic (st
: TStream
): Boolean;
100 sign
: packed array [0..3] of Char;
103 st
.ReadBuffer(sign
[0], 4);
104 st
.Seek(-4, soCurrent
);
105 if (sign
<> 'PK'#3#4) and (sign
<> 'PK'#5#6) then exit
;
110 function DFWADCheckMagic (st
: TStream
): Boolean;
112 sign
: packed array [0..5] of Char;
115 if st
.Size
< 10 then exit
;
116 st
.ReadBuffer(sign
[0], 6);
117 {fcnt :=} readWord(st
);
118 st
.Seek(-8, soCurrent
);
119 if (sign
[0] <> 'D') and (sign
[1] <> 'F') and (sign
[2] <> 'W') and
120 (sign
[3] <> 'A') and (sign
[4] <> 'D') and (sign
[5] <> #
$01) then exit
;
126 procedure TSFSZipVolume
.ZIPReadDirectory ();
129 fname
: AnsiString
= '';
130 sign
: packed array [0..3] of Char;
131 lhdr
: TZLocalFileHeader
;
138 cdofs
, hdrofs
: Int64;
140 fileOffsets
: array of Int64 = nil;
141 nameLen
, extraLen
, commentLen
: Word;
142 fileIdx
: Integer = -1;
144 // search for central dir pointer
145 if fFileStream
.size
> 65636 then bufsz
:= 65636 else bufsz
:= fFileStream
.size
;
146 fFileStream
.position
:= fFileStream
.size
-bufsz
;
151 fFileStream
.readBuffer(buf
^, bufsz
);
152 for f
:= bufsz
-16 downto 4 do
154 if (buf
[f
-4] = ord('P')) and (buf
[f
-3] = ord('K')) and (buf
[f
-2] = 5) and (buf
[f
-1] = 6) then
156 cdsize
:= LongWord(buf
[f
+8])+(LongWord(buf
[f
+9])<<8)+(LongWord(buf
[f
+10])<<16)+(LongWord(buf
[f
+11])<<24);
157 cdofs
:= Int64(buf
[f
+12])+(Int64(buf
[f
+13])<<8)+(Int64(buf
[f
+14])<<16)+(Int64(buf
[f
+15])<<24);
165 if (cdofs
>= 0) and (cdsize
> 0) then
167 // wow, we got central directory! process it
168 fFileStream
.position
:= cdofs
;
172 fFileStream
.readBuffer(sign
, 4);
173 if sign
= 'PK'#1#2 then
175 if cdsize
< 42 then break
;
177 // skip uninteresting fields
178 fFileStream
.seek(2+2+2+2+2+2+4+4+4, soCurrent
);
179 nameLen
:= readWord(fFileStream
);
180 extraLen
:= readWord(fFileStream
);
181 commentLen
:= readWord(fFileStream
);
182 // skip uninteresting fields
183 fFileStream
.seek(2+2+4, soCurrent
);
184 hdrofs
:= readLongWord(fFileStream
);
185 // now skip name, extra and comment
186 if cdsize
< nameLen
+extraLen
+commentLen
then break
;
187 Dec(cdsize
, nameLen
+extraLen
+commentLen
);
188 fFileStream
.seek(nameLen
+extraLen
+commentLen
, soCurrent
);
189 SetLength(fileOffsets
, length(fileOffsets
)+1);
190 fileOffsets
[high(fileOffsets
)] := hdrofs
;
191 //writeln('file #', high(fileOffsets), ' found at ', hdrofs);
193 else if sign
= 'PK'#7#8 then
195 if cdsize
< 3*4 then break
;
197 fFileStream
.seek(3*4, soCurrent
);
204 if length(fileOffsets
) = 0 then exit
; // no files at all
209 fFileStream
.position
:= 0;
212 // read local directory
216 if fileIdx
> High(fileOffsets
) then break
;
217 //writeln('reading file #', fileIdx, ' at ', fileOffsets[fileIdx]);
218 fFileStream
.position
:= fileOffsets
[fileIdx
];
224 fFileStream
.ReadBuffer(sign
[0], Length(sign
));
225 // skip data descriptor
226 if sign
= 'PK'#7#8 then
228 fFileStream
.seek(3*4, soCurrent
);
233 if sign
<> 'PK'#3#4 then break
;
237 readLFH(fFileStream
, lhdr
);
239 fi
:= TSFSZipFileInfo
.Create(self
);
243 SetLength(fname
, lhdr
.fnameSz
);
244 if lhdr
.fnameSz
> 0 then
246 fFileStream
.ReadBuffer(fname
[1], length(fname
));
247 fi
.fName
:= utf8to1251(fname
);
250 // here we should process extra field: it may contain utf8 filename
251 while lhdr
.localExtraSz
>= 4 do
253 efid
:= readWord(fFileStream
);
254 efsz
:= readWord(fFileStream
);
255 Dec(lhdr
.localExtraSz
, 4);
256 if efsz
> lhdr
.localExtraSz
then break
;
257 // Info-ZIP Unicode Path Extra Field?
258 if (efid
= $7075) and (efsz
> 5) then
260 fFileStream
.ReadBuffer(izver
, 1);
262 Dec(lhdr
.localExtraSz
, 1);
265 //writeln('!!!!!!!!!!!!');
266 Dec(lhdr
.localExtraSz
, efsz
);
267 fFileStream
.ReadBuffer(izcrc
, 4); // name crc, ignore it for now
269 SetLength(fname
, efsz
);
270 if length(fname
) > 0 then fFileStream
.readBuffer(fname
[1], length(fname
));
271 fi
.fName
:= utf8to1251(fname
);
272 //writeln('++++++ [', fi.fName, ']');
279 fFileStream
.Seek(efsz
, soCurrent
);
280 Dec(lhdr
.localExtraSz
, efsz
);
284 if lhdr
.localExtraSz
> 0 then fFileStream
.Seek(lhdr
.localExtraSz
, soCurrent
);
286 if (lhdr
.flags
and 1) <> 0 then
288 // encrypted file: skip it
292 if (lhdr
.method
<> 0) and (lhdr
.method
<> 8) then
294 // not stored. not deflated. skip.
298 if (length(fi
.fName
) = 0) or (fname
[length(fi
.fName
)] = '/') or (fname
[length(fi
.fName
)] = '\') then
304 for f
:= 1 to length(fi
.fName
) do if fi
.fName
[f
] = '\' then fi
.fName
[f
] := '/';
307 fi
.fOfs
:= fFileStream
.Position
;
308 fi
.fSize
:= lhdr
.unpackSz
;
309 fi
.fPackSz
:= lhdr
.packSz
;
310 fi
.fMethod
:= lhdr
.method
;
311 if fi
.fMethod
= 0 then fi
.fPackSz
:= fi
.fSize
;
314 if fileIdx
< 0 then fFileStream
.Seek(lhdr
.packSz
, soCurrent
);
315 if ignoreFile
then fi
.Free();
318 if (sign <> 'PK'#1#2) and (sign <> 'PK'#5#6) then
320 {$IFDEF SFS_DEBUG_ZIPFS}
321 WriteLn(ErrOutput, 'end: $', IntToHex(fFileStream.Position, 8));
322 WriteLn(ErrOutput, 'sign: $', sign[0], sign[1], '#', ord(sign[2]), '#', ord(sign[3]));
324 raise ESFSError.Create('invalid .ZIP archive (no central dir)');
330 procedure TSFSZipVolume
.DFWADReadDirectory ();
336 fofs
, fpksize
: LongWord
;
337 curpath
, fname
: string;
338 name
: packed array [0..15] of Char;
341 fFileStream
.Seek(6, soCurrent
); // skip signature
342 fcnt
:= readWord(fFileStream
);
343 if fcnt
= 0 then exit
;
345 for f
:= 0 to fcnt
-1 do
347 fFileStream
.ReadBuffer(name
[0], 16);
348 fofs
:= readLongWord(fFileStream
);
349 fpksize
:= readLongWord(fFileStream
);
352 while (c
< 16) and (name
[c
] <> #0) do
354 if name
[c
] = '\' then name
[c
] := '/'
355 else if name
[c
] = '/' then name
[c
] := '_';
356 fname
:= fname
+name
[c
];
360 if (fofs
= 0) and (fpksize
= 0) then
362 if length(fname
) <> 0 then fname
:= fname
+'/';
366 if length(fname
) = 0 then continue
; // just in case
367 //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
368 // create file record
369 fi
:= TSFSZipFileInfo
.Create(self
);
372 fi
.fPackSz
:= fpksize
;
379 procedure TSFSZipVolume
.ReadDirectory ();
382 sfszvZIP
: ZIPReadDirectory();
383 sfszvDFWAD
: DFWADReadDirectory();
384 else raise ESFSError
.Create('invalid archive');
388 function TSFSZipVolume
.OpenFileByIndex (const index
: Integer): TStream
;
394 if fFiles
= nil then exit
;
395 if (index
< 0) or (index
>= fFiles
.Count
) or (fFiles
[index
] = nil) then exit
;
397 if TSFSZipFileInfo(fFiles
[index
]).fMethod
= 0 then
399 result
:= TSFSPartialStream
.Create(fFileStream
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fSize
, false);
403 rs
:= TSFSPartialStream
.Create(fFileStream
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fPackSz
, false);
404 result
:= TUnZStream
.Create(rs
, TSFSZipFileInfo(fFiles
[index
]).fSize
, true, (TSFSZipFileInfo(fFiles
[index
]).fMethod
<> 255));
414 { TSFSZipVolumeFactory }
415 function TSFSZipVolumeFactory
.IsMyVolumePrefix (const prefix
: AnsiString
): Boolean;
418 StrEquCI1251(prefix
, 'zip') or
419 StrEquCI1251(prefix
, 'pk3') or
420 StrEquCI1251(prefix
, 'dfwad') or
421 StrEquCI1251(prefix
, 'dfzip');
424 procedure TSFSZipVolumeFactory
.Recycle (vol
: TSFSVolume
);
429 function TSFSZipVolumeFactory
.Produce (const prefix
, fileName
: AnsiString
; st
: TStream
): TSFSVolume
;
431 vt
: TSFSZipVolumeType
;
434 if ZIPCheckMagic(st
) then vt
:= sfszvZIP
435 else if DFWADCheckMagic(st
) then vt
:= sfszvDFWAD
;
437 if vt
<> sfszvNone
then
439 result
:= TSFSZipVolume
.Create(fileName
, st
);
440 TSFSZipVolume(result
).fType
:= vt
;
442 result
.DoDirectoryRead();
443 except {$IFDEF SFS_DEBUG_ZIPFS} on e
: Exception
do begin
444 WriteLn(errOutput
, 'ZIP ERROR: [', e
.ClassName
, ']: ', e
.Message);
448 {$IFDEF SFS_DEBUG_ZIPFS}end;{$ENDIF}
459 zipf
: TSFSZipVolumeFactory
;
461 zipf
:= TSFSZipVolumeFactory
.Create();
462 SFSRegisterVolumeFactory(zipf
);
464 // SFSUnregisterVolumeFactory(zipf);