4abd880bd4d659bf2811c49c00c0b904823675a0
1 // Streaming R/O Virtual File System v0.2.0
2 // Copyright (C) XL A.S. Ketmar. All rights reserved
3 // See the file aplicense.txt for conditions of use.
5 // grouping files with packing:
6 // zip, jar: PKZIP-compatible archives (store, deflate)
7 // fout2 : Fallout II .DAT
8 // vtdb : Asphyre's VTDb
9 // dfwad : D2D:F wad archives
11 {.$DEFINE SFS_DEBUG_ZIPFS}
12 {.$DEFINE SFS_ZIPFS_FULL}
20 SysUtils
, Classes
, Contnrs
, sfs
;
27 {$IFDEF SFS_ZIPFS_FULL}
34 TSFSZipVolume
= class(TSFSVolume
)
36 fType
: TSFSZipVolumeType
;
38 procedure ZIPReadDirectory ();
39 procedure DFWADReadDirectory ();
40 {$IFDEF SFS_ZIPFS_FULL}
41 procedure F2DATReadDirectory ();
42 procedure VTDBReadDirectory ();
45 procedure ReadDirectory (); override;
46 procedure removeCommonPath (); override;
49 function OpenFileByIndex (const index
: Integer): TStream
; override;
52 TSFSZipVolumeFactory
= class (TSFSVolumeFactory
)
54 function IsMyVolumePrefix (const prefix
: TSFSString
): Boolean; override;
55 function Produce (const prefix
, fileName
: TSFSString
; st
: TStream
): TSFSVolume
; override;
56 procedure Recycle (vol
: TSFSVolume
); override;
68 TZDecompressionStream
= TDecompressionStream
;
71 TSFSZipFileInfo
= class (TSFSFileInfo
)
73 fMethod
: Byte; // 0: store; 8: deflate; 255: other
77 TZLocalFileHeader
= packed record
91 function ZIPCheckMagic (st
: TStream
): Boolean;
93 sign
: packed array [0..3] of Char;
96 st
.ReadBuffer(sign
[0], 4);
97 st
.Seek(-4, soCurrent
);
98 if (sign
<> 'PK'#3#4) and (sign
<> 'PK'#5#6) then exit
;
102 {$IFDEF SFS_ZIPFS_FULL}
103 function F2DATCheckMagic (st
: TStream
): Boolean;
105 dsize
, fiSz
: Integer;
108 st
.Position
:= st
.Size
-8;
109 st
.ReadBuffer(dsize
, 4); st
.ReadBuffer(fiSz
, 4);
111 if (fiSz
<> st
.Size
) or (dsize
< 5+13) or (dsize
> fiSz
-4) then exit
;
115 function VTDBCheckMagic (st
: TStream
): Boolean;
117 sign
: packed array [0..3] of Char;
121 if st
.Size
< 32 then exit
;
122 st
.ReadBuffer(sign
[0], 4);
123 st
.ReadBuffer(fcnt
, 4); st
.ReadBuffer(dofs
, 4);
124 st
.Seek(-12, soCurrent
);
125 if sign
<> 'vtdm' then exit
;
126 if (fcnt
< 0) or (dofs
< 32) or (dofs
+fcnt
*8 > st
.Size
) then exit
;
131 function DFWADCheckMagic (st
: TStream
): Boolean;
133 sign
: packed array [0..5] of Char;
137 if st
.Size
< 10 then exit
;
138 st
.ReadBuffer(sign
[0], 6);
139 st
.ReadBuffer(fcnt
, 2);
140 st
.Seek(-8, soCurrent
);
141 //writeln('trying DFWAD... [', sign, ']');
142 if (sign
[0] <> 'D') and (sign
[1] <> 'F') and (sign
[2] <> 'W') and
143 (sign
[3] <> 'A') and (sign
[4] <> 'D') and (sign
[5] <> #
$01) then exit
;
144 //writeln('DFWAD FOUND, with ', fcnt, ' files');
145 //if (fcnt < 0) then exit;
149 function maxPrefix (s0
: string; s1
: string): Integer;
153 for f
:= 1 to length(s0
) do
155 if f
> length(s1
) then begin result
:= f
; exit
; end;
156 if SFSUpCase(s0
[f
]) <> SFSUpCase(s1
[f
]) then begin result
:= f
; exit
; end;
158 result
:= length(s0
);
161 procedure TSFSZipVolume
.removeCommonPath ();
163 f
, pl
, maxsc
, sc
, c
: integer;
167 if fType
<> sfszvZIP
then exit
;
169 if fFiles
.Count
= 0 then exit
;
171 for f
:= 0 to fFiles
.Count
-1 do
173 fi
:= TSFSZipFileInfo(fFiles
[f
]);
175 if length(s
) > 0 then begin cp
:= s
; break
; end;
177 if length(cp
) = 0 then exit
;
178 for f
:= 0 to fFiles
.Count
-1 do
180 fi
:= TSFSZipFileInfo(fFiles
[f
]);
182 if length(s
) = 0 then continue
;
183 pl
:= maxPrefix(cp
, s
);
184 //writeln('s=[', s, ']; cp=[', cp, ']; pl=', pl);
185 if pl
= 0 then exit
; // no common prefix at all
186 cp
:= Copy(cp
, 1, pl
);
188 for c
:= 1 to length(s
) do if s
[c
] = '/' then Inc(sc
);
189 if sc
> maxsc
then maxsc
:= sc
;
191 if maxsc
< 2 then exit
; // alas
192 while (length(cp
) > 0) and (cp
[length(cp
)] <> '/') do cp
:= Copy(cp
, 1, length(cp
)-1);
193 if length(cp
) < 2 then exit
; // nothing to do
194 for f
:= 0 to fFiles
.Count
-1 do
196 fi
:= TSFSZipFileInfo(fFiles
[f
]);
197 if length(fi
.fPath
) >= length(cp
) then
200 fi
.fPath
:= Copy(fi
.fPath
, length(cp
)+1, length(fi
.fPath
));
201 //writeln('FIXED [', s, '] -> [', fi.fPath, ']');
208 procedure TSFSZipVolume
.ZIPReadDirectory ();
212 sign
, dSign
: packed array [0..3] of Char;
213 lhdr
: TZLocalFileHeader
;
214 ignoreFile
, skipped
: Boolean;
215 crc
, psz
, usz
: LongWord;
216 buf
: packed array of Byte;
217 bufPos
, bufUsed
: Integer;
223 // read local directory
225 fFileStream
.ReadBuffer(sign
[0], Length(sign
));
227 if sign
<> 'PK'#3#4 then break
;
232 fi
:= TSFSZipFileInfo
.Create(self
);
236 //fi.fOfs := fFileStream.Position;
238 fFileStream
.ReadBuffer(lhdr
, SizeOf(lhdr
));
239 if lhdr
.fnameSz
> 255 then name
[0] := #255 else name
[0] := chr(lhdr
.fnameSz
);
240 fFileStream
.ReadBuffer(name
[1], Length(name
));
241 fFileStream
.Seek(lhdr
.fnameSz
-Length(name
), soCurrent
); // rest of the name (if any)
242 fi
.fName
:= utf8to1251(name
);
243 //writeln(Format('0x%08x : %s', [Integer(fi.fOfs), name]));
245 // here we should process extra field: it may contain utf8 filename
246 //fFileStream.Seek(lhdr.localExtraSz, soCurrent);
247 while lhdr
.localExtraSz
>= 4 do
251 fFileStream
.ReadBuffer(efid
, 2);
252 fFileStream
.ReadBuffer(efsz
, 2);
253 Dec(lhdr
.localExtraSz
, 4);
254 if efsz
> lhdr
.localExtraSz
then break
;
255 // Info-ZIP Unicode Path Extra Field?
256 if (efid
= $7075) and (efsz
<= 255+5) and (efsz
> 5) then
258 fFileStream
.ReadBuffer(izver
, 1);
266 Dec(lhdr
.localExtraSz
, efsz
);
267 fFileStream
.ReadBuffer(izcrc
, 4); // name crc, ignore it
269 name
[0] := chr(efsz
);
270 fFileStream
.ReadBuffer(name
[1], Length(name
));
271 fi
.fName
:= utf8to1251(name
);
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 fi
.fOfs
:= fFileStream
.Position
;
298 fi
.fSize
:= lhdr
.unpackSz
;
299 fi
.fPackSz
:= lhdr
.packSz
;
300 fi
.fMethod
:= lhdr
.method
;
302 if (lhdr
.flags
and (1 shl 3)) <> 0 then
304 // it has a descriptor. stupid thing at all...
305 {$IFDEF SFS_DEBUG_ZIPFS}
306 WriteLn(ErrOutput
, 'descr: $', IntToHex(fFileStream
.Position
, 8));
307 WriteLn(ErrOutput
, 'size: ', lhdr
.unpackSz
);
308 WriteLn(ErrOutput
, 'psize: ', lhdr
.packSz
);
312 if lhdr
.packSz
<> 0 then
314 // some kind of idiot already did our work (maybe paritally)
315 // trust him (her? %-)
316 fFileStream
.Seek(lhdr
.packSz
, soCurrent
);
319 // scan for descriptor
320 if Length(buf
) = 0 then SetLength(buf
, 65536);
321 bufPos
:= 0; bufUsed
:= 0;
322 fFileStream
.ReadBuffer(dSign
[0], 4);
324 if dSign
<> 'PK'#7#8 then
327 Move(dSign
[1], dSign
[0], 3);
328 if bufPos
>= bufUsed
then
332 if fFileStream
.Size
-fFileStream
.Position
> Length(buf
) then bufUsed
:= Length(buf
)
333 else bufUsed
:= fFileStream
.Size
-fFileStream
.Position
;
334 if bufUsed
= 0 then raise ESFSError
.Create('invalid ZIP file');
335 fFileStream
.ReadBuffer(buf
[0], bufUsed
);
337 dSign
[3] := chr(buf
[bufPos
]); Inc(bufPos
);
341 // signature found: check if it is a real one
342 // ???: make stronger check (for the correct following signature)?
343 // sign, crc, packsize, unpacksize
344 fFileStream
.Seek(-bufUsed
+bufPos
, soCurrent
); bufPos
:= 0; bufUsed
:= 0;
345 fFileStream
.ReadBuffer(crc
, 4); // crc
346 fFileStream
.ReadBuffer(psz
, 4); // packed size
348 if psz
= lhdr
.packSz
then
350 // this is a real description. fuck it off
351 fFileStream
.ReadBuffer(usz
, 4); // unpacked size
354 // this is just a sequence of bytes
355 fFileStream
.Seek(-8, soCurrent
);
356 fFileStream
.ReadBuffer(dSign
[0], 4);
359 // store correct values
365 if not skipped
then fFileStream
.Seek(lhdr
.packSz
, soCurrent
);
366 if ignoreFile
then fi
.Free();
369 if (sign
<> 'PK'#1#2) and (sign
<> 'PK'#5#6) then
371 {$IFDEF SFS_DEBUG_ZIPFS}
372 WriteLn(ErrOutput
, 'end: $', IntToHex(fFileStream
.Position
, 8));
373 WriteLn(ErrOutput
, 'sign: $', sign
[0], sign
[1], '#', ord(sign
[2]), '#', ord(sign
[3]));
375 raise ESFSError
.Create('invalid .ZIP archive (no central dir)');
379 {$IFDEF SFS_ZIPFS_FULL}
380 procedure TSFSZipVolume
.F2DATReadDirectory ();
388 fFileStream
.Position
:= fFileStream
.Size
-8;
389 fFileStream
.ReadBuffer(dsize
, 4);
390 fFileStream
.Seek(-dsize
, soCurrent
); Dec(dsize
, 4);
393 fi
:= TSFSZipFileInfo
.Create(self
);
394 fFileStream
.ReadBuffer(f
, 4);
395 if (f
< 1) or (f
> 255) then raise ESFSError
.Create('invalid Fallout II .DAT file');
397 if dsize
< 0 then raise ESFSError
.Create('invalid Fallout II .DAT file');
398 name
[0] := chr(f
); if f
> 0 then fFileStream
.ReadBuffer(name
[1], f
);
399 f
:= 1; while (f
<= ord(name
[0])) and (name
[f
] <> #0) do Inc(f
); name
[0] := chr(f
-1);
401 fFileStream
.ReadBuffer(b
, 1); // packed?
402 if b
= 0 then fi
.fMethod
:= 0 else fi
.fMethod
:= 255;
403 fFileStream
.ReadBuffer(fi
.fSize
, 4);
404 fFileStream
.ReadBuffer(fi
.fPackSz
, 4);
405 fFileStream
.ReadBuffer(fi
.fOfs
, 4);
409 procedure TSFSZipVolume
.VTDBReadDirectory ();
413 keys
: array of record name
: string; ofs
: Integer; end;
418 fFileStream
.Seek(4, soCurrent
); // skip signature
419 fFileStream
.ReadBuffer(fcnt
, 4);
420 fFileStream
.ReadBuffer(dofs
, 4);
421 fFileStream
.Seek(dofs
, soBeginning
);
424 SetLength(keys
, fcnt
);
425 for f
:= 0 to fcnt
-1 do
427 fFileStream
.ReadBuffer(c
, 4);
428 if (c
< 0) or (c
> 1023) then raise ESFSError
.Create('invalid VTDB file');
429 SetLength(keys
[f
].name
, c
);
432 fFileStream
.ReadBuffer(keys
[f
].name
[1], c
);
433 keys
[f
].name
:= SFSReplacePathDelims(keys
[f
].name
, '/');
434 if keys
[f
].name
[1] = '/' then Delete(keys
[f
].name
, 1, 1);
436 fFileStream
.ReadBuffer(keys
[f
].ofs
, 4);
439 // read records (record type will be converted to directory name)
440 for f
:= 0 to fcnt
-1 do
442 fFileStream
.Position
:= keys
[f
].ofs
;
443 fi
:= TSFSZipFileInfo
.Create(self
);
444 fFileStream
.ReadBuffer(rtype
, 2);
445 fFileStream
.ReadBuffer(fi
.fSize
, 4);
446 fFileStream
.ReadBuffer(fi
.fPackSz
, 4);
447 fi
.fOfs
:= fFileStream
.Position
+12;
448 fi
.fName
:= keys
[f
].name
;
449 fi
.fPath
:= IntToHex(rtype
, 4)+'/';
455 procedure TSFSZipVolume
.DFWADReadDirectory ();
460 f
, c
, fofs
, fpksize
: Integer;
461 curpath
, fname
: string;
462 name
: packed array [0..15] of Char;
465 fFileStream
.Seek(6, soCurrent
); // skip signature
466 fFileStream
.ReadBuffer(fcnt
, 2);
467 if fcnt
= 0 then exit
;
469 for f
:= 0 to fcnt
-1 do
471 fFileStream
.ReadBuffer(name
[0], 16);
472 fFileStream
.ReadBuffer(fofs
, 4);
473 fFileStream
.ReadBuffer(fpksize
, 4);
476 while (c
< 16) and (name
[c
] <> #0) do
478 if name
[c
] = '\' then name
[c
] := '/'
479 else if name
[c
] = '/' then name
[c
] := '_';
480 fname
:= fname
+name
[c
];
484 if (fofs
= 0) and (fpksize
= 0) then
486 if length(fname
) <> 0 then fname
:= fname
+'/';
490 if length(fname
) = 0 then continue
; // just in case
491 //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
492 // create file record
493 fi
:= TSFSZipFileInfo
.Create(self
);
496 fi
.fPackSz
:= fpksize
;
503 procedure TSFSZipVolume
.ReadDirectory ();
506 sfszvZIP
: ZIPReadDirectory();
507 {$IFDEF SFS_ZIPFS_FULL}
508 sfszvF2DAT
: F2DATReadDirectory();
509 sfszvVTDB
: VTDBReadDirectory();
511 sfszvDFWAD
: DFWADReadDirectory();
512 else raise ESFSError
.Create('invalid zipped SFS');
516 function TSFSZipVolume
.OpenFileByIndex (const index
: Integer): TStream
;
518 zs
: TZDecompressionStream
;
522 buf
: packed array [0..1023] of Char;
530 if fFiles
= nil then exit
;
531 if (index
< 0) or (index
>= fFiles
.Count
) or (fFiles
[index
] = nil) then exit
;
536 fs := TFileStream.Create(fFileName, fmOpenRead or fmShareDenyWrite);
543 if TSFSZipFileInfo(fFiles
[index
]).fMethod
= 0 then
545 result
:= TSFSPartialStream
.Create(fs
,
546 TSFSZipFileInfo(fFiles
[index
]).fOfs
,
547 TSFSZipFileInfo(fFiles
[index
]).fSize
, kill
);
551 fs
.Seek(TSFSZipFileInfo(fFiles
[index
]).fOfs
, soBeginning
);
552 if TSFSZipFileInfo(fFiles
[index
]).fMethod
= 255 then
554 // sorry, pals, DFWAD is completely broken, so users of it should SUFFER
555 if TSFSZipFileInfo(fFiles
[index
]).fSize
= -1 then
557 TSFSZipFileInfo(fFiles
[index
]).fSize
:= 0;
558 //writeln('trying to determine file size for [', TSFSZipFileInfo(fFiles[index]).fPath, TSFSZipFileInfo(fFiles[index]).fName, ']');
559 zs
:= TZDecompressionStream
.Create(fs
);
563 rd
:= zs
.read(buf
, 1024);
564 //writeln(' got ', rd, ' bytes');
565 if rd
> 0 then Inc(TSFSZipFileInfo(fFiles
[index
]).fSize
, rd
);
566 if rd
< 1024 then break
;
568 //writeln(' resulting size: ', TSFSZipFileInfo(fFiles[index]).fSize, ' bytes');
571 fs
.Seek(TSFSZipFileInfo(fFiles
[index
]).fOfs
, soBeginning
);
573 //writeln('*** CAN''T determine file size for [', TSFSZipFileInfo(fFiles[index]).fPath, TSFSZipFileInfo(fFiles[index]).fName, ']');
575 if kill
then FreeAndNil(fs
);
580 rs
:= TSFSPartialStream
.Create(fs
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fPackSz
, true);
581 zs
:= TZDecompressionStream
.Create(rs
);
586 rs
:= TSFSPartialStream
.Create(fs
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fPackSz
, true);
587 zs
:= TZDecompressionStream
.Create(rs
, true {-15}{MAX_WBITS});
590 gs
:= TSFSGuardStream
.Create(zs
, fs
, true, kill
, false);
593 result
:= TSFSPartialStream
.Create(gs
, 0, TSFSZipFileInfo(fFiles
[index
]).fSize
, true);
599 if kill
then FreeAndNil(fs
);
606 { TSFSZipVolumeFactory }
607 function TSFSZipVolumeFactory
.IsMyVolumePrefix (const prefix
: TSFSString
): Boolean;
610 SFSStrEqu(prefix
, 'zip') or
611 SFSStrEqu(prefix
, 'dfwad')
612 {$IFDEF SFS_ZIPFS_FULL}
613 or SFSStrEqu(prefix
, 'jar') or
614 SFSStrEqu(prefix
, 'fout2') or
615 SFSStrEqu(prefix
, 'vtdb') or
616 SFSStrEqu(prefix
, 'wad')
621 procedure TSFSZipVolumeFactory
.Recycle (vol
: TSFSVolume
);
626 function TSFSZipVolumeFactory
.Produce (const prefix
, fileName
: TSFSString
; st
: TStream
): TSFSVolume
;
628 vt
: TSFSZipVolumeType
;
631 if ZIPCheckMagic(st
) then vt
:= sfszvZIP
632 else if DFWADCheckMagic(st
) then vt
:= sfszvDFWAD
633 {$IFDEF SFS_ZIPFS_FULL}
634 else if F2DATCheckMagic(st
) then vt
:= sfszvF2DAT
635 else if VTDBCheckMagic(st
) then vt
:= sfszvVTDB
639 if vt
<> sfszvNone
then
641 result
:= TSFSZipVolume
.Create(fileName
, st
);
642 TSFSZipVolume(result
).fType
:= vt
;
644 result
.DoDirectoryRead();
645 except {$IFDEF SFS_DEBUG_ZIPFS} on e
: Exception
do begin
646 WriteLn(errOutput
, 'ZIP ERROR: [', e
.ClassName
, ']: ', e
.Message);
650 {$IFDEF SFS_DEBUG_ZIPFS}end;{$ENDIF}
661 zipf
: TSFSZipVolumeFactory
;
663 zipf
:= TSFSZipVolumeFactory
.Create();
664 SFSRegisterVolumeFactory(zipf
);
666 // SFSUnregisterVolumeFactory(zipf);