/
glscene
/
LZScene
GigaCode
beta
ОбзорЦентр заботыВойти

LZScene

Форк
0
Ветки: 1Коммиты: 13Теги: 0
LZScene
/Source
/
GLFileZLIB.pas 
345 строк · 9.6 Кб
1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   History :  
6
       22/08/10 - DaStr - Removed warnings, converted comments from Unicode to ASCII  
7
       04/06/10 - Yar - Added to GLScene
8
                           (Created by Rustam Asmandiarov aka Predator)
9
   
10
}
11


12
unit GLFileZLIB;
13


14
{$I GLScene.inc}
15


16
interface
17


18
uses
19
  Classes, 
20
  SysUtils, 
21
  GLSArchiveManager, 
22
  GLSZLibEx;
23


24
const
25
   SIGN = 'ZLIB'; //Signature for compressed zlib.
26


27
Type
28
   TZLibHeader = record
29
      Signature: array[0..3] of AnsiChar;
30
      DirOffset: integer;
31
      DirLength: integer;
32
   end;
33


34
   TFileSection = record
35
      FileName: array[0..119] of AnsiChar;
36
      FilePos: integer;
37
      FileLength: integer;
38
      CbrMode: TCompressionLevel;
39
   end;
40


41
  { TZLibArchive }
42


43
  TZLibArchive=class(TGLBaseArchive)
44
    private
45
      FHeader: TZLibHeader;
46
      FStream: TFileStream;
47


48
      function GetContentCount: integer;
49
      procedure MakeContentList;
50
    public
51
      property ContentCount: integer Read GetContentCount;
52
      destructor Destroy; override;
53


54
      procedure LoadFromFile(const FileName: string); override;
55


56
      procedure Clear; override;
57
      function ContentExists(ContentName: string): boolean;override;
58


59
      function GetContent(aStream: TStream; index: integer): TStream; override;
60
      function GetContent(index: integer): TStream; override;
61
      function GetContent(ContentName: string): TStream; override;
62


63
      function GetContentSize(index: integer): integer; override;
64
      function GetContentSize(ContentName: string): integer; override;
65


66
      procedure AddFromStream(ContentName, Path: string; FS: TStream);override;
67
      procedure AddFromFile(FileName, Path: string); override;
68


69
      procedure RemoveContent(index: integer); overload; override;
70
      procedure RemoveContent(ContentName: string); overload;override;
71


72
      procedure Extract(index: integer; NewName: string); override;
73
      procedure Extract(ContentName, NewName: string); override;
74
  end;
75


76
implementation
77


78
var
79
   Dir: TFileSection;
80


81
{ TZLibArchive }
82


83


84
function TZLibArchive.GetContentCount: integer;
85
begin
86
   Result := FHeader.DirLength div SizeOf(TFileSection);
87
end;
88


89
procedure TZLibArchive.MakeContentList;
90
var
91
   I: integer;
92
begin
93
   FStream.Seek(FHeader.DirOffset, soFromBeginning);
94
   FContentList.Clear;
95
   for i := 0 to ContentCount - 1 do
96
   begin
97
      FStream.ReadBuffer(Dir, SizeOf(TFileSection));
98
      FContentList.Add(string(Dir.FileName));
99
   end;
100
end;
101


102
destructor TZLibArchive.Destroy;
103
begin
104
  inherited Destroy;
105
end;
106


107
procedure TZLibArchive.LoadFromFile(const FileName: string);
108
begin
109
   FFileName := FileName;
110
    FStream := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite);
111
   if FStream.Size = 0 then
112
   begin
113
    FHeader.Signature := SIGN;
114
    FHeader.DirOffset := SizeOf(TZLibHeader);
115
    FHeader.DirLength := 0;
116


117
    FStream.WriteBuffer(FHeader, SizeOf(TZlibHeader));
118
    FStream.Position := 0;
119
   end;
120


121
   FStream.ReadBuffer(FHeader, SizeOf(TZlibHeader));
122
   if FHeader.Signature <> SIGN    then
123
   begin
124
      FStream.Free;
125
      raise Exception.Create(FileName+' - This is not ZLIB file');
126
      Exit;
127
   end;
128
   if ContentCount <> 0 then
129
      MakeContentList;
130
end;
131


132
procedure TZLibArchive.Clear;
133
begin
134
   FContentList.Clear;
135
   If FStream <> nil then FStream.Free;
136
end;
137


138
function TZLibArchive.ContentExists(ContentName: string): boolean;
139
begin
140
   Result := (FContentList.IndexOf(ContentName) > -1);
141
end;
142


143
function TZLibArchive.GetContent(aStream: TStream; index: integer): TStream;
144
var
145
  tempStream: TMemoryStream;
146
  decompr : TZDecompressionStream;
147
begin
148
      Result := nil;
149
      If FStream = nil then exit;
150
      Result := aStream;
151


152
      //���� ����
153
      FStream.Seek(FHeader.DirOffset + SizeOf(TFileSection) * index, soFromBeginning);
154
      FStream.Read(Dir, SizeOf(TFileSection));
155
      FStream.Seek(Dir.FilePos, soFromBeginning);
156


157
      //�������� ���� �� ������ ������ �� ��������� �����
158
      tempStream := TMemoryStream.Create;
159
      tempStream.CopyFrom(FStream, Dir.FileLength);
160
      tempStream.Position := 0;
161


162
      //������������
163
       decompr := TZDecompressionStream.Create(tempStream);
164
       try
165
         //�������� ���������
166
         Result.CopyFrom(decompr, 0);
167
       finally
168
        decompr.Free;
169
         tempStream.Free;
170
       end;
171
      Result.Position := 0;
172
end;
173


174
function TZLibArchive.GetContent(index: integer): TStream;
175
begin
176
   Result:=GetContent(TMemoryStream.Create,index);
177
end;
178


179
function TZLibArchive.GetContent(ContentName: string): TStream;
180
begin
181
   Result := nil;
182
   if ContentExists(ContentName) then
183
      Result := GetContent(FContentList.IndexOf(ContentName));
184
end;
185


186
function TZLibArchive.GetContentSize(index: integer): integer;
187
begin
188
   Result := -1;
189
   If FStream = nil then exit;
190
   FStream.Seek(FHeader.DirOffset + SizeOf(TFileSection) * index, soFromBeginning);
191
   FStream.Read(Dir, SizeOf(Dir));
192
   Result := Dir.FileLength;
193
end;
194


195
function TZLibArchive.GetContentSize(ContentName: string): integer;
196
begin
197
   Result := -1;
198
   if ContentExists(ContentName) then
199
      Result := GetContentSize(FContentList.IndexOf(ContentName));
200
end;
201


202
procedure TZLibArchive.AddFromStream(ContentName, Path: string; FS: TStream);
203
var
204
   Temp, compressed: TMemoryStream;
205
   FCompressor: TZCompressionStream;
206
begin
207
   //���������� �����
208
   If (FStream = nil) or ContentExists(ContentName) then exit;
209


210
   FStream.Position := FHeader.DirOffset;
211
   //???
212
   if FHeader.DirLength > 0 then
213
   begin
214
      Temp := TMemoryStream.Create;
215
      Temp.CopyFrom(FStream, FHeader.DirLength);
216
      Temp.Position    := 0;
217
      FStream.Position := FHeader.DirOffset;
218
   end
219
   else
220
     Temp := nil;
221
   Dir.FilePos    := FHeader.DirOffset;
222
   Dir.CbrMode := compressionLevel;
223


224
   //������� ����� ��� ������������ � ����
225
   compressed := TMemoryStream.Create;
226


227
   //������������� ������ � ����
228
   FCompressor := TZCompressionStream.Create(compressed,TZCompressionLevel(compressionLevel));
229
   FCompressor.CopyFrom(FS,   FS.Size);
230
   FCompressor.Free;
231


232
   //�������� ���������
233
   FStream.CopyFrom(compressed, 0);
234
   //����������  ������ �����
235
   Dir.FileLength := compressed.Size;
236
   Compressed .Free;
237


238
   //???
239
   FHeader.DirOffset := FStream.Position;
240
   if FHeader.DirLength > 0 then
241
   begin
242
      FStream.CopyFrom(Temp, 0);
243
      Temp.Free;
244
   end;
245
   //���������� ��� ����� � ���������
246
   StrPCopy(Dir.FileName, AnsiString(Path + ExtractFileName(ContentName)));
247
   //���������� ������ � �����
248
   FStream.WriteBuffer(Dir, SizeOf(TFileSection));
249
   //���������� ��������� � �����
250
   FHeader.DirLength := FHeader.DirLength + SizeOf(TFileSection);
251
   FStream.Position  := 0;
252
   FStream.WriteBuffer(FHeader, SizeOf(TZLibHeader));
253
   FContentList.Add(string(Dir.FileName));
254
end;
255


256
procedure TZLibArchive.AddFromFile(FileName, Path: string);
257
var
258
   FS: TFileStream;
259
begin
260
   if not SysUtils.FileExists(FileName) then
261
      exit;
262
   FS := TFileStream.Create(FileName, fmOpenRead);
263
   try
264
      AddFromStream(FileName, Path, FS);
265
   finally
266
      FS.Free;
267
   end;
268
end;
269


270
procedure TZLibArchive.RemoveContent(index: integer);
271
var
272
   Temp: TMemoryStream;
273
   i:    integer;
274
   f:    TFileSection;
275
begin
276


277
   Temp := TMemoryStream.Create;
278
   FStream.Seek(FHeader.DirOffset + SizeOf(TFileSection) * index, soFromBeginning);
279
   FStream.ReadBuffer(Dir, SizeOf(TFileSection));
280
   FStream.Seek(Dir.FilePos + Dir.FileLength, soFromBeginning);
281


282
   Temp.CopyFrom(FStream, FStream.Size - FStream.Position);
283
   FStream.Position := Dir.FilePos;
284
   FStream.CopyFrom(Temp, 0);
285
   FHeader.DirOffset := FHeader.DirOffset - dir.FileLength;
286
   Temp.Clear;
287
   for i := 0 to ContentCount - 1 do
288
      if i > index then
289
      begin
290
         FStream.Seek(FHeader.DirOffset + SizeOf(TFileSection) * i, soFromBeginning);
291
         FStream.ReadBuffer(f, SizeOf(TFileSection));
292
         FStream.Position := FStream.Position - SizeOf(TFileSection);
293
         f.FilePos := f.FilePos - dir.FileLength;
294
         FStream.WriteBuffer(f, SizeOf(TFileSection));
295
      end;
296


297
   i := FHeader.DirOffset + SizeOf(TFileSection) * index;
298
   FStream.Position := Cardinal(i + SizeOf(TFileSection));
299
   if FStream.Position < FStream.Size then
300
   begin
301
      Temp.CopyFrom(FStream, FStream.Size - FStream.Position);
302
      FStream.Position := i;
303
      FStream.CopyFrom(Temp, 0);
304
   end;
305
   Temp.Free;
306
   FHeader.DirLength := FHeader.DirLength - SizeOf(TFileSection);
307
   FStream.Position  := 0;
308
   FStream.WriteBuffer(FHeader, SizeOf(TZLibHeader));
309
   FStream.Size := FStream.Size - dir.FileLength - SizeOf(TFileSection);
310
   MakeContentList;
311
end;
312


313
procedure TZLibArchive.RemoveContent(ContentName: string);
314
begin
315
   if ContentExists(ContentName) then
316
      RemoveContent(FContentList.IndexOf(ContentName));
317
end;
318


319
procedure TZLibArchive.Extract(index: integer; NewName: string);
320
var
321
   vExtractFileStream: TFileStream;
322
   vTmpStream: Tstream;
323
begin
324
   if NewName = '' then
325
      Exit;
326
   if (index < 0) or (index >= ContentCount) then
327
      exit;
328
   vExtractFileStream := TFileStream.Create(NewName, fmCreate);
329
   vTmpStream := GetContent(index);
330
   vExtractFileStream.CopyFrom(vTmpStream, 0);
331
   vTmpStream.Free;
332
   vExtractFileStream.Free;
333
end;
334


335
procedure TZLibArchive.Extract(ContentName, NewName: string);
336
begin
337
   if ContentExists(ContentName) then
338
      Extract(FContentList.IndexOf(ContentName), NewName);
339
end;
340


341
initialization
342
  // ���� ������������ �������� ������ zlib
343
  RegisterArchiveFormat('zlib', 'GLScene file uses the zlib compression algorithm', TZLibArchive);
344


345
end.
346

Использование cookies

Мы используем файлы cookie в соответствии с Политикой конфиденциальности и Политикой использования cookies.

Нажимая кнопку «Принимаю», Вы даете АО «СберТех» согласие на обработку Ваших персональных данных в целях совершенствования нашего веб-сайта и Сервиса GitVerse, а также повышения удобства их использования.

Запретить использование cookies Вы можете самостоятельно в настройках Вашего браузера.