summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 925cb8b)
raw | patch | inline | side by side (parent: 925cb8b)
| author | DeaDDooMER <deaddoomer@deadsoftware.ru> | |
| Tue, 18 Sep 2018 15:32:12 +0000 (18:32 +0300) | ||
| committer | DeaDDooMER <deaddoomer@deadsoftware.ru> | |
| Tue, 18 Sep 2018 15:32:12 +0000 (18:32 +0300) |
12 files changed:
| src/editor/Editor.lpr | patch | blob | history | |
| src/editor/f_addresource.pas | patch | blob | history | |
| src/editor/f_addresource_sky.pas | patch | blob | history | |
| src/editor/f_addresource_sound.pas | patch | blob | history | |
| src/editor/f_addresource_texture.pas | patch | blob | history | |
| src/editor/f_main.pas | patch | blob | history | |
| src/editor/g_resources.pas | [new file with mode: 0644] | patch | blob |
| src/editor/g_textures.pas | patch | blob | history | |
| src/sfs/sfs.pas | [new file with mode: 0644] | patch | blob |
| src/sfs/sfsPlainFS.pas | [new file with mode: 0644] | patch | blob |
| src/sfs/sfsZipFS.pas | [new file with mode: 0644] | patch | blob |
| src/shared/xstreams.pas | [new file with mode: 0644] | patch | blob |
diff --git a/src/editor/Editor.lpr b/src/editor/Editor.lpr
index 8bd60c2e3f98df376d9203d5c42743332cebdd36..21d8fe5df9a97c8f5cf532dac8b453175148170d 100644 (file)
--- a/src/editor/Editor.lpr
+++ b/src/editor/Editor.lpr
WADEDITOR in '../shared/WADEDITOR.pas',
WADSTRUCT in '../shared/WADSTRUCT.pas',
CONFIG in '../shared/CONFIG.pas',
+ xstreams in '../shared/xstreams.pas',
+ sfs in '../sfs/sfs.pas',
+ sfsPlainFS in '../sfs/sfsPlainFS.pas',
+ sfsZipFS in '../sfs/sfsZipFS.pas',
+
f_about in 'f_about.pas' {AboutForm},
f_options in 'f_options.pas' {OptionsForm},
f_main in 'f_main.pas' {MainForm},
index 815fb1f38a8961a25fff67b9e211aa7d567a51a2..69b214e75e6a48b451335859dd9465950be05890 100644 (file)
implementation
uses
- f_main, WADSTRUCT, g_language, utils;
+ f_main, WADSTRUCT, g_language, utils, sfs;
{$R *.lfm}
STANDART_WAD = 'Standart.wad';
procedure TAddResourceForm.FormActivate(Sender: TObject);
-var
- SR: TSearchRec;
-
+ var
+ SR: TSearchRec;
begin
cbWADList.Clear();
cbSectionsList.Clear();
FResourceSelected := False;
ChDir(EditorDir);
- if FindFirst(EditorDir+'wads/*.wad', faAnyFile, SR) = 0 then
+ if FindFirst(EditorDir + 'wads/*.*', faAnyFile, SR) = 0 then
repeat
- cbWADList.Items.Add(SR.Name);
+ if (SR.name <> '.') and (SR.name <> '..') then
+ cbWADList.Items.Add(SR.Name);
until FindNext(SR) <> 0;
FindClose(SR);
end;
procedure TAddResourceForm.cbWADListChange(Sender: TObject);
-var
- WAD: TWADEditor_1;
- SectionList: SArray;
- i: Integer;
- FileName, fn, sn, rn: String;
-
+ var
+ wad: TSFSFileList;
+ i: Integer;
+ FileName, Section, sn, rn: String;
begin
- WAD := TWADEditor_1.Create();
-
-// Внешний WAD:
if cbWADList.Text <> _lc[I_WAD_SPECIAL_MAP] then
- FileName := EditorDir+'wads/'+cbWADList.Text
- else // WAD карты:
- begin
- g_ProcessResourceStr(OpenedMap, fn, sn, rn);
- FileName := fn;
- end;
-
-// Читаем секции:
- WAD.ReadFile(FileName);
- SectionList := WAD.GetSectionList();
- WAD.Free();
+ FileName := EditorDir + 'wads/' + cbWADList.Text (* Resource wad *)
+ else
+ g_ProcessResourceStr(OpenedMap, FileName, sn, rn); (* Map wad *)
cbSectionsList.Clear();
lbResourcesList.Clear();
- if SectionList <> nil then
- for i := 0 to High(SectionList) do
- if SectionList[i] <> '' then
- cbSectionsList.Items.Add(win2utf(SectionList[i]))
- else
- cbSectionsList.Items.Add('..');
+ wad := SFSFileList(FileName);
+ if wad <> nil then
+ begin
+ for i := 0 to wad.Count - 1 do
+ begin
+ Section := win2utf(Copy(wad.Files[i].path, 1, Length(wad.Files[i].path) - 1));
+ if cbSectionsList.Items.IndexOf(Section) = -1 then
+ cbSectionsList.Items.Add(Section)
+ end;
+ wad.Destroy
+ end;
+
+ (* Update resource list (see below) *)
+ cbSectionsListChange(Sender)
end;
procedure TAddResourceForm.cbSectionsListChange(Sender: TObject);
-var
- ResourceList: SArray;
- WAD: TWADEditor_1;
- i: DWORD;
- FileName, SectionName, fn, sn, rn: String;
-
+ var
+ wad: TSFSFileList;
+ i: Integer;
+ FileName, Section, SectionName, sn, rn: String;
begin
- WAD := TWADEditor_1.Create();
-
-// Внешний WAD:
if cbWADList.Text <> _lc[I_WAD_SPECIAL_MAP] then
- FileName := EditorDir+'wads/'+cbWADList.Text
- else // WAD карты:
- begin
- g_ProcessResourceStr(OpenedMap, fn, sn, rn);
- FileName := fn;
- end;
-
-// Читаем WAD:
- WAD.ReadFile(FileName);
-
- if cbSectionsList.Text <> '..' then
- SectionName := cbSectionsList.Text
+ FileName := EditorDir + 'wads/' + cbWADList.Text (* Resource wad *)
else
- SectionName := '';
-
-// Читаем ресурсы выбранной секции:
- ResourceList := WAD.GetResourcesList(utf2win(SectionName));
-
- WAD.Free();
+ g_ProcessResourceStr(OpenedMap, FileName, sn, rn); (* Map wad *)
+ SectionName := cbSectionsList.Text;
lbResourcesList.Clear();
- if ResourceList <> nil then
- for i := 0 to High(ResourceList) do
- lbResourcesList.Items.Add(win2utf(ResourceList[i]));
+ wad := SFSFileList(FileName);
+ if wad <> nil then
+ begin
+ for i := 0 to wad.Count - 1 do
+ begin
+ Section := win2utf(Copy(wad.Files[i].path, 1, Length(wad.Files[i].path) - 1));
+ if Section = SectionName then
+ lbResourcesList.Items.Add(win2utf(wad.Files[i].name))
+ end;
+ wad.Destroy
+ end;
end;
procedure TAddResourceForm.lbResourcesListClick(Sender: TObject);
-var
- FileName, SectionName, fn: String;
-
+ var
+ FileName, fn: String;
begin
- FResourceSelected := (lbResourcesList.SelCount > 0) or
- (lbResourcesList.ItemIndex > -1);
-
+ FResourceSelected := (lbResourcesList.SelCount > 0) or (lbResourcesList.ItemIndex > -1);
if not FResourceSelected then
begin
FResourceName := '';
Exit;
end;
- if cbSectionsList.Text = '..' then
- SectionName := ''
- else
- SectionName := cbSectionsList.Text;
-
if cbWADList.Text[1] <> '<' then
FileName := cbWADList.Text
else
FileName := '';
- FResourceName := FileName+':'+SectionName+'\'+lbResourcesList.Items[lbResourcesList.ItemIndex];
+ FResourceName := FileName + ':' + cbSectionsList.Text + '\' + lbResourcesList.Items[lbResourcesList.ItemIndex];
+ g_ProcessResourceStr(OpenedMap, @fn, nil, nil);
if FileName <> '' then
- FFullResourceName := EditorDir+'wads/'+FResourceName
+ FFullResourceName := EditorDir + 'wads/' + FResourceName
else
- begin
- g_ProcessResourceStr(OpenedMap, @fn, nil, nil);
- FFullResourceName := fn+FResourceName;
- end;
+ FFullResourceName := fn + FResourceName
end;
end.
index 98a8026ac10961fb13f3f1fe8fb493d1af1dcd05..49034d2239db2e0ff74db35a9d7756ef21496e92 100644 (file)
implementation
uses
- BinEditor, WADEDITOR, f_main, g_language;
+ WADEDITOR, f_main, g_language, g_resources;
{$R *.lfm}
BitMap: TBitMap;
TextureData: Pointer;
- WAD: TWADEditor_1;
WADName: String;
SectionName: String;
ResourceName: String;
begin
Result := nil;
-
-// Загружаем ресурс текстуры из WAD:
g_ProcessResourceStr(ResourceStr, WADName, SectionName, ResourceName);
-
- WAD := TWADEditor_1.Create();
- WAD.ReadFile(WADName);
-
- WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), TextureData, ImageSize);
-
- WAD.Free();
+ g_ReadResource(WADName, SectionName, ResourceName, TextureData, ImageSize);
InitImage(img);
if not LoadImageFromMemory(TextureData, ImageSize, img) then
index c6406d0769f032f19fa96621a193538f9106a6a0..15ea34df25db38089339dacd558aafa618435ba1 100644 (file)
implementation
uses
- BinEditor, WADEDITOR, e_log, f_main, g_language
+ BinEditor, WADEDITOR, e_log, f_main, g_language, g_resources
{$IFNDEF NOSOUND}, fmod, fmodtypes, fmoderrors;{$ELSE};{$ENDIF}
{$R *.lfm}
function CreateSoundWAD(Resource: String): Boolean;
var
- WAD: TWADEditor_1;
FileName, SectionName, ResourceName: String;
ResLength: Integer;
sz: LongWord;
Channel := nil;
{$IFNDEF NOSOUND}
g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
+ g_ReadResource(FileName, SectionName, ResourceName, SoundData, ResLength);
- WAD := TWADEditor_1.Create;
- WAD.ReadFile(FileName);
-
- if WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), SoundData, ResLength) then
+ if SoundData <> nil then
begin
sz := SizeOf(FMOD_CREATESOUNDEXINFO);
FillMemory(@soundExInfo, sz, 0);
begin
e_WriteLog(Format('Error creating sound %s', [Resource]), MSG_WARNING);
e_WriteLog(FMOD_ErrorString(res), MSG_WARNING);
- WAD.Free();
Exit;
end;
end
else
begin
e_WriteLog(Format('Error loading sound %s', [Resource]), MSG_WARNING);
- e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
- WAD.Free();
+ //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
Exit;
end;
- WAD.Free();
Result := True;
{$ENDIF}
end;
index 32a4da1d8b8c96597489e82f5474cb9f50f438ab..62d0fd5239877ede9ddf3af790bc81ce02dcae3c 100644 (file)
uses
BinEditor, WADEDITOR, WADSTRUCT, f_main, g_textures, CONFIG, g_map,
- g_language;
+ g_language, e_Log, g_resources;
{$R *.lfm}
function IsAnim(Res: String): Boolean;
-var
- WAD: TWADEditor_1;
- WADName: String;
- SectionName: String;
- ResourceName: String;
- Data: Pointer;
- Size: Integer;
- Sign: Array [0..4] of Char;
- Sections,
- Resources: SArray;
- a: Integer;
- ok: Boolean;
-
+ var
+ data: Pointer;
+ len: Integer;
+ WADName, SectionName, ResourceName: String;
begin
- Result := False;
- Data := nil;
- Size := 0;
-
-// Читаем файл и ресурс в нем:
g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
-
- WAD := TWADEditor_1.Create();
-
- if (not WAD.ReadFile(WADName)) or
- (not WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), Data, Size)) then
- begin
- WAD.Free();
- Exit;
- end;
-
- WAD.FreeWAD();
-
-// Проверка сигнатуры. Если есть - это WAD внутри WAD:
- CopyMemory(@Sign[0], Data, 5);
-
- if not (Sign = DFWAD_SIGNATURE) then
- begin
- WAD.Free();
- FreeMem(Data);
- Exit;
- end;
-
-// Пробуем прочитать данные:
- if not WAD.ReadMemory(Data, Size) then
- begin
- WAD.Free();
- FreeMem(Data);
- Exit;
- end;
-
- FreeMem(Data);
-
-// Читаем секции:
- Sections := WAD.GetSectionList();
-
- if Sections = nil then
- begin
- WAD.Free();
- Exit;
- end;
-
-// Ищем в секциях "TEXT":
- ok := False;
- for a := 0 to High(Sections) do
- if Sections[a] = 'TEXT' then
- begin
- ok := True;
- Break;
- end;
-
-// Ищем в секциях лист текстур - "TEXTURES":
- for a := 0 to High(Sections) do
- if Sections[a] = 'TEXTURES' then
- begin
- ok := ok and True;
- Break;
- end;
-
- if not ok then
- begin
- WAD.Free();
- Exit;
- end;
-
-// Получаем ресурсы секции "TEXT":
- Resources := WAD.GetResourcesList('TEXT');
-
- if Resources = nil then
- begin
- WAD.Free();
- Exit;
- end;
-
-// Ищем в них описание анимации - "ANIM":
- ok := False;
- for a := 0 to High(Resources) do
- if Resources[a] = 'ANIM' then
- begin
- ok := True;
- Break;
- end;
-
- WAD.Free();
-
-// Если все получилось, то это аним. текстура:
- Result := ok;
+ (* just check file existance *)
+ g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXT', 'ANIM', data, len);
+ (* TODO check section TEXTURES *)
+ Result := data <> nil;
+ if data <> nil then
+ FreeMem(data)
end;
-function GetFrame(Res: String; var Data: Pointer; var DataLen: Integer;
- var Width, Height: Word): Boolean;
-var
- AnimWAD: Pointer;
- WAD: TWADEditor_1;
- WADName: String;
- SectionName: String;
- ResourceName: String;
- Len: Integer;
- config: TConfig;
- TextData: Pointer;
-
+function GetFrame (Res: String; var Data: Pointer; var DataLen: Integer; var Width, Height: Word): Boolean;
+ var
+ Len: Integer;
+ TextData: Pointer;
+ WADName, SectionName, ResourceName: String;
+ config: TConfig;
begin
- Result := False;
- AnimWAD := nil;
- Len := 0;
- TextData := nil;
-
-// Читаем WAD:
+ Result := False; Data := nil; DataLen := 0; Width := 0; Height := 0;
g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
-
- WAD := TWADEditor_1.Create();
-
- if not WAD.ReadFile(WADName) then
- begin
- WAD.Free();
- Exit;
- end;
-
-// Читаем WAD-ресурс из WAD:
- if not WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), AnimWAD, Len) then
- begin
- WAD.Free();
- Exit;
- end;
-
- WAD.FreeWAD();
-
-// Читаем WAD в WAD'е:
- if not WAD.ReadMemory(AnimWAD, Len) then
- begin
- FreeMem(AnimWAD);
- WAD.Free();
- Exit;
- end;
-
-// Читаем описание анимации:
- if not WAD.GetResource('TEXT', 'ANIM', TextData, Len) then
+ g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXT', 'ANIM', TextData, Len);
+ if TextData <> nil then
begin
- FreeMem(TextData);
- FreeMem(AnimWAD);
- WAD.Free();
- Exit;
- end;
-
- config := TConfig.CreateMem(TextData, Len);
-
-// Читаем ресурс - лист текстур:
- if not WAD.GetResource('TEXTURES', config.ReadStr('', 'resource', ''), Data, Len) then
- begin
- FreeMem(TextData);
- FreeMem(AnimWAD);
- WAD.Free();
- Exit;
- end;
-
- DataLen := Len;
-
- Height := config.ReadInt('', 'frameheight', 0);
- Width := config.ReadInt('', 'framewidth', 0);
-
- config.Free();
- WAD.Free();
-
- FreeMem(TextData);
- FreeMem(AnimWAD);
-
- Result := True;
+ config := TConfig.CreateMem(TextData, Len);
+ g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXTURES', config.ReadStr('', 'resource', ''), Data, DataLen);
+ if Data <> nil then
+ begin
+ Height := config.ReadInt('', 'frameheight', 0);
+ Width := config.ReadInt('', 'framewidth', 0);
+ Result := True
+ end;
+ config.Free();
+ FreeMem(TextData)
+ end
end;
function CreateBitMap(Data: Pointer; DataSize: Cardinal): TBitMap;
end;
function ShowAnim(Res: String): TBitMap;
-var
- AnimWAD: Pointer;
- WAD: TWADEditor_1;
- WADName: String;
- SectionName: String;
- ResourceName: String;
- Len: Integer;
- config: TConfig;
- TextData: Pointer;
- TextureData: Pointer;
-
+ var
+ Len: Integer;
+ TextData, TextureData: Pointer;
+ WADName, SectionName, ResourceName: String;
+ config: TConfig;
begin
Result := nil;
- AnimWAD := nil;
- Len := 0;
- TextData := nil;
- TextureData := nil;
-
-// Читаем WAD файл и ресурс в нем:
g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
-
- WAD := TWADEditor_1.Create();
- WAD.ReadFile(WADName);
- WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), AnimWAD, Len);
- WAD.FreeWAD();
-
-// Читаем описание анимации:
- WAD.ReadMemory(AnimWAD, Len);
- WAD.GetResource('TEXT', 'ANIM', TextData, Len);
-
- config := TConfig.CreateMem(TextData, Len);
-
-// Читаем лист текстур:
- WAD.GetResource('TEXTURES', config.ReadStr('', 'resource', ''), TextureData, Len);
- NumFrames := config.ReadInt('', 'framecount', 0);
-
- if (TextureData <> nil) and
- (WAD.GetLastError = DFWAD_NOERROR) then
+ g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXT', 'ANIM', TextData, Len);
+ if TextData <> nil then
begin
- // Создаем BitMap из листа текстур:
- Result := CreateBitMap(TextureData, Len);
-
- // Размеры одного кадра - виден только первый кадр:
- Result.Height := config.ReadInt('', 'frameheight', 0);
- Result.Width := config.ReadInt('', 'framewidth', 0);
- end;
-
- config.Free();
- WAD.Free();
-
- FreeMem(TextureData);
- FreeMem(TextData);
- FreeMem(AnimWAD);
+ config := TConfig.CreateMem(TextData, Len);
+ g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXTURES', config.ReadStr('', 'resource', ''), TextureData, Len);
+ if TextureData <> nil then
+ begin
+ Result := CreateBitMap(TextureData, Len);
+ (* view only first frame *)
+ NumFrames := config.ReadInt('', 'framecount', 0);
+ Result.Height := config.ReadInt('', 'frameheight', 0);
+ Result.Width := config.ReadInt('', 'framewidth', 0);
+ FreeMem(TextureData)
+ end;
+ config.Free();
+ FreeMem(TextData)
+ end
end;
function ShowTGATexture(ResourceStr: String): TBitMap;
-var
- TextureData: Pointer;
- WAD: TWADEditor_1;
- WADName: String;
- SectionName: String;
- ResourceName: String;
- Len: Integer;
-
+ var
+ Len: Integer;
+ TextureData: Pointer;
+ WADName, SectionName, ResourceName: String;
begin
Result := nil;
- TextureData := nil;
- Len := 0;
-
-// Читаем WAD:
g_ProcessResourceStr(ResourceStr, WADName, SectionName, ResourceName);
-
- WAD := TWADEditor_1.Create();
- if not WAD.ReadFile(WADName) then
- begin
- WAD.Free();
- Exit;
- end;
-
-// Читаем ресурс текстуры в нем:
- WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), TextureData, Len);
-
- WAD.Free();
-
-// Создаем на его основе BitMap:
- Result := CreateBitMap(TextureData, Len);
-
- FreeMem(TextureData);
+ g_ReadResource(WADName, SectionName, ResourceName, TextureData, Len);
+ if TextureData <> nil then
+ Result := CreateBitMap(TextureData, Len)
end;
procedure TAddTextureForm.FormActivate(Sender: TObject);
diff --git a/src/editor/f_main.pas b/src/editor/f_main.pas
index e2635344a0977677c10d8bf4e71ec0a2470fcfb9..3f65bba33336ec96c8a80a4f7a8c0f0e268a3efa 100644 (file)
--- a/src/editor/f_main.pas
+++ b/src/editor/f_main.pas
MAPREADER, f_selectmap, f_savemap, WADEDITOR, WADSTRUCT, MAPDEF,
g_map, f_saveminimap, f_addresource, CONFIG, f_packmap,
f_addresource_sound, f_maptest, f_choosetype,
- g_language, f_selectlang, ClipBrd;
+ g_language, f_selectlang, ClipBrd, g_resources;
const
UNDO_DELETE_PANEL = 1;
cwdt, chgt: Byte;
spc: ShortInt;
ID: DWORD;
- wad: TWADEditor_1;
cfgdata: Pointer;
cfglen: Integer;
config: TConfig;
begin
- cfgdata := nil;
- cfglen := 0;
ID := 0;
-
- wad := TWADEditor_1.Create;
- if wad.ReadFile(EditorDir+'data/Game.wad') then
- wad.GetResource('FONTS', cfgres, cfgdata, cfglen);
- wad.Free();
-
- if cfglen <> 0 then
+ g_ReadResource(EditorDir + 'data/Game.wad', 'FONTS', cfgres, cfgdata, cfglen);
+ if cfgdata <> nil then
begin
- if not g_CreateTextureWAD('FONT_STD', EditorDir+'data/Game.wad:FONTS\'+texture) then
+ if not g_CreateTextureWAD('FONT_STD', EditorDir + 'data/Game.wad:FONTS\' + texture) then
e_WriteLog('ERROR ERROR ERROR', MSG_WARNING);
config := TConfig.CreateMem(cfgdata, cfglen);
spc := Min(Max(config.ReadInt('FontMap', 'Kerning', 0), -128), 127);
if g_GetTexture('FONT_STD', ID) then
- e_TextureFontBuild(ID, FontID, cwdt, chgt, spc-2);
+ e_TextureFontBuild(ID, FontID, cwdt, chgt, spc - 2);
config.Free();
+ FreeMem(cfgdata)
end
else
- e_WriteLog('Could not load FONT_STD', MSG_WARNING);
-
- if cfglen <> 0 then FreeMem(cfgdata);
+ begin
+ e_WriteLog('Could not load FONT_STD', MSG_WARNING)
+ end
end;
procedure TMainForm.FormCreate(Sender: TObject);
diff --git a/src/editor/g_resources.pas b/src/editor/g_resources.pas
--- /dev/null
@@ -0,0 +1,79 @@
+unit g_resources;
+
+interface
+
+ procedure g_ReadResource (wad, section, name: String; out data: PByte; out len: Integer);
+ procedure g_ReadSubResource (wad, section0, name0, section1, name1: String; out data: PByte; out len: Integer);
+
+implementation
+
+ uses sfs, utils, Classes;
+
+ procedure g_ReadResource (wad, section, name: String; out data: PByte; out len: Integer);
+ var
+ stream: TStream;
+ str: String;
+ i: Integer;
+ begin
+ section := utf2win(section);
+ name := utf2win(name);
+ data := nil;
+ len := 0;
+ sfsGCDisable;
+ if SFSAddDataFileTemp(wad) then
+ begin
+ str := SFSGetLastVirtualName(section + '\' + name);
+ stream := SFSFileOpen(wad + '::' + str);
+ if stream <> nil then
+ begin
+ len := stream.Size;
+ GetMem(data, len);
+ //stream.ReadBuffer(data, len); (* leads to segfault *)
+ for i := 0 to len - 1 do
+ data[i] := stream.ReadByte();
+ stream.Destroy
+ end
+ end;
+ sfsGCEnable
+ end;
+
+ procedure g_ReadSubResource (wad, section0, name0, section1, name1: String; out data: PByte; out len: Integer);
+ var
+ stream0, stream1: TStream;
+ str0, str1: String;
+ i: Integer;
+ begin
+ section0 := utf2win(section0);
+ name0 := utf2win(name0);
+ section1 := utf2win(section1);
+ name1 := utf2win(name1);
+ data := nil;
+ len := 0;
+ sfsGCDisable;
+ if SFSAddDataFile(wad) then
+ begin
+ str0 := SFSGetLastVirtualName(section0 + '\' + name0);
+ stream0 := SFSFileOpen(wad + '::' + str0);
+ if stream0 <> nil then
+ begin
+ if SFSAddSubDataFile(wad + '\' + str0, stream0) then
+ begin
+ str1 := SFSGetLastVirtualName(section1 + '\' + name1);
+ stream1 := SFSFileOpen(wad + '\' + str0 + '::' + str1);
+ if stream1 <> nil then
+ begin
+ len := stream1.Size;
+ GetMem(data, len);
+ //stream1.ReadBuffer(data, len); (* leads to segfault *)
+ for i := 0 to len - 1 do
+ data[i] := stream1.ReadByte();
+ stream1.Destroy
+ end
+ end;
+ //stream0.Destroy (* leads to memory corruption *)
+ end
+ end;
+ sfsGCEnable;
+ end;
+
+end.
index 786229a847ef6dd5777801191e59647400c89950..52c6169b807bf8cd88d4cb6db89a171f0abfb017 100644 (file)
implementation
uses
- e_log, WADEDITOR, g_basic, SysUtils;
+ e_log, WADEDITOR, g_basic, SysUtils, g_resources;
type
_TTexture = record
end;
end;
-function g_SimpleCreateTextureWAD(var ID: DWORD; Resource: string): Boolean;
-var
- WAD: TWADEditor_1;
- FileName,
- SectionName,
- ResourceName: string;
- TextureData: Pointer;
- ResourceLength: Integer;
+function g_SimpleCreateTextureWAD (var ID: DWORD; Resource: string): Boolean;
+ var
+ TextureData: Pointer;
+ ResourceLength: Integer;
+ FileName, SectionName, ResourceName: string;
begin
- Result := False;
- g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
-
- WAD := TWADEditor_1.Create;
- WAD.ReadFile(FileName);
-
- if WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), TextureData, ResourceLength) then
- begin
- if e_CreateTextureMem(TextureData, ResourceLength, ID) then Result := True;
- FreeMem(TextureData);
- end
+ Result := False;
+ g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
+ g_ReadResource(FileName, SectionName, ResourceName, TextureData, ResourceLength);
+ if TextureData <> nil then
+ begin
+ if e_CreateTextureMem(TextureData, ResourceLength, ID) then
+ Result := True;
+ FreeMem(TextureData)
+ end
else
- begin
- e_WriteLog(Format('Error loading texture %s', [Resource]), MSG_WARNING);
- e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
- end;
- WAD.Destroy;
+ begin
+ e_WriteLog(Format('Error loading texture %s', [Resource]), MSG_WARNING)
+ //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
+ end;
end;
function g_CreateTextureMemorySize(pData: Pointer; dataLen: Integer; Name: ShortString; X, Y,
end;
function g_CreateTextureWAD(TextureName: ShortString; Resource: string; flag: Byte = 0): Boolean;
-var
- WAD: TWADEditor_1;
- FileName,
- SectionName,
- ResourceName: string;
- TextureData: Pointer;
- find_id: DWORD;
- ResourceLength: Integer;
+ var
+ TextureData: Pointer;
+ ResourceLength: Integer;
+ FileName, SectionName, ResourceName: string;
+ find_id: DWORD;
begin
- g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
-
- find_id := FindTexture;
-
- WAD := TWADEditor_1.Create;
- WAD.ReadFile(FileName);
-
- if WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), TextureData, ResourceLength) then
- begin
- Result := e_CreateTextureMem(TextureData, ResourceLength, TexturesArray[find_id].ID);
- FreeMem(TextureData);
- if Result then
- begin
- e_GetTextureSize(TexturesArray[find_id].ID, @TexturesArray[find_id].Width,
- @TexturesArray[find_id].Height);
- TexturesArray[find_id].Name := TextureName;
- TexturesArray[find_id].flag := flag;
- end;
- end
- else
- begin
- e_WriteLog(Format('Error loading texture %s', [Resource]), MSG_WARNING);
- e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
- Result := False;
- end;
- WAD.Destroy;
+ find_id := FindTexture;
+ g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
+ g_ReadResource(FileName, SectionName, ResourceName, TextureData, ResourceLength);
+ if TextureData <> nil then
+ begin
+ Result := e_CreateTextureMem(TextureData, ResourceLength, TexturesArray[find_id].ID);
+ FreeMem(TextureData);
+ if Result then
+ begin
+ e_GetTextureSize(
+ TexturesArray[find_id].ID,
+ @TexturesArray[find_id].Width,
+ @TexturesArray[find_id].Height
+ );
+ TexturesArray[find_id].Name := TextureName;
+ TexturesArray[find_id].flag := flag
+ end
+ end
+ else
+ begin
+ e_WriteLog(Format('Error loading texture %s', [Resource]), MSG_WARNING);
+ //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
+ Result := False
+ end
end;
-function g_SimpleCreateTextureWADSize(var ID: DWORD; Resource: string;
- X, Y, Width, Height: Word): Boolean;
-var
- WAD: TWADEditor_1;
- FileName,
- SectionName,
- ResourceName: String;
- TextureData: Pointer;
- ResourceLength: Integer;
+function g_SimpleCreateTextureWADSize(var ID: DWORD; Resource: String; X, Y, Width, Height: Word): Boolean;
+ var
+ TextureData: Pointer;
+ ResourceLength: Integer;
+ FileName, SectionName, ResourceName: String;
begin
- Result := False;
- g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
-
- WAD := TWADEditor_1.Create;
- WAD.ReadFile(FileName);
-
- if WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), TextureData, ResourceLength) then
- begin
- if e_CreateTextureMemEx(TextureData, ResourceLength, ID, X, Y, Width, Height) then Result := True;
- FreeMem(TextureData);
- end
- else
- begin
- e_WriteLog(Format('Error loading texture %s', [Resource]), MSG_WARNING);
- e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
- end;
- WAD.Destroy;
+ Result := False;
+ g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
+ g_ReadResource(FileName, SectionName, ResourceName, TextureData, ResourceLength);
+ if TextureData <> nil then
+ begin
+ if e_CreateTextureMemEx(TextureData, ResourceLength, ID, X, Y, Width, Height) then
+ Result := True;
+ FreeMem(TextureData)
+ end
+ else
+ begin
+ e_WriteLog(Format('Error loading texture %s', [Resource]), MSG_WARNING)
+ //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING)
+ end
end;
-function g_CreateTextureWADSize(TextureName: ShortString; Resource: string;
- X, Y, Width, Height: Word; flag: Byte = 0): Boolean;
-var
- WAD: TWADEditor_1;
- FileName,
- SectionName,
- ResourceName: String;
- TextureData: Pointer;
- find_id: DWORD;
- ResourceLength: Integer;
+function g_CreateTextureWADSize(TextureName: ShortString; Resource: String; X, Y, Width, Height: Word; flag: Byte = 0): Boolean;
+ var
+ TextureData: Pointer;
+ ResourceLength: Integer;
+ FileName, SectionName, ResourceName: String;
+ find_id: DWORD;
begin
- g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
-
- find_id := FindTexture;
-
- WAD := TWADEditor_1.Create;
- WAD.ReadFile(FileName);
-
- if WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), TextureData, ResourceLength) then
- begin
- Result := e_CreateTextureMemEx(TextureData, ResourceLength, TexturesArray[find_id].ID, X, Y, Width, Height);
- FreeMem(TextureData);
- if Result then
+ find_id := FindTexture;
+ g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
+ g_ReadResource(FileName, SectionName, ResourceName, TextureData, ResourceLength);
+ if TextureData <> nil then
begin
- TexturesArray[find_id].Width := Width;
- TexturesArray[find_id].Height := Height;
- TexturesArray[find_id].Name := TextureName;
- TexturesArray[find_id].flag := flag;
- end;
- end
+ Result := e_CreateTextureMemEx(TextureData, ResourceLength, TexturesArray[find_id].ID, X, Y, Width, Height);
+ FreeMem(TextureData);
+ if Result then
+ begin
+ TexturesArray[find_id].Width := Width;
+ TexturesArray[find_id].Height := Height;
+ TexturesArray[find_id].Name := TextureName;
+ TexturesArray[find_id].flag := flag
+ end
+ end
else
- begin
- e_WriteLog(Format('Error loading texture %s', [Resource]), MSG_WARNING);
- e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
- Result := False;
- end;
- WAD.Destroy;
+ begin
+ e_WriteLog(Format('Error loading texture %s', [Resource]), MSG_WARNING);
+ //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
+ Result := False
+ end
end;
function g_GetTexture(TextureName: ShortString; var ID: DWORD): Boolean;
diff --git a/src/sfs/sfs.pas b/src/sfs/sfs.pas
--- /dev/null
+++ b/src/sfs/sfs.pas
@@ -0,0 +1,1274 @@
+(* Copyright (C) Doom 2D: Forever Developers
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <http://www.gnu.org/licenses/>.
+ *)
+// streaming file system (virtual)
+{$INCLUDE ../shared/a_modes.inc}
+{$SCOPEDENUMS OFF}
+{.$R+}
+{.$DEFINE SFS_VOLDEBUG}
+unit sfs;
+
+interface
+
+uses
+ SysUtils, Classes, Contnrs;
+
+
+type
+ ESFSError = class(Exception);
+
+ TSFSVolume = class;
+
+ TSFSFileInfo = class
+ public
+ fOwner: TSFSVolume; // òàê, íà âñÿêèé ñëó÷àé
+ fPath: AnsiString; // ðàçäåëèòåëè êàòàëîãîâ -- "/"; êîðåíü íèêàê íå îáîçíà÷åí, åñëè íå ïóñòîå, îáÿçàíî çàâåðøàòüñÿ "/"
+ fName: AnsiString; // òîëüêî èìÿ
+ fSize: Int64; // unpacked
+ fOfs: Int64; // in VFS (many of 'em need this %-)
+
+ constructor Create (pOwner: TSFSVolume);
+ destructor Destroy (); override;
+
+ property path: AnsiString read fPath;
+ property name: AnsiString read fName;
+ property size: Int64 read fSize; // can be -1 if size is unknown
+ end;
+
+ // âèðòóàëüíàÿ ôàéëîâàÿ ñèñòåìà. ÒÎËÜÊÎ ÄËß ×ÒÅÍÈß!
+ // òîì ÍÅ ÄÎËÆÅÍ óáèâàòüñÿ íèêàê èíà÷å, ÷åì ïðè ïîìîùè ôàáðèêè!
+ TSFSVolume = class
+ protected
+ fFileName: AnsiString;// îáû÷íî èìÿ îðèãèíàëüíîãî ôàéëà
+ fFileStream: TStream; // îáû÷íî ïîòîê äëÿ ÷òåíèÿ îðèãèíàëüíîãî ôàéëà
+ fFiles: TObjectList; // TSFSFileInfo èëè íàñëåäíèêè
+
+ // ïðèøèáèòü âñå ñòðóêòóðû.
+ // íå äîëæíà ïàäàòü, åñëè å¸ âûçûâàþò íåñêîëüêî ðàç.
+ procedure Clear (); virtual;
+
+ // âûçûâàåòñÿ èç DoDirectoryRead() äëÿ çàïîëíåíèÿ ñïèñêà ôàéëîâ.
+ // ñ÷èòàåòñÿ, ÷òî âñå ìàãèêè óæå ïðîâåðåíû è ôàéë òî÷íî íàø.
+ // fFileName, fFileStream óæå óñòàíîâëåíû, fFiles ñîçäàí,
+ // â í¸ì, ñêîðåå âñåãî, íèêîãî íåò.
+ // ïîçèöèÿ ïîòîêà -- òà, ÷òî îñòàâèëà ôàáðèêà.
+ // ïðè îøèáêàõ êèäàòü èñêëþ÷åíèå, òîãäà òîì áóäåò ïðèáèò ôàáðèêîé.
+ // ðàçäåëèòåëè ïóòåé äîëæíû áûòü òîëüêî "/", êîðíåâîé "/" äîëæåí
+ // áûòü îïóùåí, ïóòè (åñëè íå ïóñòûå) äîëæíû çàâåðøàòüñÿ "/"!
+ // fName äîëæíî ñîäåðæàòü òîëüêî èìÿ, fPath -- òîëüêî ïóòü.
+ // â ïðèíöèïå, îá ýòîì ïîçàáîòèòñÿ DoDirectoryRead(), íî çà÷åì
+ // äàâàòü åìó ëèøíþþ ðàáîòó?
+ procedure ReadDirectory (); virtual; abstract;
+
+ // íàéòè ôàéë, âåðíóòü åãî èíäåêñ â fFiles.
+ // ýòà ïðîöåäóðà ìîæåò ìåíÿòü fFiles!
+ // fPath -- â ïðàâèëüíîé ôîðìå, ñ "/", êîðíåâîé "/" óáèò, ôèíàëüíûé äîáàâëåí.
+ // åñëè ôàéë íå íàéäåí, âåðíóòü -1.
+ function FindFile (const fPath, fName: AnsiString): Integer; virtual;
+
+ // âîçâðàùàåò êîëè÷åñòâî ôàéëîâ â fFiles
+ function GetFileCount (): Integer; virtual;
+
+ // âîçâðàùàåò ôàéë ñ èíäåêñîì index.
+ // ìîæåò âîçâðàùàòü NIL.
+ // íèêàêèõ ïàäåíèé íà íåïðàâèëüíûå èíäåêñû!
+ function GetFiles (index: Integer): TSFSFileInfo; virtual;
+
+ public
+ // pSt íå îáÿçàòåëüíî çàïîìèíàòü, åñëè îí íå íóæåí.
+ constructor Create (const pFileName: AnsiString; pSt: TStream); virtual;
+ // fFileStream óíè÷òîæàòü íåëüçÿ, åñëè îí ðàâåí ïàðàìåòðó pSt êîíñòðóêòîðà.
+ destructor Destroy (); override;
+
+ // âûçûâàåò ReadDirectory().
+ // ýòà ïðîöåäóðà ñàìà ðàçáåð¸òñÿ ñ äóáëèêàòàìè èì¸í: ïîäîáàâëÿåò â
+ // êîíåö èì¸í-äóáëèêàòîâ ïîä÷¸ðêèâàíèå è äåñÿòè÷íûé íîìåð.
+ // òàêæå îíà íîðìàëèçóåò âèä èì¸í.
+ procedure DoDirectoryRead ();
+
+ // ïðè îøèáêàõ êèäàòüñÿ èñêëþ÷åíèÿìè.
+ function OpenFileByIndex (const index: Integer): TStream; virtual; abstract;
+
+ // åñëè íå ñìîãëî îòêóïîðèòü ôàéëî (èëè åù¸ ãäå îøèáëîñü), çàøâûðí¸ò èñêëþ÷åíèå.
+ function OpenFileEx (const fName: AnsiString): TStream; virtual;
+
+ property FileCount: Integer read GetFileCount; // ìîæåò âåðíóòü íîëü
+ // ìîæåò âîçâðàùàòü NIL.
+ // íèêàêèõ ïàäåíèé íà íåïðàâèëüíûå èíäåêñû!
+ property Files [index: Integer]: TSFSFileInfo read GetFiles;
+ end;
+
+ // ôàáðèêà òîìîâ. âñå SFS ïðè ñòàðòå äîáàâëÿþò ñâîè ôàáðèêè.
+ // áëàãîäàðÿ ýòîìó ìîæíî ñîçäàâàòü ðàçíûå âñÿêèå SFS ñòàíäàðòíûì
+ // âûçîâîì ñòàíäàðòíîé ïðîöåäóðû.
+ // ôàáðèêà ÍÅ ÄÎËÆÍÀ óáèâàòüñÿ íèêàê èíà÷å, ÷åì ïðè ïîìîùè âûçîâà
+ // SFSUnregisterVolumeFactory()! ýòî ãàðàíòèðóåò, ÷òî äâèæîê
+ // ïåðåä ðàññòðåëîì îòäàñò åé âñå å¸ òîìà.
+ TSFSVolumeFactory = class
+ public
+ // åñëè äîáàâëÿåì ôàéë äàííûõ ôàéë ñ èìåíåì òèïà "zip:....", òî
+ // SFS èçâëå÷¸ò ýòî "zip" è ïåðåäàñò â ñèþ ôóíêöèþ.
+ // åæåëè ôóíêöèÿ âåðí¸ò ïðàâäó, òî SFS âûçîâåò Produce äëÿ äàííîãî
+ // ôàéëà. åñëè íè îäíà ôàáðèêà ïðåôèêñ íå ïðèçíàåò, òî ôàéë íå îòêðîþò.
+ // èñïîëüçóåòñÿ äëÿ ñêèïàíèÿ àâòîäåòåêòà.
+ // SFS ÍÅ Ñ×ÈÒÀÅÒ ÏÐÅÔÈÊÑÎÌ ÑÒÐÎÊÓ ÊÎÐÎ×Å ÒÐ¨Õ ÑÈÌÂÎËÎÂ!
+ function IsMyVolumePrefix (const prefix: AnsiString): Boolean; virtual; abstract;
+ // ïðîâåðÿåò, ìîæåò ëè ôàáðèêà ñäåëàòü òîì äëÿ äàííîãî ôàéëà.
+ // st -- îòêðûòûé äëÿ ÷òåíèÿ ôàéëîâé ïîòîê. óêàçàòåëü ÷òåíèÿ ñòîèò â íà÷àëå.
+ // ýòîò ïîòîê íåëüçÿ çàêðûâàòü!
+ // prefix: òî, ÷òî áûëî ïåðåäàíî â IsMyVolumePrefix() èëè ''.
+ // èñêëþ÷åíèå ñ÷èòàåòñÿ îøèáêîé, âîçâðàò NIL ñ÷èòàåòñÿ îøèáêîé.
+ function Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume; virtual; abstract;
+ // êîãäà òîì áîëüøå íå íóæåí, îí áóäåò îòäàí ôàáðèêå íà ïåðåðàáîòêó.
+ // äàëåå äâèæîê íå áóäåò þçàòü ñåé òîì.
+ procedure Recycle (vol: TSFSVolume); virtual; abstract;
+ end;
+
+ // "èòåðàòîð", âîçâðàùàåìûé SFSFileList()
+ TSFSFileList = class
+ protected
+ fVolume: TSFSVolume;
+
+ function GetCount (): Integer;
+ function GetFiles (index: Integer): TSFSFileInfo;
+
+ public
+ constructor Create (const pVolume: TSFSVolume);
+ destructor Destroy (); override;
+
+ property Volume: TSFSVolume read fVolume;
+ property Count: Integer read GetCount;
+ // ïðè íåïðàâèëüíîì èíäåêñå ìîë÷à âåðí¸ò NIL.
+ // ïðè ïðàâèëüíîì òîæå ìîæåò âåðíóòü NIL!
+ // î÷åíü íå ñîâåòóþ ìåíÿòü ñîäåðæèìîå ïîëó÷åííîãî êëàññà.
+ // êîíå÷íî, ÿ ìîã áû âîçâðàùàòü íîâóþ ñòðóêòóðó èëè íå÷òî ïîõîæåå,
+ // íî áëèí, åñëè òû èäèîò è íå óìååøü äàæå êîììåíòû ÷èòàòü, òî
+ // êàêîãî òû âîîáùå â ïðîãðàììèíã ïîëåç?
+ property Files [index: Integer]: TSFSFileInfo read GetFiles; default;
+ end;
+
+
+procedure SFSRegisterVolumeFactory (factory: TSFSVolumeFactory);
+// ýòà ôóíêöèÿ àâòîìàòè÷åñêè ïðèáü¸ò factory.
+procedure SFSUnregisterVolumeFactory (factory: TSFSVolumeFactory);
+
+// äîáàâèòü ñáîðíèê â ïîñòîÿííûé ñïèñîê.
+// åñëè ñáîðíèê ñ òàêèì èìåíåì óæå îòêðûò, òî íå îòêðûâàåò åãî ïîâòîðíî.
+// íèêîãäà íå êèäàåò èñêëþ÷åíèé.
+// top: äîáàâèòü â íà÷àëî ñïèñêà ïîèñêà.
+// âåðí¸ò ëîæü ïðè îøèáêå.
+// ñïîñîáíî îòêðûâàòü ñáîðíèêè â ñáîðíèêàõ ïðè ïîìîùè êðóòûõ èì¸í a-la:
+// "zip:pack0::pack:pack1::wad2:pack2".
+// â äàëüíåéøåì ñëåäóåò îáðàùàòüñÿ ê ñáîðíèêó êàê "pack2::xxx".
+// èëè ìîæíî íàïèñàòü:
+// "zip:pack0::pack:pack1::wad2:pack2|datafile".
+// è îáðàùàòüñÿ êàê "datafile::xxx".
+// "||" ïðåîáðàçóþòñÿ â ïðîñòîé "|" è ðàçäåëèòåëåì íå ñ÷èòàþòñÿ.
+// ïðèíèìàåòñÿ âî âíèìàíèå òîëüêî ïîñëåäíÿÿ òðóáà.
+function SFSAddDataFile (const dataFileName: AnsiString; top: Boolean=false): Boolean;
+
+// äîáàâèòü ñáîðíèê âðåìåííî
+function SFSAddDataFileTemp (const dataFileName: AnsiString; top: Boolean=false): Boolean;
+
+// äîáàâèòü â ïîñòîÿííûé ñïèñîê ñáîðíèê èç ïîòîêà ds.
+// åñëè âîçâðàùàåò èñòèíó, òî SFS ñòàíîâèòñÿ âëÿäåëüöåì ïîòîêà ds è ñàìà
+// óãðîáèò ñåé ïîòîê ïî íåîáõîäèìîñòè.
+// virtualName ñòàíîâèòñÿ èìåíåì ñáîðíèêà äëÿ îïåðàöèè îòêðûòèÿ ôàéëà òèïà
+// "packfile:file.ext".
+// åñëè êàêîé-íèáóäü ñáîðíèê ñ èìåíåì virtualName óæå îòêðûò, âåðí¸ò false.
+// íèêîãäà íå êèäàåò èñêëþ÷åíèé.
+// top: äîáàâèòü â íà÷àëî ñïèñêà ïîèñêà.
+// âåðí¸ò ëîæü ïðè îøèáêå.
+// îòêðûâàåò ñáîðíèê èç ïîòîêà. dataFileName -- ÂÈÐÒÓÀËÜÍÎÅ èìÿ.
+// ò.å. íà ñàìîì äåëå òàêîãî ôàéëà ìîæåò è íå áûòü íà äèñêå.
+function SFSAddSubDataFile (const virtualName: AnsiString; ds: TStream; top: Boolean=false): Boolean;
+
+// øâûðÿåòñÿ èñêëþ÷åíèÿìè.
+// åñëè fName íå èìååò óêàçàíèÿ íà ôàéë äàííûõ (ýòî òî, ÷òî îòäåëåíî îò
+// îñòàëüíîãî èìåíè äâîåòî÷èåì), òî èùåì ñíà÷àëà ïî âñåì çàðåãèñòðèðîâàííûì
+// ôàéëàì äàííûõ, ïîòîì â òåêóùåì êàòàëîãå, ïîòîì â êàòàëîãå, îòêóäà ñòàðòîâàëè.
+// åñëè íè÷åãî íå íàøëè, êèäàåì èñêëþ÷åíèå.
+function SFSFileOpenEx (const fName: AnsiString): TStream;
+
+// ïðè îøèáêå -- NIL, è íèêàêèõ èñêëþ÷åíèé.
+function SFSFileOpen (const fName: AnsiString): TStream;
+
+// âîçâðàùàåò NIL ïðè îøèáêå.
+// ïîñëå èñïîëüçîâàíèÿ, íàòóðàëüíî, èòåðàòîð íàäî ãðîõíóòü %-)
+function SFSFileList (const dataFileName: AnsiString): TSFSFileList;
+
+// çàïðåòèòü îñâîáîæäåíèå âðåìåííûõ òîìîâ (ìîæíî âûçûâàòü ðåêóðñèâíî)
+procedure sfsGCDisable ();
+
+// ðàçðåøèòü îñâîáîæäåíèå âðåìåííûõ òîìîâ (ìîæíî âûçûâàòü ðåêóðñèâíî)
+procedure sfsGCEnable ();
+
+// for completeness sake
+procedure sfsGCCollect ();
+
+function SFSReplacePathDelims (const s: AnsiString; newDelim: Char): AnsiString;
+
+// ðàçîáðàòü òîëñòîå èìÿ ôàéëà, âåðíóòü âèðòóàëüíîå èìÿ ïîñëåäíåãî ñïèñêà
+// èëè ïóñòóþ ñòîðîêó, åñëè ñïèñêîâ íå áûëî.
+function SFSGetLastVirtualName (const fn: AnsiString): AnsiString;
+
+// Wildcard matching
+// this code is meant to allow wildcard pattern matches. tt is VERY useful
+// for matching filename wildcard patterns. tt allows unix grep-like pattern
+// comparisons, for instance:
+//
+// ? Matches any single characer
+// + Matches any single characer or nothing
+// * Matches any number of contiguous characters
+// [abc] Matches a or b or c at that position
+// [!abc] Matches anything but a or b or c at that position
+// [a-e] Matches a through e at that position
+//
+// 'ma?ch.*' -Would match match.exe, mavch.dat, march.on, etc
+// 'this [e-n]s a [!zy]est' -Would match 'this is a test', but would
+// not match 'this as a yest'
+//
+function WildMatch (pattern, text: AnsiString): Boolean;
+function WildListMatch (wildList, text: AnsiString; delimChar: AnsiChar=':'): Integer;
+function HasWildcards (const pattern: AnsiString): Boolean;
+
+
+var
+ // ïðàâäà: ðàçðåøåíî èñêàòü ôàéëî íå òîëüêî â ôàéëàõ äàííûõ, íî è íà äèñêå.
+ sfsDiskEnabled: Boolean = true;
+ // ïðàâäà: åñëè ôàéë íå ïðåôèêñîâàí, òî ñíà÷àëà èùåì ôàéëî íà äèñêå,
+ // ïîòîì â ôàéëàõ äàííûõ.
+ sfsDiskFirst: Boolean = true;
+ // ïðàâäà: äàæå äëÿ ïðåôèêñîâàíûõ ôàéëîâ ñíà÷àëà ïðîñìîòðèì äèñê
+ // (åñëè óñòàíîâëåí ôëàæîê sfsDiskFirst è sfsDiskEnabled).
+ sfsForceDiskForPrefixed: Boolean = false;
+ // ñïèñîê äèñêîâûõ êàòàëîãîâ äëÿ ïîèñêà ôàéëà. åñëè ïóñò -- èùåì òîëüêî â
+ // òåêóùåì. êàòàëîãè ðàçäåëÿþòñÿ òðóáîé ("|").
+ // <currentdir> çàìåíÿåòñÿ íà òåêóùèé êàòàëîã (ñ çàâåðøàþùèì "/"),
+ // <exedir> çàìåíÿåòñÿ íà êàòàëîã, ãäå ñèäèò .EXE (ñ çàâåðøàþùèì "/").
+ sfsDiskDirs: AnsiString = '<currentdir>|<exedir>';
+
+
+implementation
+
+uses
+ xstreams, utils;
+
+
+const
+ // character defines
+ WILD_CHAR_ESCAPE = '\';
+ WILD_CHAR_SINGLE = '?';
+ WILD_CHAR_SINGLE_OR_NONE = '+';
+ WILD_CHAR_MULTI = '*';
+ WILD_CHAR_RANGE_OPEN = '[';
+ WILD_CHAR_RANGE = '-';
+ WILD_CHAR_RANGE_CLOSE = ']';
+ WILD_CHAR_RANGE_NOT = '!';
+
+
+function HasWildcards (const pattern: AnsiString): Boolean;
+begin
+ result :=
+ (Pos(WILD_CHAR_ESCAPE, pattern) <> 0) or
+ (Pos(WILD_CHAR_SINGLE, pattern) <> 0) or
+ (Pos(WILD_CHAR_SINGLE_OR_NONE, pattern) <> 0) or
+ (Pos(WILD_CHAR_MULTI, pattern) <> 0) or
+ (Pos(WILD_CHAR_RANGE_OPEN, pattern) <> 0);
+end;
+
+function MatchMask (const pattern: AnsiString; p, pend: Integer; const text: AnsiString; t, tend: Integer): Boolean;
+var
+ rangeStart, rangeEnd: AnsiChar;
+ rangeNot, rangeMatched: Boolean;
+ ch: AnsiChar;
+begin
+ // sanity checks
+ if (pend < 0) or (pend > Length(pattern)) then pend := Length(pattern);
+ if (tend < 0) or (tend > Length(text)) then tend := Length(text);
+ if t < 1 then t := 1;
+ if p < 1 then p := 1;
+ while p <= pend do
+ begin
+ if t > tend then
+ begin
+ // no more text. check if there's no more chars in pattern (except "*" & "+")
+ while (p <= pend) and
+ ((pattern[p] = WILD_CHAR_MULTI) or
+ (pattern[p] = WILD_CHAR_SINGLE_OR_NONE)) do Inc(p);
+ result := (p > pend);
+ exit;
+ end;
+ case pattern[p] of
+ WILD_CHAR_SINGLE: ;
+ WILD_CHAR_ESCAPE:
+ begin
+ Inc(p);
+ if p > pend then result := false else result := (pattern[p] = text[t]);
+ if not result then exit;
+ end;
+ WILD_CHAR_RANGE_OPEN:
+ begin
+ result := false;
+ Inc(p); if p > pend then exit; // sanity check
+ rangeNot := (pattern[p] = WILD_CHAR_RANGE_NOT);
+ if rangeNot then begin Inc(p); if p > pend then exit; {sanity check} end;
+ if pattern[p] = WILD_CHAR_RANGE_CLOSE then exit; // sanity check
+ ch := text[t]; // speed reasons
+ rangeMatched := false;
+ repeat
+ if p > pend then exit; // sanity check
+ rangeStart := pattern[p];
+ if rangeStart = WILD_CHAR_RANGE_CLOSE then break;
+ Inc(p); if p > pend then exit; // sanity check
+ if pattern[p] = WILD_CHAR_RANGE then
+ begin
+ Inc(p); if p > pend then exit; // sanity check
+ rangeEnd := pattern[p]; Inc(p);
+ if rangeStart < rangeEnd then
+ begin
+ rangeMatched := (ch >= rangeStart) and (ch <= rangeEnd);
+ end
+ else rangeMatched := (ch >= rangeEnd) and (ch <= rangeStart);
+ end
+ else rangeMatched := (ch = rangeStart);
+ until rangeMatched;
+ if rangeNot = rangeMatched then exit;
+
+ // skip the rest or the range
+ while (p <= pend) and (pattern[p] <> WILD_CHAR_RANGE_CLOSE) do Inc(p);
+ if p > pend then exit; // sanity check
+ end;
+ WILD_CHAR_SINGLE_OR_NONE:
+ begin
+ Inc(p);
+ result := MatchMask(pattern, p, pend, text, t, tend);
+ if not result then result := MatchMask(pattern, p, pend, text, t+1, tend);
+ exit;
+ end;
+ WILD_CHAR_MULTI:
+ begin
+ while (p <= pend) and (pattern[p] = WILD_CHAR_MULTI) do Inc(p);
+ result := (p > pend); if result then exit;
+ while not result and (t <= tend) do
+ begin
+ result := MatchMask(pattern, p, pend, text, t, tend);
+ Inc(t);
+ end;
+ exit;
+ end;
+ else result := (pattern[p] = text[t]); if not result then exit;
+ end;
+ Inc(p); Inc(t);
+ end;
+ result := (t > tend);
+end;
+
+
+function WildMatch (pattern, text: AnsiString): Boolean;
+begin
+ if pattern <> '' then pattern := AnsiLowerCase(pattern);
+ if text <> '' then text := AnsiLowerCase(text);
+ result := MatchMask(pattern, 1, -1, text, 1, -1);
+end;
+
+function WildListMatch (wildList, text: AnsiString; delimChar: AnsiChar=':'): Integer;
+var
+ s, e: Integer;
+begin
+ if wildList <> '' then wildList := AnsiLowerCase(wildList);
+ if text <> '' then text := AnsiLowerCase(text);
+ result := 0;
+ s := 1;
+ while s <= Length(wildList) do
+ begin
+ e := s; while e <= Length(wildList) do
+ begin
+ if wildList[e] = WILD_CHAR_RANGE_OPEN then
+ begin
+ while (e <= Length(wildList)) and (wildList[e] <> WILD_CHAR_RANGE_CLOSE) do Inc(e);
+ end;
+ if wildList[e] = delimChar then break;
+ Inc(e);
+ end;
+ if s < e then
+ begin
+ if MatchMask(wildList, s, e-1, text, 1, -1) then exit;
+ end;
+ Inc(result);
+ s := e+1;
+ end;
+ result := -1;
+end;
+
+
+type
+ TVolumeInfo = class
+ public
+ fFactory: TSFSVolumeFactory;
+ fVolume: TSFSVolume;
+ fPackName: AnsiString; // äëÿ îäíîãî è òîãî æå ôàéëà áóäåò òîëüêî îäèí òîì!
+ fStream: TStream; // ôàéëîâûé ïîòîê äëÿ ñáîðíèêà
+ fPermanent: Boolean; // èñòèíà -- íå áóäåò óãðîáëåíà, åñëè íå îñòàíåòñÿ íè îäíîãî îòêðûòîãî òîìà
+ // èñòèíà -- ýòîò òîì áûë ñîçäàí èç ïîòîêà è íå èìååò äèñêîâîãî ôàéëà, ïîòîìó ôàáðèêå áóäåò ïåðåäàíî íå èìÿ ñáîðíèêà, à ïóñòàÿ ñòðîêà
+ fNoDiskFile: Boolean;
+ fOpenedFilesCount: Integer;
+
+ destructor Destroy (); override;
+ end;
+
+ TOwnedPartialStream = class (TSFSPartialStream)
+ protected
+ fOwner: TVolumeInfo;
+
+ public
+ constructor Create (pOwner: TVolumeInfo; pSrc: TStream; pPos, pSize: Int64; pKillSrc: Boolean);
+ destructor Destroy (); override;
+ end;
+
+
+var
+ factories: TObjectList; // TSFSVolumeFactory
+ volumes: TObjectList; // TVolumeInfo
+ gcdisabled: Integer = 0; // >0: disabled
+
+
+procedure sfsGCCollect ();
+var
+ f, c: Integer;
+ vi: TVolumeInfo;
+ used: Boolean;
+begin
+ // collect garbage
+ f := 0;
+ while f < volumes.Count do
+ begin
+ vi := TVolumeInfo(volumes[f]);
+ if vi = nil then continue;
+ if (not vi.fPermanent) and (vi.fOpenedFilesCount = 0) then
+ begin
+ // this volume probably can be removed
+ used := false;
+ c := volumes.Count-1;
+ while not used and (c >= 0) do
+ begin
+ if (c <> f) and (volumes[c] <> nil) then
+ begin
+ used := (TVolumeInfo(volumes[c]).fStream = vi.fStream);
+ if not used then used := (TVolumeInfo(volumes[c]).fVolume.fFileStream = vi.fStream);
+ if used then break;
+ end;
+ Dec(c);
+ end;
+ if not used then
+ begin
+ {$IFDEF SFS_VOLDEBUG}writeln('000: destroying volume "', TVolumeInfo(volumes[f]).fPackName, '"');{$ENDIF}
+ volumes.extract(vi); // remove from list
+ vi.Free; // and kill
+ f := 0;
+ continue;
+ end;
+ end;
+ Inc(f); // next volume
+ end;
+end;
+
+procedure sfsGCDisable ();
+begin
+ Inc(gcdisabled);
+end;
+
+procedure sfsGCEnable ();
+begin
+ Dec(gcdisabled);
+ if gcdisabled <= 0 then
+ begin
+ gcdisabled := 0;
+ sfsGCCollect();
+ end;
+end;
+
+
+// ðàçáèòü èìÿ ôàéëà íà ÷àñòè: ïðåôèêñ ôàéëîâîé ñèñòåìû, èìÿ ôàéëà äàííûõ,
+// ñîáñòâåííî èìÿ ôàéëà
+// èìÿ âûãëÿäèò êàê:
+// (("sfspfx:")?"datafile::")*"filename"
+procedure SplitFName (const fn: AnsiString; out dataFile, fileName: AnsiString);
+var
+ f: Integer;
+begin
+ f := Length(fn)-1;
+ while f >= 1 do
+ begin
+ if (fn[f] = ':') and (fn[f+1] = ':') then break;
+ Dec(f);
+ end;
+ if f < 1 then begin dataFile := ''; fileName := fn; end
+ else
+ begin
+ dataFile := Copy(fn, 1, f-1);
+ fileName := Copy(fn, f+2, maxInt-10000);
+ end;
+end;
+
+// ñàéäýôôåêò: âûðåçàåò âèðòóàëüíîå èìÿ èç dataFile.
+function ExtractVirtName (var dataFile: AnsiString): AnsiString;
+var
+ f: Integer;
+begin
+ f := Length(dataFile); result := dataFile;
+ while f > 1 do
+ begin
+ if dataFile[f] = ':' then break;
+ if dataFile[f] = '|' then
+ begin
+ if dataFile[f-1] = '|' then begin Dec(f); Delete(dataFile, f, 1); end
+ else
+ begin
+ result := Copy(dataFile, f+1, Length(dataFile));
+ Delete(dataFile, f, Length(dataFile));
+ break;
+ end;
+ end;
+ Dec(f);
+ end;
+end;
+
+// ðàçáèòü èìÿ ñáîðíèêà íà ÷àñòè: ïðåôèêñ ôàéëîâîé ñèñòåìû, èìÿ ôàéëà äàííûõ,
+// âèðòóàëüíîå èìÿ. åñëè âèðòóàëüíîãî èìåíè íå äàíî, îíî áóäåò ðàâíî dataFile.
+// èìÿ âûãëÿäèò êàê:
+// [sfspfx:]datafile[|virtname]
+// åñëè ïåðåä äâîåòî÷èåì ìåíüøå òð¸õ áóêâ, òî ýòî ñ÷èòàåòñÿ íå ïðåôèêñîì,
+// à èìåíåì äèñêà.
+procedure SplitDataName (const fn: AnsiString; out pfx, dataFile, virtName: AnsiString);
+var
+ f: Integer;
+begin
+ f := Pos(':', fn);
+ if f <= 3 then begin pfx := ''; dataFile := fn; end
+ else
+ begin
+ pfx := Copy(fn, 1, f-1);
+ dataFile := Copy(fn, f+1, maxInt-10000);
+ end;
+ virtName := ExtractVirtName(dataFile);
+end;
+
+// íàéòè ïðîèçâîäèòåëÿ äëÿ ýòîãî ôàéëà (åñëè ôàéë óæå îòêðûò).
+// onlyPerm: òîëüêî "ïîñòîÿííûå" ïðîèçâîäèòåëè.
+function FindVolumeInfo (const dataFileName: AnsiString; onlyPerm: Boolean=false): Integer;
+var
+ f: Integer;
+ vi: TVolumeInfo;
+begin
+ f := 0;
+ while f < volumes.Count do
+ begin
+ if volumes[f] <> nil then
+ begin
+ vi := TVolumeInfo(volumes[f]);
+ if not onlyPerm or vi.fPermanent then
+ begin
+ if StrEquCI1251(vi.fPackName, dataFileName) then
+ begin
+ result := f;
+ exit;
+ end;
+ end;
+ end;
+ Inc(f);
+ end;
+ result := -1;
+end;
+
+// íàéòè èíôó äëÿ ýòîãî òîìà.
+// õîðîøåå èìÿ, ïðàâäà? %-)
+function FindVolumeInfoByVolumeInstance (vol: TSFSVolume): Integer;
+begin
+ result := volumes.Count-1;
+ while result >= 0 do
+ begin
+ if volumes[result] <> nil then
+ begin
+ if TVolumeInfo(volumes[result]).fVolume = vol then exit;
+ end;
+ Dec(result);
+ end;
+end;
+
+
+// adds '/' too
+function normalizePath (fn: AnsiString): AnsiString;
+var
+ i: Integer;
+begin
+ result := '';
+ i := 1;
+ while i <= length(fn) do
+ begin
+ if (fn[i] = '.') and ((length(fn)-i = 0) or (fn[i+1] = '/') or (fn[i+1] = '\')) then
+ begin
+ i := i+2;
+ continue;
+ end;
+ if (fn[i] = '/') or (fn[i] = '\') then
+ begin
+ if (length(result) > 0) and (result[length(result)] <> '/') then result := result+'/';
+ end
+ else
+ begin
+ result := result+fn[i];
+ end;
+ Inc(i);
+ end;
+ if (length(result) > 0) and (result[length(result)] <> '/') then result := result+'/';
+end;
+
+function SFSReplacePathDelims (const s: AnsiString; newDelim: Char): AnsiString;
+var
+ f: Integer;
+begin
+ result := s;
+ for f := 1 to Length(result) do
+ begin
+ if (result[f] = '/') or (result[f] = '\') then
+ begin
+ // avoid unnecessary string changes
+ if result[f] <> newDelim then result[f] := newDelim;
+ end;
+ end;
+end;
+
+function SFSGetLastVirtualName (const fn: AnsiString): AnsiString;
+var
+ rest, tmp: AnsiString;
+ f: Integer;
+begin
+ rest := fn;
+ repeat
+ f := Pos('::', rest); if f = 0 then f := Length(rest)+1;
+ tmp := Copy(rest, 1, f-1); Delete(rest, 1, f+1);
+ result := ExtractVirtName(tmp);
+ until rest = '';
+end;
+
+
+{ TVolumeInfo }
+destructor TVolumeInfo.Destroy ();
+var
+ f, me: Integer;
+ used: Boolean; // ôëàæîê çàþçàíîñòè ïîòîêà êåì-òî åù¸
+begin
+ if fFactory <> nil then fFactory.Recycle(fVolume);
+ used := false;
+ fVolume := nil;
+ fFactory := nil;
+ fPackName := '';
+
+ // òèïà ìóñîðîñáîðíèê: åñëè íàø ïîòîê áîëåå íèêåì íå þçàåòñÿ, òî óãðîáèòü åãî íàôèã
+ if not used then
+ begin
+ me := volumes.IndexOf(self);
+ f := volumes.Count-1;
+ while not used and (f >= 0) do
+ begin
+ if (f <> me) and (volumes[f] <> nil) then
+ begin
+ used := (TVolumeInfo(volumes[f]).fStream = fStream);
+ if not used then
+ begin
+ used := (TVolumeInfo(volumes[f]).fVolume.fFileStream = fStream);
+ end;
+ if used then break;
+ end;
+ Dec(f);
+ end;
+ end;
+ if not used then FreeAndNil(fStream); // åñëè áîëüøå íèêåì íå þçàíî, ïðèøèá¸ì
+ inherited Destroy();
+end;
+
+
+{ TOwnedPartialStream }
+constructor TOwnedPartialStream.Create (pOwner: TVolumeInfo; pSrc: TStream;
+ pPos, pSize: Int64; pKillSrc: Boolean);
+begin
+ inherited Create(pSrc, pPos, pSize, pKillSrc);
+ fOwner := pOwner;
+ if pOwner <> nil then Inc(pOwner.fOpenedFilesCount);
+end;
+
+destructor TOwnedPartialStream.Destroy ();
+var
+ f: Integer;
+begin
+ inherited Destroy();
+ if fOwner <> nil then
+ begin
+ Dec(fOwner.fOpenedFilesCount);
+ if (gcdisabled = 0) and not fOwner.fPermanent and (fOwner.fOpenedFilesCount < 1) then
+ begin
+ f := volumes.IndexOf(fOwner);
+ if f <> -1 then
+ begin
+ {$IFDEF SFS_VOLDEBUG}writeln('001: destroying volume "', TVolumeInfo(volumes[f]).fPackName, '"');{$ENDIF}
+ volumes[f] := nil; // this will destroy the volume
+ end;
+ end;
+ end;
+end;
+
+
+{ TSFSFileInfo }
+constructor TSFSFileInfo.Create (pOwner: TSFSVolume);
+begin
+ inherited Create();
+ fOwner := pOwner;
+ fPath := '';
+ fName := '';
+ fSize := 0;
+ fOfs := 0;
+ if pOwner <> nil then pOwner.fFiles.Add(self);
+end;
+
+destructor TSFSFileInfo.Destroy ();
+begin
+ if fOwner <> nil then fOwner.fFiles.Extract(self);
+ inherited Destroy();
+end;
+
+
+{ TSFSVolume }
+constructor TSFSVolume.Create (const pFileName: AnsiString; pSt: TStream);
+begin
+ inherited Create();
+ fFileStream := pSt;
+ fFileName := pFileName;
+ fFiles := TObjectList.Create(true);
+end;
+
+procedure TSFSVolume.DoDirectoryRead ();
+var
+ f, c: Integer;
+ sfi: TSFSFileInfo;
+ tmp: AnsiString;
+begin
+ fFileName := ExpandFileName(SFSReplacePathDelims(fFileName, '/'));
+ ReadDirectory();
+ fFiles.Pack();
+
+ f := 0;
+ while f < fFiles.Count do
+ begin
+ sfi := TSFSFileInfo(fFiles[f]);
+ // normalize name & path
+ sfi.fPath := SFSReplacePathDelims(sfi.fPath, '/');
+ if (sfi.fPath <> '') and (sfi.fPath[1] = '/') then Delete(sfi.fPath, 1, 1);
+ if (sfi.fPath <> '') and (sfi.fPath[Length(sfi.fPath)] <> '/') then sfi.fPath := sfi.fPath+'/';
+ tmp := SFSReplacePathDelims(sfi.fName, '/');
+ c := Length(tmp); while (c > 0) and (tmp[c] <> '/') do Dec(c);
+ if c > 0 then
+ begin
+ // split path and name
+ Delete(sfi.fName, 1, c); // cut name
+ tmp := Copy(tmp, 1, c); // get path
+ if tmp = '/' then tmp := ''; // just delimiter; ignore it
+ sfi.fPath := sfi.fPath+tmp;
+ end;
+ sfi.fPath := normalizePath(sfi.fPath);
+ if (length(sfi.fPath) = 0) and (length(sfi.fName) = 0) then sfi.Free else Inc(f);
+ end;
+end;
+
+destructor TSFSVolume.Destroy ();
+begin
+ Clear();
+ FreeAndNil(fFiles);
+ inherited Destroy();
+end;
+
+procedure TSFSVolume.Clear ();
+begin
+ fFiles.Clear();
+end;
+
+function TSFSVolume.FindFile (const fPath, fName: AnsiString): Integer;
+begin
+ if fFiles = nil then result := -1
+ else
+ begin
+ result := fFiles.Count;
+ while result > 0 do
+ begin
+ Dec(result);
+ if fFiles[result] <> nil then
+ begin
+ if StrEquCI1251(fPath, TSFSFileInfo(fFiles[result]).fPath) and
+ StrEquCI1251(fName, TSFSFileInfo(fFiles[result]).fName) then exit;
+ end;
+ end;
+ result := -1;
+ end;
+end;
+
+function TSFSVolume.GetFileCount (): Integer;
+begin
+ if fFiles = nil then result := 0 else result := fFiles.Count;
+end;
+
+function TSFSVolume.GetFiles (index: Integer): TSFSFileInfo;
+begin
+ if fFiles = nil then result := nil
+ else
+ begin
+ if (index < 0) or (index >= fFiles.Count) then result := nil
+ else result := TSFSFileInfo(fFiles[index]);
+ end;
+end;
+
+function TSFSVolume.OpenFileEx (const fName: AnsiString): TStream;
+var
+ fp, fn: AnsiString;
+ f, ls: Integer;
+begin
+ fp := fName;
+ // normalize name, find split position
+ if (fp <> '') and ((fp[1] = '/') or (fp[1] = '\')) then Delete(fp, 1, 1);
+ ls := 0;
+ for f := 1 to Length(fp) do
+ begin
+ if fp[f] = '\' then fp[f] := '/';
+ if fp[f] = '/' then ls := f;
+ end;
+ fn := Copy(fp, ls+1, Length(fp));
+ fp := Copy(fp, 1, ls);
+ f := FindFile(fp, fn);
+ if f = -1 then raise ESFSError.Create('file not found: "'+fName+'"');
+ result := OpenFileByIndex(f);
+ if result = nil then raise ESFSError.Create('file not found: "'+fName+'"');
+end;
+
+
+{ TSFSFileList }
+constructor TSFSFileList.Create (const pVolume: TSFSVolume);
+var
+ f: Integer;
+begin
+ inherited Create();
+ ASSERT(pVolume <> nil);
+ f := FindVolumeInfoByVolumeInstance(pVolume);
+ ASSERT(f <> -1);
+ fVolume := pVolume;
+ Inc(TVolumeInfo(volumes[f]).fOpenedFilesCount); // íå ïîçâîëèì óáèòü çàïèñü!
+end;
+
+destructor TSFSFileList.Destroy ();
+var
+ f: Integer;
+begin
+ f := FindVolumeInfoByVolumeInstance(fVolume);
+ ASSERT(f <> -1);
+ Dec(TVolumeInfo(volumes[f]).fOpenedFilesCount);
+ // óáü¸ì çàïèñü, åñëè îíà âðåìåííàÿ, è â íåé íåò áîëüøå íè÷åãî îòêðûòîãî
+ if (gcdisabled = 0) and not TVolumeInfo(volumes[f]).fPermanent and (TVolumeInfo(volumes[f]).fOpenedFilesCount < 1) then
+ begin
+ {$IFDEF SFS_VOLDEBUG}writeln('002: destroying volume "', TVolumeInfo(volumes[f]).fPackName, '"');{$ENDIF}
+ volumes[f] := nil;
+ end;
+ inherited Destroy();
+end;
+
+function TSFSFileList.GetCount (): Integer;
+begin
+ result := fVolume.fFiles.Count;
+end;
+
+function TSFSFileList.GetFiles (index: Integer): TSFSFileInfo;
+begin
+ if (index < 0) or (index >= fVolume.fFiles.Count) then result := nil
+ else result := TSFSFileInfo(fVolume.fFiles[index]);
+end;
+
+
+procedure SFSRegisterVolumeFactory (factory: TSFSVolumeFactory);
+var
+ f: Integer;
+begin
+ if factory = nil then exit;
+ if factories.IndexOf(factory) <> -1 then
+ raise ESFSError.Create('duplicate factories are not allowed');
+ f := factories.IndexOf(nil);
+ if f = -1 then factories.Add(factory) else factories[f] := factory;
+end;
+
+procedure SFSUnregisterVolumeFactory (factory: TSFSVolumeFactory);
+var
+ f: Integer;
+ c: Integer;
+begin
+ if factory = nil then exit;
+ f := factories.IndexOf(factory);
+ if f = -1 then raise ESFSError.Create('can''t unregister nonexisting factory');
+ c := 0; while c < volumes.Count do
+ begin
+ if (volumes[c] <> nil) and (TVolumeInfo(volumes[c]).fFactory = factory) then volumes[c] := nil;
+ Inc(c);
+ end;
+ factories[f] := nil;
+end;
+
+
+function SFSAddDataFileEx (dataFileName: AnsiString; ds: TStream; top, permanent: Integer): Integer;
+// dataFileName ìîæåò èìåòü ïðåôèêñ òèïà "zip:" (ñì. âûøå: IsMyPrefix).
+// ìîæåò âûêèíóòü èñêëþ÷åíèå!
+// top:
+// <0: äîáàâèòü â íà÷àëî ñïèñêà ïîèñêà.
+// =0: íå ìåíÿòü.
+// >0: äîáàâèòü â êîíåö ñïèñêà ïîèñêà.
+// permanent:
+// <0: ñîçäàòü "âðåìåííûé" òîì.
+// =0: íå ìåíÿòü ôëàæîê ïîñòîÿíñòâà.
+// >0: ñîçäàòü "ïîñòîÿííûé" òîì.
+// åñëè ds <> nil, òî ñîçäà¸ò ñáîðíèê èç ïîòîêà. åñëè ñáîðíèê ñ èìåíåì
+// dataFileName óæå çàðåãèñòðèðîâàí, òî ïàäàåò íàôèã.
+// âîçâðàùàåò èíäåêñ â volumes.
+// óìååò äåëàòü ðåêóðñèþ.
+var
+ fac: TSFSVolumeFactory;
+ vol: TSFSVolume;
+ vi: TVolumeInfo;
+ f: Integer;
+ st, st1: TStream;
+ pfx: AnsiString;
+ fn, vfn, tmp: AnsiString;
+begin
+ f := Pos('::', dataFileName);
+ if f <> 0 then
+ begin
+ // ðåêóðñèâíîå îòêðûòèå.
+ // ðàçîáü¸ì dataFileName íà èìÿ ñáîðíèêà è îñòàòîê.
+ // pfx áóäåò èìåíåì ñáîðíèêà, dataFileName -- îñòàòêîì.
+ pfx := Copy(dataFileName, 1, f-1); Delete(dataFileName, 1, f+1);
+ // ñíà÷àëà îòêðîåì ïåðâûé ñïèñîê...
+ result := SFSAddDataFileEx(pfx, ds, 0, 0);
+ // ...òåïåðü ïðîäîëæèì ñ îñòàòêîì.
+ // óçíàåì, êàêîå ôàéëî îòêðûâàòü.
+ // âûêîâûðÿåì ïåðâûé "::" ïðåôèêñ (ýòî áóäåò èìÿ ôàéëà).
+ f := Pos('::', dataFileName); if f = 0 then f := Length(dataFileName)+1;
+ fn := Copy(dataFileName, 1, f-1); Delete(dataFileName, 1, f-1);
+ // dataFileName õðàíèò îñòàòîê.
+ // èçâëå÷¸ì èìÿ ôàéëà:
+ SplitDataName(fn, pfx, tmp, vfn);
+ // îòêðîåì ýòîò ôàéë
+ vi := TVolumeInfo(volumes[result]); st := nil;
+ try
+ st := vi.fVolume.OpenFileEx(tmp);
+ st1 := TOwnedPartialStream.Create(vi, st, 0, st.Size, true);
+ except
+ FreeAndNil(st);
+ // óäàëèì íåèñïîëüçóåìûé âðåìåííûé òîì.
+ if (gcdisabled = 0) and not vi.fPermanent and (vi.fOpenedFilesCount < 1) then volumes[result] := nil;
+ raise;
+ end;
+ // óðà. îòêðûëè ôàéë. êèäàåì â âîçäóõ ÷åï÷èêè, ïðîäîëæàåì ðàçâëå÷åíèå.
+ fn := fn+dataFileName;
+ try
+ st1.Position := 0;
+ result := SFSAddDataFileEx(fn, st1, top, permanent);
+ except
+ st1.Free(); // à âîò íå çàëàäèëîñü. çàêðûëè îòêðûòîå ôàéëî, âûëåòåëè.
+ raise;
+ end;
+ exit;
+ end;
+
+ // îáûêíîâåííîå íåðåêóðñèâíîå îòêðûòèå.
+ SplitDataName(dataFileName, pfx, fn, vfn);
+
+ f := FindVolumeInfo(vfn);
+ if f <> -1 then
+ begin
+ if ds <> nil then raise ESFSError.Create('subdata name conflict');
+ if permanent <> 0 then TVolumeInfo(volumes[f]).fPermanent := (permanent > 0);
+ if top = 0 then result := f
+ else if top < 0 then result := 0
+ else result := volumes.Count-1;
+ if result <> f then volumes.Move(f, result);
+ exit;
+ end;
+
+ if ds <> nil then st := ds
+ else st := TFileStream.Create(fn, fmOpenRead or {fmShareDenyWrite}fmShareDenyNone);
+ st.Position := 0;
+
+ volumes.Pack();
+
+ fac := nil; vol := nil;
+ try
+ for f := 0 to factories.Count-1 do
+ begin
+ fac := TSFSVolumeFactory(factories[f]);
+ if fac = nil then continue;
+ if (pfx <> '') and not fac.IsMyVolumePrefix(pfx) then continue;
+ st.Position := 0;
+ try
+ if ds <> nil then vol := fac.Produce(pfx, '', st)
+ else vol := fac.Produce(pfx, fn, st);
+ except
+ vol := nil;
+ end;
+ if vol <> nil then break;
+ end;
+ if vol = nil then raise ESFSError.Create('no factory for "'+dataFileName+'"');
+ except
+ if st <> ds then st.Free();
+ raise;
+ end;
+
+ vi := TVolumeInfo.Create();
+ try
+ if top < 0 then
+ begin
+ result := 0;
+ volumes.Insert(0, vi);
+ end
+ else result := volumes.Add(vi);
+ except
+ vol.Free();
+ if st <> ds then st.Free();
+ vi.Free();
+ raise;
+ end;
+
+ vi.fFactory := fac;
+ vi.fVolume := vol;
+ vi.fPackName := vfn;
+ vi.fStream := st;
+ vi.fPermanent := (permanent > 0);
+ vi.fNoDiskFile := (ds <> nil);
+ vi.fOpenedFilesCount := 0;
+end;
+
+function SFSAddSubDataFile (const virtualName: AnsiString; ds: TStream; top: Boolean=false): Boolean;
+var
+ tv: Integer;
+begin
+ ASSERT(ds <> nil);
+ try
+ if top then tv := -1 else tv := 1;
+ SFSAddDataFileEx(virtualName, ds, tv, 0);
+ result := true;
+ except
+ result := false;
+ end;
+end;
+
+function SFSAddDataFile (const dataFileName: AnsiString; top: Boolean=false): Boolean;
+var
+ tv: Integer;
+begin
+ try
+ if top then tv := -1 else tv := 1;
+ SFSAddDataFileEx(dataFileName, nil, tv, 1);
+ result := true;
+ except
+ result := false;
+ end;
+end;
+
+function SFSAddDataFileTemp (const dataFileName: AnsiString; top: Boolean=false): Boolean;
+var
+ tv: Integer;
+begin
+ try
+ if top then tv := -1 else tv := 1;
+ SFSAddDataFileEx(dataFileName, nil, tv, 0);
+ result := true;
+ except
+ result := false;
+ end;
+end;
+
+
+
+function SFSExpandDirName (const s: AnsiString): AnsiString;
+var
+ f, e: Integer;
+ es: AnsiString;
+begin
+ f := 1; result := s;
+ while f < Length(result) do
+ begin
+ while (f < Length(result)) and (result[f] <> '<') do Inc(f);
+ if f >= Length(result) then exit;
+ e := f; while (e < Length(result)) and (result[e] <> '>') do Inc(e);
+ es := Copy(result, f, e+1-f);
+
+ if es = '<currentdir>' then es := GetCurrentDir
+ else if es = '<exedir>' then es := ExtractFilePath(ParamStr(0))
+ else es := '';
+
+ if es <> '' then
+ begin
+ if (es[Length(es)] <> '/') and (es[Length(es)] <> '\') then es := es+'/';
+ Delete(result, f, e+1-f);
+ Insert(es, result, f);
+ Inc(f, Length(es));
+ end
+ else f := e+1;
+ end;
+end;
+
+function SFSFileOpenEx (const fName: AnsiString): TStream;
+var
+ dataFileName, fn: AnsiString;
+ f: Integer;
+ vi: TVolumeInfo;
+ diskChecked: Boolean;
+ ps: TStream;
+
+ function CheckDisk (): TStream;
+ // ïðîâåðèì, åñòü ëè ôàëî fn ãäå-òî íà äèñêàõ.
+ var
+ dfn, dirs, cdir: AnsiString;
+ f: Integer;
+ begin
+ result := nil;
+ if diskChecked or not sfsDiskEnabled then exit;
+ diskChecked := true;
+ dfn := SFSReplacePathDelims(fn, '/');
+ dirs := sfsDiskDirs; if dirs = '' then dirs := '<currentdir>';
+ while dirs <> '' do
+ begin
+ f := 1; while (f <= Length(dirs)) and (dirs[f] <> '|') do Inc(f);
+ cdir := Copy(dirs, 1, f-1); Delete(dirs, 1, f);
+ if cdir = '' then continue;
+ cdir := SFSReplacePathDelims(SFSExpandDirName(cdir), '/');
+ if cdir[Length(cdir)] <> '/' then cdir := cdir+'/';
+ try
+ result := TFileStream.Create(cdir+dfn, fmOpenRead or {fmShareDenyWrite}fmShareDenyNone);
+ exit;
+ except
+ end;
+ end;
+ end;
+
+begin
+ SplitFName(fName, dataFileName, fn);
+ if fn = '' then raise ESFSError.Create('invalid file name: "'+fName+'"');
+
+ diskChecked := false;
+
+ if dataFileName <> '' then
+ begin
+ // ïðåôèêñîâàíûé ôàéë
+ if sfsForceDiskForPrefixed then
+ begin
+ result := CheckDisk();
+ if result <> nil then exit;
+ end;
+
+ f := SFSAddDataFileEx(dataFileName, nil, 0, 0);
+ vi := TVolumeInfo(volumes[f]);
+
+ try
+ result := vi.fVolume.OpenFileEx(fn);
+ ps := TOwnedPartialStream.Create(vi, result, 0, result.Size, true);
+ except
+ result.Free();
+ if (gcdisabled = 0) and not vi.fPermanent and (vi.fOpenedFilesCount < 1) then volumes[f] := nil;
+ result := CheckDisk(); // îáëîì ñ datafile, ïðîâåðèì äèñê
+ if result = nil then raise ESFSError.Create('file not found: "'+fName+'"');
+ exit;
+ end;
+ //Inc(vi.fOpenedFilesCount);
+ result := ps;
+ exit;
+ end;
+
+ // íåïðåôèêñîâàíûé ôàéë
+ if sfsDiskFirst then
+ begin
+ result := CheckDisk();
+ if result <> nil then exit;
+ end;
+ // èùåì ïî âñåì ïåðìàíåíòíûì ïðåôèêñàì
+ f := 0;
+ while f < volumes.Count do
+ begin
+ vi := TVolumeInfo(volumes[f]);
+ if (vi <> nil) and vi.fPermanent then
+ begin
+ if vi.fVolume <> nil then
+ begin
+ result := vi.fVolume.OpenFileEx(fn);
+ if result <> nil then
+ begin
+ try
+ ps := TOwnedPartialStream.Create(vi, result, 0, result.Size, true);
+ result := ps;
+ //Inc(vi.fOpenedFilesCount);
+ except
+ FreeAndNil(result);
+ end;
+ end;
+ if result <> nil then exit;
+ end;
+ end;
+ Inc(f);
+ end;
+ result := CheckDisk();
+ if result = nil then raise ESFSError.Create('file not found: "'+fName+'"');
+end;
+
+function SFSFileOpen (const fName: AnsiString): TStream;
+begin
+ try
+ result := SFSFileOpenEx(fName);
+ except
+ result := nil;
+ end;
+end;
+
+function SFSFileList (const dataFileName: AnsiString): TSFSFileList;
+var
+ f: Integer;
+ vi: TVolumeInfo;
+begin
+ result := nil;
+ if dataFileName = '' then exit;
+
+ try
+ f := SFSAddDataFileEx(dataFileName, nil, 0, 0);
+ except
+ exit;
+ end;
+ vi := TVolumeInfo(volumes[f]);
+
+ try
+ result := TSFSFileList.Create(vi.fVolume);
+ except
+ if (gcdisabled = 0) and not vi.fPermanent and (vi.fOpenedFilesCount < 1) then volumes[f] := nil;
+ end;
+end;
+
+
+initialization
+ factories := TObjectList.Create(true);
+ volumes := TObjectList.Create(true);
+//finalization
+ //volumes.Free(); // it fails for some reason... Runtime 217 (^C hit). wtf?!
+ //factories.Free(); // not need to be done actually...
+end.
diff --git a/src/sfs/sfsPlainFS.pas b/src/sfs/sfsPlainFS.pas
--- /dev/null
+++ b/src/sfs/sfsPlainFS.pas
@@ -0,0 +1,147 @@
+(* Copyright (C) Doom 2D: Forever Developers
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <http://www.gnu.org/licenses/>.
+ *)
+// simple grouping files w/o packing:
+// Quake I/II .PAK (PACK)
+// SiN .SIN (SPAK)
+//
+{$INCLUDE ../shared/a_modes.inc}
+{$SCOPEDENUMS OFF}
+{.$R+}
+unit sfsPlainFS;
+
+interface
+
+uses
+ SysUtils, Classes, Contnrs, sfs;
+
+
+type
+ TSFSPlainVolumeType = (sfspvNone, sfspvPAK, sfspvSIN);
+
+ TSFSPlainVolume = class (TSFSVolume)
+ protected
+ fType: TSFSPlainVolumeType;
+
+ procedure ReadDirectory (); override;
+
+ public
+ function OpenFileByIndex (const index: Integer): TStream; override;
+ end;
+
+ TSFSPlainVolumeFactory = class (TSFSVolumeFactory)
+ public
+ function IsMyVolumePrefix (const prefix: AnsiString): Boolean; override;
+ function Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume; override;
+ procedure Recycle (vol: TSFSVolume); override;
+ end;
+
+
+implementation
+
+uses
+ xstreams, utils;
+
+
+{ TSFSPlainVolume }
+procedure TSFSPlainVolume.ReadDirectory ();
+var
+ dsize, dofs, esz: LongWord;
+ fi: TSFSFileInfo;
+ name: packed array [0..120] of Char;
+begin
+ if (fType <> sfspvPAK) and (fType <> sfspvSIN) then raise ESFSError.Create('invalid archive');
+ fFileStream.Seek(4, soCurrent); // skip signature
+ dofs := readLongWord(fFileStream);
+ dsize := readLongWord(fFileStream);
+ fFileStream.Position := dofs;
+ if fType = sfspvPAK then esz := 64 else esz := 128;
+ while dsize >= esz do
+ begin
+ fi := TSFSFileInfo.Create(self);
+ FillChar(name[0], length(name), 0);
+ fFileStream.ReadBuffer(name[0], esz-8);
+ fi.fName := PChar(@name[0]);
+ fi.fOfs := readLongWord(fFileStream);
+ fi.fSize := readLongWord(fFileStream);
+ Dec(dsize, esz);
+ end;
+end;
+
+function TSFSPlainVolume.OpenFileByIndex (const index: Integer): TStream;
+begin
+ result := nil;
+ if fFiles = nil then exit;
+ if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
+ result := TSFSPartialStream.Create(fFileStream, TSFSFileInfo(fFiles[index]).fOfs, TSFSFileInfo(fFiles[index]).fSize, false);
+end;
+
+
+{ TSFSPlainVolumeFactory }
+function TSFSPlainVolumeFactory.IsMyVolumePrefix (const prefix: AnsiString): Boolean;
+begin
+ result :=
+ StrEquCI1251(prefix, 'pak') or
+ StrEquCI1251(prefix, 'sin');
+end;
+
+procedure TSFSPlainVolumeFactory.Recycle (vol: TSFSVolume);
+begin
+ vol.Free();
+end;
+
+function TSFSPlainVolumeFactory.Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume;
+var
+ vt: TSFSPlainVolumeType;
+ sign: packed array [0..3] of Char;
+ dsize, dofs: Integer;
+begin
+ result := nil;
+ vt := sfspvNone;
+
+ st.ReadBuffer(sign[0], 4);
+ dofs := readLongWord(st);
+ dsize := readLongWord(st);
+ st.Seek(-12, soCurrent);
+ if sign = 'PACK' then
+ begin
+ if (dsize < 0) or (dofs < 0) or (dofs > st.Size) or (dofs+dsize > st.Size) or (dsize mod 64 <> 0) then exit;
+ vt := sfspvPAK;
+ end
+ else if sign = 'SPAK' then
+ begin
+ if (dsize < 0) or (dofs < 0) or (dofs > st.Size) or (dofs+dsize > st.Size) or (dsize mod 64 <> 0) then exit;
+ vt := sfspvSIN;
+ end;
+
+ result := TSFSPlainVolume.Create(fileName, st);
+ TSFSPlainVolume(result).fType := vt;
+ try
+ result.DoDirectoryRead();
+ except
+ FreeAndNil(result);
+ raise;
+ end;
+end;
+
+
+var
+ pakf: TSFSPlainVolumeFactory;
+initialization
+ pakf := TSFSPlainVolumeFactory.Create();
+ SFSRegisterVolumeFactory(pakf);
+//finalization
+// SFSUnregisterVolumeFactory(pakf);
+end.
diff --git a/src/sfs/sfsZipFS.pas b/src/sfs/sfsZipFS.pas
--- /dev/null
+++ b/src/sfs/sfsZipFS.pas
@@ -0,0 +1,465 @@
+(* Copyright (C) Doom 2D: Forever Developers
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <http://www.gnu.org/licenses/>.
+ *)
+// grouping files with packing:
+// zip, pk3: PKZIP-compatible archives (store, deflate)
+// dfwad : D2D:F wad archives
+//
+{.$DEFINE SFS_DEBUG_ZIPFS}
+{$INCLUDE ../shared/a_modes.inc}
+{$SCOPEDENUMS OFF}
+{.$R+}
+unit sfsZipFS;
+
+interface
+
+uses
+ SysUtils, Classes, Contnrs, sfs;
+
+
+type
+ TSFSZipVolumeType = (sfszvNone, sfszvZIP, sfszvDFWAD);
+
+ TSFSZipVolume = class(TSFSVolume)
+ protected
+ fType: TSFSZipVolumeType;
+
+ procedure ZIPReadDirectory ();
+ procedure DFWADReadDirectory ();
+
+ procedure ReadDirectory (); override;
+
+ public
+ function OpenFileByIndex (const index: Integer): TStream; override;
+ end;
+
+ TSFSZipVolumeFactory = class(TSFSVolumeFactory)
+ public
+ function IsMyVolumePrefix (const prefix: AnsiString): Boolean; override;
+ function Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume; override;
+ procedure Recycle (vol: TSFSVolume); override;
+ end;
+
+
+implementation
+
+uses
+ xstreams, utils;
+
+
+type
+ TSFSZipFileInfo = class(TSFSFileInfo)
+ public
+ fMethod: Byte; // 0: store; 8: deflate; 255: other
+ fPackSz: Int64; // can be -1
+ end;
+
+ TZLocalFileHeader = packed record
+ version: Byte;
+ hostOS: Byte;
+ flags: Word;
+ method: Word;
+ time: LongWord;
+ crc: LongWord;
+ packSz: LongWord;
+ unpackSz: LongWord;
+ fnameSz: Word;
+ localExtraSz: Word;
+ end;
+
+procedure readLFH (st: TStream; var hdr: TZLocalFileHeader);
+{.$IFDEF ENDIAN_LITTLE}
+begin
+ hdr.version := readByte(st);
+ hdr.hostOS := readByte(st);
+ hdr.flags := readWord(st);
+ hdr.method := readWord(st);
+ hdr.time := readLongWord(st);
+ hdr.crc := readLongWord(st);
+ hdr.packSz := readLongWord(st);
+ hdr.unpackSz := readLongWord(st);
+ hdr.fnameSz := readWord(st);
+ hdr.localExtraSz := readWord(st);
+end;
+
+
+function ZIPCheckMagic (st: TStream): Boolean;
+var
+ sign: packed array [0..3] of Char;
+begin
+ result := false;
+ st.ReadBuffer(sign[0], 4);
+ st.Seek(-4, soCurrent);
+ if (sign <> 'PK'#3#4) and (sign <> 'PK'#5#6) then exit;
+ result := true;
+end;
+
+
+function DFWADCheckMagic (st: TStream): Boolean;
+var
+ sign: packed array [0..5] of Char;
+begin
+ result := false;
+ if st.Size < 10 then exit;
+ st.ReadBuffer(sign[0], 6);
+ {fcnt :=} readWord(st);
+ st.Seek(-8, soCurrent);
+ if (sign[0] <> 'D') and (sign[1] <> 'F') and (sign[2] <> 'W') and
+ (sign[3] <> 'A') and (sign[4] <> 'D') and (sign[5] <> #$01) then exit;
+ result := true;
+end;
+
+
+{ TSFSZipVolume }
+procedure TSFSZipVolume.ZIPReadDirectory ();
+var
+ fi: TSFSZipFileInfo;
+ fname: AnsiString = '';
+ sign: packed array [0..3] of Char;
+ lhdr: TZLocalFileHeader;
+ ignoreFile: Boolean;
+ efid, efsz: Word;
+ izver: Byte;
+ izcrc: LongWord;
+ buf: PByte;
+ bufsz, f: Integer;
+ cdofs, hdrofs: Int64;
+ cdsize: LongWord;
+ fileOffsets: array of Int64 = nil;
+ nameLen, extraLen, commentLen: Word;
+ fileIdx: Integer = -1;
+begin
+ // search for central dir pointer
+ if fFileStream.size > 65636 then bufsz := 65636 else bufsz := fFileStream.size;
+ fFileStream.position := fFileStream.size-bufsz;
+ GetMem(buf, bufsz);
+ cdofs := -1;
+ cdsize := 0;
+ try
+ fFileStream.readBuffer(buf^, bufsz);
+ for f := bufsz-16 downto 4 do
+ begin
+ if (buf[f-4] = ord('P')) and (buf[f-3] = ord('K')) and (buf[f-2] = 5) and (buf[f-1] = 6) then
+ begin
+ cdsize := LongWord(buf[f+8])+(LongWord(buf[f+9])<<8)+(LongWord(buf[f+10])<<16)+(LongWord(buf[f+11])<<24);
+ cdofs := Int64(buf[f+12])+(Int64(buf[f+13])<<8)+(Int64(buf[f+14])<<16)+(Int64(buf[f+15])<<24);
+ break;
+ end;
+ end;
+ finally
+ FreeMem(buf);
+ end;
+
+ if (cdofs >= 0) and (cdsize > 0) then
+ begin
+ // wow, we got central directory! process it
+ fFileStream.position := cdofs;
+ while cdsize >= 4 do
+ begin
+ Dec(cdsize, 4);
+ fFileStream.readBuffer(sign, 4);
+ if sign = 'PK'#1#2 then
+ begin
+ if cdsize < 42 then break;
+ Dec(cdsize, 42);
+ // skip uninteresting fields
+ fFileStream.seek(2+2+2+2+2+2+4+4+4, soCurrent);
+ nameLen := readWord(fFileStream);
+ extraLen := readWord(fFileStream);
+ commentLen := readWord(fFileStream);
+ // skip uninteresting fields
+ fFileStream.seek(2+2+4, soCurrent);
+ hdrofs := readLongWord(fFileStream);
+ // now skip name, extra and comment
+ if cdsize < nameLen+extraLen+commentLen then break;
+ Dec(cdsize, nameLen+extraLen+commentLen);
+ fFileStream.seek(nameLen+extraLen+commentLen, soCurrent);
+ SetLength(fileOffsets, length(fileOffsets)+1);
+ fileOffsets[high(fileOffsets)] := hdrofs;
+ //writeln('file #', high(fileOffsets), ' found at ', hdrofs);
+ end
+ else if sign = 'PK'#7#8 then
+ begin
+ if cdsize < 3*4 then break;
+ Dec(cdsize, 3*4);
+ fFileStream.seek(3*4, soCurrent);
+ end
+ else
+ begin
+ break;
+ end;
+ end;
+ if length(fileOffsets) = 0 then exit; // no files at all
+ fileIdx := 0;
+ end
+ else
+ begin
+ fFileStream.position := 0;
+ end;
+
+ // read local directory
+ repeat
+ if fileIdx >= 0 then
+ begin
+ if fileIdx > High(fileOffsets) then break;
+ //writeln('reading file #', fileIdx, ' at ', fileOffsets[fileIdx]);
+ fFileStream.position := fileOffsets[fileIdx];
+ Inc(fileIdx);
+ end;
+
+ while true do
+ begin
+ fFileStream.ReadBuffer(sign[0], Length(sign));
+ // skip data descriptor
+ if sign = 'PK'#7#8 then
+ begin
+ fFileStream.seek(3*4, soCurrent);
+ continue;
+ end;
+ break;
+ end;
+ if sign <> 'PK'#3#4 then break;
+
+ ignoreFile := false;
+
+ readLFH(fFileStream, lhdr);
+
+ fi := TSFSZipFileInfo.Create(self);
+ fi.fPackSz := 0;
+ fi.fMethod := 0;
+
+ SetLength(fname, lhdr.fnameSz);
+ if lhdr.fnameSz > 0 then
+ begin
+ fFileStream.ReadBuffer(fname[1], length(fname));
+ fi.fName := utf8to1251(fname);
+ end;
+
+ // here we should process extra field: it may contain utf8 filename
+ while lhdr.localExtraSz >= 4 do
+ begin
+ efid := readWord(fFileStream);
+ efsz := readWord(fFileStream);
+ Dec(lhdr.localExtraSz, 4);
+ if efsz > lhdr.localExtraSz then break;
+ // Info-ZIP Unicode Path Extra Field?
+ if (efid = $7075) and (efsz > 5) then
+ begin
+ fFileStream.ReadBuffer(izver, 1);
+ Dec(efsz, 1);
+ Dec(lhdr.localExtraSz, 1);
+ if izver = 1 then
+ begin
+ //writeln('!!!!!!!!!!!!');
+ Dec(lhdr.localExtraSz, efsz);
+ fFileStream.ReadBuffer(izcrc, 4); // name crc, ignore it for now
+ Dec(efsz, 4);
+ SetLength(fname, efsz);
+ if length(fname) > 0 then fFileStream.readBuffer(fname[1], length(fname));
+ fi.fName := utf8to1251(fname);
+ //writeln('++++++ [', fi.fName, ']');
+ efsz := 0;
+ end;
+ end;
+ // skip it
+ if efsz > 0 then
+ begin
+ fFileStream.Seek(efsz, soCurrent);
+ Dec(lhdr.localExtraSz, efsz);
+ end;
+ end;
+ // skip the rest
+ if lhdr.localExtraSz > 0 then fFileStream.Seek(lhdr.localExtraSz, soCurrent);
+
+ if (lhdr.flags and 1) <> 0 then
+ begin
+ // encrypted file: skip it
+ ignoreFile := true;
+ end;
+
+ if (lhdr.method <> 0) and (lhdr.method <> 8) then
+ begin
+ // not stored. not deflated. skip.
+ ignoreFile := true;
+ end;
+
+ if (length(fi.fName) = 0) or (fname[length(fi.fName)] = '/') or (fname[length(fi.fName)] = '\') then
+ begin
+ ignoreFile := true;
+ end
+ else
+ begin
+ for f := 1 to length(fi.fName) do if fi.fName[f] = '\' then fi.fName[f] := '/';
+ end;
+
+ fi.fOfs := fFileStream.Position;
+ fi.fSize := lhdr.unpackSz;
+ fi.fPackSz := lhdr.packSz;
+ fi.fMethod := lhdr.method;
+ if fi.fMethod = 0 then fi.fPackSz := fi.fSize;
+
+ // skip packed data
+ if fileIdx < 0 then fFileStream.Seek(lhdr.packSz, soCurrent);
+ if ignoreFile then fi.Free();
+ until false;
+ (*
+ if (sign <> 'PK'#1#2) and (sign <> 'PK'#5#6) then
+ begin
+ {$IFDEF SFS_DEBUG_ZIPFS}
+ WriteLn(ErrOutput, 'end: $', IntToHex(fFileStream.Position, 8));
+ WriteLn(ErrOutput, 'sign: $', sign[0], sign[1], '#', ord(sign[2]), '#', ord(sign[3]));
+ {$ENDIF}
+ raise ESFSError.Create('invalid .ZIP archive (no central dir)');
+ end;
+ *)
+end;
+
+
+procedure TSFSZipVolume.DFWADReadDirectory ();
+// idiotic format
+var
+ fcnt: Word;
+ fi: TSFSZipFileInfo;
+ f, c: Integer;
+ fofs, fpksize: LongWord;
+ curpath, fname: string;
+ name: packed array [0..15] of Char;
+begin
+ curpath := '';
+ fFileStream.Seek(6, soCurrent); // skip signature
+ fcnt := readWord(fFileStream);
+ if fcnt = 0 then exit;
+ // read files
+ for f := 0 to fcnt-1 do
+ begin
+ fFileStream.ReadBuffer(name[0], 16);
+ fofs := readLongWord(fFileStream);
+ fpksize := readLongWord(fFileStream);
+ c := 0;
+ fname := '';
+ while (c < 16) and (name[c] <> #0) do
+ begin
+ if name[c] = '\' then name[c] := '/'
+ else if name[c] = '/' then name[c] := '_';
+ fname := fname+name[c];
+ Inc(c);
+ end;
+ // new directory?
+ if (fofs = 0) and (fpksize = 0) then
+ begin
+ if length(fname) <> 0 then fname := fname+'/';
+ curpath := fname;
+ continue;
+ end;
+ if length(fname) = 0 then continue; // just in case
+ //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
+ // create file record
+ fi := TSFSZipFileInfo.Create(self);
+ fi.fOfs := fofs;
+ fi.fSize := -1;
+ fi.fPackSz := fpksize;
+ fi.fName := fname;
+ fi.fPath := curpath;
+ fi.fMethod := 255;
+ end;
+end;
+
+procedure TSFSZipVolume.ReadDirectory ();
+begin
+ case fType of
+ sfszvZIP: ZIPReadDirectory();
+ sfszvDFWAD: DFWADReadDirectory();
+ else raise ESFSError.Create('invalid archive');
+ end;
+end;
+
+function TSFSZipVolume.OpenFileByIndex (const index: Integer): TStream;
+var
+ rs: TStream;
+begin
+ result := nil;
+ rs := nil;
+ if fFiles = nil then exit;
+ if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
+ try
+ if TSFSZipFileInfo(fFiles[index]).fMethod = 0 then
+ begin
+ result := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fSize, false);
+ end
+ else
+ begin
+ rs := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fPackSz, false);
+ result := TUnZStream.Create(rs, TSFSZipFileInfo(fFiles[index]).fSize, true, (TSFSZipFileInfo(fFiles[index]).fMethod <> 255));
+ end;
+ except
+ FreeAndNil(rs);
+ result := nil;
+ exit;
+ end;
+end;
+
+
+{ TSFSZipVolumeFactory }
+function TSFSZipVolumeFactory.IsMyVolumePrefix (const prefix: AnsiString): Boolean;
+begin
+ result :=
+ StrEquCI1251(prefix, 'zip') or
+ StrEquCI1251(prefix, 'pk3') or
+ StrEquCI1251(prefix, 'dfwad') or
+ StrEquCI1251(prefix, 'dfzip');
+end;
+
+procedure TSFSZipVolumeFactory.Recycle (vol: TSFSVolume);
+begin
+ vol.Free();
+end;
+
+function TSFSZipVolumeFactory.Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume;
+var
+ vt: TSFSZipVolumeType;
+begin
+ vt := sfszvNone;
+ if ZIPCheckMagic(st) then vt := sfszvZIP
+ else if DFWADCheckMagic(st) then vt := sfszvDFWAD;
+
+ if vt <> sfszvNone then
+ begin
+ result := TSFSZipVolume.Create(fileName, st);
+ TSFSZipVolume(result).fType := vt;
+ try
+ result.DoDirectoryRead();
+ except {$IFDEF SFS_DEBUG_ZIPFS} on e: Exception do begin
+ WriteLn(errOutput, 'ZIP ERROR: [', e.ClassName, ']: ', e.Message);
+ {$ENDIF}
+ FreeAndNil(result);
+ raise;
+ {$IFDEF SFS_DEBUG_ZIPFS}end;{$ENDIF}
+ end;
+ end
+ else
+ begin
+ result := nil;
+ end;
+end;
+
+
+var
+ zipf: TSFSZipVolumeFactory;
+initialization
+ zipf := TSFSZipVolumeFactory.Create();
+ SFSRegisterVolumeFactory(zipf);
+//finalization
+// SFSUnregisterVolumeFactory(zipf);
+end.
diff --git a/src/shared/xstreams.pas b/src/shared/xstreams.pas
--- /dev/null
+++ b/src/shared/xstreams.pas
@@ -0,0 +1,567 @@
+(* Copyright (C) Doom 2D: Forever Developers
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <http://www.gnu.org/licenses/>.
+ *)
+// special stream classes
+{$INCLUDE a_modes.inc}
+{.$R+}
+unit xstreams;
+
+interface
+
+uses
+ SysUtils, Classes,
+ zbase{z_stream};
+
+
+type
+ XStreamError = class(Exception);
+
+ // read-only ïîòîê äëÿ èçâëå÷åíèÿ èç èñõîäíîãî òîëüêî êóñî÷êà
+ TSFSPartialStream = class(TStream)
+ protected
+ fSource: TStream; // èñõîäíûé ïîòîê
+ fKillSource: Boolean; // óáèâàòü èñõîäíèê ïðè ïîìèðàíèè?
+ fLastReadPos: Int64; // ïîñëåäíèé Read() îñòàíîâèëñÿ çäåñü (îòíîñ. fStartPos)
+ fCurrentPos: Int64; // ïîñëåäíèé Seek() îñòàíîâèëñÿ çäåñü (îòíîñ. fStartPos)
+ fStartPos: Int64; // íà÷àëî êóñî÷êà
+ fSize: Int64; // äëèíà êóñî÷êà
+ fPreBuf: packed array of Byte; // ýòîò áóôåð áóäåò ïåðåä ôàéëîì
+
+ procedure CheckPos ();
+
+ public
+ // aSrc: ïîòîê-èñõîäíèê.
+ // aPos: íà÷àëüíàÿ ïîçèöèÿ â ïîòîêå. -1 -- ñ òåêóùåé.
+ // åñëè aPos < òåêóùåé ïîçèöèè, òî èñõîäíûé ïîòîê äîëæåí
+ // íîðìàëüíî ïîääåðæèâàòü Seek()!
+ // aSize: êîëè÷åñòâî áàéòèêîâ, êîòîðîå ìîæíî ïðî÷åñòü èç ïîòîêà.
+ // åñëè ìåíüøå íóëÿ -- òî äî êîíöà.
+ // aKillSrc: óáèâàòü ëè èñõîäíûé ïîòîê, êîãäà ñàìè óìèðàåì?
+ // òàêæå ìîæåò ïðèøïàíäîðèòü ê íà÷àëó ôàéëà áóôåð. bufSz áóäåò äîáàâëåíî ê
+ // äëèíå ôàéëà.
+ constructor Create (aSrc: TStream; aPos, aSize: Int64; aKillSrc: Boolean; preBuf: Pointer=nil; bufSz: Integer=0);
+ destructor Destroy (); override;
+
+ // íîðìàëèçóåò count è ÷èòàåò.
+ function Read (var buffer; count: LongInt): LongInt; override;
+ // Write() ïðîñòî ãðîìêî ïàäàåò.
+ function Write (const buffer; count: LongInt): LongInt; override;
+ // Seek() ðåàëèçîâàíî, ÷òîáû ìîãëà ðàáîòàòü ïðîïåðòÿ Size.
+ // âîîáùå-òî ìîæíî ïåðåêðûòü ìåòîä GetSize(), íî âäðóã êàêîé
+ // áîëüíîé íà ãîëîâó êîäåð áóäåò ïîëó÷àòü ðàçìåð ïðè ïîìîùè
+ // Seek()'à?
+ function Seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
+ end;
+
+ // this stream can kill both `proxied` and `guarded` streams on closing
+ TSFSGuardStream = class(TStream)
+ protected
+ fSource: TStream; // èñõîäíûé ïîòîê
+ fGuardedStream: TStream; // ïîòîê, êîòîðûé çàâàëèì ïðè ïîìèðàíèè
+ fKillSource: Boolean; // óáèâàòü èñõîäíèê ïðè ïîìèðàíèè?
+ fKillGuarded: Boolean; // óáèâàòü îõðàíÿåìûé ïðè ïîìèðàíèè?
+ fGuardedFirst: Boolean; // ïðè ñìåðòè ïåðâûì ïðèøèáàåì îõðàíÿåìîãî?
+
+ public
+ // aSrc: ïîòîê-èñõîäíèê (íà êîòîðûé çàìàïåíû îïåðàöèè ÷òåíèÿ/çàïèñè).
+ // aKillSrc: óáèâàòü ëè èñõîäíûé ïîòîê, êîãäà ñàìè óìèðàåì?
+ // aKillGuarded: óáèâàòü ëè îõðàíÿåìûé ïîòîê, êîãäà ñàìè óìèðàåì?
+ // aGuardedFirst: true: ïðè ñìåðòè ïåðâûì ïðèøèáàåì îõðàíÿåìîãî.
+ constructor Create (aSrc, aGuarded: TStream; aKillSrc, aKillGuarded: Boolean; aGuardedFirst: Boolean=true);
+ destructor Destroy (); override;
+
+ // íèæåñëåäóþùåå çàìàïëåíî íà fSource
+ function Read (var buffer; count: LongInt): LongInt; override;
+ function Write (const buffer; count: LongInt): LongInt; override;
+ function Seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
+ end;
+
+ TSFSMemoryStreamRO = class(TCustomMemoryStream)
+ private
+ fFreeMem: Boolean;
+ fMem: Pointer;
+
+ public
+ constructor Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
+ destructor Destroy (); override;
+
+ function Write (const buffer; count: LongInt): LongInt; override;
+ end;
+
+ TUnZStream = class(TStream)
+ protected
+ fSrcSt: TStream;
+ fZlibSt: z_stream;
+ fBuffer: PByte;
+ fPos: Int64;
+ fSkipHeader: Boolean;
+ fSize: Int64; // can be -1
+ fSrcStPos: Int64;
+ fSkipToPos: Int64; // >0: skip to this position
+ fKillSrc: Boolean;
+
+ procedure reset ();
+ function readBuf (var buffer; count: LongInt): LongInt;
+ procedure fixPos ();
+ procedure determineSize ();
+
+ public
+ // `aSize` can be -1 if stream size is unknown
+ constructor create (asrc: TStream; aSize: Int64; aKillSrc: Boolean; aSkipHeader: boolean=false);
+ destructor destroy (); override;
+ function read (var buffer; count: LongInt): LongInt; override;
+ function write (const buffer; count: LongInt): LongInt; override;
+ function seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
+ end;
+
+ // fixed memory chunk
+ TSFSMemoryChunkStream = class(TStream)
+ private
+ fFreeMem: Boolean;
+ fMemBuf: PByte;
+ fMemSize: Integer;
+ fCurPos: Integer;
+
+ public
+ // if `pMem` is `nil`, stream will allocate it
+ constructor Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
+ destructor Destroy (); override;
+
+ procedure setup (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
+
+ function Seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
+ function Read (var buffer; count: LongInt): LongInt; override;
+ function Write (const buffer; count: LongInt): LongInt; override;
+
+ property chunkSize: Integer read fMemSize;
+ property chunkData: PByte read fMemBuf;
+ end;
+
+
+implementation
+
+uses
+ zinflate;
+
+
+{ TSFSPartialStream }
+constructor TSFSPartialStream.Create (aSrc: TStream; aPos, aSize: Int64; aKillSrc: Boolean; preBuf: Pointer=nil; bufSz: Integer=0);
+begin
+ inherited Create();
+ ASSERT(aSrc <> nil);
+ if aPos < 0 then aPos := aSrc.Position;
+ if aSize < 0 then aSize := 0;
+ fSource := aSrc;
+ fKillSource := aKillSrc;
+ fLastReadPos := 0;
+ fCurrentPos := 0;
+ fStartPos := aPos;
+ fSize := aSize;
+ if bufSz > 0 then
+ begin
+ SetLength(fPreBuf, bufSz);
+ Move(preBuf^, fPreBuf[0], bufSz);
+ Inc(fSize, bufSz);
+ end
+ else
+ begin
+ fPreBuf := nil;
+ end;
+end;
+
+destructor TSFSPartialStream.Destroy ();
+begin
+ if fKillSource then FreeAndNil(fSource);
+ inherited Destroy();
+end;
+
+procedure TSFSPartialStream.CheckPos ();
+begin
+ {
+ if fSource.Position <> fStartPos+fCurrentPos-Length(fPreBuf) then
+ begin
+ fSource.Position := fStartPos+fCurrentPos-Length(fPreBuf);
+ end;
+ }
+ if fCurrentPos >= length(fPreBuf) then
+ begin
+ //writeln('seeking at ', fCurrentPos, ' (real: ', fStartPos+fCurrentPos-Length(fPreBuf), ')');
+ fSource.Position := fStartPos+fCurrentPos-Length(fPreBuf);
+ end;
+ fLastReadPos := fCurrentPos;
+end;
+
+function TSFSPartialStream.Write (const buffer; count: LongInt): LongInt;
+begin
+ result := 0;
+ raise XStreamError.Create('can''t write to read-only stream');
+ // à íå õîäè, íåõîðîøèé, â íàø ñàäèê ãóëÿòü!
+end;
+
+function TSFSPartialStream.Read (var buffer; count: LongInt): LongInt;
+var
+ left: Int64;
+ pc: Pointer;
+ rd: LongInt;
+begin
+ if count < 0 then raise XStreamError.Create('invalid Read() call'); // ñêàçî÷íûé äîëáî¸á...
+ if count = 0 then begin result := 0; exit; end;
+ pc := @buffer;
+ result := 0;
+ if (Length(fPreBuf) > 0) and (fCurrentPos < Length(fPreBuf)) then
+ begin
+ fLastReadPos := fCurrentPos;
+ left := Length(fPreBuf)-fCurrentPos;
+ if left > count then left := count;
+ if left > 0 then
+ begin
+ Move(fPreBuf[fCurrentPos], pc^, left);
+ Inc(PChar(pc), left);
+ Inc(fCurrentPos, left);
+ fLastReadPos := fCurrentPos;
+ Dec(count, left);
+ result := left;
+ if count = 0 then exit;
+ end;
+ end;
+ CheckPos();
+ left := fSize-fCurrentPos;
+ if left < count then count := left; // è òàê ñëó÷àåòñÿ...
+ if count > 0 then
+ begin
+ rd := fSource.Read(pc^, count);
+ Inc(result, rd);
+ Inc(fCurrentPos, rd);
+ fLastReadPos := fCurrentPos;
+ end
+ else
+ begin
+ result := 0;
+ end;
+end;
+
+function TSFSPartialStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
+begin
+ case origin of
+ soBeginning: result := offset;
+ soCurrent: result := offset+fCurrentPos;
+ soEnd: result := fSize+offset;
+ else raise XStreamError.Create('invalid Seek() call');
+ // äðóãèõ íå áûâàåò. à ó êîãî áûâàåò, òîìó ÿ íå äîêòîð.
+ end;
+ if result < 0 then result := 0
+ else if result > fSize then result := fSize;
+ fCurrentPos := result;
+end;
+
+
+{ TSFSGuardStream }
+constructor TSFSGuardStream.Create (aSrc, aGuarded: TStream; aKillSrc, aKillGuarded: Boolean; aGuardedFirst: Boolean=true);
+begin
+ inherited Create();
+ fSource := aSrc; fGuardedStream := aGuarded;
+ fKillSource := aKillSrc; fKillGuarded := aKillGuarded;
+ fGuardedFirst := aGuardedFirst;
+end;
+
+destructor TSFSGuardStream.Destroy ();
+begin
+ if fKillGuarded and fGuardedFirst then FreeAndNil(fGuardedStream);
+ if fKillSource then FreeAndNil(fSource);
+ if fKillGuarded and not fGuardedFirst then FreeAndNil(fGuardedStream);
+ inherited Destroy();
+end;
+
+function TSFSGuardStream.Read (var buffer; count: LongInt): LongInt;
+begin
+ result := fSource.Read(buffer, count);
+end;
+
+function TSFSGuardStream.Write (const buffer; count: LongInt): LongInt;
+begin
+ result := fSource.Write(buffer, count);
+end;
+
+function TSFSGuardStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
+begin
+ result := fSource.Seek(offset, origin);
+end;
+
+
+{ TSFSMemoryStreamRO }
+constructor TSFSMemoryStreamRO.Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
+begin
+ fFreeMem := aFreeMem;
+ fMem := pMem;
+ inherited Create();
+ SetPointer(pMem, pSize);
+ Position := 0;
+end;
+
+destructor TSFSMemoryStreamRO.Destroy ();
+begin
+ if fFreeMem and (fMem <> nil) then FreeMem(fMem);
+end;
+
+function TSFSMemoryStreamRO.Write (const buffer; count: LongInt): LongInt;
+begin
+ result := 0;
+ raise XStreamError.Create('can''t write to read-only stream');
+ // ñîâñåì ñáðåíäèë...
+end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+{ TUnZStream }
+const ZBufSize = 32768; // size of the buffer used for temporarily storing data from the child stream
+
+
+constructor TUnZStream.create (asrc: TStream; aSize: Int64; aKillSrc: Boolean; aSkipHeader: boolean=false);
+var
+ err: Integer;
+begin
+ fKillSrc := aKillSrc;
+ fPos := 0;
+ fSkipToPos := -1;
+ fSrcSt := asrc;
+ fSize := aSize;
+ GetMem(fBuffer, ZBufSize);
+ fSkipHeader := aSkipHeader;
+ fSrcStPos := fSrcSt.position;
+ FillChar(fZlibSt, sizeof(fZlibSt), 0);
+ if fSkipHeader then err := inflateInit2(fZlibSt, -MAX_WBITS) else err := inflateInit(fZlibSt);
+ if err <> Z_OK then raise XStreamError.Create(zerror(err));
+end;
+
+
+destructor TUnZStream.destroy ();
+begin
+ inflateEnd(fZlibSt);
+ FreeMem(fBuffer);
+ if fKillSrc then fSrcSt.Free();
+ inherited Destroy();
+end;
+
+
+function TUnZStream.readBuf (var buffer; count: LongInt): LongInt;
+var
+ err: Integer;
+ sz: LongInt;
+begin
+ result := 0;
+ if (fSize >= 0) and (fPos >= fSize) then exit;
+ if count > 0 then
+ begin
+ fZlibSt.next_out := @buffer;
+ fZlibSt.avail_out := count;
+ sz := fZlibSt.avail_out;
+ while fZlibSt.avail_out > 0 do
+ begin
+ if fZlibSt.avail_in = 0 then
+ begin
+ // refill the buffer
+ fZlibSt.next_in := fBuffer;
+ fZlibSt.avail_in := fSrcSt.read(Fbuffer^, ZBufSize);
+ end;
+ err := inflate(fZlibSt, Z_NO_FLUSH);
+ if (err <> Z_OK) and (err <> Z_STREAM_END) then raise XStreamError.Create(zerror(err));
+ Inc(result, sz-fZlibSt.avail_out);
+ Inc(fPos, sz-fZlibSt.avail_out);
+ sz := fZlibSt.avail_out;
+ if err = Z_STREAM_END then begin fSize := fPos; break; end;
+ end;
+ end;
+end;
+
+
+procedure TUnZStream.fixPos ();
+var
+ buf: array [0..4095] of Byte;
+ rd, rr: LongInt;
+begin
+ if fSkipToPos < 0 then exit;
+ //writeln('fixing pos: fPos=', fPos, '; fSkipToPos=', fSkipToPos);
+ if fSkipToPos < fPos then reset();
+ while fPos < fSkipToPos do
+ begin
+ if fSkipToPos-fPos > 4096 then rd := 4096 else rd := LongInt(fSkipToPos-fPos);
+ //writeln(' reading ', rd, ' bytes...');
+ rr := readBuf(buf, rd);
+ //writeln(' got ', rr, ' bytes; fPos=', fPos, '; fSkipToPos=', fSkipToPos);
+ if rr <= 0 then raise XStreamError.Create('seek error');
+ end;
+ //writeln(' pos: fPos=', fPos, '; fSkipToPos=', fSkipToPos);
+ fSkipToPos := -1;
+end;
+
+
+procedure TUnZStream.determineSize ();
+var
+ buf: array [0..4095] of Byte;
+ rd: LongInt;
+ opos: Int64;
+begin
+ if fSize >= 0 then exit;
+ opos := fPos;
+ try
+ //writeln('determining unzstream size...');
+ while true do
+ begin
+ rd := readBuf(buf, 4096);
+ if rd = 0 then break;
+ end;
+ fSize := fPos;
+ //writeln(' unzstream size is ', fSize);
+ finally
+ if fSkipToPos < 0 then fSkipToPos := opos;
+ end;
+end;
+
+
+function TUnZStream.read (var buffer; count: LongInt): LongInt;
+begin
+ if fSkipToPos >= 0 then fixPos();
+ result := readBuf(buffer, count);
+end;
+
+
+function TUnZStream.write (const buffer; count: LongInt): LongInt;
+begin
+ result := 0;
+ raise XStreamError.Create('can''t write to read-only stream');
+end;
+
+
+procedure TUnZStream.reset ();
+var
+ err: Integer;
+begin
+ //writeln('doing RESET');
+ fSrcSt.position := fSrcStPos;
+ fPos := 0;
+ inflateEnd(fZlibSt);
+ FillChar(fZlibSt, sizeof(fZlibSt), 0);
+ if fSkipHeader then err := inflateInit2(fZlibSt, -MAX_WBITS) else err := inflateInit(fZlibSt);
+ if err <> Z_OK then raise XStreamError.Create(zerror(err));
+end;
+
+
+function TUnZStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
+var
+ cpos: Int64;
+begin
+ cpos := fPos;
+ if fSkipToPos >= 0 then cpos := fSkipToPos;
+ case origin of
+ soBeginning: result := offset;
+ soCurrent: result := offset+cpos;
+ soEnd: begin determineSize(); result := fSize+offset; end;
+ else raise XStreamError.Create('invalid Seek() call');
+ // äðóãèõ íå áûâàåò. à ó êîãî áûâàåò, òîìó ÿ íå äîêòîð.
+ end;
+ if result < 0 then result := 0;
+ fSkipToPos := result;
+ //writeln('seek: ofs=', offset, '; origin=', origin, '; result=', result);
+end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+constructor TSFSMemoryChunkStream.Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
+begin
+ fMemBuf := nil;
+ fFreeMem := false;
+ fMemSize := 0;
+ fCurPos := 0;
+ setup(pMem, pSize, aFreeMem);
+end;
+
+
+procedure TSFSMemoryChunkStream.setup (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
+begin
+ if fFreeMem then FreeMem(fMemBuf);
+ fMemBuf := nil;
+ fFreeMem := false;
+ fMemSize := 0;
+ fCurPos := 0;
+ if (pSize < 0) then raise XStreamError.Create('invalid chunk size');
+ if (pMem = nil) then
+ begin
+ if (pSize > 0) then
+ begin
+ GetMem(pMem, pSize);
+ if (pMem = nil) then raise XStreamError.Create('out of memory for chunk');
+ aFreeMem := true;
+ end
+ else
+ begin
+ aFreeMem := false;
+ end;
+ end;
+ fFreeMem := aFreeMem;
+ fMemBuf := PByte(pMem);
+ fMemSize := pSize;
+end;
+
+
+destructor TSFSMemoryChunkStream.Destroy ();
+begin
+ if fFreeMem then FreeMem(fMemBuf);
+ inherited;
+end;
+
+
+function TSFSMemoryChunkStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
+begin
+ case origin of
+ soBeginning: result := offset;
+ soCurrent: result := offset+fCurPos;
+ soEnd: result := fMemSize+offset;
+ else raise XStreamError.Create('invalid Seek() call');
+ end;
+ if (result < 0) then raise XStreamError.Create('invalid Seek() call');
+ if (result > fMemSize) then result := fMemSize;
+ fCurPos := result;
+end;
+
+
+function TSFSMemoryChunkStream.Read (var buffer; count: LongInt): LongInt;
+var
+ left: Integer;
+begin
+ if (count < 0) then raise XStreamError.Create('negative read');
+ left := fMemSize-fCurPos;
+ if (left < 0) then raise XStreamError.Create('internal error in TSFSMemoryChunkStream (read)');
+ if (count > left) then count := left;
+ if (count > 0) then Move((fMemBuf+fCurPos)^, buffer, count);
+ Inc(fCurPos, count);
+ result := count;
+end;
+
+
+function TSFSMemoryChunkStream.Write (const buffer; count: LongInt): LongInt;
+var
+ left: Integer;
+begin
+ if (count < 0) then raise XStreamError.Create('negative write');
+ left := fMemSize-fCurPos;
+ if (left < 0) then raise XStreamError.Create('internal error in TSFSMemoryChunkStream (write)');
+ if (count > left) then count := left;
+ if (count > 0) then Move(buffer, (fMemBuf+fCurPos)^, count);
+ Inc(fCurPos, count);
+ result := count;
+end;
+
+
+end.