DEADSOFTWARE

FPC3.2.0 compat patch by deaddoomer
[d2df-sdl.git] / src / shared / xstreams.pas
1 (* Copyright (C) Doom 2D: Forever Developers
2 *
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, version 3 of the License ONLY.
6 *
7 * This program is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10 * GNU General Public License for more details.
11 *
12 * You should have received a copy of the GNU General Public License
13 * along with this program. If not, see <http://www.gnu.org/licenses/>.
14 *)
15 // special stream classes
16 {$INCLUDE a_modes.inc}
17 {.$R+}
18 unit xstreams;
20 interface
22 uses
23 SysUtils, Classes,
24 zbase{z_stream};
27 type
28 XStreamError = class(Exception);
30 // read-only ïîòîê äëÿ èçâëå÷åíèÿ èç èñõîäíîãî òîëüêî êóñî÷êà
31 TSFSPartialStream = class(TStream)
32 protected
33 fSource: TStream; // èñõîäíûé ïîòîê
34 fKillSource: Boolean; // óáèâàòü èñõîäíèê ïðè ïîìèðàíèè?
35 fLastReadPos: Int64; // ïîñëåäíèé Read() îñòàíîâèëñÿ çäåñü (îòíîñ. fStartPos)
36 fCurrentPos: Int64; // ïîñëåäíèé Seek() îñòàíîâèëñÿ çäåñü (îòíîñ. fStartPos)
37 fStartPos: Int64; // íà÷àëî êóñî÷êà
38 fSize: Int64; // äëèíà êóñî÷êà
39 fPreBuf: packed array of Byte; // ýòîò áóôåð áóäåò ïåðåä ôàéëîì
41 procedure CheckPos ();
43 public
44 // aSrc: ïîòîê-èñõîäíèê.
45 // aPos: íà÷àëüíàÿ ïîçèöèÿ â ïîòîêå. -1 -- ñ òåêóùåé.
46 // åñëè aPos < òåêóùåé ïîçèöèè, òî èñõîäíûé ïîòîê äîëæåí
47 // íîðìàëüíî ïîääåðæèâàòü Seek()!
48 // aSize: êîëè÷åñòâî áàéòèêîâ, êîòîðîå ìîæíî ïðî÷åñòü èç ïîòîêà.
49 // åñëè ìåíüøå íóëÿ -- òî äî êîíöà.
50 // aKillSrc: óáèâàòü ëè èñõîäíûé ïîòîê, êîãäà ñàìè óìèðàåì?
51 // òàêæå ìîæåò ïðèøïàíäîðèòü ê íà÷àëó ôàéëà áóôåð. bufSz áóäåò äîáàâëåíî ê
52 // äëèíå ôàéëà.
53 constructor Create (aSrc: TStream; aPos, aSize: Int64; aKillSrc: Boolean; preBuf: Pointer=nil; bufSz: Integer=0);
54 destructor Destroy (); override;
56 // íîðìàëèçóåò count è ÷èòàåò.
57 function Read (var buffer; count: LongInt): LongInt; override;
58 // Write() ïðîñòî ãðîìêî ïàäàåò.
59 function Write (const buffer; count: LongInt): LongInt; override;
60 // Seek() ðåàëèçîâàíî, ÷òîáû ìîãëà ðàáîòàòü ïðîïåðòÿ Size.
61 // âîîáùå-òî ìîæíî ïåðåêðûòü ìåòîä GetSize(), íî âäðóã êàêîé
62 // áîëüíîé íà ãîëîâó êîäåð áóäåò ïîëó÷àòü ðàçìåð ïðè ïîìîùè
63 // Seek()'à?
64 function Seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
65 end;
67 // this stream can kill both `proxied` and `guarded` streams on closing
68 TSFSGuardStream = class(TStream)
69 protected
70 fSource: TStream; // èñõîäíûé ïîòîê
71 fGuardedStream: TStream; // ïîòîê, êîòîðûé çàâàëèì ïðè ïîìèðàíèè
72 fKillSource: Boolean; // óáèâàòü èñõîäíèê ïðè ïîìèðàíèè?
73 fKillGuarded: Boolean; // óáèâàòü îõðàíÿåìûé ïðè ïîìèðàíèè?
74 fGuardedFirst: Boolean; // ïðè ñìåðòè ïåðâûì ïðèøèáàåì îõðàíÿåìîãî?
76 public
77 // aSrc: ïîòîê-èñõîäíèê (íà êîòîðûé çàìàïåíû îïåðàöèè ÷òåíèÿ/çàïèñè).
78 // aKillSrc: óáèâàòü ëè èñõîäíûé ïîòîê, êîãäà ñàìè óìèðàåì?
79 // aKillGuarded: óáèâàòü ëè îõðàíÿåìûé ïîòîê, êîãäà ñàìè óìèðàåì?
80 // aGuardedFirst: true: ïðè ñìåðòè ïåðâûì ïðèøèáàåì îõðàíÿåìîãî.
81 constructor Create (aSrc, aGuarded: TStream; aKillSrc, aKillGuarded: Boolean; aGuardedFirst: Boolean=true);
82 destructor Destroy (); override;
84 // íèæåñëåäóþùåå çàìàïëåíî íà fSource
85 function Read (var buffer; count: LongInt): LongInt; override;
86 function Write (const buffer; count: LongInt): LongInt; override;
87 function Seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
88 end;
90 TSFSMemoryStreamRO = class(TCustomMemoryStream)
91 private
92 fFreeMem: Boolean;
93 fMem: Pointer;
95 public
96 constructor Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
97 destructor Destroy (); override;
99 function Write (const buffer; count: LongInt): LongInt; override;
100 end;
102 TUnZStream = class(TStream)
103 protected
104 fSrcSt: TStream;
105 fZlibSt: z_stream;
106 fBuffer: PByte;
107 fPos: Int64;
108 fSkipHeader: Boolean;
109 fSize: Int64; // can be -1
110 fSrcStPos: Int64;
111 fSkipToPos: Int64; // >0: skip to this position
112 fKillSrc: Boolean;
114 procedure reset ();
115 function readBuf (var buffer; count: LongInt): LongInt;
116 procedure fixPos ();
117 procedure determineSize ();
119 public
120 // `aSize` can be -1 if stream size is unknown
121 constructor create (asrc: TStream; aSize: Int64; aKillSrc: Boolean; aSkipHeader: boolean=false);
122 destructor destroy (); override;
123 function read (var buffer; count: LongInt): LongInt; override;
124 function write (const buffer; count: LongInt): LongInt; override;
125 function seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
126 end;
128 // fixed memory chunk
129 TSFSMemoryChunkStream = class(TStream)
130 private
131 fFreeMem: Boolean;
132 fMemBuf: PByte;
133 fMemSize: Integer;
134 fCurPos: Integer;
136 public
137 // if `pMem` is `nil`, stream will allocate it
138 constructor Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
139 destructor Destroy (); override;
141 procedure setup (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
143 function Seek (const offset: Int64; origin: TSeekOrigin): Int64; override;
144 function Read (var buffer; count: LongInt): LongInt; override;
145 function Write (const buffer; count: LongInt): LongInt; override;
147 property chunkSize: Integer read fMemSize;
148 property chunkData: PByte read fMemBuf;
149 end;
152 implementation
154 uses
155 zinflate;
158 { TSFSPartialStream }
159 constructor TSFSPartialStream.Create (aSrc: TStream; aPos, aSize: Int64; aKillSrc: Boolean; preBuf: Pointer=nil; bufSz: Integer=0);
160 begin
161 inherited Create();
162 ASSERT(aSrc <> nil);
163 if aPos < 0 then aPos := aSrc.Position;
164 if aSize < 0 then aSize := 0;
165 fSource := aSrc;
166 fKillSource := aKillSrc;
167 fLastReadPos := 0;
168 fCurrentPos := 0;
169 fStartPos := aPos;
170 fSize := aSize;
171 if bufSz > 0 then
172 begin
173 SetLength(fPreBuf, bufSz);
174 Move(preBuf^, fPreBuf[0], bufSz);
175 Inc(fSize, bufSz);
176 end
177 else
178 begin
179 fPreBuf := nil;
180 end;
181 end;
183 destructor TSFSPartialStream.Destroy ();
184 begin
185 if fKillSource then FreeAndNil(fSource);
186 inherited Destroy();
187 end;
189 procedure TSFSPartialStream.CheckPos ();
190 begin
192 if fSource.Position <> fStartPos+fCurrentPos-Length(fPreBuf) then
193 begin
194 fSource.Position := fStartPos+fCurrentPos-Length(fPreBuf);
195 end;
197 if fCurrentPos >= length(fPreBuf) then
198 begin
199 //writeln('seeking at ', fCurrentPos, ' (real: ', fStartPos+fCurrentPos-Length(fPreBuf), ')');
200 fSource.Position := fStartPos+fCurrentPos-Length(fPreBuf);
201 end;
202 fLastReadPos := fCurrentPos;
203 end;
205 function TSFSPartialStream.Write (const buffer; count: LongInt): LongInt;
206 begin
207 result := 0;
208 raise XStreamError.Create('can''t write to read-only stream');
209 // à íå õîäè, íåõîðîøèé, â íàø ñàäèê ãóëÿòü!
210 end;
212 function TSFSPartialStream.Read (var buffer; count: LongInt): LongInt;
213 var
214 left: Int64;
215 pc: Pointer;
216 rd: LongInt;
217 begin
218 if count < 0 then raise XStreamError.Create('invalid Read() call'); // ñêàçî÷íûé äîëáî¸á...
219 if count = 0 then begin result := 0; exit; end;
220 pc := @buffer;
221 result := 0;
222 if (Length(fPreBuf) > 0) and (fCurrentPos < Length(fPreBuf)) then
223 begin
224 fLastReadPos := fCurrentPos;
225 left := Length(fPreBuf)-fCurrentPos;
226 if left > count then left := count;
227 if left > 0 then
228 begin
229 Move(fPreBuf[fCurrentPos], pc^, left);
230 Inc(PChar(pc), left);
231 Inc(fCurrentPos, left);
232 fLastReadPos := fCurrentPos;
233 Dec(count, left);
234 result := left;
235 if count = 0 then exit;
236 end;
237 end;
238 CheckPos();
239 left := fSize-fCurrentPos;
240 if left < count then count := left; // è òàê ñëó÷àåòñÿ...
241 if count > 0 then
242 begin
243 rd := fSource.Read(pc^, count);
244 Inc(result, rd);
245 Inc(fCurrentPos, rd);
246 fLastReadPos := fCurrentPos;
247 end
248 else
249 begin
250 result := 0;
251 end;
252 end;
254 function TSFSPartialStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
255 begin
256 case origin of
257 soBeginning: result := offset;
258 soCurrent: result := offset+fCurrentPos;
259 soEnd: result := fSize+offset;
260 else raise XStreamError.Create('invalid Seek() call');
261 // äðóãèõ íå áûâàåò. à ó êîãî áûâàåò, òîìó ÿ íå äîêòîð.
262 end;
263 if result < 0 then result := 0
264 else if result > fSize then result := fSize;
265 fCurrentPos := result;
266 end;
269 { TSFSGuardStream }
270 constructor TSFSGuardStream.Create (aSrc, aGuarded: TStream; aKillSrc, aKillGuarded: Boolean; aGuardedFirst: Boolean=true);
271 begin
272 inherited Create();
273 fSource := aSrc; fGuardedStream := aGuarded;
274 fKillSource := aKillSrc; fKillGuarded := aKillGuarded;
275 fGuardedFirst := aGuardedFirst;
276 end;
278 destructor TSFSGuardStream.Destroy ();
279 begin
280 if fKillGuarded and fGuardedFirst then FreeAndNil(fGuardedStream);
281 if fKillSource then FreeAndNil(fSource);
282 if fKillGuarded and not fGuardedFirst then FreeAndNil(fGuardedStream);
283 inherited Destroy();
284 end;
286 function TSFSGuardStream.Read (var buffer; count: LongInt): LongInt;
287 begin
288 result := fSource.Read(buffer, count);
289 end;
291 function TSFSGuardStream.Write (const buffer; count: LongInt): LongInt;
292 begin
293 result := fSource.Write(buffer, count);
294 end;
296 function TSFSGuardStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
297 begin
298 result := fSource.Seek(offset, origin);
299 end;
302 { TSFSMemoryStreamRO }
303 constructor TSFSMemoryStreamRO.Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
304 begin
305 fFreeMem := aFreeMem;
306 fMem := pMem;
307 inherited Create();
308 SetPointer(pMem, pSize);
309 Position := 0;
310 end;
312 destructor TSFSMemoryStreamRO.Destroy ();
313 begin
314 if fFreeMem and (fMem <> nil) then FreeMem(fMem);
315 end;
317 function TSFSMemoryStreamRO.Write (const buffer; count: LongInt): LongInt;
318 begin
319 result := 0;
320 raise XStreamError.Create('can''t write to read-only stream');
321 // ñîâñåì ñáðåíäèë...
322 end;
325 // ////////////////////////////////////////////////////////////////////////// //
326 { TUnZStream }
327 const ZBufSize = 32768; // size of the buffer used for temporarily storing data from the child stream
330 constructor TUnZStream.create (asrc: TStream; aSize: Int64; aKillSrc: Boolean; aSkipHeader: boolean=false);
331 var
332 err: Integer;
333 begin
334 fKillSrc := aKillSrc;
335 fPos := 0;
336 fSkipToPos := -1;
337 fSrcSt := asrc;
338 fSize := aSize;
339 GetMem(fBuffer, ZBufSize);
340 fSkipHeader := aSkipHeader;
341 fSrcStPos := fSrcSt.position;
342 FillChar(fZlibSt, sizeof(fZlibSt), 0);
343 if fSkipHeader then err := inflateInit2(fZlibSt, -MAX_WBITS) else err := inflateInit(fZlibSt);
344 if err <> Z_OK then raise XStreamError.Create(zerror(err));
345 end;
348 destructor TUnZStream.destroy ();
349 begin
350 inflateEnd(fZlibSt);
351 FreeMem(fBuffer);
352 if fKillSrc then fSrcSt.Free();
353 inherited Destroy();
354 end;
357 function TUnZStream.readBuf (var buffer; count: LongInt): LongInt;
358 var
359 err: Integer;
360 sz: LongInt;
361 begin
362 result := 0;
363 if (fSize >= 0) and (fPos >= fSize) then exit;
364 if count > 0 then
365 begin
366 fZlibSt.next_out := @buffer;
367 fZlibSt.avail_out := count;
368 sz := fZlibSt.avail_out;
369 while fZlibSt.avail_out > 0 do
370 begin
371 if fZlibSt.avail_in = 0 then
372 begin
373 // refill the buffer
374 fZlibSt.next_in := fBuffer;
375 fZlibSt.avail_in := fSrcSt.read(Fbuffer^, ZBufSize);
376 end;
377 err := inflate(fZlibSt, Z_NO_FLUSH);
378 if (err <> Z_OK) and (err <> Z_STREAM_END) then raise XStreamError.Create(zerror(err));
379 Inc(result, sz-fZlibSt.avail_out);
380 Inc(fPos, sz-fZlibSt.avail_out);
381 sz := fZlibSt.avail_out;
382 if err = Z_STREAM_END then begin fSize := fPos; break; end;
383 end;
384 end;
385 end;
388 procedure TUnZStream.fixPos ();
389 var
390 buf: array [0..4095] of Byte;
391 rd, rr: LongInt;
392 begin
393 if fSkipToPos < 0 then exit;
394 //writeln('fixing pos: fPos=', fPos, '; fSkipToPos=', fSkipToPos);
395 if fSkipToPos < fPos then reset();
396 while fPos < fSkipToPos do
397 begin
398 if fSkipToPos-fPos > 4096 then rd := 4096 else rd := LongInt(fSkipToPos-fPos);
399 //writeln(' reading ', rd, ' bytes...');
400 rr := readBuf(buf, rd);
401 //writeln(' got ', rr, ' bytes; fPos=', fPos, '; fSkipToPos=', fSkipToPos);
402 if rr <= 0 then raise XStreamError.Create('seek error');
403 end;
404 //writeln(' pos: fPos=', fPos, '; fSkipToPos=', fSkipToPos);
405 fSkipToPos := -1;
406 end;
409 procedure TUnZStream.determineSize ();
410 var
411 buf: array [0..4095] of Byte;
412 rd: LongInt;
413 opos: Int64;
414 begin
415 if fSize >= 0 then exit;
416 opos := fPos;
417 try
418 //writeln('determining unzstream size...');
419 while true do
420 begin
421 rd := readBuf(buf, 4096);
422 if rd = 0 then break;
423 end;
424 fSize := fPos;
425 //writeln(' unzstream size is ', fSize);
426 finally
427 if fSkipToPos < 0 then fSkipToPos := opos;
428 end;
429 end;
432 function TUnZStream.read (var buffer; count: LongInt): LongInt;
433 begin
434 if fSkipToPos >= 0 then fixPos();
435 result := readBuf(buffer, count);
436 end;
439 function TUnZStream.write (const buffer; count: LongInt): LongInt;
440 begin
441 result := 0;
442 raise XStreamError.Create('can''t write to read-only stream');
443 end;
446 procedure TUnZStream.reset ();
447 var
448 err: Integer;
449 begin
450 //writeln('doing RESET');
451 fSrcSt.position := fSrcStPos;
452 fPos := 0;
453 inflateEnd(fZlibSt);
454 FillChar(fZlibSt, sizeof(fZlibSt), 0);
455 if fSkipHeader then err := inflateInit2(fZlibSt, -MAX_WBITS) else err := inflateInit(fZlibSt);
456 if err <> Z_OK then raise XStreamError.Create(zerror(err));
457 end;
460 function TUnZStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
461 var
462 cpos: Int64;
463 begin
464 cpos := fPos;
465 if fSkipToPos >= 0 then cpos := fSkipToPos;
466 case origin of
467 soBeginning: result := offset;
468 soCurrent: result := offset+cpos;
469 soEnd: begin determineSize(); result := fSize+offset; end;
470 else raise XStreamError.Create('invalid Seek() call');
471 // äðóãèõ íå áûâàåò. à ó êîãî áûâàåò, òîìó ÿ íå äîêòîð.
472 end;
473 if result < 0 then result := 0;
474 fSkipToPos := result;
475 //writeln('seek: ofs=', offset, '; origin=', origin, '; result=', result);
476 end;
479 // ////////////////////////////////////////////////////////////////////////// //
480 constructor TSFSMemoryChunkStream.Create (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
481 begin
482 fMemBuf := nil;
483 fFreeMem := false;
484 fMemSize := 0;
485 fCurPos := 0;
486 setup(pMem, pSize, aFreeMem);
487 end;
490 procedure TSFSMemoryChunkStream.setup (pMem: Pointer; pSize: Integer; aFreeMem: Boolean=false);
491 begin
492 if fFreeMem then FreeMem(fMemBuf);
493 fMemBuf := nil;
494 fFreeMem := false;
495 fMemSize := 0;
496 fCurPos := 0;
497 if (pSize < 0) then raise XStreamError.Create('invalid chunk size');
498 if (pMem = nil) then
499 begin
500 if (pSize > 0) then
501 begin
502 GetMem(pMem, pSize);
503 if (pMem = nil) then raise XStreamError.Create('out of memory for chunk');
504 aFreeMem := true;
505 end
506 else
507 begin
508 aFreeMem := false;
509 end;
510 end;
511 fFreeMem := aFreeMem;
512 fMemBuf := PByte(pMem);
513 fMemSize := pSize;
514 end;
517 destructor TSFSMemoryChunkStream.Destroy ();
518 begin
519 if fFreeMem then FreeMem(fMemBuf);
520 inherited;
521 end;
524 function TSFSMemoryChunkStream.Seek (const offset: Int64; origin: TSeekOrigin): Int64;
525 begin
526 case origin of
527 soBeginning: result := offset;
528 soCurrent: result := offset+fCurPos;
529 soEnd: result := fMemSize+offset;
530 else raise XStreamError.Create('invalid Seek() call');
531 end;
532 if (result < 0) then raise XStreamError.Create('invalid Seek() call');
533 if (result > fMemSize) then result := fMemSize;
534 fCurPos := result;
535 end;
538 function TSFSMemoryChunkStream.Read (var buffer; count: LongInt): LongInt;
539 var
540 left: Integer;
541 begin
542 if (count < 0) then raise XStreamError.Create('negative read');
543 left := fMemSize-fCurPos;
544 if (left < 0) then raise XStreamError.Create('internal error in TSFSMemoryChunkStream (read)');
545 if (count > left) then count := left;
546 if (count > 0) then Move((fMemBuf+fCurPos)^, buffer, count);
547 Inc(fCurPos, count);
548 result := count;
549 end;
552 function TSFSMemoryChunkStream.Write (const buffer; count: LongInt): LongInt;
553 var
554 left: Integer;
555 begin
556 if (count < 0) then raise XStreamError.Create('negative write');
557 left := fMemSize-fCurPos;
558 if (left < 0) then raise XStreamError.Create('internal error in TSFSMemoryChunkStream (write)');
559 if (count > left) then count := left;
560 if (count > 0) then Move(buffer, (fMemBuf+fCurPos)^, count);
561 Inc(fCurPos, count);
562 result := count;
563 end;
566 end.