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 // grouping files with packing:
16 // zip, pk3: PKZIP-compatible archives (store, deflate)
17 // dfwad : D2D:F wad archives
19 {.$DEFINE SFS_DEBUG_ZIPFS}
20 {$INCLUDE ../shared/a_modes.inc}
28 SysUtils
, Classes
, Contnrs
, sfs
;
32 TSFSZipVolumeType
= (sfszvNone
, sfszvZIP
, sfszvDFWAD
);
34 TSFSZipVolume
= class(TSFSVolume
)
36 fType
: TSFSZipVolumeType
;
38 procedure ZIPReadDirectory ();
39 procedure DFWADReadDirectory ();
41 procedure ReadDirectory (); override;
44 function OpenFileByIndex (const index
: Integer): TStream
; override;
47 TSFSZipVolumeFactory
= class (TSFSVolumeFactoryMethods
)
49 class function IsMyVolumePrefix (const prefix
: AnsiString
): Boolean; override;
50 class function Produce (const prefix
, fileName
: AnsiString
; st
: TStream
): TSFSVolume
; override;
51 class procedure Recycle (vol
: TSFSVolume
); override;
62 TSFSZipFileInfo
= class(TSFSFileInfo
)
64 fMethod
: Byte; // 0: store; 8: deflate; 255: other
65 fPackSz
: Int64; // can be -1
68 TZLocalFileHeader
= packed record
81 procedure readLFH (st
: TStream
; var hdr
: TZLocalFileHeader
);
82 {.$IFDEF ENDIAN_LITTLE}
84 hdr
.version
:= st
.ReadByte();
85 hdr
.hostOS
:= st
.ReadByte();
86 hdr
.flags
:= st
.ReadWordLE();
87 hdr
.method
:= st
.ReadWordLE();
88 hdr
.time
:= st
.ReadDWordLE();
89 hdr
.crc
:= st
.ReadDWordLE();
90 hdr
.packSz
:= st
.ReadDWordLE();
91 hdr
.unpackSz
:= st
.ReadDWordLE();
92 hdr
.fnameSz
:= st
.ReadWordLE();
93 hdr
.localExtraSz
:= st
.ReadWordLE();
97 function ZIPCheckMagic (st
: TStream
): Boolean;
99 sign
: packed array [0..3] of Char;
102 st
.ReadBuffer(sign
[0], 4);
103 st
.Seek(-4, soCurrent
);
104 if (sign
<> 'PK'#3#4) and (sign
<> 'PK'#5#6) then exit
;
109 function DFWADCheckMagic (st
: TStream
): Boolean;
111 sign
: packed array [0..5] of Char;
114 if st
.Size
< 10 then exit
;
115 st
.ReadBuffer(sign
[0], 6);
116 {fcnt :=} st
.ReadWordLE();
117 st
.Seek(-8, soCurrent
);
118 if (sign
[0] <> 'D') and (sign
[1] <> 'F') and (sign
[2] <> 'W') and
119 (sign
[3] <> 'A') and (sign
[4] <> 'D') and (sign
[5] <> #
$01) then exit
;
125 procedure TSFSZipVolume
.ZIPReadDirectory ();
128 fname
: AnsiString
= '';
129 sign
: packed array [0..3] of Char;
130 lhdr
: TZLocalFileHeader
;
137 cdofs
, hdrofs
: Int64;
139 fileOffsets
: array of Int64 = nil;
140 nameLen
, extraLen
, commentLen
: Word;
141 fileIdx
: Integer = -1;
143 // search for central dir pointer
144 if fFileStream
.size
> 65636 then bufsz
:= 65636 else bufsz
:= fFileStream
.size
;
145 fFileStream
.position
:= fFileStream
.size
-bufsz
;
150 fFileStream
.readBuffer(buf
^, bufsz
);
151 for f
:= bufsz
-16 downto 4 do
153 if (buf
[f
-4] = ord('P')) and (buf
[f
-3] = ord('K')) and (buf
[f
-2] = 5) and (buf
[f
-1] = 6) then
155 cdsize
:= LongWord(buf
[f
+8])+(LongWord(buf
[f
+9])<<8)+(LongWord(buf
[f
+10])<<16)+(LongWord(buf
[f
+11])<<24);
156 cdofs
:= Int64(buf
[f
+12])+(Int64(buf
[f
+13])<<8)+(Int64(buf
[f
+14])<<16)+(Int64(buf
[f
+15])<<24);
164 if (cdofs
>= 0) and (cdsize
> 0) then
166 // wow, we got central directory! process it
167 fFileStream
.position
:= cdofs
;
171 fFileStream
.readBuffer(sign
, 4);
172 if sign
= 'PK'#1#2 then
174 if cdsize
< 42 then break
;
176 // skip uninteresting fields
177 fFileStream
.seek(2+2+2+2+2+2+4+4+4, soCurrent
);
178 nameLen
:= fFileStream
.ReadWordLE();
179 extraLen
:= fFileStream
.ReadWordLE();
180 commentLen
:= fFileStream
.ReadWordLE();
181 // skip uninteresting fields
182 fFileStream
.seek(2+2+4, soCurrent
);
183 hdrofs
:= fFileStream
.ReadDWordLE();
184 // now skip name, extra and comment
185 if cdsize
< nameLen
+extraLen
+commentLen
then break
;
186 Dec(cdsize
, nameLen
+extraLen
+commentLen
);
187 fFileStream
.seek(nameLen
+extraLen
+commentLen
, soCurrent
);
188 SetLength(fileOffsets
, length(fileOffsets
)+1);
189 fileOffsets
[high(fileOffsets
)] := hdrofs
;
190 //writeln('file #', high(fileOffsets), ' found at ', hdrofs);
192 else if sign
= 'PK'#7#8 then
194 if cdsize
< 3*4 then break
;
196 fFileStream
.seek(3*4, soCurrent
);
203 if length(fileOffsets
) = 0 then exit
; // no files at all
208 fFileStream
.position
:= 0;
211 // read local directory
215 if fileIdx
> High(fileOffsets
) then break
;
216 //writeln('reading file #', fileIdx, ' at ', fileOffsets[fileIdx]);
217 fFileStream
.position
:= fileOffsets
[fileIdx
];
223 fFileStream
.ReadBuffer(sign
[0], Length(sign
));
224 // skip data descriptor
225 if sign
= 'PK'#7#8 then
227 fFileStream
.seek(3*4, soCurrent
);
232 if sign
<> 'PK'#3#4 then break
;
236 readLFH(fFileStream
, lhdr
);
238 fi
:= TSFSZipFileInfo
.Create(self
);
242 SetLength(fname
, lhdr
.fnameSz
);
243 if lhdr
.fnameSz
> 0 then
245 fFileStream
.ReadBuffer(fname
[1], length(fname
));
246 fi
.fName
:= utf8to1251(fname
);
249 // here we should process extra field: it may contain utf8 filename
250 while lhdr
.localExtraSz
>= 4 do
252 efid
:= fFileStream
.ReadWordLE();
253 efsz
:= fFileStream
.ReadWordLE();
254 Dec(lhdr
.localExtraSz
, 4);
255 if efsz
> lhdr
.localExtraSz
then break
;
256 // Info-ZIP Unicode Path Extra Field?
257 if (efid
= $7075) and (efsz
> 5) then
259 fFileStream
.ReadBuffer(izver
, 1);
261 Dec(lhdr
.localExtraSz
, 1);
264 //writeln('!!!!!!!!!!!!');
265 Dec(lhdr
.localExtraSz
, efsz
);
266 fFileStream
.ReadBuffer(izcrc
, 4); // name crc, ignore it for now
268 SetLength(fname
, efsz
);
269 if length(fname
) > 0 then fFileStream
.readBuffer(fname
[1], length(fname
));
270 fi
.fName
:= utf8to1251(fname
);
271 //writeln('++++++ [', fi.fName, ']');
278 fFileStream
.Seek(efsz
, soCurrent
);
279 Dec(lhdr
.localExtraSz
, efsz
);
283 if lhdr
.localExtraSz
> 0 then fFileStream
.Seek(lhdr
.localExtraSz
, soCurrent
);
285 if (lhdr
.flags
and 1) <> 0 then
287 // encrypted file: skip it
291 if (lhdr
.method
<> 0) and (lhdr
.method
<> 8) then
293 // not stored. not deflated. skip.
297 if (length(fi
.fName
) = 0) or (fname
[length(fi
.fName
)] = '/') or (fname
[length(fi
.fName
)] = '\') then
303 for f
:= 1 to length(fi
.fName
) do if fi
.fName
[f
] = '\' then fi
.fName
[f
] := '/';
306 fi
.fOfs
:= fFileStream
.Position
;
307 fi
.fSize
:= lhdr
.unpackSz
;
308 fi
.fPackSz
:= lhdr
.packSz
;
309 fi
.fMethod
:= lhdr
.method
;
310 if fi
.fMethod
= 0 then fi
.fPackSz
:= fi
.fSize
;
313 if fileIdx
< 0 then fFileStream
.Seek(lhdr
.packSz
, soCurrent
);
314 if ignoreFile
then fi
.Free();
317 if (sign <> 'PK'#1#2) and (sign <> 'PK'#5#6) then
319 {$IFDEF SFS_DEBUG_ZIPFS}
320 WriteLn(ErrOutput, 'end: $', IntToHex(fFileStream.Position, 8));
321 WriteLn(ErrOutput, 'sign: $', sign[0], sign[1], '#', ord(sign[2]), '#', ord(sign[3]));
323 raise ESFSError.Create('invalid .ZIP archive (no central dir)');
329 procedure TSFSZipVolume
.DFWADReadDirectory ();
335 fofs
, fpksize
: LongWord
;
336 curpath
, fname
: string;
337 name
: packed array [0..15] of Char;
340 fFileStream
.Seek(6, soCurrent
); // skip signature
341 fcnt
:= fFileStream
.ReadWordLE();
342 if fcnt
= 0 then exit
;
344 for f
:= 0 to fcnt
-1 do
346 fFileStream
.ReadBuffer(name
[0], 16);
347 fofs
:= fFileStream
.ReadDWordLE();
348 fpksize
:= fFileStream
.ReadDWordLE();
351 while (c
< 16) and (name
[c
] <> #0) do
353 if name
[c
] = '\' then name
[c
] := '/'
354 else if name
[c
] = '/' then name
[c
] := '_';
355 fname
:= fname
+name
[c
];
359 if (fofs
= 0) and (fpksize
= 0) then
361 if length(fname
) <> 0 then fname
:= fname
+'/';
365 if length(fname
) = 0 then continue
; // just in case
366 //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
367 // create file record
368 fi
:= TSFSZipFileInfo
.Create(self
);
371 fi
.fPackSz
:= fpksize
;
378 procedure TSFSZipVolume
.ReadDirectory ();
381 sfszvZIP
: ZIPReadDirectory();
382 sfszvDFWAD
: DFWADReadDirectory();
383 else raise ESFSError
.Create('invalid archive');
387 function TSFSZipVolume
.OpenFileByIndex (const index
: Integer): TStream
;
393 if fFiles
= nil then exit
;
394 if (index
< 0) or (index
>= fFiles
.Count
) or (fFiles
[index
] = nil) then exit
;
396 if TSFSZipFileInfo(fFiles
[index
]).fMethod
= 0 then
398 result
:= TSFSPartialStream
.Create(fFileStream
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fSize
, false);
402 rs
:= TSFSPartialStream
.Create(fFileStream
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fPackSz
, false);
403 result
:= TUnZStream
.Create(rs
, TSFSZipFileInfo(fFiles
[index
]).fSize
, true, (TSFSZipFileInfo(fFiles
[index
]).fMethod
<> 255));
413 { TSFSZipVolumeFactory }
414 class function TSFSZipVolumeFactory
.IsMyVolumePrefix (const prefix
: AnsiString
): Boolean;
417 StrEquCI1251(prefix
, 'zip') or
418 StrEquCI1251(prefix
, 'pk3') or
419 StrEquCI1251(prefix
, 'dfz') or
420 StrEquCI1251(prefix
, 'dfwad') or
421 StrEquCI1251(prefix
, 'dfzip');
424 class procedure TSFSZipVolumeFactory
.Recycle (vol
: TSFSVolume
);
429 class 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}
458 SFSRegisterVolumeFactory(TSFSZipVolumeFactory
);