summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: dd6a8c0)
raw | patch | inline | side by side (parent: dd6a8c0)
| author | DeaDDooMER <deaddoomer@deadsoftware.ru> | |
| Mon, 4 Sep 2023 12:00:04 +0000 (15:00 +0300) | ||
| committer | DeaDDooMER <deaddoomer@deadsoftware.ru> | |
| Thu, 7 Sep 2023 16:55:51 +0000 (19:55 +0300) |
24 files changed:
diff --git a/lang/editor.ru_RU.lng b/lang/editor.ru_RU.lng
index 681f634a2b843edfee718af889cfb77933506d24..29bf4c95c34c84e49b6e0bbcbe0f76f77b598753 100644 (file)
--- a/lang/editor.ru_RU.lng
+++ b/lang/editor.ru_RU.lng
g_language.MsgWadSpecialTexs$ = "<EXTRA TEXTURES>"
g_language.MsgWadSpecialTexs = "<СПЕЦТЕКСТУРЫ>"
-g_language.MsgFileFilterAll$ = "Doom 2D: Forever Maps (*.dfz, *.dfzip, *.zip, *.wad)|*.dfz;*.dfzip;*.zip;*.wad|Doom 2D: Forever 0.30 Maps (*.ini)|*.ini|All Files (*.*)|*.*"
-g_language.MsgFileFilterAll = "Карты Doom 2D: Forever (*.dfz, *.dfzip, *.zip, *.wad)|*.dfz;*.dfzip;*.zip;*.wad|Старые карты Doom 2D: Forever 0.30 (*.ini)|*.ini|Все файлы (*.*)|*.*"
-g_language.MsgFileFilterWad$ = "Doom 2D: Forever Maps (*.dfz)|*.dfz|Doom 2D: Forever Maps (*.dfzip)|*.dfzip|Doom 2D: Forever Maps (*.zip)|*.zip|Doom 2D: Forever Maps (*.wad)|*.wad|All Files (*.*)|*.*"
-g_language.MsgFileFilterWad = "Карты Doom 2D: Forever (*.dfz)|*.dfz|Карты Doom 2D: Forever (*.dfzip)|*.dfzip|Карты Doom 2D: Forever (*.zip)|*.zip|Карты Doom 2D: Forever (*.wad)|*.wad|Все файлы (*.*)|*.*"
+g_language.MsgFileFilterAll$ = "Doom 2D: Forever Maps (*.wad)|*.wad|Doom 2D: Forever 0.30 Maps (*.ini)|*.ini|All Files (*.*)|*.*"
+g_language.MsgFileFilterAll = "Карты Doom 2D: Forever (*.wad)|*.wad|Старые карты Doom 2D: Forever 0.30 (*.ini)|*.ini|Все файлы (*.*)|*.*"
+g_language.MsgFileFilterWad$ = "Doom 2D: Forever Maps (*.wad)|*.wad|All Files (*.*)|*.*"
+g_language.MsgFileFilterWad = "Карты Doom 2D: Forever (*.wad)|*.wad|Все файлы (*.*)|*.*"
g_language.MsgFileFilterExeMac$ = "Doom 2D Forever.app|*.app|Doom 2D Forever (Unix Executable)|Doom2DF;*"
g_language.MsgFileFilterExeMac = "Doom 2D Forever.app|*.app|Doom 2D Forever (Исполняемый файл)|Doom2DF;*"
g_language.MsgFileFilterExeWin$ = "Doom2DF.exe|Doom2DF.exe;*.exe"
diff --git a/src/editor/Editor.lpi b/src/editor/Editor.lpi
index 1354cd3e31a746655c6aeae35fee632b0788d514..c958b71251f1f6b7abfdf359b3e8cce39285ccbc 100644 (file)
--- a/src/editor/Editor.lpi
+++ b/src/editor/Editor.lpi
<Parsing>
<SyntaxOptions>
<SyntaxMode Value="Delphi"/>
- <IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
<Optimizations>
- <OptimizationLevel Value="2"/>
+ <OptimizationLevel Value="3"/>
</Optimizations>
</CodeGeneration>
<Linking>
diff --git a/src/editor/Editor.lpr b/src/editor/Editor.lpr
index 6bf0b86243c94bff222999756e0d4db8bde52f4a..eaf830dd4e54b85042be85b1135bac2548d14ead 100644 (file)
--- a/src/editor/Editor.lpr
+++ b/src/editor/Editor.lpr
WADEDITOR in '../shared/WADEDITOR.pas',
WADSTRUCT in '../shared/WADSTRUCT.pas',
CONFIG in '../shared/CONFIG.pas',
- xstreams in '../shared/xstreams.pas',
- dfzip in '../shared/dfzip.pas',
- sfs in '../sfs/sfs.pas',
- sfsPlainFS in '../sfs/sfsPlainFS.pas',
- sfsZipFS in '../sfs/sfsZipFS.pas',
-
f_about in 'f_about.pas' {AboutForm},
f_options in 'f_options.pas' {OptionsForm},
f_main in 'f_main.pas' {MainForm},
index 103d9b031f3165cb39920cd042a8f4d56c5dcf3f..a0bebb99bd2912ada915778f7aef692159bd35d9 100644 (file)
implementation
uses
- f_main, WADSTRUCT, g_language, utils, sfs, g_options;
+ f_main, WADSTRUCT, g_language, utils, g_options;
{$R *.lfm}
STANDART_WAD = 'standart.wad';
procedure TAddResourceForm.FormActivate(Sender: TObject);
- var
- SR: TSearchRec;
+var
+ SR: TSearchRec;
+
begin
cbWADList.Clear();
cbSectionsList.Clear();
if FindFirst(WadsDir + DirectorySeparator + '*.*', faAnyFile, SR) = 0 then
repeat
- if (SR.name <> '.') and (SR.name <> '..') then
- cbWADList.Items.Add(SR.Name);
+ cbWADList.Items.Add(SR.Name);
until FindNext(SR) <> 0;
FindClose(SR);
end;
procedure TAddResourceForm.cbWADListChange(Sender: TObject);
- var
- wad: TSFSFileList;
- i: Integer;
- FileName, Section, sn, rn: String;
+var
+ WAD: TWADEditor_1;
+ SectionList: SArray;
+ i: Integer;
+ FileName, fn, sn, rn: String;
+
begin
+ WAD := TWADEditor_1.Create();
+
+// Внешний WAD:
if cbWADList.Text <> MsgWadSpecialMap then
- FileName := WadsDir + DirectorySeparator + cbWADList.Text (* Resource wad *)
- else
- g_ProcessResourceStr(OpenedMap, FileName, sn, rn); (* Map wad *)
+ FileName := WadsDir + DirectorySeparator + cbWADList.Text
+ else // WAD карты:
+ begin
+ g_ProcessResourceStr(OpenedMap, fn, sn, rn);
+ FileName := fn;
+ end;
+
+// Читаем секции:
+ WAD.ReadFile(FileName);
+ SectionList := WAD.GetSectionList();
+ WAD.Free();
cbSectionsList.Clear();
lbResourcesList.Clear();
- 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)
+ 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('..');
end;
procedure TAddResourceForm.cbSectionsListChange(Sender: TObject);
- var
- wad: TSFSFileList;
- i: Integer;
- FileName, Section, SectionName, sn, rn: String;
+var
+ ResourceList: SArray;
+ WAD: TWADEditor_1;
+ i: DWORD;
+ FileName, SectionName, fn, sn, rn: String;
+
begin
+ WAD := TWADEditor_1.Create();
+
+// Внешний WAD:
if cbWADList.Text <> MsgWadSpecialMap then
- FileName := WadsDir + DirectorySeparator + cbWADList.Text (* Resource wad *)
+ FileName := WadsDir + DirectorySeparator + 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
else
- g_ProcessResourceStr(OpenedMap, FileName, sn, rn); (* Map wad *)
+ SectionName := '';
+
+// Читаем ресурсы выбранной секции:
+ ResourceList := WAD.GetResourcesList(utf2win(SectionName));
+
+ WAD.Free();
- SectionName := cbSectionsList.Text;
lbResourcesList.Clear();
- 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;
+ if ResourceList <> nil then
+ for i := 0 to High(ResourceList) do
+ lbResourcesList.Items.Add(win2utf(ResourceList[i]));
end;
procedure TAddResourceForm.lbResourcesListClick(Sender: TObject);
- var
- FileName, fn: String;
+var
+ FileName, SectionName, fn: String;
+
begin
- FResourceSelected := (lbResourcesList.SelCount > 0) or (lbResourcesList.ItemIndex > -1);
+ FResourceSelected := (lbResourcesList.SelCount > 0) or
+ (lbResourcesList.ItemIndex > -1);
+
if not FResourceSelected then
begin
FResourceName := '';
Exit;
end;
+ if cbSectionsList.Text = '..' then
+ SectionName := ''
+ else
+ SectionName := cbSectionsList.Text;
+
if cbWADList.Text[1] <> '<' then
FileName := cbWADList.Text
else
FileName := '';
- FResourceName := FileName + ':' + cbSectionsList.Text + '\' + lbResourcesList.Items[lbResourcesList.ItemIndex];
+ FResourceName := FileName+':'+SectionName+'\'+lbResourcesList.Items[lbResourcesList.ItemIndex];
- g_ProcessResourceStr(OpenedMap, @fn, nil, nil);
if FileName <> '' then
FFullResourceName := WadsDir + DirectorySeparator + FResourceName
else
- FFullResourceName := fn + FResourceName
+ begin
+ g_ProcessResourceStr(OpenedMap, @fn, nil, nil);
+ FFullResourceName := fn+FResourceName;
+ end;
end;
end.
index bb4fa10e2ed6a12d92c739c050b3ea0577d5367c..e7b03613ddcb20db4c4f00e523db8b1647548905 100644 (file)
implementation
uses
- WADEDITOR, f_main, g_language, g_resources;
+ BinEditor, WADEDITOR, f_main, g_language;
{$R *.lfm}
TextureData: Pointer;
ImageSize: Integer;
+ WAD: TWADEditor_1;
WADName: String;
SectionName: String;
ResourceName: String;
begin
Result := nil;
+
+// Загружаем ресурс текстуры из WAD:
g_ProcessResourceStr(ResourceStr, WADName, SectionName, ResourceName);
- g_ReadResource(WADName, SectionName, ResourceName, TextureData, ImageSize);
+
+ WAD := TWADEditor_1.Create();
+ WAD.ReadFile(WADName);
+
+ WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), TextureData, ImageSize);
+
+ WAD.Free();
(* !!! copypaste from f_addresource_texture.CreateBitMap *)
index a3d3fe15c415323c647e899b4f695c81f443f369..eaba574aa61e2d71e0f8621e5f3b0842d3442301 100644 (file)
implementation
uses
- BinEditor, WADEDITOR, e_log, f_main, g_language, g_resources
+ BinEditor, WADEDITOR, e_log, f_main, g_language
{$IFNDEF NOSOUND}, fmod, fmodtypes, fmoderrors;{$ELSE};{$ENDIF}
{$R *.lfm}
function TAddSoundForm.CreateSoundWAD(Resource: String): Boolean;
var
+ WAD: TWADEditor_1;
FileName, SectionName, ResourceName: String;
ResLength: Integer;
sz: LongWord;
{$IFNDEF NOSOUND}
g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
- g_ReadResource(FileName, SectionName, ResourceName, SoundData, ResLength);
- if SoundData <> nil then
+ WAD := TWADEditor_1.Create;
+ WAD.ReadFile(FileName);
+
+ if WAD.GetResource(utf2win(SectionName), utf2win(ResourceName), SoundData, ResLength) then
begin
sz := SizeOf(FMOD_CREATESOUNDEXINFO);
FillMemory(@soundExInfo, sz, 0);
begin
e_WriteLog(Format('Error creating sound %s', [Resource]), MSG_WARNING);
e_WriteLog(FMOD_ErrorString(res), MSG_WARNING);
+ WAD.Free();
Exit;
end;
end
else
begin
e_WriteLog(Format('Error loading sound %s', [Resource]), MSG_WARNING);
- //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
+ e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
+ WAD.Free();
Exit;
end;
+ WAD.Free();
Result := True;
{$ENDIF}
end;
index 927017e6de9d6cfba12566faae8c9b5e51eb9d87..13adf3cb958db9f2fe163717b8c574df7eb5b53c 100644 (file)
uses
BinEditor, WADEDITOR, WADSTRUCT, f_main, g_textures, CONFIG, g_map,
- g_language, e_Log, g_resources;
+ g_language;
{$R *.lfm}
function IsAnim(Res: String): Boolean;
- var
- data: Pointer;
- len: Integer;
- WADName, SectionName, ResourceName: String;
+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;
+
begin
+ Result := False;
+ Data := nil;
+ Size := 0;
+
+// Читаем файл и ресурс в нем:
g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
- (* 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)
+
+ 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;
end;
-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;
+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;
+
begin
- Result := False; Data := nil; DataLen := 0; Width := 0; Height := 0;
+ Result := False;
+ AnimWAD := nil;
+ Len := 0;
+ TextData := nil;
+
+// Читаем WAD:
g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
- g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXT', 'ANIM', TextData, Len);
- if TextData <> nil then
+
+ WAD := TWADEditor_1.Create();
+
+ if not WAD.ReadFile(WADName) then
begin
- 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
+ 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
+ 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;
end;
function CreateBitMap (Data: Pointer; DataSize: Cardinal): TBitMap;
end;
function ShowAnim(Res: String): TBitMap;
- var
- Len: Integer;
- TextData, TextureData: Pointer;
- WADName, SectionName, ResourceName: String;
- config: TConfig;
+var
+ AnimWAD: Pointer;
+ WAD: TWADEditor_1;
+ WADName: String;
+ SectionName: String;
+ ResourceName: String;
+ Len: Integer;
+ config: TConfig;
+ TextData: Pointer;
+ TextureData: Pointer;
+
begin
Result := nil;
+ AnimWAD := nil;
+ Len := 0;
+ TextData := nil;
+ TextureData := nil;
+
+// Читаем WAD файл и ресурс в нем:
g_ProcessResourceStr(Res, WADName, SectionName, ResourceName);
- g_ReadSubResource(WADName, SectionName, ResourceName, 'TEXT', 'ANIM', TextData, Len);
- if TextData <> nil then
+
+ 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
begin
- 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
+ // Создаем 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);
end;
function ShowTGATexture(ResourceStr: String): TBitMap;
- var
- Len: Integer;
- TextureData: Pointer;
- WADName, SectionName, ResourceName: String;
+var
+ TextureData: Pointer;
+ WAD: TWADEditor_1;
+ WADName: String;
+ SectionName: String;
+ ResourceName: String;
+ Len: Integer;
+
begin
Result := nil;
+ TextureData := nil;
+ Len := 0;
+
+// Читаем WAD:
g_ProcessResourceStr(ResourceStr, WADName, SectionName, ResourceName);
- g_ReadResource(WADName, SectionName, ResourceName, TextureData, Len);
- if TextureData <> nil then
- Result := CreateBitMap(TextureData, Len)
+
+ 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);
end;
procedure TAddTextureForm.FormActivate(Sender: TObject);
diff --git a/src/editor/f_main.lfm b/src/editor/f_main.lfm
index 07a325d4446c46f04247db73bbd093769fdd03e8..79d039a252cdbedeefd5193501b79a03c3d3dbd6 100644 (file)
--- a/src/editor/f_main.lfm
+++ b/src/editor/f_main.lfm
end
end
object OpenDialog: TOpenDialog
- DefaultExt = '.dfz'
- Filter = 'Карты Doom 2D: Forever (*.dfz, *.dfzip, *.zip, *.wad)|*.dfz;*.dfzip;*.zip;*.wad|Старые карты Doom 2D: Forever 0.30 (*.ini)|*.ini|Все файлы (*.*)|*.*'
+ DefaultExt = '.wad'
+ Filter = 'Карты Doom 2D: Forever (*.wad)|*.wad|Старые карты Doom 2D: Forever (*.ini)|*.ini|Все файлы (*.*)|*.*'
Options = [ofHideReadOnly, ofNoChangeDir, ofPathMustExist, ofFileMustExist, ofEnableSizing, ofDontAddToRecent]
Left = 32
Top = 64
}
end
object SaveDialog: TSaveDialog
- DefaultExt = '.dfz'
- Filter = 'Карты Doom 2D: Forever (*.dfz)|*.dfz|Карты Doom 2D: Forever (*.dfzip)|*.dfzip|Карты Doom 2D: Forever (*.zip)|*.zip|Карты Doom 2D: Forever (*.wad)|*.wad|Все файлы (*.*)|*.*'
+ DefaultExt = '.wad'
+ Filter = 'Карты Doom 2D: Forever (*.wad)|*.wad|Все файлы (*.*)|*.*'
Options = [ofHideReadOnly, ofNoChangeDir, ofPathMustExist, ofNoReadOnlyReturn, ofEnableSizing, ofDontAddToRecent]
Left = 64
Top = 64
diff --git a/src/editor/f_main.pas b/src/editor/f_main.pas
index 53bf85da742cf26b936bb5276e2694763f6bc7ea..2bd2fc6bff2a770560fb6b3fad4685fe6ea8e50d 100644 (file)
--- a/src/editor/f_main.pas
+++ b/src/editor/f_main.pas
f_mapoptions, g_basic, f_about, f_mapoptimization,
f_mapcheck, f_addresource_texture, g_textures,
f_activationtype, f_keys, wadreader, fileutil,
- MAPREADER, f_selectmap, f_savemap, WADEDITOR, MAPDEF,
+ MAPREADER, f_selectmap, f_savemap, WADEDITOR, WADSTRUCT, MAPDEF,
g_map, f_saveminimap, f_addresource, CONFIG, f_packmap,
f_addresource_sound, f_choosetype,
- g_language, ClipBrd, g_resources, g_options;
+ g_language, ClipBrd, g_options;
const
UNDO_DELETE_PANEL = 1;
cwdt, chgt: Byte;
spc: ShortInt;
ID: DWORD;
+ wad: TWADEditor_1;
cfgdata: Pointer;
cfglen: Integer;
config: TConfig;
begin
+ cfgdata := nil;
+ cfglen := 0;
ID := 0;
- g_ReadResource(GameWad, 'FONTS', cfgres, cfgdata, cfglen);
- if cfgdata <> nil then
+
+ wad := TWADEditor_1.Create;
+ if wad.ReadFile(GameWad) then
+ wad.GetResource('FONTS', cfgres, cfgdata, cfglen);
+ wad.Free();
+
+ if cfglen <> 0 then
begin
if not g_CreateTextureWAD('FONT_STD', GameWad + ':FONTS\' + texture) then
e_WriteLog('ERROR ERROR ERROR', MSG_WARNING);
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
- begin
- e_WriteLog('Could not load FONT_STD', MSG_WARNING)
- end
+ e_WriteLog('Could not load FONT_STD', MSG_WARNING);
+
+ if cfglen <> 0 then FreeMem(cfgdata);
end;
procedure TMainForm.FormCreate(Sender: TObject);
s := config.ReadStr('Editor', 'Language', '');
gLanguage := s;
- Compress := config.ReadBool('Editor', 'Compress', True);
- Backup := config.ReadBool('Editor', 'Backup', True);
-
TestGameMode := config.ReadStr('TestRun', 'GameMode', 'DM');
TestLimTime := config.ReadStr('TestRun', 'LimTime', '0');
TestLimScore := config.ReadStr('TestRun', 'LimScore', '0');
procedure TMainForm.aDeleteMap(Sender: TObject);
var
- res: Integer;
- FileName: String;
- MapName: String;
+ WAD: TWADEditor_1;
+ MapList: SArray;
+ MapName: Char16;
+ a: Integer;
+ str: String;
begin
OpenDialog.Filter := MsgFileFilterWad;
if not OpenDialog.Execute() then
Exit;
- FileName := OpenDialog.FileName;
- SelectMapForm.Caption := MsgCapRemove;
- SelectMapForm.lbMapList.Items.Clear();
- SelectMapForm.GetMaps(FileName);
+ WAD := TWADEditor_1.Create();
- if SelectMapForm.ShowModal() <> mrOK then
+ if not WAD.ReadFile(OpenDialog.FileName) then
+ begin
+ WAD.Free();
Exit;
+ end;
- MapName := SelectMapForm.lbMapList.Items[SelectMapForm.lbMapList.ItemIndex];
- if Application.MessageBox(PChar(Format(MsgMsgDeleteMapPrompt, [MapName, OpenDialog.FileName])), PChar(MsgMsgDeleteMap), MB_ICONQUESTION or MB_YESNO or MB_DEFBUTTON2) <> mrYes then
- Exit;
+ WAD.CreateImage();
+
+ MapList := WAD.GetResourcesList('');
- g_DeleteResource(FileName, '', MapName, res);
- if res <> 0 then
+ SelectMapForm.Caption := MsgCapRemove;
+ SelectMapForm.lbMapList.Items.Clear();
+
+ if MapList <> nil then
+ for a := 0 to High(MapList) do
+ SelectMapForm.lbMapList.Items.Add(win2utf(MapList[a]));
+
+ if (SelectMapForm.ShowModal() = mrOK) then
begin
- Application.MessageBox(PChar('Cant delete map res=' + IntToStr(res)), PChar('Map not deleted!'), MB_ICONINFORMATION or MB_OK or MB_DEFBUTTON1);
- Exit
- end;
+ str := SelectMapForm.lbMapList.Items[SelectMapForm.lbMapList.ItemIndex];
+ MapName := '';
+ Move(str[1], MapName[0], Min(16, Length(str)));
+
+ if Application.MessageBox(PChar(Format(MsgMsgDeleteMapPrompt, [MapName, OpenDialog.FileName])), PChar(MsgMsgDeleteMap), MB_ICONQUESTION or MB_YESNO or MB_DEFBUTTON2) <> mrYes then
+ Exit;
+
+ WAD.RemoveResource('', utf2win(MapName));
+
+ Application.MessageBox(
+ PChar(Format(MsgMsgMapDeletedPrompt, [MapName])),
+ PChar(MsgMsgMapDeleted),
+ MB_ICONINFORMATION or MB_OK or MB_DEFBUTTON1
+ );
- Application.MessageBox(
- PChar(Format(MsgMsgMapDeletedPrompt, [MapName])),
- PChar(MsgMsgMapDeleted),
- MB_ICONINFORMATION or MB_OK or MB_DEFBUTTON1
- );
+ WAD.SaveTo(OpenDialog.FileName);
// Удалили текущую карту - сохранять по старому ее нельзя:
- if OpenedMap = (FileName + ':\' + MapName) then
- begin
- OpenedMap := '';
- OpenedWAD := '';
- MainForm.Caption := FormCaption
- end
+ if OpenedMap = (OpenDialog.FileName+':\'+MapName) then
+ begin
+ OpenedMap := '';
+ OpenedWAD := '';
+ MainForm.Caption := FormCaption;
+ end;
+ end;
+
+ WAD.Free();
end;
procedure TMainForm.vleObjectPropertyKeyDown(Sender: TObject;
index 0a3eca32107fe2c3f30ee1a89ea02cc5c2193a7b..6ae5c8e46d8a6f4f32cd9afc867a4e3bdee0f0b5 100644 (file)
--- a/src/editor/f_options.lfm
+++ b/src/editor/f_options.lfm
object OptionsForm: TOptionsForm
- Left = 98
- Height = 360
+ Left = 96
+ Height = 401
Top = 345
- Width = 640
+ Width = 713
BorderIcons = [biSystemMenu]
BorderStyle = bsSingle
Caption = 'Настройки редактора'
- ClientHeight = 360
- ClientWidth = 640
+ ClientHeight = 401
+ ClientWidth = 713
Color = clBtnFace
+ DesignTimePPI = 107
Font.Color = clWindowText
- Font.Height = -11
+ Font.Height = -12
Font.Name = 'MS Sans Serif'
OnCreate = FormCreate
OnShow = FormShow
Position = poScreenCenter
LCLVersion = '2.2.4.0'
object PageControl: TPageControl
- Left = 8
- Height = 312
- Top = 8
- Width = 624
+ Left = 9
+ Height = 348
+ Top = 9
+ Width = 696
ActivePage = TabGeneral
TabIndex = 0
TabOrder = 0
Options = [nboKeyboardTabSwitch, nboDoChangeOnSetIndex]
object TabGeneral: TTabSheet
Caption = 'General'
- ClientHeight = 284
- ClientWidth = 620
+ ClientHeight = 319
+ ClientWidth = 692
object cbShowDots: TCheckBox
- Left = 8
+ Left = 9
Height = 21
- Top = 8
- Width = 128
+ Top = 9
+ Width = 135
Caption = 'Показывать сетку'
TabOrder = 0
end
object cbShowTexture: TCheckBox
- Left = 8
+ Left = 9
Height = 21
- Top = 32
- Width = 193
+ Top = 36
+ Width = 207
Caption = 'Показывать текстуру панели'
TabOrder = 1
end
object cbShowSize: TCheckBox
- Left = 8
+ Left = 9
Height = 21
- Top = 56
- Width = 191
+ Top = 62
+ Width = 204
Caption = 'Показывать размеры панели'
TabOrder = 2
end
object cbCheckerboard: TCheckBox
- Left = 8
+ Left = 9
Height = 21
- Top = 80
- Width = 164
+ Top = 89
+ Width = 176
Caption = 'Использовать шахматку'
Checked = True
State = cbChecked
TabOrder = 3
end
object LabelGrid: TLabel
- Left = 8
- Height = 14
- Top = 112
- Width = 72
+ Left = 9
+ Height = 15
+ Top = 125
+ Width = 78
Caption = 'Шаги сетки:'
ParentColor = False
end
object SpinEdit1: TSpinEdit
- Left = 8
- Height = 22
- Top = 128
- Width = 50
+ Left = 9
+ Height = 23
+ Top = 143
+ Width = 56
MaxValue = 2048
MinValue = 4
TabOrder = 4
Value = 16
end
object SpinEdit2: TSpinEdit
- Left = 8
- Height = 22
- Top = 152
- Width = 50
+ Left = 9
+ Height = 23
+ Top = 169
+ Width = 56
MaxValue = 2048
MinValue = 4
TabOrder = 5
Value = 8
end
object LabelGridSize: TLabel
- Left = 8
- Height = 14
- Top = 184
- Width = 118
+ Left = 9
+ Height = 15
+ Top = 205
+ Width = 127
Caption = 'Размер точек сетки:'
ParentColor = False
WordWrap = True
end
object SpinEdit4: TSpinEdit
- Left = 8
- Height = 22
- Top = 200
- Width = 50
+ Left = 9
+ Height = 23
+ Top = 223
+ Width = 56
MaxValue = 2
MinValue = 1
TabOrder = 6
Value = 1
end
object LabelMinimap: TLabel
- Left = 8
- Height = 14
- Top = 232
- Width = 128
+ Left = 9
+ Height = 15
+ Top = 259
+ Width = 139
Caption = 'Масштаб мини-карты:'
ParentColor = False
end
object SpinEdit5: TSpinEdit
- Left = 8
- Height = 22
- Top = 248
- Width = 50
+ Left = 9
+ Height = 23
+ Top = 276
+ Width = 56
MaxValue = 10
MinValue = 1
TabOrder = 7
Value = 1
end
object LabelGridCol: TLabel
- Left = 304
- Height = 14
- Top = 8
- Width = 68
+ Left = 339
+ Height = 15
+ Top = 9
+ Width = 74
Caption = 'Цвет сетки:'
ParentColor = False
end
object ColorButton1: TColorButton
- Left = 304
- Height = 25
- Top = 24
- Width = 75
+ Left = 339
+ Height = 28
+ Top = 27
+ Width = 84
BorderWidth = 2
ButtonColorSize = 16
ButtonColor = clRed
end
object LabelBack: TLabel
- Left = 304
- Height = 14
- Top = 64
- Width = 65
+ Left = 339
+ Height = 15
+ Top = 71
+ Width = 70
Caption = 'Цвет фона:'
ParentColor = False
end
object ColorButton2: TColorButton
- Left = 304
- Height = 25
- Top = 80
- Width = 75
+ Left = 339
+ Height = 28
+ Top = 89
+ Width = 84
BorderWidth = 2
ButtonColorSize = 16
ButtonColor = clLime
end
object LabelPreview: TLabel
- Left = 304
- Height = 14
- Top = 120
- Width = 248
+ Left = 339
+ Height = 15
+ Top = 134
+ Width = 270
Caption = 'Цвет фона поля предпросмотра текстуры:'
ParentColor = False
WordWrap = True
end
object ColorButton3: TColorButton
- Left = 304
- Height = 25
- Top = 136
- Width = 75
+ Left = 339
+ Height = 28
+ Top = 152
+ Width = 84
BorderWidth = 2
ButtonColorSize = 16
ButtonColor = clBlue
end
object LabelLanguage: TLabel
- Left = 304
- Height = 14
- Top = 172
+ Left = 339
+ Height = 15
+ Top = 192
Width = 34
Caption = 'Язык:'
ParentColor = False
end
object cbLanguage: TComboBox
- Left = 304
- Height = 26
- Top = 192
- Width = 120
+ Left = 339
+ Height = 27
+ Top = 214
+ Width = 134
ItemHeight = 0
Style = csDropDownList
TabOrder = 8
end
object TabFiles: TTabSheet
Caption = 'Files'
- ClientHeight = 284
- ClientWidth = 620
- object cbCompress: TCheckBox
- Left = 8
- Height = 21
- Top = 8
- Width = 208
- Caption = 'Сжимать архив при сохранении'
- TabOrder = 0
- end
- object cbBackup: TCheckBox
- Left = 8
- Height = 21
- Top = 32
- Width = 218
- Caption = 'Резервная копия при сохранении'
- TabOrder = 1
- end
+ ClientHeight = 319
+ ClientWidth = 692
object LabelRecent: TLabel
- Left = 8
- Height = 14
- Top = 64
- Width = 230
+ Left = 9
+ Height = 15
+ Top = 8
+ Width = 250
Caption = 'Запоминать последних открытых карт:'
ParentColor = False
WordWrap = True
end
object SpinEdit3: TSpinEdit
- Left = 8
- Height = 22
- Top = 80
- Width = 50
+ Left = 9
+ Height = 23
+ Top = 32
+ Width = 56
MaxValue = 10
MinValue = 2
- TabOrder = 2
+ TabOrder = 0
Value = 2
end
end
object TabTesting: TTabSheet
Caption = 'Testing'
- ClientHeight = 284
- ClientWidth = 620
+ ClientHeight = 319
+ ClientWidth = 692
object LabelPath: TLabel
- Left = 8
- Height = 14
- Top = 8
- Width = 120
+ Left = 9
+ Height = 15
+ Top = 9
+ Width = 131
Caption = 'Путь к Doom2DF.exe:'
ParentColor = False
end
object ExeEdit: TFileNameEdit
- Left = 8
- Height = 22
- Top = 24
- Width = 328
+ Left = 9
+ Height = 23
+ Top = 27
+ Width = 366
FileName = 'Doom2DF.exe'
DialogOptions = [ofNoChangeDir, ofDontAddToRecent, ofViewDetail]
FilterIndex = 0
HideDirectories = False
- ButtonWidth = 23
+ ButtonWidth = 26
NumGlyphs = 1
MaxLength = 0
TabOrder = 0
Text = 'Doom2DF.exe'
end
object LabelArgs: TLabel
- Left = 8
- Height = 14
- Top = 55
- Width = 120
+ Left = 9
+ Height = 15
+ Top = 61
+ Width = 128
Caption = 'Параметры запуска:'
ParentColor = False
end
object edD2DArgs: TEdit
- Left = 8
- Height = 22
- Top = 72
- Width = 301
+ Left = 9
+ Height = 23
+ Top = 80
+ Width = 335
TabOrder = 1
end
object rbDM: TRadioButton
- Left = 8
+ Left = 9
Height = 21
- Top = 104
- Width = 91
+ Top = 116
+ Width = 98
Caption = 'Deathmatch'
Checked = True
TabOrder = 2
TabStop = True
end
object rbTDM: TRadioButton
- Left = 8
+ Left = 9
Height = 21
- Top = 120
- Width = 124
+ Top = 134
+ Width = 133
Caption = 'Team Deathmatch'
TabOrder = 3
end
object rbCTF: TRadioButton
- Left = 8
+ Left = 9
Height = 21
- Top = 136
- Width = 114
+ Top = 152
+ Width = 124
Caption = 'Capture the Flag'
TabOrder = 4
end
object rbCOOP: TRadioButton
- Left = 8
+ Left = 9
Height = 21
- Top = 152
- Width = 92
+ Top = 169
+ Width = 94
Caption = 'Cooperative'
TabOrder = 5
end
object cbTwoPlayers: TCheckBox
- Left = 168
+ Left = 187
Height = 21
- Top = 104
- Width = 89
+ Top = 116
+ Width = 93
Caption = 'Два игрока'
TabOrder = 6
end
object cbTeamDamage: TCheckBox
- Left = 168
+ Left = 187
Height = 21
- Top = 120
- Width = 141
+ Top = 134
+ Width = 150
Caption = 'Урон своей команде'
TabOrder = 7
end
object cbAllowExit: TCheckBox
- Left = 168
+ Left = 187
Height = 21
- Top = 136
- Width = 122
+ Top = 152
+ Width = 128
Caption = 'Выход из уровня'
Checked = True
State = cbChecked
TabOrder = 8
end
object cbWeaponStay: TCheckBox
- Left = 168
+ Left = 187
Height = 21
- Top = 152
- Width = 125
+ Top = 169
+ Width = 133
Caption = 'Оружие остается'
TabOrder = 9
end
object cbMonstersDM: TCheckBox
- Left = 168
+ Left = 187
Height = 21
- Top = 168
- Width = 103
+ Top = 187
+ Width = 113
Caption = 'Монстры в DM'
TabOrder = 10
end
object LabelTime: TLabel
- Left = 8
- Height = 14
- Top = 200
- Width = 92
+ Left = 9
+ Height = 15
+ Top = 223
+ Width = 103
Caption = 'Лимит времени:'
ParentColor = False
end
object edTime: TEdit
- Left = 120
- Height = 22
- Top = 200
- Width = 49
+ Left = 134
+ Height = 23
+ Top = 223
+ Width = 55
TabOrder = 11
Text = '0'
end
object LabelSecs: TLabel
- Left = 174
- Height = 14
- Top = 200
- Width = 42
+ Left = 194
+ Height = 15
+ Top = 223
+ Width = 44
Caption = 'секунд'
ParentColor = False
end
object LabelScore: TLabel
- Left = 8
- Height = 14
- Top = 223
- Width = 76
+ Left = 9
+ Height = 15
+ Top = 249
+ Width = 84
Caption = 'Лимит очков:'
ParentColor = False
end
object edScore: TEdit
- Left = 120
- Height = 22
- Top = 223
- Width = 49
+ Left = 134
+ Height = 23
+ Top = 249
+ Width = 55
TabOrder = 12
Text = '0'
end
object cbMapOnce: TCheckBox
- Left = 8
+ Left = 9
Height = 21
- Top = 256
- Width = 241
+ Top = 285
+ Width = 259
Caption = 'Закрыть игру после выхода из карты'
TabOrder = 13
end
end
end
object bOK: TButton
- Left = 464
- Height = 25
- Top = 328
- Width = 75
+ Left = 517
+ Height = 28
+ Top = 366
+ Width = 84
Caption = 'ОК'
Default = True
OnClick = bOKClick
TabOrder = 1
end
object bCancel: TButton
- Left = 557
- Height = 25
- Top = 328
- Width = 75
+ Left = 621
+ Height = 28
+ Top = 366
+ Width = 84
Cancel = True
Caption = 'Отмена'
OnClick = bCancelClick
index fe05e20f2e5a964b59a9d6b649a34c5079f0aa46..ebb38cb3a6dae85cb4194bb7c5e29b46fb060676 100644 (file)
--- a/src/editor/f_options.pas
+++ b/src/editor/f_options.pas
ExtCtrls, ComCtrls, ActnList, Spin, EditBtn, Registry, Math, Types;
type
-
- { TOptionsForm }
-
TOptionsForm = class (TForm)
bOK: TButton;
bCancel: TButton;
cbAllowExit: TCheckBox;
- cbBackup: TCheckBox;
cbCheckerboard: TCheckBox;
- cbCompress: TCheckBox;
cbLanguage: TComboBox;
cbMapOnce: TCheckBox;
cbMonstersDM: TCheckBox;
implementation
uses
- LazFileUtils, f_main, StdConvs, CONFIG, g_language, g_resources, g_options;
+ LazFileUtils, f_main, StdConvs, CONFIG, g_language, g_options;
{$R *.lfm}
end;
// Files Tab:
- cbCompress.Checked := Compress;
- cbBackup.Checked := Backup;
SpinEdit3.Value := RecentCount;
// Testing Tab:
// Files tab:
re := SpinEdit3.Value;
- Compress := cbCompress.Checked;
- Backup := cbBackup.Checked;
// Testing tab:
TestD2DExe := ExeEdit.Text;
config.WriteStr('Editor', 'Language', gLanguage);
config.WriteInt('Editor', 'RecentCount', re);
- config.WriteBool('Editor', 'Compress', Compress);
- config.WriteBool('Editor', 'Backup', Backup);
config.WriteStr('TestRun', 'GameMode', TestGameMode);
config.WriteStr('TestRun', 'LimTime', TestLimTime);
index 9a6db34d007a2902144bf7ee62ef9aaefbe7c791..2a275ebfac3801352933a77a79652461c68b2d22 100644 (file)
--- a/src/editor/f_packmap.lfm
+++ b/src/editor/f_packmap.lfm
TabOrder = 1
end
object SaveDialog: TSaveDialog
- DefaultExt = '.dfz'
- Filter = 'Карты Doom 2D: Forever (*.dfz)|*.dfz|Карты Doom 2D: Forever (*.dfzip)|*.dfzip|Карты Doom 2D: Forever (*.zip)|*.zip|Карты Doom2D: Forever (*.wad)|*.wad|All files (*.*)|*.*'
+ DefaultExt = '.wad'
+ Filter = 'Карты Doom2D: Forever (*.wad)|*.wad|All files (*.*)|*.*'
Options = [ofHideReadOnly, ofPathMustExist, ofEnableSizing, ofDontAddToRecent]
left = 8
top = 200
index f06f5c8c6b15e7715131a600304fc5abf2f1c7b3..911700b7df8a5f18cf6aaee493d5cd6371b4546b 100644 (file)
--- a/src/editor/f_packmap.pas
+++ b/src/editor/f_packmap.pas
uses
BinEditor, WADEDITOR, g_map, MAPREADER, MAPWRITER, MAPSTRUCT,
- f_main, math, g_language, g_resources, g_options, e_log;
+ f_main, math, g_language, g_options, e_log;
{$R *.lfm}
eWAD.Text := SaveDialog.FileName;
end;
-function ProcessResource(wad_to, section_to, filename, section, resource: String): Boolean;
- var
- data: Pointer;
- res, len: Integer;
- us, un: String;
+function ProcessResource(wad_to: TWADEditor_1; section_to, filename, section, resource: String): Boolean;
+var
+ wad2: TWADEditor_1;
+ data: Pointer;
+ reslen: Integer;
+ //s: string;
+
begin
- Result := True;
+ Result := False;
+
if filename = '' then
- g_GetResourceSection(OpenedMap, filename, us, un)
+ g_ProcessResourceStr(OpenedMap, @filename, nil, nil)
else
filename := WadsDir + DirectorySeparator + filename;
- e_WriteLog('ProcessResource: "' + wad_to + '" "' + section_to + '" "' + filename + '" "' + section + '" "' + resource + '"', MSG_NOTIFY);
- if resource = '' then Exit;
+// Читаем ресурс из WAD-файла карты или какого-то другого:
+ wad2 := TWADEditor_1.Create();
- g_ReadResource(filename, section, resource, data, len);
- if data <> nil then
+ if not wad2.ReadFile(filename) then
begin
- (* Write resource only if it does not exists *)
- g_ExistsResource(wad_to, section_to, resource, res);
- if res <> 0 then
- begin
- g_AddResource(wad_to, section_to, resource, data, len, res);
- ASSERT(res = 0)
- end;
- FreeMem(data);
- end
- else
+ Application.MessageBox(PChar(Format(MsgMsgWadError, [ExtractFileName(filename)])), PChar(MsgMsgError), MB_OK + MB_ICONERROR);
+ wad2.Free();
+ Exit;
+ end;
+
+ if not wad2.GetResource(utf2win(section), utf2win(resource), data, reslen) then
begin
- //Application.MessageBox(PChar(Format(MsgMsgWadError, [ExtractFileName(filename)])), PChar(MsgMsgError), MB_OK + MB_ICONERROR);
Application.MessageBox(PChar(Format(MsgMsgResError, [filename, section, resource])), PChar(MsgMsgError), MB_OK + MB_ICONERROR);
- Result := False
- end
+ wad2.Free();
+ Exit;
+ end;
+
+ wad2.Free();
+
+ {if wad_to.HaveResource(utf2win(section_to), utf2win(resource)) then
+ begin
+ for a := 2 to 256 do
+ begin
+ s := IntToStr(a);
+ if not wad_to.HaveResource(utf2win(section_to), utf2win(resource+s)) then Break;
+ end;
+ resource := resource+s;
+ end;}
+
+// Если такого ресурса нет в WAD-файле-назначении, то копируем:
+ if not wad_to.HaveResource(utf2win(section_to), utf2win(resource)) then
+ begin
+ if not wad_to.HaveSection(utf2win(section_to)) then
+ wad_to.AddSection(utf2win(section_to));
+ wad_to.AddResource(data, reslen, utf2win(resource), utf2win(section_to));
+ end;
+
+ FreeMem(data);
+
+ Result := True;
end;
procedure TPackMapForm.bPackClick(Sender: TObject);
var
+ WAD: TWADEditor_1;
mr: TMapReader_1;
mw: TMapWriter_1;
data: Pointer;
if data = nil then
Exit;
- if not cbAdd.Checked then
- g_DeleteFile(eWAD.Text, '.bak0');
+ WAD := TWADEditor_1.Create();
+
+// Не перезаписывать WAD, а дополнить:
+ if cbAdd.Checked then
+ if WAD.ReadFile(eWAD.Text) then
+ WAD.CreateImage();
// Читаем карту из памяти:
mr := TMapReader_1.Create();
if IsSpecialTexture(res) then
Continue;
- g_GetResourceSection(res, filename, section, resource);
+ g_ProcessResourceStr(res, @filename, @section, @resource);
// Не записывать стандартные текстуры:
if (not cbNonStandart.Checked) or
(AnsiLowerCase(filename) <> SHRSHADE_WAD) ) then
begin
// Копируем ресурс текстуры:
- if not f_packmap.ProcessResource(eWAD.Text, tsection, filename, section, resource) then
+ if not f_packmap.ProcessResource(WAD, tsection, filename, section, resource) then
begin
mr.Free();
+ WAD.Free();
Exit;
end;
if cbSky.Checked then
begin
res := win2utf(header.SkyName);
- g_GetResourceSection(res, filename, section, resource);
+ g_ProcessResourceStr(res, @filename, @section, @resource);
// Не записывать стандартное небо:
if (not cbNonStandart.Checked) or
(AnsiLowerCase(filename) <> SHRSHADE_WAD) ) then
begin
// Копируем ресурс неба:
- if not f_packmap.ProcessResource(eWAD.Text, ssection, filename, section, resource) then
+ if not f_packmap.ProcessResource(WAD, ssection, filename, section, resource) then
begin
mr.Free();
+ WAD.Free();
Exit;
end;
if cbMusic.Checked then
begin
res := win2utf(header.MusicName);
- g_GetResourceSection(res, filename, section, resource);
+ g_ProcessResourceStr(res, @filename, @section, @resource);
// Не записывать стандартную музыку:
if (not cbNonStandart.Checked) or
(AnsiLowerCase(filename) <> SHRSHADE_WAD) ) then
begin
// Копируем ресурс музыки:
- if not f_packmap.ProcessResource(eWAD.Text, msection, filename, section, resource) then
+ if not f_packmap.ProcessResource(WAD, msection, filename, section, resource) then
begin
mr.Free();
+ WAD.Free();
Exit;
end;
if res = '' then
Break;
- g_GetResourceSection(res, @filename, @section, @resource);
+ g_ProcessResourceStr(res, @filename, @section, @resource);
// Не записывать стандартные дополнительные текстуры:
if (not cbNonStandart.Checked) or
(AnsiLowerCase(filename) <> SHRSHADE_WAD) ) then
begin
// Копируем ресурс дополнительной текстуры:
- if f_packmap.ProcessResource(eWAD.Text, tsection, filename, section, resource) then
+ if f_packmap.ProcessResource(WAD, tsection, filename, section, resource) then
begin
Нужно проверять есть такая текстура textures и есть ли она вообще?
// Сохраняем карту из памяти под новым именем в WAD-файл:
len := mw.SaveMap(data);
- g_AddResource(eWAD.Text, '', eResource.Text, data, len, a);
+ WAD.AddResource(data, len, eResource.Text, '');
+ WAD.SaveTo(eWAD.Text);
+
mw.Free();
mr.Free();
- Close();
+ WAD.Free();
- ASSERT(a = 0); (* saved *)
MessageDlg(Format(MsgMsgPacked, [eResource.Text, ExtractFileName(eWAD.Text)]), mtInformation, [mbOK], 0);
+ Close();
end;
procedure TPackMapForm.FormCreate(Sender: TObject);
index a508c24bc2a2240d477dab6a5e650c4b6c041c84..e57fb791d4887b01b223c56fbdf76f60f597a429 100644 (file)
--- a/src/editor/f_savemap.pas
+++ b/src/editor/f_savemap.pas
implementation
uses
- MAPREADER, MAPSTRUCT, g_language, g_resources, sfs;
+ BinEditor, MAPREADER, WADEDITOR, WADSTRUCT, MAPSTRUCT, g_language;
{$R *.lfm}
end;
procedure TSaveMapForm.GetMaps(FileName: String; placeName: Boolean);
- var
- nm: String;
- data: Pbyte;
- list: TSFSFileList;
- i, j, len, max_num: Integer;
- sign: Array [0..2] of Char;
+var
+ WAD: TWADEditor_1;
+ a, max_num, j: Integer;
+ ResList: SArray;
+ Data: Pointer;
+ Len: Integer;
+ Sign: Array [0..2] of Char;
+ nm: String;
+
begin
lbMapList.Items.Clear();
max_num := 1;
- list := SFSFileList(FileName);
- if list <> nil then
- begin
- for i := 0 to list.Count - 1 do
+ WAD := TWADEditor_1.Create();
+ WAD.ReadFile(FileName);
+ ResList := WAD.GetResourcesList('');
+
+ if ResList <> nil then
+ for a := 0 to High(ResList) do
begin
- g_ReadResource(FileName, win2utf(list.Files[i].path), win2utf(list.Files[i].name), data, len);
+ if not WAD.GetResource('', ResList[a], Data, Len) then
+ Continue;
+
+ CopyMemory(@Sign[0], Data, 3);
+ FreeMem(Data);
- if len >= 3 then
+ if Sign = MAP_SIGNATURE then
begin
- sign[0] := chr(data[0]);
- sign[1] := chr(data[1]);
- sign[2] := chr(data[2]);
- if sign = MAP_SIGNATURE then
+ nm := win2utf(ResList[a]);
+ lbMapList.Items.Add(nm);
+
+ if placeName then
begin
- nm := win2utf(list.Files[i].name);
- lbMapList.Items.Add(nm);
- if placeName then
+ nm := UpperCase(nm);
+ if (nm[1] = 'M') and
+ (nm[2] = 'A') and
+ (nm[3] = 'P') then
begin
- nm := UpperCase(nm);
- if (nm[1] = 'M') and (nm[2] = 'A') and (nm[3] = 'P') then
- begin
- nm := Trim(Copy(nm, 4, Length(nm)-3));
- j := StrToIntDef(nm, 0);
- if j >= max_num then
- max_num := j + 1;
- end
- end
- end
+ nm := Trim(Copy(nm, 4, Length(nm)-3));
+ j := StrToIntDef(nm, 0);
+ if j >= max_num then
+ max_num := j + 1;
+ end;
+ end;
end;
- if len > 0 then FreeMem(data)
+ Sign := '';
end;
- list.Destroy;
- end;
-
+ WAD.Free();
if placeName then
- begin
- nm := IntToStr(max_num);
- if Length(nm) < 2 then
- nm := '0' + nm;
- eMapName.Text := 'MAP' + nm
- end
+ begin
+ nm := IntToStr(max_num);
+ if Length(nm) < 2 then
+ nm := '0' + nm;
+ nm := 'MAP' + nm;
+ eMapName.Text := nm;
+ end
else
- begin
- eMapName.Text := ''
- end
+ eMapName.Text := '';
end;
end.
index 7474330705f0c70b96027895375359b9a5cffbed..46f365c7f6cfe4c9bf0a50ebc6046f559d8c9f69 100644 (file)
implementation
uses
- MAPREADER, MAPSTRUCT, g_resources, sfs;
+ BinEditor, MAPREADER, WADEDITOR, WADSTRUCT, MAPSTRUCT;
{$R *.lfm}
end;
procedure TSelectMapForm.GetMaps(FileName: String);
- var
- data: PByte;
- list: TSFSFileList;
- sign: Array [0..2] of Char;
- i, len: Integer;
+var
+ WAD: TWADEditor_1;
+ a: Integer;
+ ResList: SArray;
+ Data: Pointer;
+ Len: Integer;
+ Sign: Array [0..2] of Char;
+
begin
lbMapList.Items.Clear();
- list := SFSFileList(FileName);
- if list = nil then Exit;
-
- for i := 0 to list.Count - 1 do
+ WAD := TWADEditor_1.Create();
+ if not WAD.ReadFile(FileName) then
begin
- g_ReadResource(FileName, win2utf(list.Files[i].path), win2utf(list.Files[i].name), data, len);
+ WAD.Free();
+ Exit;
+ end;
+
+ ResList := WAD.GetResourcesList('');
- if len >= 3 then
+ if ResList <> nil then
+ for a := 0 to High(ResList) do
begin
- sign[0] := chr(data[0]);
- sign[1] := chr(data[1]);
- sign[2] := chr(data[2]);
- if sign = MAP_SIGNATURE then
- lbMapList.Items.Add(win2utf(list.Files[i].name))
- end;
+ if not WAD.GetResource('', ResList[a], Data, Len) then
+ Continue;
- if len > 0 then FreeMem(data)
- end;
+ CopyMemory(@Sign[0], Data, 3);
+ FreeMem(Data);
+
+ if Sign = MAP_SIGNATURE then
+ lbMapList.Items.Add(win2utf(ResList[a]));
+ Sign := '';
+ end;
- list.Destroy
+ WAD.Free();
end;
end.
index 9edd8876eb39be6b19a3ce26f485ab441cff7590..ea1f23660237da8593209739dc0200d84287843f 100644 (file)
MsgLabEsLanguageAuto = 'System Default';
MsgCtrlEsFiles = 'Files';
- MsgLabEsCompress = 'Compress archive when save';
- MsgLabEsBackup = 'Make backup before save';
MsgLabPackSaveTo = 'Save to:';
MsgLabPackMapName = 'Map Resource Name:';
MsgWadSpecialMap = '<MAP WAD-FILE>';
MsgWadSpecialTexs = '<EXTRA TEXTURES>';
- MsgFileFilterAll = 'Doom 2D: Forever Maps (*.dfz, *.dfzip, *.zip, *.wad)|*.dfz;*.dfzip;*.zip;*.wad|Doom 2D: Forever 0.30 Maps (*.ini)|*.ini|All Files (*.*)|*.*';
- MsgFileFilterWad = 'Doom 2D: Forever Maps (*.dfz)|*.dfz|Doom 2D: Forever Maps (*.dfzip)|*.dfzip|Doom 2D: Forever Maps (*.zip)|*.zip|Doom 2D: Forever Maps (*.wad)|*.wad|All Files (*.*)|*.*';
+ MsgFileFilterAll = 'Doom 2D: Forever Maps (*.wad)|*.wad|Doom 2D: Forever 0.30 Maps (*.ini)|*.ini|All Files (*.*)|*.*';
+ MsgFileFilterWad = 'Doom 2D: Forever Maps (*.wad)|*.wad|All Files (*.*)|*.*';
MsgFileFilterExeMac = 'Doom 2D Forever.app|*.app|Doom 2D Forever (Unix Executable)|Doom2DF;*';
MsgFileFilterExeWin = 'Doom2DF.exe|Doom2DF.exe;*.exe';
MsgFileFilterExeUnix = 'Doom2DF|Doom2DF;*';
LabelLanguage.Caption := MsgLabEsLanguage;
// TabFiles:
TabFiles.Caption := MsgCtrlEsFiles;
- cbCompress.Caption := MsgLabEsCompress;
- cbBackup.Caption := MsgLabEsBackup;
LabelRecent.Caption := MsgLabEsRecent;
// TabTesting:
TabTesting.Caption := MsgCtrlEsTesting;
diff --git a/src/editor/g_map.pas b/src/editor/g_map.pas
index 0c35d481384f5164798248af97a007c9244106b7..a93a75af45ac2396fb8f48f8849aeb24d50824eb 100644 (file)
--- a/src/editor/g_map.pas
+++ b/src/editor/g_map.pas
uses
BinEditor, g_textures, Dialogs, SysUtils, CONFIG, f_main,
- Forms, Math, f_addresource_texture, WADEDITOR, g_language, g_resources, g_options;
+ Forms, Math, f_addresource_texture, WADEDITOR, g_language, g_options;
const
OLD_ITEM_MEDKIT_SMALL = 1;
function SaveMap(Res: String): Pointer;
var
+ WAD: TWADEditor_1;
MapWriter: TMapWriter_1;
textures: TTexturesRec1Array;
panels: TPanelsRec1Array;
Len: LongWord;
begin
+ WAD := nil;
textures := nil;
panels := nil;
items := nil;
Data := nil;
Len := 0;
+// Открываем WAD, если надо:
+ if Res <> '' then
+ begin
+ WAD := TWADEditor_1.Create();
+ g_ProcessResourceStr(Res, FileName, SectionName, ResName);
+ if not WAD.ReadFile(FileName) then
+ WAD.FreeWAD();
+
+ WAD.CreateImage();
+ end;
+
MapWriter := TMapWriter_1.Create();
// Сохраняем заголовок:
// Записываем в WAD, если надо:
if Res <> '' then
- begin
- g_ProcessResourceStr(Res, FileName, SectionName, ResName);
- g_AddResource(FileName, SectionName, ResName, Data, Len, a);
- ASSERT(a = 0);
- FreeMem(Data);
- Result := nil
- end
+ begin
+ s := utf2win(ResName);
+ WAD.RemoveResource('', s);
+ WAD.AddResource(Data, Len, s, '');
+ WAD.SaveTo(FileName);
+
+ FreeMem(Data);
+ WAD.Free();
+
+ Result := nil;
+ end
else
- begin
- Result := Data
- end
+ Result := Data;
end;
procedure AddTexture(res: String; Error: Boolean);
function LoadMap(Res: String): Boolean;
var
+ WAD: TWADEditor_1;
MapReader: TMapReader_1;
Header: TMapHeaderRec_1;
textures: TTexturesRec1Array;
MainForm.lLoad.Caption := MsgLoadWad;
Application.ProcessMessages();
-// Читаем ресурс карты
+// Открываем WAD:
+ WAD := TWADEditor_1.Create();
g_ProcessResourceStr(Res, FileName, SectionName, ResName);
- g_ReadResource(FileName, SectionName, ResName, pData, Len);
- if pData = nil then Exit;
+
+ if not WAD.ReadFile(FileName) then
+ begin
+ WAD.Free();
+ Exit;
+ end;
+
+// Читаем ресурс карты:
+ if not WAD.GetResource('', utf2win(ResName), pData, Len) then
+ begin
+ WAD.Free();
+ Exit;
+ end;
+
+ WAD.Free();
MapReader := TMapReader_1.Create();
diff --git a/src/editor/g_resources.pas b/src/editor/g_resources.pas
+++ /dev/null
@@ -1,413 +0,0 @@
-{$ASSERTIONS ON}
-unit g_resources;
-
-interface
-
- (**
- g_GetResourceSection
- Parse path in form 'path/to/file.wad:some/section/resouce' to
- wad = 'path/to/file.wad', section = 'some/section', name = 'resource'
-
- g_DeleteFile
- Delete file if it exists. Make backup if enabled.
- return true when file not exists.
-
- g_ReadResource
- Read whole file from wad
- (data <> nil) and (len > 0) when ok
- use FreeMem(data) when done
-
- g_ReadSubResource
- Read whole file from folded wad
- (data <> nil) and (len > 0) when ok
- use FreeMem(data) when done
-
- g_DeleteResource
- Delete file from wad
- res = 0 when ok
-
- g_AddResource
- Add/overwrite file to wad
- res = 0 when ok
-
- g_ExistsResource
- Check that resource exists
- res = 0 when ok
- **)
-
- (* Editor options *)
- var
- Compress: Boolean;
- Backup: Boolean;
-
- procedure g_GetResourceSection (path: String; out wad, section, name: String);
- function g_DeleteFile(wad: String; backupPostfix: String = '.bak'): Boolean;
-
- 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);
- procedure g_DeleteResource (wad, section, name: String; out res: Integer);
- procedure g_AddResource (wad, section, name: String; const data: PByte; len: Integer; out res: Integer);
- procedure g_ExistsResource (wad, section, name: String; out res: Integer);
-
-implementation
-
- uses sfs, xstreams, dfzip, utils, Classes, SysUtils, WADEDITOR, e_log;
-
- function NoTrailing (path: String): String;
- var i: Integer;
- begin
- i := Length(path);
- while (i > 0) and ((path[i] = '/') or (path[i] = '\')) do dec(i);
- result := Copy(path, 1, i)
- end;
-
- function g_CleanPath (path: String; sys: Boolean = False): String;
- var i, len: Integer;
- begin
- i := 1;
- result := '';
- len := Length(path);
- (* drop separators at the end *)
- while (len > 1) and ((path[i] = '/') or (path[i] = '\')) do dec(len);
- while i <= len do
- begin
- while (i <= len) and (path[i] <> '/') and (path[i] <> '\') do
- begin
- result := result + path[i];
- inc(i)
- end;
- if i <= len then
- if sys then
- result := result + DirectorySeparator
- else
- result := result + '/';
- inc(i);
- while (i <= len) and ((path[i] = '/') or (path[i] = '\')) do inc(i)
- end;
- end;
-
- procedure g_GetResourceSection (path: String; out wad, section, name: String);
- var i, j, len: Integer;
- begin
- len := Length(path);
- i := len;
- while (i > 0) and (path[i] <> '/') and (path[i] <> '\') do dec(i);
- name := Copy(path, i + 1, len);
- j := i;
- while (i > 0) and (path[i] <> ':') do dec(i);
- section := Copy(path, i + 1, j - i - 1);
- wad := Copy(path, 1, i - 1);
- end;
-
- function g_DeleteFile (wad: String; backupPostfix: String = '.bak'): Boolean;
- var newwad: String; ok: Boolean;
- begin
- SFSGCCollect;
- SFSGCCollect;
- SFSGCCollect;
- ok := true;
- if FileExists(wad) then
- begin
- if Backup then
- begin
- newwad := wad + backupPostfix;
- if FileExists(newwad) then ok := DeleteFile(newwad);
- if ok then ok := RenameFile(wad, newwad);
- end
- else
- ok := DeleteFile(wad);
- end;
- result := ok;
- end;
-
- procedure g_AddResourceToDFWAD (wad, section, name: String; const data: PByte; len: Integer; out res: Integer);
- var f: TWADEditor_1;
- begin
- res := 1; (* error *)
- section := utf2win(NoTrailing(section));
- name := utf2win(name);
- ASSERT(name <> '');
- f := TWADEditor_1.Create();
- if not f.ReadFile(wad) then
- begin
- (* do nothing *)
- end;
- f.CreateImage;
- f.RemoveResource(section, name);
- f.AddResource(data, len, name, section);
- g_DeleteFile(wad);
- f.SaveTo(wad);
- f.Free;
- res := 0
- end;
-
- procedure g_AddResourceToZip (wad, section, name: String; const data: PByte; len: Integer; out res: Integer);
- var
- i, n, len0: Integer;
- data0: PByte;
- list: TSFSFileList;
- tmp, path: String;
- ts: TFileStream;
- dir: array of TFileInfo;
- ok: Boolean;
-
- procedure Add (name: String; data: PByte; len: Integer);
- var ds: TSFSMemoryChunkStream;
- begin
- SetLength(dir, n + 1);
- ds := TSFSMemoryChunkStream.Create(data, len, False);
- dir[n] := dfzip.ZipOne(ts, name, ds, Compress);
- ds.Free;
- INC(n);
- end;
-
- begin
- res := 1;
- wad := ExpandFileName(wad);
- section := utf2win(NoTrailing(section));
- name := utf2win(name);
- ASSERT(name <> '');
- list := SFSFileList(wad);
- tmp := wad + '.tmp' + IntToStr(Random(100000));
- ts := TFileStream.Create(tmp, fmCreate);
- n := 0;
- SetLength(dir, 0);
- if list <> nil then
- begin
- for i := 0 to list.Count - 1 do
- begin
- path := NoTrailing(list.Files[i].path);
- if (path <> section) or (list.Files[i].name <> name) then
- begin
- g_ReadResource(wad, win2utf(path), win2utf(list.Files[i].name), data0, len0);
- ASSERT(data0 <> nil);
- if path = '' then
- path := list.Files[i].name
- else
- path := path + '/' + list.Files[i].name;
- Add(path, data0, len0);
- FreeMem(data0)
- end
- end;
- list.Destroy
- end;
-
- if section = '' then
- path := name
- else
- path := section + '/' + name;
- Add(path, data, len);
-
- dfzip.writeCentralDir(ts, dir);
- ts.Free;
-
- ok := g_DeleteFile(wad);
- if not ok then e_WriteLog('Cant delete older wad [' + wad + ']', TRecordCategory.MSG_WARNING);
- ok := RenameFile(tmp, wad);
- if not ok then e_WriteLog('ERROR: Cant rename [' + tmp + '] -> [' + wad + ']', TRecordCategory.MSG_WARNING);
- if ok then res := 0 else res := 2;
- end;
-
- procedure g_AddResource (wad, section, name: String; const data: PByte; len: Integer; out res: Integer);
- var ext: String;
- begin
- ASSERT(name <> '');
- res := 2; (* unknown type *)
- ext := LowerCase(SysUtils.ExtractFileExt(wad));
- e_WriteLog('g_AddResource "' + wad + '" "' + section + '" "' + name + '"', MSG_NOTIFY);
- if ext = '.wad' then
- g_AddResourceToDFWAD(wad, section, name, data, len, res)
- else
- g_AddResourceToZip(wad, section, name, data, len, res)
- end;
-
- procedure g_DeleteResourceFromDFWAD (wad, section, name: String; out res: Integer);
- var f: TWADEditor_1;
- begin
- ASSERT(name <> '');
- res := 1; (* error *)
- section := utf2win(NoTrailing(section));
- name := utf2win(name);
- f := TWADEditor_1.Create;
- if not f.ReadFile(wad) then
- begin
- f.Free;
- Exit
- end;
- f.CreateImage;
- f.RemoveResource(section, name);
- g_DeleteFile(wad);
- f.SaveTo(wad);
- f.Free;
- res := 0 (* ok *)
- end;
-
- procedure g_DeleteResourceFromZip (wad, section, name: String; out res: Integer);
- var
- data0: PByte;
- i, n, len0: Integer;
- list: TSFSFileList;
- tmp, path: String;
- ts: TFileStream;
- dir: array of TFileInfo;
- ok: Boolean;
-
- procedure Add (name: String; data: PByte; len: Integer);
- var ds: TSFSMemoryChunkStream;
- begin
- SetLength(dir, n + 1);
- ds := TSFSMemoryChunkStream.Create(data, len, False);
- dir[n] := dfzip.ZipOne(ts, name, ds, Compress);
- ds.Free;
- INC(n);
- end;
-
- begin
- res := 1;
- wad := ExpandFileName(wad);
- section := utf2win(NoTrailing(section));
- name := utf2win(name);
- ASSERT(name <> '');
- list := SFSFileList(wad);
- tmp := wad + '.tmp' + IntToStr(Random(100000));
- ts := TFileStream.Create(tmp, fmCreate);
- n := 0;
- SetLength(dir, 0);
- if list <> nil then
- begin
- for i := 0 to list.Count - 1 do
- begin
- path := NoTrailing(list.Files[i].path);
- if (path <> section) or (list.Files[i].name <> name) then
- begin
- g_ReadResource(wad, win2utf(path), win2utf(list.Files[i].name), data0, len0);
- ASSERT(data0 <> nil);
- if path = '' then
- path := list.Files[i].name
- else
- path := path + '/' + list.Files[i].name;
- Add(path, data0, len0);
- FreeMem(data0)
- end
- end;
- list.Destroy
- end;
-
- dfzip.writeCentralDir(ts, dir);
- ts.Free;
-
- ok := g_DeleteFile(wad);
- if not ok then e_WriteLog('Cant delete older wad [' + wad + ']', TRecordCategory.MSG_WARNING);
- ok := RenameFile(tmp, wad);
- if not ok then e_WriteLog('ERROR: Cant rename [' + tmp + '] -> [' + wad + ']', TRecordCategory.MSG_WARNING);
- if ok then res := 0 else res := 2;
- end;
-
- procedure g_DeleteResource (wad, section, name: String; out res: Integer);
- var ext: String;
- begin
- ASSERT(name <> '');
- res := 2; (* unknown type *)
- ext := LowerCase(SysUtils.ExtractFileExt(wad));
- if ext = '.wad' then
- g_DeleteResourceFromDFWAD(wad, section, name, res)
- else
- g_DeleteResourceFromZip(wad, section, name, res)
- end;
-
- procedure g_ExistsResource (wad, section, name: String; out res: Integer);
- var str: String; stream: TStream;
- begin
- res := 1;
- section := utf2win(NoTrailing(section));
- name := utf2win(name);
- ASSERT(name <> '');
- if SFSAddDataFileTemp(wad, TRUE) then
- begin
- str := SFSGetLastVirtualName(section + '\' + name);
- stream := SFSFileOpen(wad + '::' + str);
- if stream <> nil then
- begin
- res := 0;
- stream.Destroy
- end
- end;
- SFSGCCollect
- end;
-
- procedure g_ReadResource (wad, section, name: String; out data: PByte; out len: Integer);
- var stream: TStream; str: String; i: Integer;
- begin
- e_WriteLog('g_ReadResource: "' + wad + '" "' + section + '" "' + name + '"', MSG_NOTIFY);
- section := utf2win(NoTrailing(section));
- name := utf2win(name);
- data := nil;
- len := 0;
- //ASSERT(name <> '');
- if name = '' then Exit; (* SKY can be void *)
- if SFSAddDataFileTemp(wad, TRUE) then
- begin
- str := SFSGetLastVirtualName(section + '/' + name);
- stream := SFSFileOpen(wad + '::' + str);
- if stream <> nil then
- begin
- len := stream.Size;
- GetMem(data, len);
- ASSERT(data <> nil);
- //stream.ReadBuffer(data, len); (* leads to segfault *)
- for i := 0 to len - 1 do
- data[i] := stream.ReadByte();
- stream.Destroy
- end
- end;
- SFSGCCollect
- 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
- data := nil;
- len := 0;
- section0 := utf2win(NoTrailing(section0));
- name0 := utf2win(name0);
- section1 := utf2win(NoTrailing(section1));
- name1 := utf2win(name1);
- //ASSERT(name0 <> '');
- //ASSERT(name1 <> '');
- if (wad = '') OR (name0 = '') OR (name1 = '') then Exit; (* ??? *)
- if SFSAddDataFileTemp(wad, TRUE) then
- begin
- str0 := SFSGetLastVirtualName(section0 + '\' + name0);
- stream0 := SFSFileOpen(wad + '::' + str0);
- if stream0 <> nil then
- begin
- if SFSAddSubDataFile(wad + '\' + str0, stream0, TRUE) then
- begin
- str1 := SFSGetLastVirtualName(section1 + '\' + name1);
- stream1 := SFSFileOpen(wad + '\' + str0 + '::' + str1);
- if stream1 <> nil then
- begin
- len := stream1.Size;
- GetMem(data, len);
- ASSERT(data <> nil);
- //stream1.ReadBuffer(data, len); (* leads to segfault *)
- for i := 0 to len - 1 do
- data[i] := stream1.ReadByte();
- stream1.Destroy
- //stream0.Destroy (* leads to memory corruption, it destroyed with stream1? *)
- end
- else
- begin
- stream0.Destroy
- end
- end
- else
- begin
- stream0.Destroy
- end
- end
- end;
- SFSGCCollect
- end;
-
-end.
index 52c6169b807bf8cd88d4cb6db89a171f0abfb017..5d591577a4854b6697a6c965990363757f6860d0 100644 (file)
implementation
uses
- e_log, WADEDITOR, g_basic, SysUtils, g_resources;
+ e_log, WADEDITOR, g_basic, SysUtils;
type
_TTexture = record
end;
end;
-function g_SimpleCreateTextureWAD (var ID: DWORD; Resource: string): Boolean;
- var
- TextureData: Pointer;
- ResourceLength: Integer;
- FileName, SectionName, ResourceName: string;
+function g_SimpleCreateTextureWAD(var ID: DWORD; Resource: string): Boolean;
+var
+ WAD: TWADEditor_1;
+ FileName,
+ SectionName,
+ ResourceName: string;
+ TextureData: Pointer;
+ ResourceLength: Integer;
begin
- 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
+ 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
else
- begin
- e_WriteLog(Format('Error loading texture %s', [Resource]), MSG_WARNING)
- //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
- end;
+ 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;
end;
function g_CreateTextureMemorySize(pData: Pointer; dataLen: Integer; Name: ShortString; X, Y,
end;
function g_CreateTextureWAD(TextureName: ShortString; Resource: string; flag: Byte = 0): Boolean;
- var
- TextureData: Pointer;
- ResourceLength: Integer;
- FileName, SectionName, ResourceName: string;
- find_id: DWORD;
+var
+ WAD: TWADEditor_1;
+ FileName,
+ SectionName,
+ ResourceName: string;
+ TextureData: Pointer;
+ find_id: DWORD;
+ ResourceLength: Integer;
begin
- 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
+ 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;
end;
-function g_SimpleCreateTextureWADSize(var ID: DWORD; Resource: String; X, Y, Width, Height: Word): Boolean;
- var
- TextureData: Pointer;
- ResourceLength: Integer;
- FileName, SectionName, ResourceName: String;
+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;
begin
- 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
+ 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;
end;
-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;
+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;
begin
- find_id := FindTexture;
- g_ProcessResourceStr(Resource, FileName, SectionName, ResourceName);
- g_ReadResource(FileName, SectionName, ResourceName, TextureData, ResourceLength);
- if TextureData <> nil then
+ 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
begin
- 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
+ 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
+ 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;
end;
function g_GetTexture(TextureName: ShortString; var ID: DWORD): Boolean;
diff --git a/src/sfs/sfs.pas b/src/sfs/sfs.pas
--- a/src/sfs/sfs.pas
+++ /dev/null
@@ -1,1272 +0,0 @@
-(* 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, version 3 of the License ONLY.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program. If not, see <http://www.gnu.org/licenses/>.
- *)
-// streaming file system (virtual)
-{$INCLUDE ../shared/a_modes.inc}
-{$SCOPEDENUMS OFF}
-{.$R+}
-{.$DEFINE SFS_VOLDEBUG}
-unit sfs;
-
-interface
-
-uses
- SysUtils, Classes, Contnrs;
-
-
-type
- ESFSError = class(Exception);
-
- TSFSVolume = class;
-
- TSFSFileInfo = class
- public
- fOwner: TSFSVolume; // òàê, íà âñÿêèé ñëó÷àé
- fPath: AnsiString; // ðàçäåëèòåëè êàòàëîãîâ -- "/"; êîðåíü íèêàê íå îáîçíà÷åí, åñëè íå ïóñòîå, îáÿçàíî çàâåðøàòüñÿ "/"
- fName: AnsiString; // òîëüêî èìÿ
- fSize: Int64; // unpacked
- fOfs: Int64; // in VFS (many of 'em need this %-)
-
- constructor Create (pOwner: TSFSVolume);
- destructor Destroy (); override;
-
- property path: AnsiString read fPath;
- property name: AnsiString read fName;
- property size: Int64 read fSize; // can be -1 if size is unknown
- end;
-
- // âèðòóàëüíàÿ ôàéëîâàÿ ñèñòåìà. ÒÎËÜÊÎ ÄËß ×ÒÅÍÈß!
- // òîì ÍÅ ÄÎËÆÅÍ óáèâàòüñÿ íèêàê èíà÷å, ÷åì ïðè ïîìîùè ôàáðèêè!
- TSFSVolume = class
- protected
- fFileName: AnsiString;// îáû÷íî èìÿ îðèãèíàëüíîãî ôàéëà
- fFileStream: TStream; // îáû÷íî ïîòîê äëÿ ÷òåíèÿ îðèãèíàëüíîãî ôàéëà
- fFiles: TObjectList; // TSFSFileInfo èëè íàñëåäíèêè
-
- // ïðèøèáèòü âñå ñòðóêòóðû.
- // íå äîëæíà ïàäàòü, åñëè å¸ âûçûâàþò íåñêîëüêî ðàç.
- procedure Clear (); virtual;
-
- // âûçûâàåòñÿ èç DoDirectoryRead() äëÿ çàïîëíåíèÿ ñïèñêà ôàéëîâ.
- // ñ÷èòàåòñÿ, ÷òî âñå ìàãèêè óæå ïðîâåðåíû è ôàéë òî÷íî íàø.
- // fFileName, fFileStream óæå óñòàíîâëåíû, fFiles ñîçäàí,
- // â í¸ì, ñêîðåå âñåãî, íèêîãî íåò.
- // ïîçèöèÿ ïîòîêà -- òà, ÷òî îñòàâèëà ôàáðèêà.
- // ïðè îøèáêàõ êèäàòü èñêëþ÷åíèå, òîãäà òîì áóäåò ïðèáèò ôàáðèêîé.
- // ðàçäåëèòåëè ïóòåé äîëæíû áûòü òîëüêî "/", êîðíåâîé "/" äîëæåí
- // áûòü îïóùåí, ïóòè (åñëè íå ïóñòûå) äîëæíû çàâåðøàòüñÿ "/"!
- // fName äîëæíî ñîäåðæàòü òîëüêî èìÿ, fPath -- òîëüêî ïóòü.
- // â ïðèíöèïå, îá ýòîì ïîçàáîòèòñÿ DoDirectoryRead(), íî çà÷åì
- // äàâàòü åìó ëèøíþþ ðàáîòó?
- procedure ReadDirectory (); virtual; abstract;
-
- // íàéòè ôàéë, âåðíóòü åãî èíäåêñ â fFiles.
- // ýòà ïðîöåäóðà ìîæåò ìåíÿòü fFiles!
- // fPath -- â ïðàâèëüíîé ôîðìå, ñ "/", êîðíåâîé "/" óáèò, ôèíàëüíûé äîáàâëåí.
- // åñëè ôàéë íå íàéäåí, âåðíóòü -1.
- function FindFile (const fPath, fName: AnsiString): Integer; virtual;
-
- // âîçâðàùàåò êîëè÷åñòâî ôàéëîâ â fFiles
- function GetFileCount (): Integer; virtual;
-
- // âîçâðàùàåò ôàéë ñ èíäåêñîì index.
- // ìîæåò âîçâðàùàòü NIL.
- // íèêàêèõ ïàäåíèé íà íåïðàâèëüíûå èíäåêñû!
- function GetFiles (index: Integer): TSFSFileInfo; virtual;
-
- public
- // pSt íå îáÿçàòåëüíî çàïîìèíàòü, åñëè îí íå íóæåí.
- constructor Create (const pFileName: AnsiString; pSt: TStream); virtual;
- // fFileStream óíè÷òîæàòü íåëüçÿ, åñëè îí ðàâåí ïàðàìåòðó pSt êîíñòðóêòîðà.
- destructor Destroy (); override;
-
- // âûçûâàåò ReadDirectory().
- // ýòà ïðîöåäóðà ñàìà ðàçáåð¸òñÿ ñ äóáëèêàòàìè èì¸í: ïîäîáàâëÿåò â
- // êîíåö èì¸í-äóáëèêàòîâ ïîä÷¸ðêèâàíèå è äåñÿòè÷íûé íîìåð.
- // òàêæå îíà íîðìàëèçóåò âèä èì¸í.
- procedure DoDirectoryRead ();
-
- // ïðè îøèáêàõ êèäàòüñÿ èñêëþ÷åíèÿìè.
- function OpenFileByIndex (const index: Integer): TStream; virtual; abstract;
-
- // åñëè íå ñìîãëî îòêóïîðèòü ôàéëî (èëè åù¸ ãäå îøèáëîñü), çàøâûðí¸ò èñêëþ÷åíèå.
- function OpenFileEx (const fName: AnsiString): TStream; virtual;
-
- property FileCount: Integer read GetFileCount; // ìîæåò âåðíóòü íîëü
- // ìîæåò âîçâðàùàòü NIL.
- // íèêàêèõ ïàäåíèé íà íåïðàâèëüíûå èíäåêñû!
- property Files [index: Integer]: TSFSFileInfo read GetFiles;
- end;
-
- // ôàáðèêà òîìîâ. âñå SFS ïðè ñòàðòå äîáàâëÿþò ñâîè ôàáðèêè.
- // áëàãîäàðÿ ýòîìó ìîæíî ñîçäàâàòü ðàçíûå âñÿêèå SFS ñòàíäàðòíûì
- // âûçîâîì ñòàíäàðòíîé ïðîöåäóðû.
- // ôàáðèêà ÍÅ ÄÎËÆÍÀ óáèâàòüñÿ íèêàê èíà÷å, ÷åì ïðè ïîìîùè âûçîâà
- // SFSUnregisterVolumeFactory()! ýòî ãàðàíòèðóåò, ÷òî äâèæîê
- // ïåðåä ðàññòðåëîì îòäàñò åé âñå å¸ òîìà.
- TSFSVolumeFactory = class
- public
- // åñëè äîáàâëÿåì ôàéë äàííûõ ôàéë ñ èìåíåì òèïà "zip:....", òî
- // SFS èçâëå÷¸ò ýòî "zip" è ïåðåäàñò â ñèþ ôóíêöèþ.
- // åæåëè ôóíêöèÿ âåðí¸ò ïðàâäó, òî SFS âûçîâåò Produce äëÿ äàííîãî
- // ôàéëà. åñëè íè îäíà ôàáðèêà ïðåôèêñ íå ïðèçíàåò, òî ôàéë íå îòêðîþò.
- // èñïîëüçóåòñÿ äëÿ ñêèïàíèÿ àâòîäåòåêòà.
- // SFS ÍÅ Ñ×ÈÒÀÅÒ ÏÐÅÔÈÊÑÎÌ ÑÒÐÎÊÓ ÊÎÐÎ×Å ÒÐ¨Õ ÑÈÌÂÎËÎÂ!
- function IsMyVolumePrefix (const prefix: AnsiString): Boolean; virtual; abstract;
- // ïðîâåðÿåò, ìîæåò ëè ôàáðèêà ñäåëàòü òîì äëÿ äàííîãî ôàéëà.
- // st -- îòêðûòûé äëÿ ÷òåíèÿ ôàéëîâé ïîòîê. óêàçàòåëü ÷òåíèÿ ñòîèò â íà÷àëå.
- // ýòîò ïîòîê íåëüçÿ çàêðûâàòü!
- // prefix: òî, ÷òî áûëî ïåðåäàíî â IsMyVolumePrefix() èëè ''.
- // èñêëþ÷åíèå ñ÷èòàåòñÿ îøèáêîé, âîçâðàò NIL ñ÷èòàåòñÿ îøèáêîé.
- function Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume; virtual; abstract;
- // êîãäà òîì áîëüøå íå íóæåí, îí áóäåò îòäàí ôàáðèêå íà ïåðåðàáîòêó.
- // äàëåå äâèæîê íå áóäåò þçàòü ñåé òîì.
- procedure Recycle (vol: TSFSVolume); virtual; abstract;
- end;
-
- // "èòåðàòîð", âîçâðàùàåìûé SFSFileList()
- TSFSFileList = class
- protected
- fVolume: TSFSVolume;
-
- function GetCount (): Integer;
- function GetFiles (index: Integer): TSFSFileInfo;
-
- public
- constructor Create (const pVolume: TSFSVolume);
- destructor Destroy (); override;
-
- property Volume: TSFSVolume read fVolume;
- property Count: Integer read GetCount;
- // ïðè íåïðàâèëüíîì èíäåêñå ìîë÷à âåðí¸ò NIL.
- // ïðè ïðàâèëüíîì òîæå ìîæåò âåðíóòü NIL!
- // î÷åíü íå ñîâåòóþ ìåíÿòü ñîäåðæèìîå ïîëó÷åííîãî êëàññà.
- // êîíå÷íî, ÿ ìîã áû âîçâðàùàòü íîâóþ ñòðóêòóðó èëè íå÷òî ïîõîæåå,
- // íî áëèí, åñëè òû èäèîò è íå óìååøü äàæå êîììåíòû ÷èòàòü, òî
- // êàêîãî òû âîîáùå â ïðîãðàììèíã ïîëåç?
- property Files [index: Integer]: TSFSFileInfo read GetFiles; default;
- end;
-
-
-procedure SFSRegisterVolumeFactory (factory: TSFSVolumeFactory);
-// ýòà ôóíêöèÿ àâòîìàòè÷åñêè ïðèáü¸ò factory.
-procedure SFSUnregisterVolumeFactory (factory: TSFSVolumeFactory);
-
-// äîáàâèòü ñáîðíèê â ïîñòîÿííûé ñïèñîê.
-// åñëè ñáîðíèê ñ òàêèì èìåíåì óæå îòêðûò, òî íå îòêðûâàåò åãî ïîâòîðíî.
-// íèêîãäà íå êèäàåò èñêëþ÷åíèé.
-// top: äîáàâèòü â íà÷àëî ñïèñêà ïîèñêà.
-// âåðí¸ò ëîæü ïðè îøèáêå.
-// ñïîñîáíî îòêðûâàòü ñáîðíèêè â ñáîðíèêàõ ïðè ïîìîùè êðóòûõ èì¸í a-la:
-// "zip:pack0::pack:pack1::wad2:pack2".
-// â äàëüíåéøåì ñëåäóåò îáðàùàòüñÿ ê ñáîðíèêó êàê "pack2::xxx".
-// èëè ìîæíî íàïèñàòü:
-// "zip:pack0::pack:pack1::wad2:pack2|datafile".
-// è îáðàùàòüñÿ êàê "datafile::xxx".
-// "||" ïðåîáðàçóþòñÿ â ïðîñòîé "|" è ðàçäåëèòåëåì íå ñ÷èòàþòñÿ.
-// ïðèíèìàåòñÿ âî âíèìàíèå òîëüêî ïîñëåäíÿÿ òðóáà.
-function SFSAddDataFile (const dataFileName: AnsiString; top: Boolean=false): Boolean;
-
-// äîáàâèòü ñáîðíèê âðåìåííî
-function SFSAddDataFileTemp (const dataFileName: AnsiString; top: Boolean=false): Boolean;
-
-// äîáàâèòü â ïîñòîÿííûé ñïèñîê ñáîðíèê èç ïîòîêà ds.
-// åñëè âîçâðàùàåò èñòèíó, òî SFS ñòàíîâèòñÿ âëÿäåëüöåì ïîòîêà ds è ñàìà
-// óãðîáèò ñåé ïîòîê ïî íåîáõîäèìîñòè.
-// virtualName ñòàíîâèòñÿ èìåíåì ñáîðíèêà äëÿ îïåðàöèè îòêðûòèÿ ôàéëà òèïà
-// "packfile:file.ext".
-// åñëè êàêîé-íèáóäü ñáîðíèê ñ èìåíåì virtualName óæå îòêðûò, âåðí¸ò false.
-// íèêîãäà íå êèäàåò èñêëþ÷åíèé.
-// top: äîáàâèòü â íà÷àëî ñïèñêà ïîèñêà.
-// âåðí¸ò ëîæü ïðè îøèáêå.
-// îòêðûâàåò ñáîðíèê èç ïîòîêà. dataFileName -- ÂÈÐÒÓÀËÜÍÎÅ èìÿ.
-// ò.å. íà ñàìîì äåëå òàêîãî ôàéëà ìîæåò è íå áûòü íà äèñêå.
-function SFSAddSubDataFile (const virtualName: AnsiString; ds: TStream; top: Boolean=false): Boolean;
-
-// øâûðÿåòñÿ èñêëþ÷åíèÿìè.
-// åñëè fName íå èìååò óêàçàíèÿ íà ôàéë äàííûõ (ýòî òî, ÷òî îòäåëåíî îò
-// îñòàëüíîãî èìåíè äâîåòî÷èåì), òî èùåì ñíà÷àëà ïî âñåì çàðåãèñòðèðîâàííûì
-// ôàéëàì äàííûõ, ïîòîì â òåêóùåì êàòàëîãå, ïîòîì â êàòàëîãå, îòêóäà ñòàðòîâàëè.
-// åñëè íè÷åãî íå íàøëè, êèäàåì èñêëþ÷åíèå.
-function SFSFileOpenEx (const fName: AnsiString): TStream;
-
-// ïðè îøèáêå -- NIL, è íèêàêèõ èñêëþ÷åíèé.
-function SFSFileOpen (const fName: AnsiString): TStream;
-
-// âîçâðàùàåò NIL ïðè îøèáêå.
-// ïîñëå èñïîëüçîâàíèÿ, íàòóðàëüíî, èòåðàòîð íàäî ãðîõíóòü %-)
-function SFSFileList (const dataFileName: AnsiString): TSFSFileList;
-
-// çàïðåòèòü îñâîáîæäåíèå âðåìåííûõ òîìîâ (ìîæíî âûçûâàòü ðåêóðñèâíî)
-procedure sfsGCDisable ();
-
-// ðàçðåøèòü îñâîáîæäåíèå âðåìåííûõ òîìîâ (ìîæíî âûçûâàòü ðåêóðñèâíî)
-procedure sfsGCEnable ();
-
-// for completeness sake
-procedure sfsGCCollect ();
-
-function SFSReplacePathDelims (const s: AnsiString; newDelim: Char): AnsiString;
-
-// ðàçîáðàòü òîëñòîå èìÿ ôàéëà, âåðíóòü âèðòóàëüíîå èìÿ ïîñëåäíåãî ñïèñêà
-// èëè ïóñòóþ ñòîðîêó, åñëè ñïèñêîâ íå áûëî.
-function SFSGetLastVirtualName (const fn: AnsiString): AnsiString;
-
-// Wildcard matching
-// this code is meant to allow wildcard pattern matches. tt is VERY useful
-// for matching filename wildcard patterns. tt allows unix grep-like pattern
-// comparisons, for instance:
-//
-// ? Matches any single characer
-// + Matches any single characer or nothing
-// * Matches any number of contiguous characters
-// [abc] Matches a or b or c at that position
-// [!abc] Matches anything but a or b or c at that position
-// [a-e] Matches a through e at that position
-//
-// 'ma?ch.*' -Would match match.exe, mavch.dat, march.on, etc
-// 'this [e-n]s a [!zy]est' -Would match 'this is a test', but would
-// not match 'this as a yest'
-//
-function WildMatch (pattern, text: AnsiString): Boolean;
-function WildListMatch (wildList, text: AnsiString; delimChar: AnsiChar=':'): Integer;
-function HasWildcards (const pattern: AnsiString): Boolean;
-
-
-var
- // ïðàâäà: ðàçðåøåíî èñêàòü ôàéëî íå òîëüêî â ôàéëàõ äàííûõ, íî è íà äèñêå.
- sfsDiskEnabled: Boolean = true;
- // ïðàâäà: åñëè ôàéë íå ïðåôèêñîâàí, òî ñíà÷àëà èùåì ôàéëî íà äèñêå,
- // ïîòîì â ôàéëàõ äàííûõ.
- sfsDiskFirst: Boolean = true;
- // ïðàâäà: äàæå äëÿ ïðåôèêñîâàíûõ ôàéëîâ ñíà÷àëà ïðîñìîòðèì äèñê
- // (åñëè óñòàíîâëåí ôëàæîê sfsDiskFirst è sfsDiskEnabled).
- sfsForceDiskForPrefixed: Boolean = false;
- // ñïèñîê äèñêîâûõ êàòàëîãîâ äëÿ ïîèñêà ôàéëà. åñëè ïóñò -- èùåì òîëüêî â
- // òåêóùåì. êàòàëîãè ðàçäåëÿþòñÿ òðóáîé ("|").
- // <currentdir> çàìåíÿåòñÿ íà òåêóùèé êàòàëîã (ñ çàâåðøàþùèì "/"),
- // <exedir> çàìåíÿåòñÿ íà êàòàëîã, ãäå ñèäèò .EXE (ñ çàâåðøàþùèì "/").
- sfsDiskDirs: AnsiString = '<currentdir>|<exedir>';
-
-
-implementation
-
-uses
- xstreams, utils;
-
-
-const
- // character defines
- WILD_CHAR_ESCAPE = '\';
- WILD_CHAR_SINGLE = '?';
- WILD_CHAR_SINGLE_OR_NONE = '+';
- WILD_CHAR_MULTI = '*';
- WILD_CHAR_RANGE_OPEN = '[';
- WILD_CHAR_RANGE = '-';
- WILD_CHAR_RANGE_CLOSE = ']';
- WILD_CHAR_RANGE_NOT = '!';
-
-
-function HasWildcards (const pattern: AnsiString): Boolean;
-begin
- result :=
- (Pos(WILD_CHAR_ESCAPE, pattern) <> 0) or
- (Pos(WILD_CHAR_SINGLE, pattern) <> 0) or
- (Pos(WILD_CHAR_SINGLE_OR_NONE, pattern) <> 0) or
- (Pos(WILD_CHAR_MULTI, pattern) <> 0) or
- (Pos(WILD_CHAR_RANGE_OPEN, pattern) <> 0);
-end;
-
-function MatchMask (const pattern: AnsiString; p, pend: Integer; const text: AnsiString; t, tend: Integer): Boolean;
-var
- rangeStart, rangeEnd: AnsiChar;
- rangeNot, rangeMatched: Boolean;
- ch: AnsiChar;
-begin
- // sanity checks
- if (pend < 0) or (pend > Length(pattern)) then pend := Length(pattern);
- if (tend < 0) or (tend > Length(text)) then tend := Length(text);
- if t < 1 then t := 1;
- if p < 1 then p := 1;
- while p <= pend do
- begin
- if t > tend then
- begin
- // no more text. check if there's no more chars in pattern (except "*" & "+")
- while (p <= pend) and
- ((pattern[p] = WILD_CHAR_MULTI) or
- (pattern[p] = WILD_CHAR_SINGLE_OR_NONE)) do Inc(p);
- result := (p > pend);
- exit;
- end;
- case pattern[p] of
- WILD_CHAR_SINGLE: ;
- WILD_CHAR_ESCAPE:
- begin
- Inc(p);
- if p > pend then result := false else result := (pattern[p] = text[t]);
- if not result then exit;
- end;
- WILD_CHAR_RANGE_OPEN:
- begin
- result := false;
- Inc(p); if p > pend then exit; // sanity check
- rangeNot := (pattern[p] = WILD_CHAR_RANGE_NOT);
- if rangeNot then begin Inc(p); if p > pend then exit; {sanity check} end;
- if pattern[p] = WILD_CHAR_RANGE_CLOSE then exit; // sanity check
- ch := text[t]; // speed reasons
- rangeMatched := false;
- repeat
- if p > pend then exit; // sanity check
- rangeStart := pattern[p];
- if rangeStart = WILD_CHAR_RANGE_CLOSE then break;
- Inc(p); if p > pend then exit; // sanity check
- if pattern[p] = WILD_CHAR_RANGE then
- begin
- Inc(p); if p > pend then exit; // sanity check
- rangeEnd := pattern[p]; Inc(p);
- if rangeStart < rangeEnd then
- begin
- rangeMatched := (ch >= rangeStart) and (ch <= rangeEnd);
- end
- else rangeMatched := (ch >= rangeEnd) and (ch <= rangeStart);
- end
- else rangeMatched := (ch = rangeStart);
- until rangeMatched;
- if rangeNot = rangeMatched then exit;
-
- // skip the rest or the range
- while (p <= pend) and (pattern[p] <> WILD_CHAR_RANGE_CLOSE) do Inc(p);
- if p > pend then exit; // sanity check
- end;
- WILD_CHAR_SINGLE_OR_NONE:
- begin
- Inc(p);
- result := MatchMask(pattern, p, pend, text, t, tend);
- if not result then result := MatchMask(pattern, p, pend, text, t+1, tend);
- exit;
- end;
- WILD_CHAR_MULTI:
- begin
- while (p <= pend) and (pattern[p] = WILD_CHAR_MULTI) do Inc(p);
- result := (p > pend); if result then exit;
- while not result and (t <= tend) do
- begin
- result := MatchMask(pattern, p, pend, text, t, tend);
- Inc(t);
- end;
- exit;
- end;
- else result := (pattern[p] = text[t]); if not result then exit;
- end;
- Inc(p); Inc(t);
- end;
- result := (t > tend);
-end;
-
-
-function WildMatch (pattern, text: AnsiString): Boolean;
-begin
- if pattern <> '' then pattern := AnsiLowerCase(pattern);
- if text <> '' then text := AnsiLowerCase(text);
- result := MatchMask(pattern, 1, -1, text, 1, -1);
-end;
-
-function WildListMatch (wildList, text: AnsiString; delimChar: AnsiChar=':'): Integer;
-var
- s, e: Integer;
-begin
- if wildList <> '' then wildList := AnsiLowerCase(wildList);
- if text <> '' then text := AnsiLowerCase(text);
- result := 0;
- s := 1;
- while s <= Length(wildList) do
- begin
- e := s; while e <= Length(wildList) do
- begin
- if wildList[e] = WILD_CHAR_RANGE_OPEN then
- begin
- while (e <= Length(wildList)) and (wildList[e] <> WILD_CHAR_RANGE_CLOSE) do Inc(e);
- end;
- if wildList[e] = delimChar then break;
- Inc(e);
- end;
- if s < e then
- begin
- if MatchMask(wildList, s, e-1, text, 1, -1) then exit;
- end;
- Inc(result);
- s := e+1;
- end;
- result := -1;
-end;
-
-
-type
- TVolumeInfo = class
- public
- fFactory: TSFSVolumeFactory;
- fVolume: TSFSVolume;
- fPackName: AnsiString; // äëÿ îäíîãî è òîãî æå ôàéëà áóäåò òîëüêî îäèí òîì!
- fStream: TStream; // ôàéëîâûé ïîòîê äëÿ ñáîðíèêà
- fPermanent: Boolean; // èñòèíà -- íå áóäåò óãðîáëåíà, åñëè íå îñòàíåòñÿ íè îäíîãî îòêðûòîãî òîìà
- // èñòèíà -- ýòîò òîì áûë ñîçäàí èç ïîòîêà è íå èìååò äèñêîâîãî ôàéëà, ïîòîìó ôàáðèêå áóäåò ïåðåäàíî íå èìÿ ñáîðíèêà, à ïóñòàÿ ñòðîêà
- fNoDiskFile: Boolean;
- fOpenedFilesCount: Integer;
-
- destructor Destroy (); override;
- end;
-
- TOwnedPartialStream = class (TSFSPartialStream)
- protected
- fOwner: TVolumeInfo;
-
- public
- constructor Create (pOwner: TVolumeInfo; pSrc: TStream; pPos, pSize: Int64; pKillSrc: Boolean);
- destructor Destroy (); override;
- end;
-
-
-var
- factories: TObjectList; // TSFSVolumeFactory
- volumes: TObjectList; // TVolumeInfo
- gcdisabled: Integer = 0; // >0: disabled
-
-
-procedure sfsGCCollect ();
-var
- f, c: Integer;
- vi: TVolumeInfo;
- used: Boolean;
-begin
- // collect garbage
- f := 0;
- while f < volumes.Count do
- begin
- vi := TVolumeInfo(volumes[f]);
- if (vi <> nil) and (not vi.fPermanent) and (vi.fOpenedFilesCount = 0) then
- begin
- // this volume probably can be removed
- used := false;
- c := volumes.Count-1;
- while not used and (c >= 0) do
- begin
- if (c <> f) and (volumes[c] <> nil) then
- begin
- used := (TVolumeInfo(volumes[c]).fStream = vi.fStream);
- if not used then used := (TVolumeInfo(volumes[c]).fVolume.fFileStream = vi.fStream);
- if used then break;
- end;
- Dec(c);
- end;
- if not used then
- begin
- {$IFDEF SFS_VOLDEBUG}writeln('000: destroying volume "', TVolumeInfo(volumes[f]).fPackName, '"');{$ENDIF}
- volumes.extract(vi); // remove from list
- vi.Free; // and kill
- f := 0;
- continue;
- end;
- end;
- Inc(f); // next volume
- end;
-end;
-
-procedure sfsGCDisable ();
-begin
- Inc(gcdisabled);
-end;
-
-procedure sfsGCEnable ();
-begin
- Dec(gcdisabled);
- if gcdisabled <= 0 then
- begin
- gcdisabled := 0;
- sfsGCCollect();
- end;
-end;
-
-
-// ðàçáèòü èìÿ ôàéëà íà ÷àñòè: ïðåôèêñ ôàéëîâîé ñèñòåìû, èìÿ ôàéëà äàííûõ,
-// ñîáñòâåííî èìÿ ôàéëà
-// èìÿ âûãëÿäèò êàê:
-// (("sfspfx:")?"datafile::")*"filename"
-procedure SplitFName (const fn: AnsiString; out dataFile, fileName: AnsiString);
-var
- f: Integer;
-begin
- f := Length(fn)-1;
- while f >= 1 do
- begin
- if (fn[f] = ':') and (fn[f+1] = ':') then break;
- Dec(f);
- end;
- if f < 1 then begin dataFile := ''; fileName := fn; end
- else
- begin
- dataFile := Copy(fn, 1, f-1);
- fileName := Copy(fn, f+2, maxInt-10000);
- end;
-end;
-
-// ñàéäýôôåêò: âûðåçàåò âèðòóàëüíîå èìÿ èç dataFile.
-function ExtractVirtName (var dataFile: AnsiString): AnsiString;
-var
- f: Integer;
-begin
- f := Length(dataFile); result := dataFile;
- while f > 1 do
- begin
- if dataFile[f] = ':' then break;
- if dataFile[f] = '|' then
- begin
- if dataFile[f-1] = '|' then begin Dec(f); Delete(dataFile, f, 1); end
- else
- begin
- result := Copy(dataFile, f+1, Length(dataFile));
- Delete(dataFile, f, Length(dataFile));
- break;
- end;
- end;
- Dec(f);
- end;
-end;
-
-// ðàçáèòü èìÿ ñáîðíèêà íà ÷àñòè: ïðåôèêñ ôàéëîâîé ñèñòåìû, èìÿ ôàéëà äàííûõ,
-// âèðòóàëüíîå èìÿ. åñëè âèðòóàëüíîãî èìåíè íå äàíî, îíî áóäåò ðàâíî dataFile.
-// èìÿ âûãëÿäèò êàê:
-// [sfspfx:]datafile[|virtname]
-// åñëè ïåðåä äâîåòî÷èåì ìåíüøå òð¸õ áóêâ, òî ýòî ñ÷èòàåòñÿ íå ïðåôèêñîì,
-// à èìåíåì äèñêà.
-procedure SplitDataName (const fn: AnsiString; out pfx, dataFile, virtName: AnsiString);
-var
- f: Integer;
-begin
- f := Pos(':', fn);
- if f <= 3 then begin pfx := ''; dataFile := fn; end
- else
- begin
- pfx := Copy(fn, 1, f-1);
- dataFile := Copy(fn, f+1, maxInt-10000);
- end;
- virtName := ExtractVirtName(dataFile);
-end;
-
-// íàéòè ïðîèçâîäèòåëÿ äëÿ ýòîãî ôàéëà (åñëè ôàéë óæå îòêðûò).
-// onlyPerm: òîëüêî "ïîñòîÿííûå" ïðîèçâîäèòåëè.
-function FindVolumeInfo (const dataFileName: AnsiString; onlyPerm: Boolean=false): Integer;
-var
- f: Integer;
- vi: TVolumeInfo;
-begin
- f := 0;
- while f < volumes.Count do
- begin
- if volumes[f] <> nil then
- begin
- vi := TVolumeInfo(volumes[f]);
- if not onlyPerm or vi.fPermanent then
- begin
- if StrEquCI1251(vi.fPackName, dataFileName) then
- begin
- result := f;
- exit;
- end;
- end;
- end;
- Inc(f);
- end;
- result := -1;
-end;
-
-// íàéòè èíôó äëÿ ýòîãî òîìà.
-// õîðîøåå èìÿ, ïðàâäà? %-)
-function FindVolumeInfoByVolumeInstance (vol: TSFSVolume): Integer;
-begin
- result := volumes.Count-1;
- while result >= 0 do
- begin
- if volumes[result] <> nil then
- begin
- if TVolumeInfo(volumes[result]).fVolume = vol then exit;
- end;
- Dec(result);
- end;
-end;
-
-
-// adds '/' too
-function normalizePath (fn: AnsiString): AnsiString;
-var
- i: Integer;
-begin
- result := '';
- i := 1;
- while i <= length(fn) do
- begin
- if (fn[i] = '.') and ((length(fn)-i = 0) or (fn[i+1] = '/') or (fn[i+1] = '\')) then
- begin
- i := i+2;
- continue;
- end;
- if (fn[i] = '/') or (fn[i] = '\') then
- begin
- if (length(result) > 0) and (result[length(result)] <> '/') then result := result+'/';
- end
- else
- begin
- result := result+fn[i];
- end;
- Inc(i);
- end;
- if (length(result) > 0) and (result[length(result)] <> '/') then result := result+'/';
-end;
-
-function SFSReplacePathDelims (const s: AnsiString; newDelim: Char): AnsiString;
-var
- f: Integer;
-begin
- result := s;
- for f := 1 to Length(result) do
- begin
- if (result[f] = '/') or (result[f] = '\') then
- begin
- // avoid unnecessary string changes
- if result[f] <> newDelim then result[f] := newDelim;
- end;
- end;
-end;
-
-function SFSGetLastVirtualName (const fn: AnsiString): AnsiString;
-var
- rest, tmp: AnsiString;
- f: Integer;
-begin
- rest := fn;
- repeat
- f := Pos('::', rest); if f = 0 then f := Length(rest)+1;
- tmp := Copy(rest, 1, f-1); Delete(rest, 1, f+1);
- result := ExtractVirtName(tmp);
- until rest = '';
-end;
-
-
-{ TVolumeInfo }
-destructor TVolumeInfo.Destroy ();
-var
- f, me: Integer;
- used: Boolean; // ôëàæîê çàþçàíîñòè ïîòîêà êåì-òî åù¸
-begin
- if fFactory <> nil then fFactory.Recycle(fVolume);
- used := false;
- fVolume := nil;
- fFactory := nil;
- fPackName := '';
-
- // òèïà ìóñîðîñáîðíèê: åñëè íàø ïîòîê áîëåå íèêåì íå þçàåòñÿ, òî óãðîáèòü åãî íàôèã
- if not used then
- begin
- me := volumes.IndexOf(self);
- f := volumes.Count-1;
- while not used and (f >= 0) do
- begin
- if (f <> me) and (volumes[f] <> nil) then
- begin
- used := (TVolumeInfo(volumes[f]).fStream = fStream);
- if not used then
- begin
- used := (TVolumeInfo(volumes[f]).fVolume.fFileStream = fStream);
- end;
- if used then break;
- end;
- Dec(f);
- end;
- end;
- if not used then FreeAndNil(fStream); // åñëè áîëüøå íèêåì íå þçàíî, ïðèøèá¸ì
- inherited Destroy();
-end;
-
-
-{ TOwnedPartialStream }
-constructor TOwnedPartialStream.Create (pOwner: TVolumeInfo; pSrc: TStream;
- pPos, pSize: Int64; pKillSrc: Boolean);
-begin
- inherited Create(pSrc, pPos, pSize, pKillSrc);
- fOwner := pOwner;
- if pOwner <> nil then Inc(pOwner.fOpenedFilesCount);
-end;
-
-destructor TOwnedPartialStream.Destroy ();
-var
- f: Integer;
-begin
- inherited Destroy();
- if fOwner <> nil then
- begin
- Dec(fOwner.fOpenedFilesCount);
- if (gcdisabled = 0) and not fOwner.fPermanent and (fOwner.fOpenedFilesCount < 1) then
- begin
- f := volumes.IndexOf(fOwner);
- if f <> -1 then
- begin
- {$IFDEF SFS_VOLDEBUG}writeln('001: destroying volume "', TVolumeInfo(volumes[f]).fPackName, '"');{$ENDIF}
- volumes[f] := nil; // this will destroy the volume
- end;
- end;
- end;
-end;
-
-
-{ TSFSFileInfo }
-constructor TSFSFileInfo.Create (pOwner: TSFSVolume);
-begin
- inherited Create();
- fOwner := pOwner;
- fPath := '';
- fName := '';
- fSize := 0;
- fOfs := 0;
- if pOwner <> nil then pOwner.fFiles.Add(self);
-end;
-
-destructor TSFSFileInfo.Destroy ();
-begin
- if fOwner <> nil then fOwner.fFiles.Extract(self);
- inherited Destroy();
-end;
-
-
-{ TSFSVolume }
-constructor TSFSVolume.Create (const pFileName: AnsiString; pSt: TStream);
-begin
- inherited Create();
- fFileStream := pSt;
- fFileName := pFileName;
- fFiles := TObjectList.Create(true);
-end;
-
-procedure TSFSVolume.DoDirectoryRead ();
-var
- f, c: Integer;
- sfi: TSFSFileInfo;
- tmp: AnsiString;
-begin
- fFileName := ExpandFileName(SFSReplacePathDelims(fFileName, '/'));
- ReadDirectory();
- fFiles.Pack();
-
- f := 0;
- while f < fFiles.Count do
- begin
- sfi := TSFSFileInfo(fFiles[f]);
- // normalize name & path
- sfi.fPath := SFSReplacePathDelims(sfi.fPath, '/');
- if (sfi.fPath <> '') and (sfi.fPath[1] = '/') then Delete(sfi.fPath, 1, 1);
- if (sfi.fPath <> '') and (sfi.fPath[Length(sfi.fPath)] <> '/') then sfi.fPath := sfi.fPath+'/';
- tmp := SFSReplacePathDelims(sfi.fName, '/');
- c := Length(tmp); while (c > 0) and (tmp[c] <> '/') do Dec(c);
- if c > 0 then
- begin
- // split path and name
- Delete(sfi.fName, 1, c); // cut name
- tmp := Copy(tmp, 1, c); // get path
- if tmp = '/' then tmp := ''; // just delimiter; ignore it
- sfi.fPath := sfi.fPath+tmp;
- end;
- sfi.fPath := normalizePath(sfi.fPath);
- if (length(sfi.fPath) = 0) and (length(sfi.fName) = 0) then sfi.Free else Inc(f);
- end;
-end;
-
-destructor TSFSVolume.Destroy ();
-begin
- Clear();
- FreeAndNil(fFiles);
- inherited Destroy();
-end;
-
-procedure TSFSVolume.Clear ();
-begin
- fFiles.Clear();
-end;
-
-function TSFSVolume.FindFile (const fPath, fName: AnsiString): Integer;
-begin
- if fFiles = nil then result := -1
- else
- begin
- result := fFiles.Count;
- while result > 0 do
- begin
- Dec(result);
- if fFiles[result] <> nil then
- begin
- if StrEquCI1251(fPath, TSFSFileInfo(fFiles[result]).fPath) and
- StrEquCI1251(fName, TSFSFileInfo(fFiles[result]).fName) then exit;
- end;
- end;
- result := -1;
- end;
-end;
-
-function TSFSVolume.GetFileCount (): Integer;
-begin
- if fFiles = nil then result := 0 else result := fFiles.Count;
-end;
-
-function TSFSVolume.GetFiles (index: Integer): TSFSFileInfo;
-begin
- if fFiles = nil then result := nil
- else
- begin
- if (index < 0) or (index >= fFiles.Count) then result := nil
- else result := TSFSFileInfo(fFiles[index]);
- end;
-end;
-
-function TSFSVolume.OpenFileEx (const fName: AnsiString): TStream;
-var
- fp, fn: AnsiString;
- f, ls: Integer;
-begin
- fp := fName;
- // normalize name, find split position
- if (fp <> '') and ((fp[1] = '/') or (fp[1] = '\')) then Delete(fp, 1, 1);
- ls := 0;
- for f := 1 to Length(fp) do
- begin
- if fp[f] = '\' then fp[f] := '/';
- if fp[f] = '/' then ls := f;
- end;
- fn := Copy(fp, ls+1, Length(fp));
- fp := Copy(fp, 1, ls);
- f := FindFile(fp, fn);
- if f = -1 then raise ESFSError.Create('file not found: "'+fName+'"');
- result := OpenFileByIndex(f);
- if result = nil then raise ESFSError.Create('file not found: "'+fName+'"');
-end;
-
-
-{ TSFSFileList }
-constructor TSFSFileList.Create (const pVolume: TSFSVolume);
-var
- f: Integer;
-begin
- inherited Create();
- ASSERT(pVolume <> nil);
- f := FindVolumeInfoByVolumeInstance(pVolume);
- ASSERT(f <> -1);
- fVolume := pVolume;
- Inc(TVolumeInfo(volumes[f]).fOpenedFilesCount); // íå ïîçâîëèì óáèòü çàïèñü!
-end;
-
-destructor TSFSFileList.Destroy ();
-var
- f: Integer;
-begin
- f := FindVolumeInfoByVolumeInstance(fVolume);
- ASSERT(f <> -1);
- Dec(TVolumeInfo(volumes[f]).fOpenedFilesCount);
- // óáü¸ì çàïèñü, åñëè îíà âðåìåííàÿ, è â íåé íåò áîëüøå íè÷åãî îòêðûòîãî
- if (gcdisabled = 0) and not TVolumeInfo(volumes[f]).fPermanent and (TVolumeInfo(volumes[f]).fOpenedFilesCount < 1) then
- begin
- {$IFDEF SFS_VOLDEBUG}writeln('002: destroying volume "', TVolumeInfo(volumes[f]).fPackName, '"');{$ENDIF}
- volumes[f] := nil;
- end;
- inherited Destroy();
-end;
-
-function TSFSFileList.GetCount (): Integer;
-begin
- result := fVolume.fFiles.Count;
-end;
-
-function TSFSFileList.GetFiles (index: Integer): TSFSFileInfo;
-begin
- if (index < 0) or (index >= fVolume.fFiles.Count) then result := nil
- else result := TSFSFileInfo(fVolume.fFiles[index]);
-end;
-
-
-procedure SFSRegisterVolumeFactory (factory: TSFSVolumeFactory);
-var
- f: Integer;
-begin
- if factory = nil then exit;
- if factories.IndexOf(factory) <> -1 then
- raise ESFSError.Create('duplicate factories are not allowed');
- f := factories.IndexOf(nil);
- if f = -1 then factories.Add(factory) else factories[f] := factory;
-end;
-
-procedure SFSUnregisterVolumeFactory (factory: TSFSVolumeFactory);
-var
- f: Integer;
- c: Integer;
-begin
- if factory = nil then exit;
- f := factories.IndexOf(factory);
- if f = -1 then raise ESFSError.Create('can''t unregister nonexisting factory');
- c := 0; while c < volumes.Count do
- begin
- if (volumes[c] <> nil) and (TVolumeInfo(volumes[c]).fFactory = factory) then volumes[c] := nil;
- Inc(c);
- end;
- factories[f] := nil;
-end;
-
-
-function SFSAddDataFileEx (dataFileName: AnsiString; ds: TStream; top, permanent: Integer): Integer;
-// dataFileName ìîæåò èìåòü ïðåôèêñ òèïà "zip:" (ñì. âûøå: IsMyPrefix).
-// ìîæåò âûêèíóòü èñêëþ÷åíèå!
-// top:
-// <0: äîáàâèòü â íà÷àëî ñïèñêà ïîèñêà.
-// =0: íå ìåíÿòü.
-// >0: äîáàâèòü â êîíåö ñïèñêà ïîèñêà.
-// permanent:
-// <0: ñîçäàòü "âðåìåííûé" òîì.
-// =0: íå ìåíÿòü ôëàæîê ïîñòîÿíñòâà.
-// >0: ñîçäàòü "ïîñòîÿííûé" òîì.
-// åñëè ds <> nil, òî ñîçäà¸ò ñáîðíèê èç ïîòîêà. åñëè ñáîðíèê ñ èìåíåì
-// dataFileName óæå çàðåãèñòðèðîâàí, òî ïàäàåò íàôèã.
-// âîçâðàùàåò èíäåêñ â volumes.
-// óìååò äåëàòü ðåêóðñèþ.
-var
- fac: TSFSVolumeFactory;
- vol: TSFSVolume;
- vi: TVolumeInfo;
- f: Integer;
- st, st1: TStream;
- pfx: AnsiString;
- fn, vfn, tmp: AnsiString;
-begin
- f := Pos('::', dataFileName);
- if f <> 0 then
- begin
- // ðåêóðñèâíîå îòêðûòèå.
- // ðàçîáü¸ì dataFileName íà èìÿ ñáîðíèêà è îñòàòîê.
- // pfx áóäåò èìåíåì ñáîðíèêà, dataFileName -- îñòàòêîì.
- pfx := Copy(dataFileName, 1, f-1); Delete(dataFileName, 1, f+1);
- // ñíà÷àëà îòêðîåì ïåðâûé ñïèñîê...
- result := SFSAddDataFileEx(pfx, ds, 0, 0);
- // ...òåïåðü ïðîäîëæèì ñ îñòàòêîì.
- // óçíàåì, êàêîå ôàéëî îòêðûâàòü.
- // âûêîâûðÿåì ïåðâûé "::" ïðåôèêñ (ýòî áóäåò èìÿ ôàéëà).
- f := Pos('::', dataFileName); if f = 0 then f := Length(dataFileName)+1;
- fn := Copy(dataFileName, 1, f-1); Delete(dataFileName, 1, f-1);
- // dataFileName õðàíèò îñòàòîê.
- // èçâëå÷¸ì èìÿ ôàéëà:
- SplitDataName(fn, pfx, tmp, vfn);
- // îòêðîåì ýòîò ôàéë
- vi := TVolumeInfo(volumes[result]); st := nil;
- try
- st := vi.fVolume.OpenFileEx(tmp);
- st1 := TOwnedPartialStream.Create(vi, st, 0, st.Size, true);
- except
- FreeAndNil(st);
- // óäàëèì íåèñïîëüçóåìûé âðåìåííûé òîì.
- if (gcdisabled = 0) and not vi.fPermanent and (vi.fOpenedFilesCount < 1) then volumes[result] := nil;
- raise;
- end;
- // óðà. îòêðûëè ôàéë. êèäàåì â âîçäóõ ÷åï÷èêè, ïðîäîëæàåì ðàçâëå÷åíèå.
- fn := fn+dataFileName;
- try
- st1.Position := 0;
- result := SFSAddDataFileEx(fn, st1, top, permanent);
- except
- st1.Free(); // à âîò íå çàëàäèëîñü. çàêðûëè îòêðûòîå ôàéëî, âûëåòåëè.
- raise;
- end;
- exit;
- end;
-
- // îáûêíîâåííîå íåðåêóðñèâíîå îòêðûòèå.
- SplitDataName(dataFileName, pfx, fn, vfn);
-
- f := FindVolumeInfo(vfn);
- if f <> -1 then
- begin
- if ds <> nil then raise ESFSError.Create('subdata name conflict');
- if permanent <> 0 then TVolumeInfo(volumes[f]).fPermanent := (permanent > 0);
- if top = 0 then result := f
- else if top < 0 then result := 0
- else result := volumes.Count-1;
- if result <> f then volumes.Move(f, result);
- exit;
- end;
-
- if ds <> nil then st := ds
- else st := TFileStream.Create(fn, fmOpenRead or {fmShareDenyWrite}fmShareDenyNone);
- st.Position := 0;
-
- volumes.Pack();
-
- fac := nil; vol := nil;
- try
- for f := 0 to factories.Count-1 do
- begin
- fac := TSFSVolumeFactory(factories[f]);
- if fac = nil then continue;
- if (pfx <> '') and not fac.IsMyVolumePrefix(pfx) then continue;
- st.Position := 0;
- try
- if ds <> nil then vol := fac.Produce(pfx, '', st)
- else vol := fac.Produce(pfx, fn, st);
- except
- vol := nil;
- end;
- if vol <> nil then break;
- end;
- if vol = nil then raise ESFSError.Create('no factory for "'+dataFileName+'"');
- except
- if st <> ds then st.Free();
- raise;
- end;
-
- vi := TVolumeInfo.Create();
- try
- if top < 0 then
- begin
- result := 0;
- volumes.Insert(0, vi);
- end
- else result := volumes.Add(vi);
- except
- vol.Free();
- if st <> ds then st.Free();
- vi.Free();
- raise;
- end;
-
- vi.fFactory := fac;
- vi.fVolume := vol;
- vi.fPackName := vfn;
- vi.fStream := st;
- vi.fPermanent := (permanent > 0);
- vi.fNoDiskFile := (ds <> nil);
- vi.fOpenedFilesCount := 0;
-end;
-
-function SFSAddSubDataFile (const virtualName: AnsiString; ds: TStream; top: Boolean=false): Boolean;
-var
- tv: Integer;
-begin
- ASSERT(ds <> nil);
- try
- if top then tv := -1 else tv := 1;
- SFSAddDataFileEx(virtualName, ds, tv, 0);
- result := true;
- except
- result := false;
- end;
-end;
-
-function SFSAddDataFile (const dataFileName: AnsiString; top: Boolean=false): Boolean;
-var
- tv: Integer;
-begin
- try
- if top then tv := -1 else tv := 1;
- SFSAddDataFileEx(dataFileName, nil, tv, 1);
- result := true;
- except
- result := false;
- end;
-end;
-
-function SFSAddDataFileTemp (const dataFileName: AnsiString; top: Boolean=false): Boolean;
-var
- tv: Integer;
-begin
- try
- if top then tv := -1 else tv := 1;
- SFSAddDataFileEx(dataFileName, nil, tv, 0);
- result := true;
- except
- result := false;
- end;
-end;
-
-
-
-function SFSExpandDirName (const s: AnsiString): AnsiString;
-var
- f, e: Integer;
- es: AnsiString;
-begin
- f := 1; result := s;
- while f < Length(result) do
- begin
- while (f < Length(result)) and (result[f] <> '<') do Inc(f);
- if f >= Length(result) then exit;
- e := f; while (e < Length(result)) and (result[e] <> '>') do Inc(e);
- es := Copy(result, f, e+1-f);
-
- if es = '<currentdir>' then es := GetCurrentDir
- else if es = '<exedir>' then es := ExtractFilePath(ParamStr(0))
- else es := '';
-
- if es <> '' then
- begin
- if (es[Length(es)] <> '/') and (es[Length(es)] <> '\') then es := es+'/';
- Delete(result, f, e+1-f);
- Insert(es, result, f);
- Inc(f, Length(es));
- end
- else f := e+1;
- end;
-end;
-
-function SFSFileOpenEx (const fName: AnsiString): TStream;
-var
- dataFileName, fn: AnsiString;
- f: Integer;
- vi: TVolumeInfo;
- diskChecked: Boolean;
- ps: TStream;
-
- function CheckDisk (): TStream;
- // ïðîâåðèì, åñòü ëè ôàëî fn ãäå-òî íà äèñêàõ.
- var
- dfn, dirs, cdir: AnsiString;
- f: Integer;
- begin
- result := nil;
- if diskChecked or not sfsDiskEnabled then exit;
- diskChecked := true;
- dfn := SFSReplacePathDelims(fn, '/');
- dirs := sfsDiskDirs; if dirs = '' then dirs := '<currentdir>';
- while dirs <> '' do
- begin
- f := 1; while (f <= Length(dirs)) and (dirs[f] <> '|') do Inc(f);
- cdir := Copy(dirs, 1, f-1); Delete(dirs, 1, f);
- if cdir = '' then continue;
- cdir := SFSReplacePathDelims(SFSExpandDirName(cdir), '/');
- if cdir[Length(cdir)] <> '/' then cdir := cdir+'/';
- try
- result := TFileStream.Create(cdir+dfn, fmOpenRead or {fmShareDenyWrite}fmShareDenyNone);
- exit;
- except
- end;
- end;
- end;
-
-begin
- SplitFName(fName, dataFileName, fn);
- if fn = '' then raise ESFSError.Create('invalid file name: "'+fName+'"');
-
- diskChecked := false;
-
- if dataFileName <> '' then
- begin
- // ïðåôèêñîâàíûé ôàéë
- if sfsForceDiskForPrefixed then
- begin
- result := CheckDisk();
- if result <> nil then exit;
- end;
-
- f := SFSAddDataFileEx(dataFileName, nil, 0, 0);
- vi := TVolumeInfo(volumes[f]);
-
- try
- result := vi.fVolume.OpenFileEx(fn);
- ps := TOwnedPartialStream.Create(vi, result, 0, result.Size, true);
- except
- result.Free();
- if (gcdisabled = 0) and not vi.fPermanent and (vi.fOpenedFilesCount < 1) then volumes[f] := nil;
- result := CheckDisk(); // îáëîì ñ datafile, ïðîâåðèì äèñê
- if result = nil then raise ESFSError.Create('file not found: "'+fName+'"');
- exit;
- end;
- //Inc(vi.fOpenedFilesCount);
- result := ps;
- exit;
- end;
-
- // íåïðåôèêñîâàíûé ôàéë
- if sfsDiskFirst then
- begin
- result := CheckDisk();
- if result <> nil then exit;
- end;
- // èùåì ïî âñåì ïåðìàíåíòíûì ïðåôèêñàì
- f := 0;
- while f < volumes.Count do
- begin
- vi := TVolumeInfo(volumes[f]);
- if (vi <> nil) and vi.fPermanent then
- begin
- if vi.fVolume <> nil then
- begin
- result := vi.fVolume.OpenFileEx(fn);
- if result <> nil then
- begin
- try
- ps := TOwnedPartialStream.Create(vi, result, 0, result.Size, true);
- result := ps;
- //Inc(vi.fOpenedFilesCount);
- except
- FreeAndNil(result);
- end;
- end;
- if result <> nil then exit;
- end;
- end;
- Inc(f);
- end;
- result := CheckDisk();
- if result = nil then raise ESFSError.Create('file not found: "'+fName+'"');
-end;
-
-function SFSFileOpen (const fName: AnsiString): TStream;
-begin
- try
- result := SFSFileOpenEx(fName);
- except
- result := nil;
- end;
-end;
-
-function SFSFileList (const dataFileName: AnsiString): TSFSFileList;
-var
- f: Integer;
- vi: TVolumeInfo;
-begin
- result := nil;
- if dataFileName = '' then exit;
-
- try
- f := SFSAddDataFileEx(dataFileName, nil, 0, 0);
- except
- exit;
- end;
- vi := TVolumeInfo(volumes[f]);
-
- try
- result := TSFSFileList.Create(vi.fVolume);
- except
- if (gcdisabled = 0) and not vi.fPermanent and (vi.fOpenedFilesCount < 1) then volumes[f] := nil;
- end;
-end;
-
-
-initialization
- factories := TObjectList.Create(true);
- volumes := TObjectList.Create(true);
-//finalization
- //volumes.Free(); // it fails for some reason... Runtime 217 (^C hit). wtf?!
- //factories.Free(); // not need to be done actually...
-end.
diff --git a/src/sfs/sfsPlainFS.pas b/src/sfs/sfsPlainFS.pas
--- a/src/sfs/sfsPlainFS.pas
+++ /dev/null
@@ -1,146 +0,0 @@
-(* 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, version 3 of the License ONLY.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program. If not, see <http://www.gnu.org/licenses/>.
- *)
-// simple grouping files w/o packing:
-// Quake I/II .PAK (PACK)
-// SiN .SIN (SPAK)
-//
-{$INCLUDE ../shared/a_modes.inc}
-{$SCOPEDENUMS OFF}
-{.$R+}
-unit sfsPlainFS;
-
-interface
-
-uses
- SysUtils, Classes, Contnrs, sfs;
-
-
-type
- TSFSPlainVolumeType = (sfspvNone, sfspvPAK, sfspvSIN);
-
- TSFSPlainVolume = class (TSFSVolume)
- protected
- fType: TSFSPlainVolumeType;
-
- procedure ReadDirectory (); override;
-
- public
- function OpenFileByIndex (const index: Integer): TStream; override;
- end;
-
- TSFSPlainVolumeFactory = class (TSFSVolumeFactory)
- public
- function IsMyVolumePrefix (const prefix: AnsiString): Boolean; override;
- function Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume; override;
- procedure Recycle (vol: TSFSVolume); override;
- end;
-
-
-implementation
-
-uses
- xstreams, utils;
-
-
-{ TSFSPlainVolume }
-procedure TSFSPlainVolume.ReadDirectory ();
-var
- dsize, dofs, esz: LongWord;
- fi: TSFSFileInfo;
- name: packed array [0..120] of Char;
-begin
- if (fType <> sfspvPAK) and (fType <> sfspvSIN) then raise ESFSError.Create('invalid archive');
- fFileStream.Seek(4, soCurrent); // skip signature
- dofs := readLongWord(fFileStream);
- dsize := readLongWord(fFileStream);
- fFileStream.Position := dofs;
- if fType = sfspvPAK then esz := 64 else esz := 128;
- while dsize >= esz do
- begin
- fi := TSFSFileInfo.Create(self);
- FillChar(name[0], length(name), 0);
- fFileStream.ReadBuffer(name[0], esz-8);
- fi.fName := PChar(@name[0]);
- fi.fOfs := readLongWord(fFileStream);
- fi.fSize := readLongWord(fFileStream);
- Dec(dsize, esz);
- end;
-end;
-
-function TSFSPlainVolume.OpenFileByIndex (const index: Integer): TStream;
-begin
- result := nil;
- if fFiles = nil then exit;
- if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
- result := TSFSPartialStream.Create(fFileStream, TSFSFileInfo(fFiles[index]).fOfs, TSFSFileInfo(fFiles[index]).fSize, false);
-end;
-
-
-{ TSFSPlainVolumeFactory }
-function TSFSPlainVolumeFactory.IsMyVolumePrefix (const prefix: AnsiString): Boolean;
-begin
- result :=
- StrEquCI1251(prefix, 'pak') or
- StrEquCI1251(prefix, 'sin');
-end;
-
-procedure TSFSPlainVolumeFactory.Recycle (vol: TSFSVolume);
-begin
- vol.Free();
-end;
-
-function TSFSPlainVolumeFactory.Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume;
-var
- vt: TSFSPlainVolumeType;
- sign: packed array [0..3] of Char;
- dsize, dofs: Integer;
-begin
- result := nil;
- vt := sfspvNone;
-
- st.ReadBuffer(sign[0], 4);
- dofs := readLongWord(st);
- dsize := readLongWord(st);
- st.Seek(-12, soCurrent);
- if sign = 'PACK' then
- begin
- if (dsize < 0) or (dofs < 0) or (dofs > st.Size) or (dofs+dsize > st.Size) or (dsize mod 64 <> 0) then exit;
- vt := sfspvPAK;
- end
- else if sign = 'SPAK' then
- begin
- if (dsize < 0) or (dofs < 0) or (dofs > st.Size) or (dofs+dsize > st.Size) or (dsize mod 64 <> 0) then exit;
- vt := sfspvSIN;
- end;
-
- result := TSFSPlainVolume.Create(fileName, st);
- TSFSPlainVolume(result).fType := vt;
- try
- result.DoDirectoryRead();
- except
- FreeAndNil(result);
- raise;
- end;
-end;
-
-
-var
- pakf: TSFSPlainVolumeFactory;
-initialization
- pakf := TSFSPlainVolumeFactory.Create();
- SFSRegisterVolumeFactory(pakf);
-//finalization
-// SFSUnregisterVolumeFactory(pakf);
-end.
diff --git a/src/sfs/sfsZipFS.pas b/src/sfs/sfsZipFS.pas
--- a/src/sfs/sfsZipFS.pas
+++ /dev/null
@@ -1,465 +0,0 @@
-(* 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, version 3 of the License ONLY.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program. If not, see <http://www.gnu.org/licenses/>.
- *)
-// grouping files with packing:
-// zip, pk3: PKZIP-compatible archives (store, deflate)
-// dfwad : D2D:F wad archives
-//
-{.$DEFINE SFS_DEBUG_ZIPFS}
-{$INCLUDE ../shared/a_modes.inc}
-{$SCOPEDENUMS OFF}
-{.$R+}
-unit sfsZipFS;
-
-interface
-
-uses
- SysUtils, Classes, Contnrs, sfs;
-
-
-type
- TSFSZipVolumeType = (sfszvNone, sfszvZIP, sfszvDFWAD);
-
- TSFSZipVolume = class(TSFSVolume)
- protected
- fType: TSFSZipVolumeType;
-
- procedure ZIPReadDirectory ();
- procedure DFWADReadDirectory ();
-
- procedure ReadDirectory (); override;
-
- public
- function OpenFileByIndex (const index: Integer): TStream; override;
- end;
-
- TSFSZipVolumeFactory = class(TSFSVolumeFactory)
- public
- function IsMyVolumePrefix (const prefix: AnsiString): Boolean; override;
- function Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume; override;
- procedure Recycle (vol: TSFSVolume); override;
- end;
-
-
-implementation
-
-uses
- xstreams, utils;
-
-
-type
- TSFSZipFileInfo = class(TSFSFileInfo)
- public
- fMethod: Byte; // 0: store; 8: deflate; 255: other
- fPackSz: Int64; // can be -1
- end;
-
- TZLocalFileHeader = packed record
- version: Byte;
- hostOS: Byte;
- flags: Word;
- method: Word;
- time: LongWord;
- crc: LongWord;
- packSz: LongWord;
- unpackSz: LongWord;
- fnameSz: Word;
- localExtraSz: Word;
- end;
-
-procedure readLFH (st: TStream; var hdr: TZLocalFileHeader);
-{.$IFDEF ENDIAN_LITTLE}
-begin
- hdr.version := readByte(st);
- hdr.hostOS := readByte(st);
- hdr.flags := readWord(st);
- hdr.method := readWord(st);
- hdr.time := readLongWord(st);
- hdr.crc := readLongWord(st);
- hdr.packSz := readLongWord(st);
- hdr.unpackSz := readLongWord(st);
- hdr.fnameSz := readWord(st);
- hdr.localExtraSz := readWord(st);
-end;
-
-
-function ZIPCheckMagic (st: TStream): Boolean;
-var
- sign: packed array [0..3] of Char;
-begin
- result := false;
- st.ReadBuffer(sign[0], 4);
- st.Seek(-4, soCurrent);
- if (sign <> 'PK'#3#4) and (sign <> 'PK'#5#6) then exit;
- result := true;
-end;
-
-
-function DFWADCheckMagic (st: TStream): Boolean;
-var
- sign: packed array [0..5] of Char;
-begin
- result := false;
- if st.Size < 10 then exit;
- st.ReadBuffer(sign[0], 6);
- {fcnt :=} readWord(st);
- st.Seek(-8, soCurrent);
- if (sign[0] <> 'D') and (sign[1] <> 'F') and (sign[2] <> 'W') and
- (sign[3] <> 'A') and (sign[4] <> 'D') and (sign[5] <> #$01) then exit;
- result := true;
-end;
-
-
-{ TSFSZipVolume }
-procedure TSFSZipVolume.ZIPReadDirectory ();
-var
- fi: TSFSZipFileInfo;
- fname: AnsiString = '';
- sign: packed array [0..3] of Char;
- lhdr: TZLocalFileHeader;
- ignoreFile: Boolean;
- efid, efsz: Word;
- izver: Byte;
- izcrc: LongWord;
- buf: PByte;
- bufsz, f: Integer;
- cdofs, hdrofs: Int64;
- cdsize: LongWord;
- fileOffsets: array of Int64 = nil;
- nameLen, extraLen, commentLen: Word;
- fileIdx: Integer = -1;
-begin
- // search for central dir pointer
- if fFileStream.size > 65636 then bufsz := 65636 else bufsz := fFileStream.size;
- fFileStream.position := fFileStream.size-bufsz;
- GetMem(buf, bufsz);
- cdofs := -1;
- cdsize := 0;
- try
- fFileStream.readBuffer(buf^, bufsz);
- for f := bufsz-16 downto 4 do
- begin
- if (buf[f-4] = ord('P')) and (buf[f-3] = ord('K')) and (buf[f-2] = 5) and (buf[f-1] = 6) then
- begin
- cdsize := LongWord(buf[f+8])+(LongWord(buf[f+9])<<8)+(LongWord(buf[f+10])<<16)+(LongWord(buf[f+11])<<24);
- cdofs := Int64(buf[f+12])+(Int64(buf[f+13])<<8)+(Int64(buf[f+14])<<16)+(Int64(buf[f+15])<<24);
- break;
- end;
- end;
- finally
- FreeMem(buf);
- end;
-
- if (cdofs >= 0) and (cdsize > 0) then
- begin
- // wow, we got central directory! process it
- fFileStream.position := cdofs;
- while cdsize >= 4 do
- begin
- Dec(cdsize, 4);
- fFileStream.readBuffer(sign, 4);
- if sign = 'PK'#1#2 then
- begin
- if cdsize < 42 then break;
- Dec(cdsize, 42);
- // skip uninteresting fields
- fFileStream.seek(2+2+2+2+2+2+4+4+4, soCurrent);
- nameLen := readWord(fFileStream);
- extraLen := readWord(fFileStream);
- commentLen := readWord(fFileStream);
- // skip uninteresting fields
- fFileStream.seek(2+2+4, soCurrent);
- hdrofs := readLongWord(fFileStream);
- // now skip name, extra and comment
- if cdsize < nameLen+extraLen+commentLen then break;
- Dec(cdsize, nameLen+extraLen+commentLen);
- fFileStream.seek(nameLen+extraLen+commentLen, soCurrent);
- SetLength(fileOffsets, length(fileOffsets)+1);
- fileOffsets[high(fileOffsets)] := hdrofs;
- //writeln('file #', high(fileOffsets), ' found at ', hdrofs);
- end
- else if sign = 'PK'#7#8 then
- begin
- if cdsize < 3*4 then break;
- Dec(cdsize, 3*4);
- fFileStream.seek(3*4, soCurrent);
- end
- else
- begin
- break;
- end;
- end;
- if length(fileOffsets) = 0 then exit; // no files at all
- fileIdx := 0;
- end
- else
- begin
- fFileStream.position := 0;
- end;
-
- // read local directory
- repeat
- if fileIdx >= 0 then
- begin
- if fileIdx > High(fileOffsets) then break;
- //writeln('reading file #', fileIdx, ' at ', fileOffsets[fileIdx]);
- fFileStream.position := fileOffsets[fileIdx];
- Inc(fileIdx);
- end;
-
- while true do
- begin
- fFileStream.ReadBuffer(sign[0], Length(sign));
- // skip data descriptor
- if sign = 'PK'#7#8 then
- begin
- fFileStream.seek(3*4, soCurrent);
- continue;
- end;
- break;
- end;
- if sign <> 'PK'#3#4 then break;
-
- ignoreFile := false;
-
- readLFH(fFileStream, lhdr);
-
- fi := TSFSZipFileInfo.Create(self);
- fi.fPackSz := 0;
- fi.fMethod := 0;
-
- SetLength(fname, lhdr.fnameSz);
- if lhdr.fnameSz > 0 then
- begin
- fFileStream.ReadBuffer(fname[1], length(fname));
- fi.fName := utf8to1251(fname);
- end;
-
- // here we should process extra field: it may contain utf8 filename
- while lhdr.localExtraSz >= 4 do
- begin
- efid := readWord(fFileStream);
- efsz := readWord(fFileStream);
- Dec(lhdr.localExtraSz, 4);
- if efsz > lhdr.localExtraSz then break;
- // Info-ZIP Unicode Path Extra Field?
- if (efid = $7075) and (efsz > 5) then
- begin
- fFileStream.ReadBuffer(izver, 1);
- Dec(efsz, 1);
- Dec(lhdr.localExtraSz, 1);
- if izver = 1 then
- begin
- //writeln('!!!!!!!!!!!!');
- Dec(lhdr.localExtraSz, efsz);
- fFileStream.ReadBuffer(izcrc, 4); // name crc, ignore it for now
- Dec(efsz, 4);
- SetLength(fname, efsz);
- if length(fname) > 0 then fFileStream.readBuffer(fname[1], length(fname));
- fi.fName := utf8to1251(fname);
- //writeln('++++++ [', fi.fName, ']');
- efsz := 0;
- end;
- end;
- // skip it
- if efsz > 0 then
- begin
- fFileStream.Seek(efsz, soCurrent);
- Dec(lhdr.localExtraSz, efsz);
- end;
- end;
- // skip the rest
- if lhdr.localExtraSz > 0 then fFileStream.Seek(lhdr.localExtraSz, soCurrent);
-
- if (lhdr.flags and 1) <> 0 then
- begin
- // encrypted file: skip it
- ignoreFile := true;
- end;
-
- if (lhdr.method <> 0) and (lhdr.method <> 8) then
- begin
- // not stored. not deflated. skip.
- ignoreFile := true;
- end;
-
- if (length(fi.fName) = 0) or (fname[length(fi.fName)] = '/') or (fname[length(fi.fName)] = '\') then
- begin
- ignoreFile := true;
- end
- else
- begin
- for f := 1 to length(fi.fName) do if fi.fName[f] = '\' then fi.fName[f] := '/';
- end;
-
- fi.fOfs := fFileStream.Position;
- fi.fSize := lhdr.unpackSz;
- fi.fPackSz := lhdr.packSz;
- fi.fMethod := lhdr.method;
- if fi.fMethod = 0 then fi.fPackSz := fi.fSize;
-
- // skip packed data
- if fileIdx < 0 then fFileStream.Seek(lhdr.packSz, soCurrent);
- if ignoreFile then fi.Free();
- until false;
- (*
- if (sign <> 'PK'#1#2) and (sign <> 'PK'#5#6) then
- begin
- {$IFDEF SFS_DEBUG_ZIPFS}
- WriteLn(ErrOutput, 'end: $', IntToHex(fFileStream.Position, 8));
- WriteLn(ErrOutput, 'sign: $', sign[0], sign[1], '#', ord(sign[2]), '#', ord(sign[3]));
- {$ENDIF}
- raise ESFSError.Create('invalid .ZIP archive (no central dir)');
- end;
- *)
-end;
-
-
-procedure TSFSZipVolume.DFWADReadDirectory ();
-// idiotic format
-var
- fcnt: Word;
- fi: TSFSZipFileInfo;
- f, c: Integer;
- fofs, fpksize: LongWord;
- curpath, fname: string;
- name: packed array [0..15] of Char;
-begin
- curpath := '';
- fFileStream.Seek(6, soCurrent); // skip signature
- fcnt := readWord(fFileStream);
- if fcnt = 0 then exit;
- // read files
- for f := 0 to fcnt-1 do
- begin
- fFileStream.ReadBuffer(name[0], 16);
- fofs := readLongWord(fFileStream);
- fpksize := readLongWord(fFileStream);
- c := 0;
- fname := '';
- while (c < 16) and (name[c] <> #0) do
- begin
- if name[c] = '\' then name[c] := '/'
- else if name[c] = '/' then name[c] := '_';
- fname := fname+name[c];
- Inc(c);
- end;
- // new directory?
- if (fofs = 0) and (fpksize = 0) then
- begin
- if length(fname) <> 0 then fname := fname+'/';
- curpath := fname;
- continue;
- end;
- if length(fname) = 0 then continue; // just in case
- //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
- // create file record
- fi := TSFSZipFileInfo.Create(self);
- fi.fOfs := fofs;
- fi.fSize := -1;
- fi.fPackSz := fpksize;
- fi.fName := fname;
- fi.fPath := curpath;
- fi.fMethod := 255;
- end;
-end;
-
-procedure TSFSZipVolume.ReadDirectory ();
-begin
- case fType of
- sfszvZIP: ZIPReadDirectory();
- sfszvDFWAD: DFWADReadDirectory();
- else raise ESFSError.Create('invalid archive');
- end;
-end;
-
-function TSFSZipVolume.OpenFileByIndex (const index: Integer): TStream;
-var
- rs: TStream;
-begin
- result := nil;
- rs := nil;
- if fFiles = nil then exit;
- if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
- try
- if TSFSZipFileInfo(fFiles[index]).fMethod = 0 then
- begin
- result := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fSize, false);
- end
- else
- begin
- rs := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fPackSz, false);
- result := TUnZStream.Create(rs, TSFSZipFileInfo(fFiles[index]).fSize, true, (TSFSZipFileInfo(fFiles[index]).fMethod <> 255));
- end;
- except
- FreeAndNil(rs);
- result := nil;
- exit;
- end;
-end;
-
-
-{ TSFSZipVolumeFactory }
-function TSFSZipVolumeFactory.IsMyVolumePrefix (const prefix: AnsiString): Boolean;
-begin
- result :=
- StrEquCI1251(prefix, 'zip') or
- StrEquCI1251(prefix, 'pk3') or
- StrEquCI1251(prefix, 'dfz') 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/dfzip.pas b/src/shared/dfzip.pas
--- a/src/shared/dfzip.pas
+++ /dev/null
@@ -1,390 +0,0 @@
-(* 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, version 3 of the License ONLY.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program. If not, see <http://www.gnu.org/licenses/>.
- *)
-{$INCLUDE ../shared/a_modes.inc}
-unit dfzip;
-
- (** Based on WadCvt tool **)
-
-interface
-
- uses SysUtils, Classes;
-
- type
- TFileInfo = class
- public
- name: AnsiString;
- pkofs: Int64; // offset of file header
- size: Int64;
- pksize: Int64;
- crc: LongWord;
- method: Word;
-
- constructor Create ();
- end;
-
- function ZipOne (ds: TStream; fname: AnsiString; st: TStream; dopack: Boolean=true): TFileInfo;
- procedure writeCentralDir (ds: TStream; files: array of TFileInfo);
-
-implementation
-
- uses utils, xstreams, crc, paszlib, e_log;
-
- const
- uni2wint: array [128..255] of Word = (
- $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
- $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
- $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
- $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
- $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
- $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
- $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
- $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
- );
-
-constructor TFileInfo.Create;
-begin
- name := '';
- pkofs := 0;
- size := 0;
- pksize := 0;
- crc := crc32(0, nil, 0);
- method := 0;
-end;
-
-function toUtf8 (const s: AnsiString): AnsiString;
-var
- uc: PUnicodeChar;
- xdc: PChar;
- pos, f: Integer;
-begin
- GetMem(uc, length(s)*8);
- GetMem(xdc, length(s)*8);
- try
- FillChar(uc^, length(s)*8, 0);
- FillChar(xdc^, length(s)*8, 0);
- pos := 0;
- for f := 1 to length(s) do
- begin
- if ord(s[f]) < 128 then
- uc[pos] := UnicodeChar(ord(s[f]))
- else
- uc[pos] := UnicodeChar(uni2wint[ord(s[f])]);
- Inc(pos);
- end;
- FillChar(xdc^, length(s)*8, 0);
- f := UnicodeToUtf8(xdc, length(s)*8, uc, pos);
- while (f > 0) and (xdc[f-1] = #0) do Dec(f);
- SetLength(result, f);
- Move(xdc^, result[1], f);
- finally
- FreeMem(xdc);
- FreeMem(uc);
- end;
-end;
-
-// returs crc
-function zpack (ds: TStream; ss: TStream; var aborted: Boolean): LongWord;
-const
- IBSize = 65536;
- OBSize = 65536;
-var
- zst: TZStream;
- ib, ob: PByte;
- err: Integer;
- rd: Integer;
- eof: Boolean;
- crc: LongWord;
- dstp, srcsize: Int64;
-begin
- result := 0;
- //aborted := true; exit;
- aborted := false;
- crc := crc32(0, nil, 0);
- GetMem(ib, IBSize);
- GetMem(ob, OBSize);
- ss.position := 0;
- dstp := ds.position;
- srcsize := ss.size;
- try
- zst.next_out := ob;
- zst.avail_out := OBSize;
- zst.next_in := ib;
- zst.avail_in := 0;
- err := deflateInit2(zst, Z_BEST_COMPRESSION, Z_DEFLATED, -15, 9, 0);
- if err <> Z_OK then raise Exception.Create(zerror(err));
- try
- eof := false;
- repeat
- if zst.avail_in = 0 then
- begin
- // read input buffer part
- rd := ss.read(ib^, IBSize);
- if rd < 0 then raise Exception.Create('reading error');
- //writeln(' read ', rd, ' bytes');
- eof := (rd = 0);
- if rd <> 0 then begin crc := crc32(crc, Pointer(ib), rd); result := crc; end;
- zst.next_in := ib;
- zst.avail_in := rd;
- end;
- // now process the whole input
- while zst.avail_in > 0 do
- begin
- err := deflate(zst, Z_NO_FLUSH);
- if err <> Z_OK then raise Exception.Create(zerror(err));
- if zst.avail_out < OBSize then
- begin
- //writeln(' written ', OBSize-zst.avail_out, ' bytes');
- if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then
- begin
- // this will be overwritten anyway
- aborted := true;
- exit;
- end;
- ds.writeBuffer(ob^, OBSize-zst.avail_out);
- zst.next_out := ob;
- zst.avail_out := OBSize;
- end;
- end;
- until eof;
- // do leftovers
- while true do
- begin
- zst.avail_in := 0;
- err := deflate(zst, Z_FINISH);
- if (err <> Z_OK) and (err <> Z_STREAM_END) then raise Exception.Create(zerror(err));
- if zst.avail_out < OBSize then
- begin
- //writeln(' .written ', OBSize-zst.avail_out, ' bytes');
- if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then
- begin
- // this will be overwritten anyway
- aborted := true;
- exit;
- end;
- ds.writeBuffer(ob^, OBSize-zst.avail_out);
- zst.next_out := ob;
- zst.avail_out := OBSize;
- end;
- if err <> Z_OK then break;
- end;
- // succesfully flushed?
- if (err <> Z_STREAM_END) then raise Exception.Create(zerror(err));
- finally
- deflateEnd(zst);
- end;
- finally
- FreeMem(ob);
- FreeMem(ib);
- end;
-end;
-
-// this will write "extra field length" and extra field itself
-{$IFDEF UTFEXTRA}
-const UtfFlags = 0;
-
-type
- TByteArray = array of Byte;
-
-function buildUtfExtra (fname: AnsiString): TByteArray;
-var
- crc: LongWord;
- fu: AnsiString;
- sz: Word;
-begin
- fu := toUtf8(fname);
- if fu = fname then begin result := nil; exit; end; // no need to write anything
- crc := crc32(0, @fname[1], length(fname));
- sz := 2+2+1+4+length(fu);
- SetLength(result, sz);
- result[0] := ord('u');
- result[1] := ord('p');
- Dec(sz, 4);
- result[2] := sz and $ff;
- result[3] := (sz shr 8) and $ff;
- result[4] := 1;
- result[5] := crc and $ff;
- result[6] := (crc shr 8) and $ff;
- result[7] := (crc shr 16) and $ff;
- result[8] := (crc shr 24) and $ff;
- Move(fu[1], result[9], length(fu));
-end;
-{$ELSE}
-const UtfFlags = (1 shl 10); // bit 11
-{$ENDIF}
-
-function ZipOne (ds: TStream; fname: AnsiString; st: TStream; dopack: Boolean=true): TFileInfo;
-var
- oldofs, nfoofs, pkdpos, rd: Int64;
- sign: packed array [0..3] of Char;
- buf: PChar;
- bufsz: Integer;
- aborted: Boolean = false;
-{$IFDEF UTFEXTRA}
- ef: TByteArray;
-{$ENDIF}
-begin
- result := TFileInfo.Create();
- result.pkofs := ds.position;
- result.size := st.size;
- if result.size > 0 then result.method := 8 else result.method := 0;
- if not dopack then
- begin
- result.method := 0;
- result.pksize := result.size;
- end;
-{$IFDEF UTFEXTRA}
- result.name := fname;
- ef := buildUtfExtra(result.name);
-{$ELSE}
- result.name := toUtf8(fname);
-{$ENDIF}
- // write local header
- sign := 'PK'#3#4;
- ds.writeBuffer(sign, 4);
- writeInt(ds, Word($0A10)); // version to extract
- writeInt(ds, Word(UtfFlags)); // flags
- writeInt(ds, Word(result.method)); // compression method
- writeInt(ds, Word(0)); // file time
- writeInt(ds, Word(0)); // file date
- nfoofs := ds.position;
- writeInt(ds, LongWord(result.crc)); // crc32
- writeInt(ds, LongWord(result.pksize)); // packed size
- writeInt(ds, LongWord(result.size)); // unpacked size
- writeInt(ds, Word(length(fname))); // name length
-{$IFDEF UTFEXTRA}
- writeInt(ds, Word(length(ef))); // extra field length
-{$ELSE}
- writeInt(ds, Word(0)); // extra field length
-{$ENDIF}
- ds.writeBuffer(fname[1], length(fname));
-{$IFDEF UTFEXTRA}
- if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef));
-{$ENDIF}
- if dopack then
- begin
- // now write packed data
- if result.size > 0 then
- begin
- pkdpos := ds.position;
- st.position := 0;
- result.crc := zpack(ds, st, aborted);
- result.pksize := ds.position-pkdpos;
- if {result.pksize >= result.size} aborted then
- begin
- // there's no sence to pack this file, so just store it
- st.position := 0;
- ds.position := result.pkofs;
- result.Free();
- // store it
- result := ZipOne(ds, fname, st, false);
- exit;
- end
- else
- begin
- // fix header
- oldofs := ds.position;
- ds.position := nfoofs;
- writeInt(ds, LongWord(result.crc)); // crc32
- writeInt(ds, LongWord(result.pksize)); // crc32
- ds.position := oldofs;
- end;
- end;
- end
- else
- begin
- bufsz := 1024*1024;
- GetMem(buf, bufsz);
- try
- st.position := 0;
- result.crc := crc32(0, nil, 0);
- result.pksize := 0;
- while result.pksize < result.size do
- begin
- rd := result.size-result.pksize;
- if rd > bufsz then rd := bufsz;
- st.readBuffer(buf^, rd);
- ds.writeBuffer(buf^, rd);
- Inc(result.pksize, rd);
- result.crc := crc32(result.crc, buf, rd);
- end;
- finally
- FreeMem(buf);
- end;
- // fix header
- oldofs := ds.position;
- ds.position := nfoofs;
- writeInt(ds, LongWord(result.crc)); // crc32
- ds.position := oldofs;
- //write('(S) ');
- end;
-end;
-
-
-procedure writeCentralDir (ds: TStream; files: array of TFileInfo);
-var
- cdofs, cdend: Int64;
- sign: packed array [0..3] of Char;
- f: Integer;
-{$IFDEF UTFEXTRA}
- ef: TByteArray;
-{$ENDIF}
-begin
- cdofs := ds.position;
- for f := 0 to high(files) do
- begin
-{$IFDEF UTFEXTRA}
- ef := buildUtfExtra(files[f].name);
-{$ENDIF}
- sign := 'PK'#1#2;
- ds.writeBuffer(sign, 4);
- writeInt(ds, Word($0A10)); // version made by
- writeInt(ds, Word($0010)); // version to extract
- writeInt(ds, Word(UtfFlags)); // flags
- writeInt(ds, Word(files[f].method)); // compression method
- writeInt(ds, Word(0)); // file time
- writeInt(ds, Word(0)); // file date
- writeInt(ds, LongWord(files[f].crc));
- writeInt(ds, LongWord(files[f].pksize));
- writeInt(ds, LongWord(files[f].size));
- writeInt(ds, Word(length(files[f].name))); // name length
-{$IFDEF UTFEXTRA}
- writeInt(ds, Word(length(ef))); // extra field length
-{$ELSE}
- writeInt(ds, Word(0)); // extra field length
-{$ENDIF}
- writeInt(ds, Word(0)); // comment length
- writeInt(ds, Word(0)); // disk start
- writeInt(ds, Word(0)); // internal attributes
- writeInt(ds, LongWord(0)); // external attributes
- writeInt(ds, LongWord(files[f].pkofs)); // header offset
- ds.writeBuffer(files[f].name[1], length(files[f].name));
-{$IFDEF UTFEXTRA}
- if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef));
-{$ENDIF}
- end;
- cdend := ds.position;
- // write end of central dir
- sign := 'PK'#5#6;
- ds.writeBuffer(sign, 4);
- writeInt(ds, Word(0)); // disk number
- writeInt(ds, Word(0)); // disk with central dir
- writeInt(ds, Word(length(files))); // number of files on this dist
- writeInt(ds, Word(length(files))); // number of files total
- writeInt(ds, LongWord(cdend-cdofs)); // size of central directory
- writeInt(ds, LongWord(cdofs)); // central directory offset
- writeInt(ds, Word(0)); // archive comment length
-end;
-
-end.
diff --git a/src/shared/xstreams.pas b/src/shared/xstreams.pas
--- a/src/shared/xstreams.pas
+++ /dev/null
@@ -1,566 +0,0 @@
-(* 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, version 3 of the License ONLY.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program. If not, see <http://www.gnu.org/licenses/>.
- *)
-// special stream classes
-{$INCLUDE a_modes.inc}
-{.$R+}
-unit xstreams;
-
-interface
-
-uses
- SysUtils, Classes,
- zbase{z_stream};
-
-
-type
- XStreamError = class(Exception);
-
- // read-only ïîòîê äëÿ èçâëå÷åíèÿ èç èñõîäíîãî òîëüêî êóñî÷êà
- TSFSPartialStream = class(TStream)
- protected
- fSource: TStream; // èñõîäíûé ïîòîê
- fKillSource: Boolean; // óáèâàòü èñõîäíèê ïðè ïîìèðàíèè?
- fLastReadPos: Int64; // ïîñëåäíèé Read() îñòàíîâèëñÿ çäåñü (îòíîñ. fStartPos)
- fCurrentPos: Int64; // ïîñëåäíèé Seek() îñòàíîâèëñÿ çäåñü (îòíîñ. fStartPos)
- fStartPos: Int64; // íà÷àëî êóñî÷êà
- fSize: Int64; // äëèíà êóñî÷êà
- fPreBuf: packed array of Byte; // ýòîò áóôåð áóäåò ïåðåä ôàéëîì
-
- procedure CheckPos ();
-
- public
- // aSrc: ïîòîê-èñõîäíèê.
- // aPos: íà÷àëüíàÿ ïîçèöèÿ â ïîòîêå. -1 -- ñ òåêóùåé.
- // åñëè aPos < òåêóùåé ïîçèöèè, òî èñõîäíûé ïîòîê äîëæåí
- // íîðìàëüíî ïîääåðæèâàòü Seek()!
- // aSize: êîëè÷åñòâî áàéòèêîâ, êîòîðîå ìîæíî ïðî÷åñòü èç ïîòîêà.
- // åñëè ìåíüøå íóëÿ -- òî äî êîíöà.
- // aKillSrc: óáèâàòü ëè èñõîäíûé ïîòîê, êîãäà ñàìè óìèðàåì?
- // òàêæå ìîæåò ïðèøïàíäîðèòü ê íà÷àëó ôàéëà áóôåð. bufSz áóäåò äîáàâëåíî ê
- // äëèíå ôàéëà.
- constructor Create (aSrc: TStream; aPos, aSize: Int64; aKillSrc: Boolean; preBuf: Pointer=nil; bufSz: Integer=0);
- destructor Destroy (); override;
-
- // íîðìàëèçóåò count è ÷èòàåò.
- function Read (var buffer; count: LongInt): LongInt; override;
- // Write() ïðîñòî ãðîìêî ïàäàåò.
- function Write (const buffer; count: LongInt): LongInt; override;
- // Seek() ðåàëèçîâàíî, ÷òîáû ìîãëà ðàáîòàòü ïðîïåðòÿ Size.
- // âîîáùå-òî ìîæíî ïåðåêðûòü ìåòîä GetSize(), íî âäðóã êàêîé
- // áîëüíîé íà ãîëîâó êîäåð áóäåò ïîëó÷àòü ðàçìåð ïðè ïîìîùè
- // Seek()'à?
- function Seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
- end;
-
- // this stream can kill both `proxied` and `guarded` streams on closing
- TSFSGuardStream = class(TStream)
- protected
- fSource: TStream; // èñõîäíûé ïîòîê
- fGuardedStream: TStream; // ïîòîê, êîòîðûé çàâàëèì ïðè ïîìèðàíèè
- fKillSource: Boolean; // óáèâàòü èñõîäíèê ïðè ïîìèðàíèè?
- fKillGuarded: Boolean; // óáèâàòü îõðàíÿåìûé ïðè ïîìèðàíèè?
- fGuardedFirst: Boolean; // ïðè ñìåðòè ïåðâûì ïðèøèáàåì îõðàíÿåìîãî?
-
- public
- // aSrc: ïîòîê-èñõîäíèê (íà êîòîðûé çàìàïåíû îïåðàöèè ÷òåíèÿ/çàïèñè).
- // aKillSrc: óáèâàòü ëè èñõîäíûé ïîòîê, êîãäà ñàìè óìèðàåì?
- // aKillGuarded: óáèâàòü ëè îõðàíÿåìûé ïîòîê, êîãäà ñàìè óìèðàåì?
- // aGuardedFirst: true: ïðè ñìåðòè ïåðâûì ïðèøèáàåì îõðàíÿåìîãî.
- constructor Create (aSrc, aGuarded: TStream; aKillSrc, aKillGuarded: Boolean; aGuardedFirst: Boolean=true);
- destructor Destroy (); override;
-
- // íèæåñëåäóþùåå çàìàïëåíî íà fSource
- function Read (var buffer; count: LongInt): LongInt; override;
- function Write (const buffer; count: LongInt): LongInt; override;
- function Seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
- end;
-
- TSFSMemoryStreamRO = class(TCustomMemoryStream)
- private
- fFreeMem: Boolean;
- fMem: Pointer;
-
- public
- constructor Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
- destructor Destroy (); override;
-
- function Write (const buffer; count: LongInt): LongInt; override;
- end;
-
- TUnZStream = class(TStream)
- protected
- fSrcSt: TStream;
- fZlibSt: z_stream;
- fBuffer: PByte;
- fPos: Int64;
- fSkipHeader: Boolean;
- fSize: Int64; // can be -1
- fSrcStPos: Int64;
- fSkipToPos: Int64; // >0: skip to this position
- fKillSrc: Boolean;
-
- procedure reset ();
- function readBuf (var buffer; count: LongInt): LongInt;
- procedure fixPos ();
- procedure determineSize ();
-
- public
- // `aSize` can be -1 if stream size is unknown
- constructor create (asrc: TStream; aSize: Int64; aKillSrc: Boolean; aSkipHeader: boolean=false);
- destructor destroy (); override;
- function read (var buffer; count: LongInt): LongInt; override;
- function write (const buffer; count: LongInt): LongInt; override;
- function seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
- end;
-
- // fixed memory chunk
- TSFSMemoryChunkStream = class(TStream)
- private
- fFreeMem: Boolean;
- fMemBuf: PByte;
- fMemSize: Integer;
- fCurPos: Integer;
-
- public
- // if `pMem` is `nil`, stream will allocate it
- constructor Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
- destructor Destroy (); override;
-
- procedure setup (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
-
- function Seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
- function Read (var buffer; count: LongInt): LongInt; override;
- function Write (const buffer; count: LongInt): LongInt; override;
-
- property chunkSize: Integer read fMemSize;
- property chunkData: PByte read fMemBuf;
- end;
-
-
-implementation
-
-uses
- zinflate;
-
-
-{ TSFSPartialStream }
-constructor TSFSPartialStream.Create (aSrc: TStream; aPos, aSize: Int64; aKillSrc: Boolean; preBuf: Pointer=nil; bufSz: Integer=0);
-begin
- inherited Create();
- ASSERT(aSrc <> nil);
- if aPos < 0 then aPos := aSrc.Position;
- if aSize < 0 then aSize := 0;
- fSource := aSrc;
- fKillSource := aKillSrc;
- fLastReadPos := 0;
- fCurrentPos := 0;
- fStartPos := aPos;
- fSize := aSize;
- if bufSz > 0 then
- begin
- SetLength(fPreBuf, bufSz);
- Move(preBuf^, fPreBuf[0], bufSz);
- Inc(fSize, bufSz);
- end
- else
- begin
- fPreBuf := nil;
- end;
-end;
-
-destructor TSFSPartialStream.Destroy ();
-begin
- if fKillSource then FreeAndNil(fSource);
- inherited Destroy();
-end;
-
-procedure TSFSPartialStream.CheckPos ();
-begin
- {
- if fSource.Position <> fStartPos+fCurrentPos-Length(fPreBuf) then
- begin
- fSource.Position := fStartPos+fCurrentPos-Length(fPreBuf);
- end;
- }
- if fCurrentPos >= length(fPreBuf) then
- begin
- //writeln('seeking at ', fCurrentPos, ' (real: ', fStartPos+fCurrentPos-Length(fPreBuf), ')');
- fSource.Position := fStartPos+fCurrentPos-Length(fPreBuf);
- end;
- fLastReadPos := fCurrentPos;
-end;
-
-function TSFSPartialStream.Write (const buffer; count: LongInt): LongInt;
-begin
- result := 0;
- raise XStreamError.Create('can''t write to read-only stream');
- // à íå õîäè, íåõîðîøèé, â íàø ñàäèê ãóëÿòü!
-end;
-
-function TSFSPartialStream.Read (var buffer; count: LongInt): LongInt;
-var
- left: Int64;
- pc: Pointer;
- rd: LongInt;
-begin
- if count < 0 then raise XStreamError.Create('invalid Read() call'); // ñêàçî÷íûé äîëáî¸á...
- if count = 0 then begin result := 0; exit; end;
- pc := @buffer;
- result := 0;
- if (Length(fPreBuf) > 0) and (fCurrentPos < Length(fPreBuf)) then
- begin
- fLastReadPos := fCurrentPos;
- left := Length(fPreBuf)-fCurrentPos;
- if left > count then left := count;
- if left > 0 then
- begin
- Move(fPreBuf[fCurrentPos], pc^, left);
- Inc(PChar(pc), left);
- Inc(fCurrentPos, left);
- fLastReadPos := fCurrentPos;
- Dec(count, left);
- result := left;
- if count = 0 then exit;
- end;
- end;
- CheckPos();
- left := fSize-fCurrentPos;
- if left < count then count := left; // è òàê ñëó÷àåòñÿ...
- if count > 0 then
- begin
- rd := fSource.Read(pc^, count);
- Inc(result, rd);
- Inc(fCurrentPos, rd);
- fLastReadPos := fCurrentPos;
- end
- else
- begin
- result := 0;
- end;
-end;
-
-function TSFSPartialStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
-begin
- case origin of
- soBeginning: result := offset;
- soCurrent: result := offset+fCurrentPos;
- soEnd: result := fSize+offset;
- else raise XStreamError.Create('invalid Seek() call');
- // äðóãèõ íå áûâàåò. à ó êîãî áûâàåò, òîìó ÿ íå äîêòîð.
- end;
- if result < 0 then result := 0
- else if result > fSize then result := fSize;
- fCurrentPos := result;
-end;
-
-
-{ TSFSGuardStream }
-constructor TSFSGuardStream.Create (aSrc, aGuarded: TStream; aKillSrc, aKillGuarded: Boolean; aGuardedFirst: Boolean=true);
-begin
- inherited Create();
- fSource := aSrc; fGuardedStream := aGuarded;
- fKillSource := aKillSrc; fKillGuarded := aKillGuarded;
- fGuardedFirst := aGuardedFirst;
-end;
-
-destructor TSFSGuardStream.Destroy ();
-begin
- if fKillGuarded and fGuardedFirst then FreeAndNil(fGuardedStream);
- if fKillSource then FreeAndNil(fSource);
- if fKillGuarded and not fGuardedFirst then FreeAndNil(fGuardedStream);
- inherited Destroy();
-end;
-
-function TSFSGuardStream.Read (var buffer; count: LongInt): LongInt;
-begin
- result := fSource.Read(buffer, count);
-end;
-
-function TSFSGuardStream.Write (const buffer; count: LongInt): LongInt;
-begin
- result := fSource.Write(buffer, count);
-end;
-
-function TSFSGuardStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
-begin
- result := fSource.Seek(offset, origin);
-end;
-
-
-{ TSFSMemoryStreamRO }
-constructor TSFSMemoryStreamRO.Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
-begin
- fFreeMem := aFreeMem;
- fMem := pMem;
- inherited Create();
- SetPointer(pMem, pSize);
- Position := 0;
-end;
-
-destructor TSFSMemoryStreamRO.Destroy ();
-begin
- if fFreeMem and (fMem <> nil) then FreeMem(fMem);
-end;
-
-function TSFSMemoryStreamRO.Write (const buffer; count: LongInt): LongInt;
-begin
- result := 0;
- raise XStreamError.Create('can''t write to read-only stream');
- // ñîâñåì ñáðåíäèë...
-end;
-
-
-// ////////////////////////////////////////////////////////////////////////// //
-{ TUnZStream }
-const ZBufSize = 32768; // size of the buffer used for temporarily storing data from the child stream
-
-
-constructor TUnZStream.create (asrc: TStream; aSize: Int64; aKillSrc: Boolean; aSkipHeader: boolean=false);
-var
- err: Integer;
-begin
- fKillSrc := aKillSrc;
- fPos := 0;
- fSkipToPos := -1;
- fSrcSt := asrc;
- fSize := aSize;
- GetMem(fBuffer, ZBufSize);
- fSkipHeader := aSkipHeader;
- fSrcStPos := fSrcSt.position;
- FillChar(fZlibSt, sizeof(fZlibSt), 0);
- if fSkipHeader then err := inflateInit2(fZlibSt, -MAX_WBITS) else err := inflateInit(fZlibSt);
- if err <> Z_OK then raise XStreamError.Create(zerror(err));
-end;
-
-
-destructor TUnZStream.destroy ();
-begin
- inflateEnd(fZlibSt);
- FreeMem(fBuffer);
- if fKillSrc then fSrcSt.Free();
- inherited Destroy();
-end;
-
-
-function TUnZStream.readBuf (var buffer; count: LongInt): LongInt;
-var
- err: Integer;
- sz: LongInt;
-begin
- result := 0;
- if (fSize >= 0) and (fPos >= fSize) then exit;
- if count > 0 then
- begin
- fZlibSt.next_out := @buffer;
- fZlibSt.avail_out := count;
- sz := fZlibSt.avail_out;
- while fZlibSt.avail_out > 0 do
- begin
- if fZlibSt.avail_in = 0 then
- begin
- // refill the buffer
- fZlibSt.next_in := fBuffer;
- fZlibSt.avail_in := fSrcSt.read(Fbuffer^, ZBufSize);
- end;
- err := inflate(fZlibSt, Z_NO_FLUSH);
- if (err <> Z_OK) and (err <> Z_STREAM_END) then raise XStreamError.Create(zerror(err));
- Inc(result, sz-fZlibSt.avail_out);
- Inc(fPos, sz-fZlibSt.avail_out);
- sz := fZlibSt.avail_out;
- if err = Z_STREAM_END then begin fSize := fPos; break; end;
- end;
- end;
-end;
-
-
-procedure TUnZStream.fixPos ();
-var
- buf: array [0..4095] of Byte;
- rd, rr: LongInt;
-begin
- if fSkipToPos < 0 then exit;
- //writeln('fixing pos: fPos=', fPos, '; fSkipToPos=', fSkipToPos);
- if fSkipToPos < fPos then reset();
- while fPos < fSkipToPos do
- begin
- if fSkipToPos-fPos > 4096 then rd := 4096 else rd := LongInt(fSkipToPos-fPos);
- //writeln(' reading ', rd, ' bytes...');
- rr := readBuf(buf, rd);
- //writeln(' got ', rr, ' bytes; fPos=', fPos, '; fSkipToPos=', fSkipToPos);
- if rr <= 0 then raise XStreamError.Create('seek error');
- end;
- //writeln(' pos: fPos=', fPos, '; fSkipToPos=', fSkipToPos);
- fSkipToPos := -1;
-end;
-
-
-procedure TUnZStream.determineSize ();
-var
- buf: array [0..4095] of Byte;
- rd: LongInt;
- opos: Int64;
-begin
- if fSize >= 0 then exit;
- opos := fPos;
- try
- //writeln('determining unzstream size...');
- while true do
- begin
- rd := readBuf(buf, 4096);
- if rd = 0 then break;
- end;
- fSize := fPos;
- //writeln(' unzstream size is ', fSize);
- finally
- if fSkipToPos < 0 then fSkipToPos := opos;
- end;
-end;
-
-
-function TUnZStream.read (var buffer; count: LongInt): LongInt;
-begin
- if fSkipToPos >= 0 then fixPos();
- result := readBuf(buffer, count);
-end;
-
-
-function TUnZStream.write (const buffer; count: LongInt): LongInt;
-begin
- result := 0;
- raise XStreamError.Create('can''t write to read-only stream');
-end;
-
-
-procedure TUnZStream.reset ();
-var
- err: Integer;
-begin
- //writeln('doing RESET');
- fSrcSt.position := fSrcStPos;
- fPos := 0;
- inflateEnd(fZlibSt);
- FillChar(fZlibSt, sizeof(fZlibSt), 0);
- if fSkipHeader then err := inflateInit2(fZlibSt, -MAX_WBITS) else err := inflateInit(fZlibSt);
- if err <> Z_OK then raise XStreamError.Create(zerror(err));
-end;
-
-
-function TUnZStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
-var
- cpos: Int64;
-begin
- cpos := fPos;
- if fSkipToPos >= 0 then cpos := fSkipToPos;
- case origin of
- soBeginning: result := offset;
- soCurrent: result := offset+cpos;
- soEnd: begin determineSize(); result := fSize+offset; end;
- else raise XStreamError.Create('invalid Seek() call');
- // äðóãèõ íå áûâàåò. à ó êîãî áûâàåò, òîìó ÿ íå äîêòîð.
- end;
- if result < 0 then result := 0;
- fSkipToPos := result;
- //writeln('seek: ofs=', offset, '; origin=', origin, '; result=', result);
-end;
-
-
-// ////////////////////////////////////////////////////////////////////////// //
-constructor TSFSMemoryChunkStream.Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
-begin
- fMemBuf := nil;
- fFreeMem := false;
- fMemSize := 0;
- fCurPos := 0;
- setup(pMem, pSize, aFreeMem);
-end;
-
-
-procedure TSFSMemoryChunkStream.setup (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
-begin
- if fFreeMem then FreeMem(fMemBuf);
- fMemBuf := nil;
- fFreeMem := false;
- fMemSize := 0;
- fCurPos := 0;
- if (pSize < 0) then raise XStreamError.Create('invalid chunk size');
- if (pMem = nil) then
- begin
- if (pSize > 0) then
- begin
- GetMem(pMem, pSize);
- if (pMem = nil) then raise XStreamError.Create('out of memory for chunk');
- aFreeMem := true;
- end
- else
- begin
- aFreeMem := false;
- end;
- end;
- fFreeMem := aFreeMem;
- fMemBuf := PByte(pMem);
- fMemSize := pSize;
-end;
-
-
-destructor TSFSMemoryChunkStream.Destroy ();
-begin
- if fFreeMem then FreeMem(fMemBuf);
- inherited;
-end;
-
-
-function TSFSMemoryChunkStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
-begin
- case origin of
- soBeginning: result := offset;
- soCurrent: result := offset+fCurPos;
- soEnd: result := fMemSize+offset;
- else raise XStreamError.Create('invalid Seek() call');
- end;
- if (result < 0) then raise XStreamError.Create('invalid Seek() call');
- if (result > fMemSize) then result := fMemSize;
- fCurPos := result;
-end;
-
-
-function TSFSMemoryChunkStream.Read (var buffer; count: LongInt): LongInt;
-var
- left: Integer;
-begin
- if (count < 0) then raise XStreamError.Create('negative read');
- left := fMemSize-fCurPos;
- if (left < 0) then raise XStreamError.Create('internal error in TSFSMemoryChunkStream (read)');
- if (count > left) then count := left;
- if (count > 0) then Move((fMemBuf+fCurPos)^, buffer, count);
- Inc(fCurPos, count);
- result := count;
-end;
-
-
-function TSFSMemoryChunkStream.Write (const buffer; count: LongInt): LongInt;
-var
- left: Integer;
-begin
- if (count < 0) then raise XStreamError.Create('negative write');
- left := fMemSize-fCurPos;
- if (left < 0) then raise XStreamError.Create('internal error in TSFSMemoryChunkStream (write)');
- if (count > left) then count := left;
- if (count > 0) then Move(buffer, (fMemBuf+fCurPos)^, count);
- Inc(fCurPos, count);
- result := count;
-end;
-
-
-end.