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
71 procedure readLFH (st
: TStream
; var hdr
: TZLocalFileHeader
);
72 {.$IFDEF ENDIAN_LITTLE}
74 hdr
.version
:= readByte(st
);
75 hdr
.hostOS
:= readByte(st
);
76 hdr
.flags
:= readWord(st
);
77 hdr
.method
:= readWord(st
);
78 hdr
.time
:= readLongWord(st
);
79 hdr
.crc
:= readLongWord(st
);
80 hdr
.packSz
:= readLongWord(st
);
81 hdr
.unpackSz
:= readLongWord(st
);
82 hdr
.fnameSz
:= readWord(st
);
83 hdr
.localExtraSz
:= readWord(st
);
87 function ZIPCheckMagic (st
: TStream
): Boolean;
89 sign
: packed array [0..3] of Char;
92 st
.ReadBuffer(sign
[0], 4);
93 st
.Seek(-4, soCurrent
);
94 if (sign
<> 'PK'#3#4) and (sign
<> 'PK'#5#6) then exit
;
99 function DFWADCheckMagic (st
: TStream
): Boolean;
101 sign
: packed array [0..5] of Char;
104 if st
.Size
< 10 then exit
;
105 st
.ReadBuffer(sign
[0], 6);
106 {fcnt :=} readWord(st
);
107 st
.Seek(-8, soCurrent
);
108 //writeln('trying DFWAD... [', sign, ']');
109 if (sign
[0] <> 'D') and (sign
[1] <> 'F') and (sign
[2] <> 'W') and
110 (sign
[3] <> 'A') and (sign
[4] <> 'D') and (sign
[5] <> #
$01) then exit
;
111 //writeln('DFWAD FOUND, with ', fcnt, ' files');
112 //if (fcnt < 0) then exit;
117 function maxPrefix (s0
: string; s1
: string): Integer;
121 for f
:= 1 to length(s0
) do
123 if f
> length(s1
) then begin result
:= f
; exit
; end;
124 if UpCase1251(s0
[f
]) <> UpCase1251(s1
[f
]) then begin result
:= f
; exit
; end;
126 result
:= length(s0
);
130 procedure TSFSZipVolume
.removeCommonPath ();
132 f
, pl
, maxsc
, sc
, c
: integer;
136 if fType
<> sfszvZIP
then exit
;
138 if fFiles
.Count
= 0 then exit
;
140 for f
:= 0 to fFiles
.Count
-1 do
142 fi
:= TSFSZipFileInfo(fFiles
[f
]);
144 if length(s
) > 0 then begin cp
:= s
; break
; end;
146 if length(cp
) = 0 then exit
;
147 for f
:= 0 to fFiles
.Count
-1 do
149 fi
:= TSFSZipFileInfo(fFiles
[f
]);
151 if length(s
) = 0 then continue
;
152 pl
:= maxPrefix(cp
, s
);
153 //writeln('s=[', s, ']; cp=[', cp, ']; pl=', pl);
154 if pl
= 0 then exit
; // no common prefix at all
155 cp
:= Copy(cp
, 1, pl
);
157 for c
:= 1 to length(s
) do if s
[c
] = '/' then Inc(sc
);
158 if sc
> maxsc
then maxsc
:= sc
;
160 if maxsc
< 2 then exit
; // alas
161 while (length(cp
) > 0) and (cp
[length(cp
)] <> '/') do cp
:= Copy(cp
, 1, length(cp
)-1);
162 if length(cp
) < 2 then exit
; // nothing to do
163 for f
:= 0 to fFiles
.Count
-1 do
165 fi
:= TSFSZipFileInfo(fFiles
[f
]);
166 if length(fi
.fPath
) >= length(cp
) then
169 fi
.fPath
:= Copy(fi
.fPath
, length(cp
)+1, length(fi
.fPath
));
170 //writeln('FIXED [', s, '] -> [', fi.fPath, ']');
177 procedure TSFSZipVolume
.ZIPReadDirectory ();
181 sign
: packed array [0..3] of Char;
182 lhdr
: TZLocalFileHeader
;
188 // read local directory
190 fFileStream
.ReadBuffer(sign
[0], Length(sign
));
192 // skip data descriptor
193 if sign
= 'PK'#7#8 then
195 fFileStream
.seek(3*4, soCurrent
);
199 if sign
<> 'PK'#3#4 then break
;
203 readLFH(fFileStream
, lhdr
);
205 fi
:= TSFSZipFileInfo
.Create(self
);
209 if lhdr
.fnameSz
> 255 then name
[0] := #255 else name
[0] := chr(lhdr
.fnameSz
);
210 fFileStream
.ReadBuffer(name
[1], Length(name
));
211 fFileStream
.Seek(lhdr
.fnameSz
-Length(name
), soCurrent
); // rest of the name (if any)
212 fi
.fName
:= utf8to1251(name
);
214 // here we should process extra field: it may contain utf8 filename
215 while lhdr
.localExtraSz
>= 4 do
217 efid
:= readWord(fFileStream
);
218 efsz
:= readWord(fFileStream
);
219 Dec(lhdr
.localExtraSz
, 4);
220 if efsz
> lhdr
.localExtraSz
then break
;
221 // Info-ZIP Unicode Path Extra Field?
222 if (efid
= $7075) and (efsz
<= 255+5) and (efsz
> 5) then
224 fFileStream
.ReadBuffer(izver
, 1);
232 Dec(lhdr
.localExtraSz
, efsz
);
233 fFileStream
.ReadBuffer(izcrc
, 4); // name crc, ignore it
235 name
[0] := chr(efsz
);
236 fFileStream
.ReadBuffer(name
[1], Length(name
));
237 fi
.fName
:= utf8to1251(name
);
244 fFileStream
.Seek(efsz
, soCurrent
);
245 Dec(lhdr
.localExtraSz
, efsz
);
249 if lhdr
.localExtraSz
> 0 then fFileStream
.Seek(lhdr
.localExtraSz
, soCurrent
);
251 if (lhdr
.flags
and 1) <> 0 then
253 // encrypted file: skip it
257 if (lhdr
.method
<> 0) and (lhdr
.method
<> 8) then
259 // not stored. not deflated. skip.
263 fi
.fOfs
:= fFileStream
.Position
;
264 fi
.fSize
:= lhdr
.unpackSz
;
265 fi
.fPackSz
:= lhdr
.packSz
;
266 fi
.fMethod
:= lhdr
.method
;
269 fFileStream
.Seek(lhdr
.packSz
, soCurrent
);
270 if ignoreFile
then fi
.Free();
273 if (sign <> 'PK'#1#2) and (sign <> 'PK'#5#6) then
275 {$IFDEF SFS_DEBUG_ZIPFS}
276 WriteLn(ErrOutput, 'end: $', IntToHex(fFileStream.Position, 8));
277 WriteLn(ErrOutput, 'sign: $', sign[0], sign[1], '#', ord(sign[2]), '#', ord(sign[3]));
279 raise ESFSError.Create('invalid .ZIP archive (no central dir)');
285 procedure TSFSZipVolume
.DFWADReadDirectory ();
291 fofs
, fpksize
: LongWord;
292 curpath
, fname
: string;
293 name
: packed array [0..15] of Char;
296 fFileStream
.Seek(6, soCurrent
); // skip signature
297 fcnt
:= readWord(fFileStream
);
298 if fcnt
= 0 then exit
;
300 for f
:= 0 to fcnt
-1 do
302 fFileStream
.ReadBuffer(name
[0], 16);
303 fofs
:= readLongWord(fFileStream
);
304 fpksize
:= readLongWord(fFileStream
);
307 while (c
< 16) and (name
[c
] <> #0) do
309 if name
[c
] = '\' then name
[c
] := '/'
310 else if name
[c
] = '/' then name
[c
] := '_';
311 fname
:= fname
+name
[c
];
315 if (fofs
= 0) and (fpksize
= 0) then
317 if length(fname
) <> 0 then fname
:= fname
+'/';
321 if length(fname
) = 0 then continue
; // just in case
322 //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
323 // create file record
324 fi
:= TSFSZipFileInfo
.Create(self
);
327 fi
.fPackSz
:= fpksize
;
334 procedure TSFSZipVolume
.ReadDirectory ();
337 sfszvZIP
: ZIPReadDirectory();
338 sfszvDFWAD
: DFWADReadDirectory();
339 else raise ESFSError
.Create('invalid archive');
343 function TSFSZipVolume
.OpenFileByIndex (const index
: Integer): TStream
;
349 if fFiles
= nil then exit
;
350 if (index
< 0) or (index
>= fFiles
.Count
) or (fFiles
[index
] = nil) then exit
;
352 if TSFSZipFileInfo(fFiles
[index
]).fMethod
= 0 then
354 result
:= TSFSPartialStream
.Create(fFileStream
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fSize
, false);
358 rs
:= TSFSPartialStream
.Create(fFileStream
, TSFSZipFileInfo(fFiles
[index
]).fOfs
, TSFSZipFileInfo(fFiles
[index
]).fPackSz
, false);
359 result
:= TUnZStream
.Create(rs
, TSFSZipFileInfo(fFiles
[index
]).fSize
, true, (TSFSZipFileInfo(fFiles
[index
]).fMethod
<> 255));
369 { TSFSZipVolumeFactory }
370 function TSFSZipVolumeFactory
.IsMyVolumePrefix (const prefix
: AnsiString): Boolean;
373 StrEquCI1251(prefix
, 'zip') or
374 StrEquCI1251(prefix
, 'pk3') or
375 StrEquCI1251(prefix
, 'dfwad');
378 procedure TSFSZipVolumeFactory
.Recycle (vol
: TSFSVolume
);
383 function TSFSZipVolumeFactory
.Produce (const prefix
, fileName
: AnsiString; st
: TStream
): TSFSVolume
;
385 vt
: TSFSZipVolumeType
;
388 if ZIPCheckMagic(st
) then vt
:= sfszvZIP
389 else if DFWADCheckMagic(st
) then vt
:= sfszvDFWAD
;
391 if vt
<> sfszvNone
then
393 result
:= TSFSZipVolume
.Create(fileName
, st
);
394 TSFSZipVolume(result
).fType
:= vt
;
396 result
.DoDirectoryRead();
397 except {$IFDEF SFS_DEBUG_ZIPFS} on e
: Exception
do begin
398 WriteLn(errOutput
, 'ZIP ERROR: [', e
.ClassName
, ']: ', e
.Message);
402 {$IFDEF SFS_DEBUG_ZIPFS}end;{$ENDIF}
413 zipf
: TSFSZipVolumeFactory
;
415 zipf
:= TSFSZipVolumeFactory
.Create();
416 SFSRegisterVolumeFactory(zipf
);
418 // SFSUnregisterVolumeFactory(zipf);