From 7bc7d5022ae82e37fee8b3003432f9294176a470 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Tue, 18 Sep 2018 18:32:12 +0300 Subject: [PATCH] Added SFS support (resource wads only) (#4) --- src/editor/Editor.lpr | 5 + src/editor/f_addresource.pas | 131 ++- src/editor/f_addresource_sky.pas | 13 +- src/editor/f_addresource_sound.pas | 14 +- src/editor/f_addresource_texture.pas | 317 ++----- src/editor/f_main.pas | 25 +- src/editor/g_resources.pas | 79 ++ src/editor/g_textures.pas | 211 ++--- src/sfs/sfs.pas | 1274 ++++++++++++++++++++++++++ src/sfs/sfsPlainFS.pas | 147 +++ src/sfs/sfsZipFS.pas | 465 ++++++++++ src/shared/xstreams.pas | 567 ++++++++++++ 12 files changed, 2755 insertions(+), 493 deletions(-) create mode 100644 src/editor/g_resources.pas create mode 100644 src/sfs/sfs.pas create mode 100644 src/sfs/sfsPlainFS.pas create mode 100644 src/sfs/sfsZipFS.pas create mode 100644 src/shared/xstreams.pas diff --git a/src/editor/Editor.lpr b/src/editor/Editor.lpr index 8bd60c2..21d8fe5 100644 --- a/src/editor/Editor.lpr +++ b/src/editor/Editor.lpr @@ -15,6 +15,11 @@ uses 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}, diff --git a/src/editor/f_addresource.pas b/src/editor/f_addresource.pas index 815fb1f..69b214e 100644 --- a/src/editor/f_addresource.pas +++ b/src/editor/f_addresource.pas @@ -45,7 +45,7 @@ var implementation uses - f_main, WADSTRUCT, g_language, utils; + f_main, WADSTRUCT, g_language, utils, sfs; {$R *.lfm} @@ -53,9 +53,8 @@ const STANDART_WAD = 'Standart.wad'; procedure TAddResourceForm.FormActivate(Sender: TObject); -var - SR: TSearchRec; - + var + SR: TSearchRec; begin cbWADList.Clear(); cbSectionsList.Clear(); @@ -66,9 +65,10 @@ begin 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); @@ -103,87 +103,67 @@ begin 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 := ''; @@ -191,25 +171,18 @@ begin 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. diff --git a/src/editor/f_addresource_sky.pas b/src/editor/f_addresource_sky.pas index 98a8026..49034d2 100644 --- a/src/editor/f_addresource_sky.pas +++ b/src/editor/f_addresource_sky.pas @@ -31,7 +31,7 @@ var implementation uses - BinEditor, WADEDITOR, f_main, g_language; + WADEDITOR, f_main, g_language, g_resources; {$R *.lfm} @@ -48,23 +48,14 @@ var 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 diff --git a/src/editor/f_addresource_sound.pas b/src/editor/f_addresource_sound.pas index c6406d0..15ea34d 100644 --- a/src/editor/f_addresource_sound.pas +++ b/src/editor/f_addresource_sound.pas @@ -43,7 +43,7 @@ var 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} @@ -118,7 +118,6 @@ end; function CreateSoundWAD(Resource: String): Boolean; var - WAD: TWADEditor_1; FileName, SectionName, ResourceName: String; ResLength: Integer; sz: LongWord; @@ -132,11 +131,9 @@ begin 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); @@ -151,19 +148,16 @@ begin 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; diff --git a/src/editor/f_addresource_texture.pas b/src/editor/f_addresource_texture.pas index 32a4da1..62d0fd5 100644 --- a/src/editor/f_addresource_texture.pas +++ b/src/editor/f_addresource_texture.pas @@ -49,197 +49,48 @@ implementation 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; @@ -309,94 +160,44 @@ begin 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 e263534..3f65bba 100644 --- a/src/editor/f_main.pas +++ b/src/editor/f_main.pas @@ -339,7 +339,7 @@ uses 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; @@ -2619,23 +2619,15 @@ var 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); @@ -2644,14 +2636,15 @@ begin 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 new file mode 100644 index 0000000..c85eb74 --- /dev/null +++ b/src/editor/g_resources.pas @@ -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. diff --git a/src/editor/g_textures.pas b/src/editor/g_textures.pas index 786229a..52c6169 100644 --- a/src/editor/g_textures.pas +++ b/src/editor/g_textures.pas @@ -28,7 +28,7 @@ procedure g_DeleteAllTextures(); implementation uses - e_log, WADEDITOR, g_basic, SysUtils; + e_log, WADEDITOR, g_basic, SysUtils, g_resources; type _TTexture = record @@ -65,32 +65,26 @@ begin 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, @@ -121,109 +115,88 @@ begin 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 new file mode 100644 index 0000000..67136e9 --- /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 . + *) +// 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; + // ñïèñîê äèñêîâûõ êàòàëîãîâ äëÿ ïîèñêà ôàéëà. åñëè ïóñò -- èùåì òîëüêî â + // òåêóùåì. êàòàëîãè ðàçäåëÿþòñÿ òðóáîé ("|"). + // çàìåíÿåòñÿ íà òåêóùèé êàòàëîã (ñ çàâåðøàþùèì "/"), + // çàìåíÿåòñÿ íà êàòàëîã, ãäå ñèäèò .EXE (ñ çàâåðøàþùèì "/"). + sfsDiskDirs: AnsiString = '|'; + + +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 = '' then es := GetCurrentDir + else if es = '' 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 := ''; + 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 new file mode 100644 index 0000000..e6571ef --- /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 . + *) +// 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 new file mode 100644 index 0000000..2cc9eff --- /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 . + *) +// 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 new file mode 100644 index 0000000..e27f73a --- /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 . + *) +// 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. -- 2.29.2