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, pk3: PKZIP-compatible archives (store, deflate)
7 // dfwad : D2D:F wad archives
9 {.$DEFINE SFS_DEBUG_ZIPFS}
17 SysUtils
, Classes
, Contnrs
, sfs
;
21 TSFSZipVolumeType
= (sfszvNone
, sfszvZIP
, sfszvDFWAD
);
23 TSFSZipVolume
= class(TSFSVolume
)
25 fType
: TSFSZipVolumeType
;
27 procedure ZIPReadDirectory ();
28 procedure DFWADReadDirectory ();
30 procedure ReadDirectory (); override;
31 procedure removeCommonPath (); override;
34 function OpenFileByIndex (const index
: Integer): TStream
; override;
37 TSFSZipVolumeFactory
= class(TSFSVolumeFactory
)
39 function IsMyVolumePrefix (const prefix
: AnsiString): Boolean; override;
40 function Produce (const prefix
, fileName
: AnsiString; st
: TStream
): TSFSVolume
; override;
41 procedure Recycle (vol
: TSFSVolume
); override;
52 TSFSZipFileInfo
= class(TSFSFileInfo
)
54 fMethod
: Byte; // 0: store; 8: deflate; 255: other
55 fPackSz
: Int64; // can be -1
58 TZLocalFileHeader
= packed record
72 function ZIPCheckMagic (st
: TStream
): Boolean;
74 sign
: packed array [0..3] of Char;
77 st
.ReadBuffer(sign
[0], 4);
78 st
.Seek(-4, soCurrent
);
79 if (sign
<> 'PK'#3#4) and (sign
<> 'PK'#5#6) then exit
;
84 function DFWADCheckMagic (st
: TStream
): Boolean;
86 sign
: packed array [0..5] of Char;
90 if st
.Size
< 10 then exit
;
91 st
.ReadBuffer(sign
[0], 6);
92 st
.ReadBuffer(fcnt
, 2);
93 st
.Seek(-8, soCurrent
);
94 //writeln('trying DFWAD... [', sign, ']');
95 if (sign
[0] <> 'D') and (sign
[1] <> 'F') and (sign
[2] <> 'W') and
96 (sign
[3] <> 'A') and (sign
[4] <> 'D') and (sign
[5] <> #
$01) then exit
;
97 //writeln('DFWAD FOUND, with ', fcnt, ' files');
98 //if (fcnt < 0) then exit;
103 function maxPrefix (s0
: string; s1
: string): Integer;
107 for f
:= 1 to length(s0
) do
109 if f
> length(s1
) then begin result
:= f
; exit
; end;
110 if UpCase1251(s0
[f
]) <> UpCase1251(s1
[f
]) then begin result
:= f
; exit
; end;
112 result
:= length(s0
);
116 procedure TSFSZipVolume
.removeCommonPath ();
118 f
, pl
, maxsc
, sc
, c
: integer;
122 if fType
<> sfszvZIP
then exit
;
124 if fFiles
.Count
= 0 then exit
;
126 for f
:= 0 to fFiles
.Count
-1 do
128 fi
:= TSFSZipFileInfo(fFiles
[f
]);
130 if length(s
) > 0 then begin cp
:= s
; break
; end;
132 if length(cp
) = 0 then exit
;
133 for f
:= 0 to fFiles
.Count
-1 do
135 fi
:= TSFSZipFileInfo(fFiles
[f
]);
137 if length(s
) = 0 then continue
;
138 pl
:= maxPrefix(cp
, s
);
139 //writeln('s=[', s, ']; cp=[', cp, ']; pl=', pl);
140 if pl
= 0 then exit
; // no common prefix at all
141 cp
:= Copy(cp
, 1, pl
);
143 for c
:= 1 to length(s
) do if s
[c
] = '/' then Inc(sc
);
144 if sc
> maxsc
then maxsc
:= sc
;
146 if maxsc
< 2 then exit
; // alas
147 while (length(cp
) > 0) and (cp
[length(cp
)] <> '/') do cp
:= Copy(cp
, 1, length(cp
)-1);
148 if length(cp
) < 2 then exit
; // nothing to do
149 for f
:= 0 to fFiles
.Count
-1 do
151 fi
:= TSFSZipFileInfo(fFiles
[f
]);
152 if length(fi
.fPath
) >= length(cp
) then
155 fi
.fPath
:= Copy(fi
.fPath
, length(cp
)+1, length(fi
.fPath
));
156 //writeln('FIXED [', s, '] -> [', fi.fPath, ']');
163 procedure TSFSZipVolume
.ZIPReadDirectory ();
167 sign
, dSign
: packed array [0..3] of Char;
168 lhdr
: TZLocalFileHeader
;
169 ignoreFile
, skipped
: Boolean;
170 crc
, psz
, usz
: LongWord;
171 buf
: packed array of Byte;
172 bufPos
, bufUsed
: Integer;
178 // read local directory
180 fFileStream
.ReadBuffer(sign
[0], Length(sign
));
182 if sign
<> 'PK'#3#4 then break
;
187 fi
:= TSFSZipFileInfo
.Create(self
);
191 //fi.fOfs := fFileStream.Position;
193 fFileStream
.ReadBuffer(lhdr
, SizeOf(lhdr
));
194 if lhdr
.fnameSz
> 255 then name
[0] := #255 else name
[0] := chr(lhdr
.fnameSz
);
195 fFileStream
.ReadBuffer(name
[1], Length(name
));
196 fFileStream
.Seek(lhdr
.fnameSz
-Length(name
), soCurrent
); // rest of the name (if any)
197 fi
.fName
:= utf8to1251(name
);
198 //writeln(Format('0x%08x : %s', [Integer(fi.fOfs), name]));
200 // here we should process extra field: it may contain utf8 filename
201 //fFileStream.Seek(lhdr.localExtraSz, soCurrent);
202 while lhdr
.localExtraSz
>= 4 do
206 fFileStream
.ReadBuffer(efid
, 2);
207 fFileStream
.ReadBuffer(efsz
, 2);
208 Dec(lhdr
.localExtraSz
, 4);
209 if efsz
> lhdr
.localExtraSz
then break
;
210 // Info-ZIP Unicode Path Extra Field?
211 if (efid
= $7075) and (efsz
<= 255+5) and (efsz
> 5) then
213 fFileStream
.ReadBuffer(izver
, 1);
221 Dec(lhdr
.localExtraSz
, efsz
);
222 fFileStream
.ReadBuffer(izcrc
, 4); // name crc, ignore it
224 name
[0] := chr(efsz
);
225 fFileStream
.ReadBuffer(name
[1], Length(name
));
226 fi
.fName
:= utf8to1251(name
);
233 fFileStream
.Seek(efsz
, soCurrent
);
234 Dec(lhdr
.localExtraSz
, efsz
);
238 if lhdr
.localExtraSz
> 0 then fFileStream
.Seek(lhdr
.localExtraSz
, soCurrent
);
240 if (lhdr
.flags
and 1) <> 0 then
242 // encrypted file: skip it
246 if (lhdr
.method
<> 0) and (lhdr
.method
<> 8) then
248 // not stored. not deflated. skip.
252 fi
.fOfs
:= fFileStream
.Position
;
253 fi
.fSize
:= lhdr
.unpackSz
;
254 fi
.fPackSz
:= lhdr
.packSz
;
255 fi
.fMethod
:= lhdr
.method
;
257 if (lhdr
.flags
and (1 shl 3)) <> 0 then
259 // it has a descriptor. stupid thing at all...
260 {$IFDEF SFS_DEBUG_ZIPFS}
261 WriteLn(ErrOutput
, 'descr: $', IntToHex(fFileStream
.Position
, 8));
262 WriteLn(ErrOutput
, 'size: ', lhdr
.unpackSz
);
263 WriteLn(ErrOutput
, 'psize: ', lhdr
.packSz
);
267 if lhdr
.packSz
<> 0 then
269 // some kind of idiot already did our work (maybe paritally)
270 // trust him (her? %-)
271 fFileStream
.Seek(lhdr
.packSz
, soCurrent
);
274 // scan for descriptor
275 if Length(buf
) = 0 then SetLength(buf
, 65536);
276 bufPos
:= 0; bufUsed
:= 0;
277 fFileStream
.ReadBuffer(dSign
[0], 4);
279 if dSign
<> 'PK'#7#8 then
282 Move(dSign
[1], dSign
[0], 3);
283 if bufPos
>= bufUsed
then
287 if fFileStream
.Size
-fFileStream
.Position
> Length(buf
) then bufUsed
:= Length(buf
)
288 else bufUsed
:= fFileStream
.Size
-fFileStream
.Position
;
289 if bufUsed
= 0 then raise ESFSError
.Create('invalid ZIP file');
290 fFileStream
.ReadBuffer(buf
[0], bufUsed
);
292 dSign
[3] := chr(buf
[bufPos
]); Inc(bufPos
);
296 // signature found: check if it is a real one
297 // ???: make stronger check (for the correct following signature)?
298 // sign, crc, packsize, unpacksize
299 fFileStream
.Seek(-bufUsed
+bufPos
, soCurrent
); bufPos
:= 0; bufUsed
:= 0;
300 fFileStream
.ReadBuffer(crc
, 4); // crc
301 fFileStream
.ReadBuffer(psz
, 4); // packed size
303 if psz
= lhdr
.packSz
then
305 // this is a real description. fuck it off
306 fFileStream
.ReadBuffer(usz
, 4); // unpacked size
309 // this is just a sequence of bytes
310 fFileStream
.Seek(-8, soCurrent
);
311 fFileStream
.ReadBuffer(dSign
[0], 4);
314 // store correct values
320 if not skipped
then fFileStream
.Seek(lhdr
.packSz
, soCurrent
);
321 if ignoreFile
then fi
.Free();
324 if (sign
<> 'PK'#1#2) and (sign
<> 'PK'#5#6) then
326 {$IFDEF SFS_DEBUG_ZIPFS}
327 WriteLn(ErrOutput
, 'end: $', IntToHex(fFileStream
.Position
, 8));
328 WriteLn(ErrOutput
, 'sign: $', sign
[0], sign
[1], '#', ord(sign
[2]), '#', ord(sign
[3]));
330 raise ESFSError
.Create('invalid .ZIP archive (no central dir)');
335 procedure TSFSZipVolume
.DFWADReadDirectory ();
340 f
, c
, fofs
, fpksize
: Integer;
341 curpath
, fname
: string;
342 name
: packed array [0..15] of Char;
345 fFileStream
.Seek(6, soCurrent
); // skip signature
346 fFileStream
.ReadBuffer(fcnt
, 2);
347 if fcnt
= 0 then exit
;
349 for f
:= 0 to fcnt
-1 do
351 fFileStream
.ReadBuffer(name
[0], 16);
352 fFileStream
.ReadBuffer(fofs
, 4);
353 fFileStream
.ReadBuffer(fpksize
, 4);
356 while (c
< 16) and (name
[c
] <> #0) do
358 if name
[c
] = '\' then name
[c
] := '/'
359 else if name
[c
] = '/' then name
[c
] := '_';
360 fname
:= fname
+name
[c
];
364 if (fofs
= 0) and (fpksize
= 0) then
366 if length(fname
) <> 0 then fname
:= fname
+'/';
370 if length(fname
) = 0 then continue
; // just in case
371 //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
372 // create file record
373 fi
:= TSFSZipFileInfo
.Create(self
);
376 fi
.fPackSz
:= fpksize
;
383 procedure TSFSZipVolume
.ReadDirectory ();
386 sfszvZIP
: ZIPReadDirectory();
387 sfszvDFWAD
: DFWADReadDirectory();
388 else raise ESFSError
.Create('invalid archive');
392 function TSFSZipVolume
.OpenFileByIndex (const index
: Integer): TStream
;
398 if fFiles
= nil then exit
;
399 if (index
< 0) or (index
>= fFiles
.Count
) or (fFiles
[index
] = nil) then exit
;
401 if TSFSZipFileInfo(fFiles
[index
]).fMethod
= 0 then
403 result
:= TSFSPartialStream
.Create(fFileStream
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fSize
, false);
407 rs
:= TSFSPartialStream
.Create(fFileStream
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fPackSz
, false);
408 result
:= TUnZStream
.Create(rs
, TSFSZipFileInfo(fFiles
[index
]).fSize
, true, (TSFSZipFileInfo(fFiles
[index
]).fMethod
<> 255));
418 { TSFSZipVolumeFactory }
419 function TSFSZipVolumeFactory
.IsMyVolumePrefix (const prefix
: AnsiString): Boolean;
422 StrEquCI1251(prefix
, 'zip') or
423 StrEquCI1251(prefix
, 'pk3') or
424 StrEquCI1251(prefix
, 'dfwad');
427 procedure TSFSZipVolumeFactory
.Recycle (vol
: TSFSVolume
);
432 function TSFSZipVolumeFactory
.Produce (const prefix
, fileName
: AnsiString; st
: TStream
): TSFSVolume
;
434 vt
: TSFSZipVolumeType
;
437 if ZIPCheckMagic(st
) then vt
:= sfszvZIP
438 else if DFWADCheckMagic(st
) then vt
:= sfszvDFWAD
;
440 if vt
<> sfszvNone
then
442 result
:= TSFSZipVolume
.Create(fileName
, st
);
443 TSFSZipVolume(result
).fType
:= vt
;
445 result
.DoDirectoryRead();
446 except {$IFDEF SFS_DEBUG_ZIPFS} on e
: Exception
do begin
447 WriteLn(errOutput
, 'ZIP ERROR: [', e
.ClassName
, ']: ', e
.Message);
451 {$IFDEF SFS_DEBUG_ZIPFS}end;{$ENDIF}
462 zipf
: TSFSZipVolumeFactory
;
464 zipf
:= TSFSZipVolumeFactory
.Create();
465 SFSRegisterVolumeFactory(zipf
);
467 // SFSUnregisterVolumeFactory(zipf);