The Wiert Corner – irregular stream of stuff

Jeroen W. Pluimers on .NET, C#, Delphi, databases, and personal interests

  • My badges

    Mastodon

  • Twitter Updates

  • My Flickr Stream

    20140508-Delphi-2007--Project-Options--Cannot-Edit-Application-Title-HelpFile-Icon-Theming20140430-Fiddler-Filter-Actions-Button-Run-Filterset-now20140424-VMware-Fusion-6.0.3.-no-reclaimable
    More Photos

  • Pages

  • All categories

  • Enter your email address to subscribe to this blog and receive notifications of new posts by email.

    Join 1,860 other subscribers
«
»

On the design of the Delphi TStream classes – why aren’t they decomposed better?

Posted by jpluimers on 2017/05/16

Ever since I started using Delphi more than 2 decades ago, I wondered about the design of the TStream classes, especially as “stream16.zip” by Duncan Murdoch from the DOS Turbo Pascal era (which I copied in the below gist) showed how to perform composition using streams.

Even though by now there is TStreamReader/TStreamWriter allowing some level of composition, it always bugged me that large parts of the resource handling and component (de)serialisation is in it (centred around ReadComponentRes/WriteComponentRes in stead of fully being in TFiler/TReader/TWriter or even further decomposed), that you cannot interrogate capabilities (like supporting seeking, length, directionality and such) and that a lot of overloads (for instance Read/ReadBuffer/ReadBufferData/Write/WriteBuffer/WriteBufferData) are still based on signed or 32-bit types (though it has improved back in the early days they were even signed 16-bit types).

I’m not the only one who wonders about this: Faster FileStream with TBufferedFileStream • DelphiABall mentioned a new Berlin piece the TStream hierarchy and – being in the field a lot longer – Stefan Glienke rightly asked why the buffering isn’t done with the decorator pattern like JclStreams does, and Asbjørn Heid chimed in with a very dense version of more gripes.

Even TZCompressionStream/TZDecompressionStream (though relatively new) aren’t doing composition really well (by not abstracting the compression/decompression from the write-only/read-only behaviour).

Now that all key players from the early TStream design day and age have left the core Delphi R&D team, maybe one of them can step in and explain why.

–jeroen

via: [WayBack] I was wondering if the TBufferedFileStream (see https://delphiaball.co.uk/2016/04/29/faster-filestream-tbufferedfilestream/) would not have been implemented using the decorator pattern… – Stefan Glienke – Google+ -> https://github.com/project-jedi/jcl/blob/master/jcl/source/common/JclStreams.pas#L207

TJclBufferedStream = class(TJclStreamDecorator)


{$B-} { Use fast boolean evaluation. }
program Compress;
{ Program to demonstrate use of TLZWFilter }
{$i stdefine.inc}
uses
{$ifdef windows} wincrt, {$endif}
{$ifdef wobjects} wobjects, {$else} objects, {$endif}
streams;
procedure SyntaxExit(s:string);
begin
writeln;
writeln(s);
writeln;
writeln('Usage: COMPRESS Sourcefile Destfile [/X]');
writeln(' will compress the source file to the destination');
writeln(' file, or if /X flag is used, will expand source to destination.');
halt(99);
end;
var
Source : PStream; { We don't know in advance which will be compressed }
Dest : PStream;
filename : string;
begin
Case ParamCount of
2 : begin
{$ifdef windows}
Filename := Paramstr(1);
Filename[length(filename)+1] := #0;
Source := New(PBufStream, init(@filename[1], stOpenRead, 2048));
Filename := Paramstr(2);
Filename[length(filename)+1] := #0;
Dest := New(PLZWFilter, init(New(PBufStream,
init(@filename[1],
stCreate, 2048)),
stOpenWrite));
{$else}
Source := New(PBufStream, init(Paramstr(1), stOpenRead, 2048));
Dest := New(PLZWFilter, init(New(PBufStream,
init(Paramstr(2),
stCreate, 2048)),
stOpenWrite));
{$endif windows}
Write('Compressing ',Paramstr(1),' (',Source^.GetSize,
' bytes) to ',Paramstr(2));
end;
3 : begin
if (Paramstr(3) <> '/X') and (Paramstr(3) <> '/x') then
SyntaxExit('Unrecognized option '+Paramstr(3));
{$ifdef windows}
Filename := Paramstr(2);
Filename[length(filename)+1] := #0;
Source := New(PLZWFilter, init(New(PBufStream,
init(@filename[1],
stOpenRead, 2048)),
stOpenRead));
Filename := Paramstr(2);
Filename[length(filename)+1] := #0;
Dest := New(PBufStream, init(@filename[1], stCreate, 2048));
{$else}
Source := New(PLZWFilter, init(New(PBufStream,
init(Paramstr(1),
stOpenRead, 2048)),
stOpenRead));
Dest := New(PBufStream, init(Paramstr(2), stCreate, 2048));
{$endif windows}
Write('Expanding ',Paramstr(1),' (',
PLZWFilter(Source)^.Base^.GetSize,' bytes) to ',
Paramstr(2));
end;
else
SyntaxExit('Two or three parameters required.');
end;
if (Source = nil) or (Source^.status <> stOk) then
SyntaxExit('Unable to open file '+ParamStr(1)+' for reading.');
if (Dest = nil) or (Dest^.status <> stOk) then
SyntaxExit('Unable to create file '+Paramstr(2)+'.');
FastCopy(Source^,Dest^, Source^.GetSize);
if Dest^.status <> stOK then
SyntaxExit('File error during compression/expansion.');
Case ParamCount of
2 : begin
Dest^.Flush;
Writeln(' (',PLZWFilter(Dest)^.Base^.GetSize,' bytes).');
end;
3 : Writeln(' (',Dest^.GetSize,' bytes).');
end;
Dispose(Source, done);
Dispose(Dest, done);
end.

view raw

compress.pas

hosted with ❤ by GitHub


IDEAL
; This CRC-16 routine and tables were converted from C code discovered
; in rzsz.arc by Chuck Forsberg. The comments there are:
;
; crctab calculated by Mark G. Mendel, Network Systems Corporation
;
; updcrc macro derived from article Copyright (C) 1986 Stephen Satchell.
; NOTE: First srgument must be in range 0 to 255.
; Second argument is referenced twice.
;
; Programmers may incorporate any or all code into their programs,
; giving proper credit within the source. Publication of the
; source routines is permitted so long as proper credit is given
; to Stephen Satchell, Satchell Evaluations and Chuck Forsberg,
; Omen Technology.
;
; <End of rzsz comments>
;
; The C macro is:
;
; #define updcrc(cp, crc) ( crctab[((crc >> 8) & 255)] ^ (crc << 8) ^ cp)
;
; This routine appears to compute the 16 bit CRC used by XModem and its
; derivatives. For transmission, the CRC value should start with 0 and,
; after the block crc is computed, the value should be updated with two
; nulls and transmitted high-order byte first. The computed CRC value
; on the received block + 2 byte CRC should be zero.
c:\dosauto
;
; This TASM conversion done by:
;
; Edwin T. Floyd [76067h747]
; #9 Adams Park Ct.
; Columbush GA 31909
; 404-576-3305 (work)
; 404-322-0076 (home)
;
; Borland's Turbo Assembler – TASM is required to assemble this program.
;
SEGMENT code BYTE PUBLIC
ASSUME cs:code
; 0
crctab dw 00000h, 01021h, 02042h, 03063h, 04084h, 050a5h, 060c6h, 070e7h
dw 08108h, 09129h, 0a14ah, 0b16bh, 0c18ch, 0d1adh, 0e1ceh, 0f1efh
; 1
dw 01231h, 00210h, 03273h, 02252h, 052b5h, 04294h, 072f7h, 062d6h
dw 09339h, 08318h, 0b37bh, 0a35ah, 0d3bdh, 0c39ch, 0f3ffh, 0e3deh
; 2
dw 02462h, 03443h, 00420h, 01401h, 064e6h, 074c7h, 044a4h, 05485h
dw 0a56ah, 0b54bh, 08528h, 09509h, 0e5eeh, 0f5cfh, 0c5ach, 0d58dh
; 3
dw 03653h, 02672h, 01611h, 00630h, 076d7h, 066f6h, 05695h, 046b4h
dw 0b75bh, 0a77ah, 09719h, 08738h, 0f7dfh, 0e7feh, 0d79dh, 0c7bch
; 4
dw 048c4h, 058e5h, 06886h, 078a7h, 00840h, 01861h, 02802h, 03823h
dw 0c9cch, 0d9edh, 0e98eh, 0f9afh, 08948h, 09969h, 0a90ah, 0b92bh
; 5
dw 05af5h, 04ad4h, 07ab7h, 06a96h, 01a71h, 00a50h, 03a33h, 02a12h
dw 0dbfdh, 0cbdch, 0fbbfh, 0eb9eh, 09b79h, 08b58h, 0bb3bh, 0ab1ah
; 6
dw 06ca6h, 07c87h, 04ce4h, 05cc5h, 02c22h, 03c03h, 00c60h, 01c41h
dw 0edaeh, 0fd8fh, 0cdech, 0ddcdh, 0ad2ah, 0bd0bh, 08d68h, 09d49h
; 7
dw 07e97h, 06eb6h, 05ed5h, 04ef4h, 03e13h, 02e32h, 01e51h, 00e70h
dw 0ff9fh, 0efbeh, 0dfddh, 0cffch, 0bf1bh, 0af3ah, 09f59h, 08f78h
; 8
dw 09188h, 081a9h, 0b1cah, 0a1ebh, 0d10ch, 0c12dh, 0f14eh, 0e16fh
dw 01080h, 000a1h, 030c2h, 020e3h, 05004h, 04025h, 07046h, 06067h
; 9
dw 083b9h, 09398h, 0a3fbh, 0b3dah, 0c33dh, 0d31ch, 0e37fh, 0f35eh
dw 002b1h, 01290h, 022f3h, 032d2h, 04235h, 05214h, 06277h, 07256h
; A
dw 0b5eah, 0a5cbh, 095a8h, 08589h, 0f56eh, 0e54fh, 0d52ch, 0c50dh
dw 034e2h, 024c3h, 014a0h, 00481h, 07466h, 06447h, 05424h, 04405h
; B
dw 0a7dbh, 0b7fah, 08799h, 097b8h, 0e75fh, 0f77eh, 0c71dh, 0d73ch
dw 026d3h, 036f2h, 00691h, 016b0h, 06657h, 07676h, 04615h, 05634h
; C
dw 0d94ch, 0c96dh, 0f90eh, 0e92fh, 099c8h, 089e9h, 0b98ah, 0a9abh
dw 05844h, 04865h, 07806h, 06827h, 018c0h, 008e1h, 03882h, 028a3h
; D
dw 0cb7dh, 0db5ch, 0eb3fh, 0fb1eh, 08bf9h, 09bd8h, 0abbbh, 0bb9ah
dw 04a75h, 05a54h, 06a37h, 07a16h, 00af1h, 01ad0h, 02ab3h, 03a92h
; E
dw 0fd2eh, 0ed0fh, 0dd6ch, 0cd4dh, 0bdaah, 0ad8bh, 09de8h, 08dc9h
dw 07c26h, 06c07h, 05c64h, 04c45h, 03ca2h, 02c83h, 01ce0h, 00cc1h
; F
dw 0ef1fh, 0ff3eh, 0cf5dh, 0df7ch, 0af9bh, 0bfbah, 08fd9h, 09ff8h
dw 06e17h, 07e36h, 04e55h, 05e74h, 02e93h, 03eb2h, 00ed1h, 01ef0h
MODEL TPASCAL
PUBLIC UpdateCRC16
PROC UpdateCRC16 FAR initcrc:WORD,inbuf:DWORD,inlen:WORD
; UpdateCRC16 takes an initial CRC value and updates it with inlen bytes from
; inbuf. The updated CRC is returned in AX. The Pascal declaration is:
; Function UpdateCRC16(InitCRC : Word; Var InBuf; InLen : Word) : Word;
; Stomps registers: AX,BX,CX,SI
push ds
lds si,[inbuf] ; ds:si := ^inbuf
mov ax,[initcrc] ; ax := initcrc
mov cx,[inlen] ; cx := inlen
or cx,cx
jz @@done
@@loop:
xor bh,bh
mov bl,ah
mov ah,al
lodsb
shl bx,1
xor ax,[crctab+bx]
loop @@loop
@@done:
pop ds
ret
ENDP
ENDS
END

view raw

crc16.asm

hosted with ❤ by GitHub


IDEAL
; This CRC-32 routine and tables were converted from code discovered
; in the DEZIP.PAS V2.0 by R. P. Byrne. The comments there are:
;
; Converted to Turbo Pascal ™ V4.0 March, 1988 by J.R.Louvau
; COPYRIGHT (C) 1986 Gary S. Brown. You may use this program, or
; code or tables extracted from it, as desired without restriction.
;
; First, the polynomial itself and its table of feedback terms. The
; polynomial is
; X^32+X^26+X^23+X^22+X^16+X^12+X^11+X^10+X^8+X^7+X^5+X^4+X^2+X^1+X^0
;
; Note that we take it "backwards" and put the highest-order term in
; the lowest-order bit. The X^32 term is "implied"; the LSB is the
; X^31 term, etc. The X^0 term (usually shown as "+1") results in
; the MSB being 1.
;
; Note that the usual hardware shift register implementation, which
; is what we're using (we're merely optimizing it by doing eight-bit
; chunks at a time) shifts bits into the lowest-order term. In our
; implementation, that means shifting towards the right. Why do we
; do it this way? Because the calculated CRC must be transmitted in
; order from highest-order term to lowest-order term. UARTs transmit
; characters in order from LSB to MSB. By storing the CRC this way,
; we hand it to the UART in the order low-byte to high-byte; the UART
; sends each low-bit to high-bit; and the result is transmission bit
; by bit from highest- to lowest-order term without requiring any bit
; shuffling on our part. Reception works similarly.
;
; The feedback terms table consists of 256, 32-bit entries. Notes:
;
; The table can be generated at runtime if desired; code to do so
; is shown later. It might not be obvious, but the feedback
; terms simply represent the results of eight shift/xor opera-
; tions for all combinations of data and CRC register values.
;
; The values must be right-shifted by eight bits by the "updcrc"
; logic; the shift must be unsigned (bring in zeroes). On some
; hardware you could probably optimize the shift in assembler by
; using byte-swap instructions.
; polynomial $edb88320
;
; <End of Pascal version comments>
;
; The Pascal logic is:
;
; Function UpdC32(Octet: Byte; Crc: LongInt) : LongInt;
; Begin
;
; UpdC32 := CRC_32_TAB[Byte(Crc XOR LongInt(Octet))] XOR ((Crc SHR 8)
; AND $00FFFFFF);
;
; End {UpdC32};
;
; This routine computes the 32 bit CRC used by PKZIP and its derivatives,
; and by Chuck Forsberg's "ZMODEM" protocol. The block CRC computation
; should start with high-values (0ffffffffh), and finish by inverting all
; bits.
;
; This TASM conversion done by:
;
; Edwin T. Floyd [76067,747]
; #9 Adams Park Ct.
; Columbus, GA 31909
; 404-576-3305 (work)
; 404-322-0076 (home)
;
; Borland's Turbo Assembler – TASM is required to assemble this program.
;
SEGMENT code BYTE PUBLIC
ASSUME cs:code
; 0
crc32tab dd 000000000h, 077073096h, 0ee0e612ch, 0990951bah
dd 0076dc419h, 0706af48fh, 0e963a535h, 09e6495a3h
dd 00edb8832h, 079dcb8a4h, 0e0d5e91eh, 097d2d988h
dd 009b64c2bh, 07eb17cbdh, 0e7b82d07h, 090bf1d91h
; 1
dd 01db71064h, 06ab020f2h, 0f3b97148h, 084be41deh
dd 01adad47dh, 06ddde4ebh, 0f4d4b551h, 083d385c7h
dd 0136c9856h, 0646ba8c0h, 0fd62f97ah, 08a65c9ech
dd 014015c4fh, 063066cd9h, 0fa0f3d63h, 08d080df5h
; 2
dd 03b6e20c8h, 04c69105eh, 0d56041e4h, 0a2677172h
dd 03c03e4d1h, 04b04d447h, 0d20d85fdh, 0a50ab56bh
dd 035b5a8fah, 042b2986ch, 0dbbbc9d6h, 0acbcf940h
dd 032d86ce3h, 045df5c75h, 0dcd60dcfh, 0abd13d59h
; 3
dd 026d930ach, 051de003ah, 0c8d75180h, 0bfd06116h
dd 021b4f4b5h, 056b3c423h, 0cfba9599h, 0b8bda50fh
dd 02802b89eh, 05f058808h, 0c60cd9b2h, 0b10be924h
dd 02f6f7c87h, 058684c11h, 0c1611dabh, 0b6662d3dh
; 4
dd 076dc4190h, 001db7106h, 098d220bch, 0efd5102ah
dd 071b18589h, 006b6b51fh, 09fbfe4a5h, 0e8b8d433h
dd 07807c9a2h, 00f00f934h, 09609a88eh, 0e10e9818h
dd 07f6a0dbbh, 0086d3d2dh, 091646c97h, 0e6635c01h
; 5
dd 06b6b51f4h, 01c6c6162h, 0856530d8h, 0f262004eh
dd 06c0695edh, 01b01a57bh, 08208f4c1h, 0f50fc457h
dd 065b0d9c6h, 012b7e950h, 08bbeb8eah, 0fcb9887ch
dd 062dd1ddfh, 015da2d49h, 08cd37cf3h, 0fbd44c65h
; 6
dd 04db26158h, 03ab551ceh, 0a3bc0074h, 0d4bb30e2h
dd 04adfa541h, 03dd895d7h, 0a4d1c46dh, 0d3d6f4fbh
dd 04369e96ah, 0346ed9fch, 0ad678846h, 0da60b8d0h
dd 044042d73h, 033031de5h, 0aa0a4c5fh, 0dd0d7cc9h
; 7
dd 05005713ch, 0270241aah, 0be0b1010h, 0c90c2086h
dd 05768b525h, 0206f85b3h, 0b966d409h, 0ce61e49fh
dd 05edef90eh, 029d9c998h, 0b0d09822h, 0c7d7a8b4h
dd 059b33d17h, 02eb40d81h, 0b7bd5c3bh, 0c0ba6cadh
; 8
dd 0edb88320h, 09abfb3b6h, 003b6e20ch, 074b1d29ah
dd 0ead54739h, 09dd277afh, 004db2615h, 073dc1683h
dd 0e3630b12h, 094643b84h, 00d6d6a3eh, 07a6a5aa8h
dd 0e40ecf0bh, 09309ff9dh, 00a00ae27h, 07d079eb1h
; 9
dd 0f00f9344h, 08708a3d2h, 01e01f268h, 06906c2feh
dd 0f762575dh, 0806567cbh, 0196c3671h, 06e6b06e7h
dd 0fed41b76h, 089d32be0h, 010da7a5ah, 067dd4acch
dd 0f9b9df6fh, 08ebeeff9h, 017b7be43h, 060b08ed5h
; A
dd 0d6d6a3e8h, 0a1d1937eh, 038d8c2c4h, 04fdff252h
dd 0d1bb67f1h, 0a6bc5767h, 03fb506ddh, 048b2364bh
dd 0d80d2bdah, 0af0a1b4ch, 036034af6h, 041047a60h
dd 0df60efc3h, 0a867df55h, 0316e8eefh, 04669be79h
; B
dd 0cb61b38ch, 0bc66831ah, 0256fd2a0h, 05268e236h
dd 0cc0c7795h, 0bb0b4703h, 0220216b9h, 05505262fh
dd 0c5ba3bbeh, 0b2bd0b28h, 02bb45a92h, 05cb36a04h
dd 0c2d7ffa7h, 0b5d0cf31h, 02cd99e8bh, 05bdeae1dh
; C
dd 09b64c2b0h, 0ec63f226h, 0756aa39ch, 0026d930ah
dd 09c0906a9h, 0eb0e363fh, 072076785h, 005005713h
dd 095bf4a82h, 0e2b87a14h, 07bb12baeh, 00cb61b38h
dd 092d28e9bh, 0e5d5be0dh, 07cdcefb7h, 00bdbdf21h
; D
dd 086d3d2d4h, 0f1d4e242h, 068ddb3f8h, 01fda836eh
dd 081be16cdh, 0f6b9265bh, 06fb077e1h, 018b74777h
dd 088085ae6h, 0ff0f6a70h, 066063bcah, 011010b5ch
dd 08f659effh, 0f862ae69h, 0616bffd3h, 0166ccf45h
; E
dd 0a00ae278h, 0d70dd2eeh, 04e048354h, 03903b3c2h
dd 0a7672661h, 0d06016f7h, 04969474dh, 03e6e77dbh
dd 0aed16a4ah, 0d9d65adch, 040df0b66h, 037d83bf0h
dd 0a9bcae53h, 0debb9ec5h, 047b2cf7fh, 030b5ffe9h
; F
dd 0bdbdf21ch, 0cabac28ah, 053b39330h, 024b4a3a6h
dd 0bad03605h, 0cdd70693h, 054de5729h, 023d967bfh
dd 0b3667a2eh, 0c4614ab8h, 05d681b02h, 02a6f2b94h
dd 0b40bbe37h, 0c30c8ea1h, 05a05df1bh, 02d02ef8dh
MODEL TPASCAL
PUBLIC UpdateCRC32
PROC UpdateCRC32 FAR initcrc:DWORD,inbuf:DWORD,inlen:WORD
; UpdateCRC32 takes an initial CRC value and updates it with inlen bytes from
; inbuf. The updated CRC is returned in DX:AX. The Pascal declaration is:
; Function UpdateCRC32(InitCRC : LongInt; Var InBuf; InLen : Word) : LongInt;
; Stomps registers: AX,BX,CX,DX,ES,SI
push ds
lds si,[inbuf] ; ds:si := ^inbuf
les ax,[initcrc] ; dx:ax := initcrc
mov dx,es
mov cx,[inlen] ; cx := inlen
or cx,cx
jz @@done
@@loop:
xor bh,bh
mov bl,al
lodsb
xor bl,al
mov al,ah
mov ah,dl
mov dl,dh
xor dh,dh
shl bx,1
shl bx,1
les bx,[crc32tab+bx]
xor ax,bx
mov bx,es
xor dx,bx
loop @@loop
@@done:
pop ds
ret
ENDP
ENDS
END

view raw

crc32.asm

hosted with ❤ by GitHub


IDEAL
; This CRC-16 routine and tables were converted from pascal code discovered
; in DEARC.PAS (author unknown). The result matches the 16 bit CRC computed
; by SEA's "ARC" utility. This CRC routine is contributed to the public
; domain.
;
; The Pascal logic is:
;
; crc := ((crc shr 8) and $00FF) xor crctab[(crc xor c) and $00FF];
;
; This TASM conversion done by:
;
; Edwin T. Floyd [76067h747]
; #9 Adams Park Ct.
; Columbus, GA 31909
; 404-576-3305 (work)
; 404-322-0076 (home)
;
; Borland's Turbo Assembler – TASM is required to assemble this program.
;
SEGMENT code BYTE PUBLIC
ASSUME cs:code
; 0
crctab dw 00000h, 0C0C1h, 0C181h, 00140h, 0C301h, 003C0h, 00280h, 0C241h
dw 0C601h, 006C0h, 00780h, 0C741h, 00500h, 0C5C1h, 0C481h, 00440h
; 1
dw 0CC01h, 00CC0h, 00D80h, 0CD41h, 00F00h, 0CFC1h, 0CE81h, 00E40h
dw 00A00h, 0CAC1h, 0CB81h, 00B40h, 0C901h, 009C0h, 00880h, 0C841h
; 2
dw 0D801h, 018C0h, 01980h, 0D941h, 01B00h, 0DBC1h, 0DA81h, 01A40h
dw 01E00h, 0DEC1h, 0DF81h, 01F40h, 0DD01h, 01DC0h, 01C80h, 0DC41h
; 3
dw 01400h, 0D4C1h, 0D581h, 01540h, 0D701h, 017C0h, 01680h, 0D641h
dw 0D201h, 012C0h, 01380h, 0D341h, 01100h, 0D1C1h, 0D081h, 01040h
; 4
dw 0F001h, 030C0h, 03180h, 0F141h, 03300h, 0F3C1h, 0F281h, 03240h
dw 03600h, 0F6C1h, 0F781h, 03740h, 0F501h, 035C0h, 03480h, 0F441h
; 5
dw 03C00h, 0FCC1h, 0FD81h, 03D40h, 0FF01h, 03FC0h, 03E80h, 0FE41h
dw 0FA01h, 03AC0h, 03B80h, 0FB41h, 03900h, 0F9C1h, 0F881h, 03840h
; 6
dw 02800h, 0E8C1h, 0E981h, 02940h, 0EB01h, 02BC0h, 02A80h, 0EA41h
dw 0EE01h, 02EC0h, 02F80h, 0EF41h, 02D00h, 0EDC1h, 0EC81h, 02C40h
; 7
dw 0E401h, 024C0h, 02580h, 0E541h, 02700h, 0E7C1h, 0E681h, 02640h
dw 02200h, 0E2C1h, 0E381h, 02340h, 0E101h, 021C0h, 02080h, 0E041h
; 8
dw 0A001h, 060C0h, 06180h, 0A141h, 06300h, 0A3C1h, 0A281h, 06240h
dw 06600h, 0A6C1h, 0A781h, 06740h, 0A501h, 065C0h, 06480h, 0A441h
; 9
dw 06C00h, 0ACC1h, 0AD81h, 06D40h, 0AF01h, 06FC0h, 06E80h, 0AE41h
dw 0AA01h, 06AC0h, 06B80h, 0AB41h, 06900h, 0A9C1h, 0A881h, 06840h
; A
dw 07800h, 0B8C1h, 0B981h, 07940h, 0BB01h, 07BC0h, 07A80h, 0BA41h
dw 0BE01h, 07EC0h, 07F80h, 0BF41h, 07D00h, 0BDC1h, 0BC81h, 07C40h
; B
dw 0B401h, 074C0h, 07580h, 0B541h, 07700h, 0B7C1h, 0B681h, 07640h
dw 07200h, 0B2C1h, 0B381h, 07340h, 0B101h, 071C0h, 07080h, 0B041h
; C
dw 05000h, 090C1h, 09181h, 05140h, 09301h, 053C0h, 05280h, 09241h
dw 09601h, 056C0h, 05780h, 09741h, 05500h, 095C1h, 09481h, 05440h
; D
dw 09C01h, 05CC0h, 05D80h, 09D41h, 05F00h, 09FC1h, 09E81h, 05E40h
dw 05A00h, 09AC1h, 09B81h, 05B40h, 09901h, 059C0h, 05880h, 09841h
; E
dw 08801h, 048C0h, 04980h, 08941h, 04B00h, 08BC1h, 08A81h, 04A40h
dw 04E00h, 08EC1h, 08F81h, 04F40h, 08D01h, 04DC0h, 04C80h, 08C41h
; F
dw 04400h, 084C1h, 08581h, 04540h, 08701h, 047C0h, 04680h, 08641h
dw 08201h, 042C0h, 04380h, 08341h, 04100h, 081C1h, 08081h, 04040h
MODEL TPASCAL
PUBLIC UpdateCRCArc
PROC UpdateCRCArc FAR initcrc:WORD,inbuf:DWORD,inlen:WORD
; UpdateCRCArc takes an initial CRC value and updates it with inlen bytes from
; inbuf. The updated CRC is returned in AX. The Pascal declaration is:
; Function UpdateCRCArc(InitCRC : Word; Var InBuf; InLen : Word) : Word;
; Stomps registers: AX,BX,CX,SI
push ds
lds si,[inbuf] ; ds:si := ^inbuf
mov ax,[initcrc] ; ax := initcrc
mov cx,[inlen] ; cx := inlen
or cx,cx
jz @@done
@@loop:
xor bh,bh
mov bl,al
lodsb
xor bl,al
shl bx,1
mov bx,[crctab+bx]
xor bl,ah
mov ax,bx
loop @@loop
@@done:
pop ds
ret
ENDP
ENDS
END

view raw

crcarc.asm

hosted with ❤ by GitHub


{$B-} { Use fast boolean evaluation. }
program Encrypt;
{ Program to demonstrate use of TEncryptFilter }
{$i StDefine.inc}
uses
{$ifdef wobjects} wobjects, {$else} objects, {$endif}
{$ifdef windows} wincrt, {$endif}
streams;
procedure SyntaxExit(s:string);
begin
writeln;
writeln(s);
writeln;
writeln('Usage: ENCRYPT Sourcefile Destfile');
writeln(' will encrypt sourcefile using key $12345678.');
writeln(' Run ENCRYPT on the encrypted file to decrypt it.');
halt(99);
end;
var
Source : PBufStream;
Dest : PEncryptFilter;
filename : string;
begin
if paramcount <> 2 then
SyntaxExit('Two parameters required.');
{ Open the source file with a buffer size of 2048. }
{$ifdef windows}
Filename := Paramstr(1);
Filename[length(filename)+1] := #0;
New(Source, Init( @filename[1], stOpenRead, 2048) );
{$else}
New(Source, Init( Paramstr(1), stOpenRead, 2048) );
{$endif windows}
if (Source = nil) or (Source^.status <> stOk) then
SyntaxExit('Unable to open file '+ParamStr(1)+' for reading.');
{ Open the destination file with a buffer size of 2048, and insert it
into the encrypting filter. }
{$ifdef windows}
Filename := Paramstr(2);
Filename[length(filename)+1] := #0;
New(Dest, Init($12345678, New(PBufStream,
Init( @filename[1], stCreate, 2048))));
{$else}
New(Dest, Init($12345678, New(PBufStream,
Init( Paramstr(2), stCreate, 2048))));
{$endif windows}
if (Dest = nil) or (Dest^.status <> stOk) then
SyntaxExit('Unable to create file '+Paramstr(2)+'.');
{ Encrypt the source file by copying it to the filter.}
Write('Encrypting ',Paramstr(1),' to ',Paramstr(2),'…');
FastCopy(Source^, Dest^, Source^.GetSize);
if Dest^.status <> stOK then
SyntaxExit('File error during encryption.');
{ Dispose of stream variables to close the files.}
Dispose(Source, done);
Dispose(Dest, done);
Writeln('Done.');
end.

view raw

encrypt.pas

hosted with ❤ by GitHub


{$B-} { Use fast boolean evaluation. }
Program HuffComp;
{ Simple compression program using Huffman compression. Much like
COMPRESS.PAS. }
{$i StDefine.inc}
uses
{$ifdef wobjects} wobjects, {$else} objects, {$endif}
{$ifdef windows} wincrt, {$endif}
streams, huffman;
procedure SyntaxExit(s:string);
begin
writeln;
writeln(s);
writeln;
writeln('Usage: HUFFMAN Sourcefile Destfile [/X]');
writeln(' will compress the source file to the destination');
writeln(' file, or if /X flag is used, will expand source to destination.');
halt(99);
end;
var
Source : PStream; { We don't know in advance which will be compressed }
Dest : PStream;
Fullsize:longint;
Filename : string;
begin
Case ParamCount of
2 : begin
{$ifdef windows}
Filename := Paramstr(1);
Filename[length(filename)+1] := #0;
Source := New(PBufStream, init(@filename[1], stOpenRead, 2048));
Filename := Paramstr(2);
Filename[length(filename)+1] := #0;
Dest := New(PHuffmanFilter, init(New(PBufStream,
init(@filename[1],
stCreate, 2048))));
{$else}
Source := New(PBufStream, init(Paramstr(1), stOpenRead, 2048));
Dest := New(PHuffmanFilter, init(New(PBufStream,
init(Paramstr(2),
stCreate, 2048))));
{$endif windows}
Write('Compressing ',Paramstr(1),' (',Source^.GetSize,
' bytes) to ',Paramstr(2));
{ Count characters in source. }
FullSize := Source^.GetSize;
Dest^.Write(FullSize,sizeof(FullSize));
FastCopy(Source^,Dest^,Source^.GetSize);
Source^.Seek(0);
With PHuffmanFilter(Dest)^ do
begin
Seek(0);
BuildCode;
StoreCode;
Learning := false;
Write(Fullsize,sizeof(Fullsize));
end;
end;
3 : begin
if (Paramstr(3) <> '/X') and (Paramstr(3) <> '/x') then
SyntaxExit('Unrecognized option '+Paramstr(3));
{$ifdef windows}
Filename := Paramstr(1);
Filename[length(filename)+1] := #0;
Source := New(PHuffmanFilter, init(New(PBufStream,
init(@filename[1],
stOpenRead, 2048))));
Filename := Paramstr(2);
Filename[length(filename)+1] := #0;
Dest := New(PBufStream, init(@filename[1], stCreate, 2048));
{$else}
Source := New(PHuffmanFilter, init(New(PBufStream,
init(Paramstr(1),
stOpenRead, 2048))));
Dest := New(PBufStream, init(Paramstr(2), stCreate, 2048));
{$endif}
Write('Expanding ',Paramstr(1),' (',
PHuffmanFilter(Source)^.Base^.GetSize,' bytes) to ',
Paramstr(2));
with PHuffmanFilter(Source)^ do
begin
LoadCode;
Learning := false;
Read(Fullsize,Sizeof(Fullsize));
end;
end;
else
SyntaxExit('Two or three parameters required.');
end;
if (Source = nil) or (Source^.status <> stOk) then
SyntaxExit('Unable to open file '+ParamStr(1)+' for reading.');
if (Dest = nil) or (Dest^.status <> stOk) then
SyntaxExit('Unable to create file '+Paramstr(2)+'.');
FastCopy(Source^, Dest^, FullSize);
if Dest^.status <> stOK then
SyntaxExit('File error during compression/expansion.');
Case ParamCount of
2 : begin
Dest^.Flush;
Writeln(' (',PHuffmanFilter(Dest)^.Base^.GetSize,' bytes).');
end;
3 : Writeln(' (',FullSize,' bytes).');
end;
Dispose(Source, done);
Dispose(Dest, done);
end.
end.

view raw

huffcomp.pas

hosted with ❤ by GitHub


{$B-} { Use fast boolean evaluation. }
unit Huffman; { Copyright D.J. Murdoch, (1992) }
{ Defines a Huffman compression filter to illustrate use of the TBitFilter. }
{ The THuffmanFilter object defined in this file isn't optimized as much as
I'd like, so I haven't put it into the main Streams unit. It's also a
little rough – be careful if you use it. If you make any substantial
improvements, I'd like to see them! – djm}
interface
{$i StDefine.inc}
uses
{$ifdef wobjects} wobjects, {$else} objects, {$endif}
streams;
const
MaxNode = 510;
StoreSize = ((MaxNode-255)*18+7) div 8; { Bytes required to store the code
table }
type
PHuffmanfilter = ^THuffmanfilter;
THuffmanfilter = object(TBitfilter)
{ This object defines a Huffman encoder/decoder which encodes the 256
letter alphabet of bytes using variable length codes in the 2 letter
alphabet of bits. }
Size, { The size of the expanded stream. }
Position : LongInt; { The current position in the expanded stream }
Counts : array[0..MaxNode] of longint; { Counts uncompressed characters;
second half used as workspace }
Decoder : array[256..MaxNode,TBit] of integer; { Array holding decoder }
EncodeStates : array[0..MaxNode] of integer; { The state change array }
EncodeBits : array[0..MaxNode] of TBit; { The encoding bit for each
state }
Learning : boolean; { Signals whether writes are enabled, and whether
to attempt to decode reads. }
constructor init(ABase:PStream);
{ Inits the Counts to 0, but doesn't set up a code. Puts filter
in "learning" mode. Before setting Learning to false, be sure to
call LoadCode or BuildCode. }
procedure LoadCode;
{ Reads an encoding from the base stream. }
procedure StoreCode;
{ Writes an encoding to the base stream. }
procedure BuildCode;
{ Builds the optimal encoding based on the values in the Counts array }
procedure BuildEncoder(Verify:boolean);
{ Initializes the Encode arrays based on the Decoder array. Called
automatically by LoadCode and BuildCode; use this routine only
if you've loaded the Decoder in some other way. If Verify is true,
it will check that the Decoder array is valid. }
function CodeBits(b:byte):word;
{ Returns the number of bits that will be used in the current code
to write b. }
function PredictedSize:Longint;
{ Returns the predicted number of bytes to write the distribution of
bytes given in Counts in the current encoding. }
procedure read(var buf; count:word); virtual;
procedure write(var buf; count:word); virtual;
function getpos:longint; virtual;
function getsize:longint; virtual;
end;
implementation
constructor THuffmanFilter.Init(ABase:PStream);
begin
if not TFilter.Init(ABase) then
fail;
Size := 0;
Position := 0;
FillChar(counts,sizeof(counts),0);
Learning := true;
end;
procedure THuffmanFilter.LoadCode;
var
i,code : integer;
begin
for i:=256 to MaxNode do
begin
ReadBits(code,9);
Decoder[i,0] := code; { Should we confirm code<=MaxNode? }
ReadBits(code,9);
Decoder[i,1] := code;
end;
BuildEncoder(true);
end;
procedure THuffmanFilter.StoreCode;
var
i : integer;
begin
for i:=256 to MaxNode do
begin
WriteBits(Decoder[i,0],9);
WriteBits(Decoder[i,1],9);
end;
end;
procedure THuffmanFilter.BuildCode;
var
letters : array[byte] of integer; { The array of symbols }
procedure Revsort;
{ Procedure to do a Quicksort on the array of letters,
to put Counts[letters[i]] into decreasing order.
Ties are broken by the letter order.
Based on Quicksort as given in Steal This Code, by F.D. Boswell, Watcom 1986.
}
procedure quick(first,last : integer);
var
pivot : integer;
temp : integer;
scanright, scanleft : integer;
begin
if (first < last) then
begin
pivot := letters[first];
scanright := first;
scanleft := last;
while scanright < scanleft do
begin
if Counts[letters[scanright+1]] < Counts[pivot] then
begin
if Counts[letters[scanleft]] >= Counts[pivot] then
begin
temp := letters[scanleft];
inc(scanright);
letters[scanleft] := letters[scanright];
letters[scanright] := temp;
dec(scanleft);
end
else
dec(scanleft);
end
else
inc(scanright);
end;
temp := letters[scanright];
letters[scanright] := letters[first];
letters[first] := temp;
quick(first, scanright-1);
quick(scanright+1, last);
end;
end;
begin {quicksort}
quick(0, 255);
end;
var
i,LastEntry,LastLetter,PrevLetter,InsertAt : integer;
begin { BuildCode }
for i:=0 to 255 do
letters[i] := i; { Initialize to match counts }
RevSort; { Sort into decreasing frequency }
for i :=256 to MaxNode do
begin
{ Create node by combining last two entries }
LastEntry := 511-i;
LastLetter := Letters[LastEntry];
PrevLetter := Letters[LastEntry-1];
Decoder[i,0] := PrevLetter;
Decoder[i,1] := LastLetter;
Counts[i] := Counts[PrevLetter] + Counts[LastLetter];
{ Find where to insert it }
InsertAt := LastEntry-1;
While (InsertAt > 0) and (Counts[Letters[InsertAt-1]] <= Counts[i]) do
dec(InsertAt);
{ Insert the node }
Move(Letters[InsertAt],Letters[InsertAt+1],
(LastEntry-1-InsertAt)*sizeof(Integer));
Letters[InsertAt] := i;
end;
BuildEncoder(false);
end;
procedure THuffmanFilter.BuildEncoder(verify:boolean);
var
i,code : integer;
j : TBit;
begin
fillchar(EncodeBits,sizeof(EncodeBits),0);
if verify then
begin
{ First, confirm that all the Decoder values are in range }
for i:=256 to MaxNode do
for j:=0 to 1 do
if (Decoder[i,j] < 0) or (Decoder[i,j] > MaxNode) then
begin
Error(stIntegrity,i);
exit;
end;
{ Initialize the EncodeStates to illegal values to detect missing
codes }
fillchar(EncodeStates,sizeof(EncodeStates),0);
end;
for i:=256 to MaxNode do
begin
EncodeStates[Decoder[i,0]] := i;
code := Decoder[i,1];
EncodeStates := i;
EncodeBits := 1;
end;
if verify then
for i:=0 to pred(MaxNode) do
if EncodeStates[i] = 0 then
begin
Error(stIntegrity,i);
exit;
end;
end;
function THuffmanFilter.CodeBits(b:byte):word;
var
state : 0..MaxNode;
result : word;
begin
result := 0;
state := b;
while state < MaxNode do
begin
inc(result);
state := EncodeStates[state];
end;
CodeBits := result;
end;
function THuffmanFilter.PredictedSize:longint;
var
bitcount : longint;
b : byte;
begin
bitcount := 0;
for b:=0 to 255 do
inc(bitcount,Counts[b]*CodeBits(b));
PredictedSize := (bitcount+7) div 8;
end;
procedure THuffmanFilter.Read(var buf;Count:word);
var
i : word;
bbuf : TByteArray absolute buf;
State : 0..MaxNode;
begin
if CheckStatus then
begin
if learning then
TBitFilter.Read(buf,Count)
else
for i:=0 to Count-1 do
begin
State := MaxNode;
repeat
State := Decoder[State,GetBit];
until State < 256;
bbuf[i] := State;
end;
for i:=0 to Count-1 do
inc(Counts[bbuf[i]]);
inc(position,Count);
if Position>Size then
Size := Position;
CheckBase;
end;
end;
procedure THuffmanFilter.Write(var buf;Count:word);
var
bbuf : TByteArray absolute buf;
i : word;
bitstack : word;
bitcount : word;
words : word;
state : 0..MaxNode;
begin
if CheckStatus then
begin
for i:=0 to Count-1 do
inc(Counts[bbuf[i]]);
if not learning then
begin
for i:=0 to Count-1 do
begin
bitstack := 0;
bitcount := 0;
words := 0;
state := bbuf[i];
{ Push all the bits onto the stack }
while state < MaxNode do
begin
bitstack := 2*bitstack + EncodeBits[state];
inc(bitcount);
if bitcount = 16 then
begin
asm
push bitstack
end;
bitstack := 0;
bitcount := 0;
inc(words);
end;
state := EncodeStates[state];
end;
{ Now write out all the bits }
WriteBits(bitstack,bitcount);
while words > 0 do
begin
asm
pop bitstack
end;
WriteBits(BitStack,16);
dec(words);
end;
end;
inc(position,count);
if position>size then
size := position;
CheckBase;
end;
end;
end;
function THuffmanFilter.GetPos:longint;
begin
GetPos := Position;
end;
function THuffmanFilter.GetSize:longint;
begin
GetSize := Size;
end;
end.

view raw

huffman.pas

hosted with ❤ by GitHub


{$B-} { Use fast boolean evaluation. }
program logdemo;
{ Demonstrates use of TLogFilter }
{$i stdefine.inc}
uses
{$ifdef windows} wincrt, {$endif}
{$ifdef wobjects} wobjects, {$else} objects, {$endif}
streams;
var
i : integer;
inlog,log : PLogFilter;
begin
{ Log both input and output to Logdemo.out }
new(log, init( new(PDOSStream, init('Logdemo.out',stCreate))));
log^.log(input);
log^.log(output);
writeln('This is the Logdemo program, which logs input and output');
writeln('to LOGDEMO.OUT');
write('Enter an integer:');
readln(i);
writeln('Logging will now be turned off.');
if not log^.unlog(input) then; { This is one way to stop logging. }
close(output); { This is another way. }
{ Re-open output; input was never closed. }
rewrite(output);
writeln('This line will not be logged.');
write('Enter another integer:');
readln(i);
writeln('Logging will be turned back on now.');
log^.log(input);
log^.log(output);
writeln('This line will be logged to the file.');
writeln('All done now; close the log.');
dispose(log,done);
writeln('The log has been closed, so this line won''t be logged.');
end.

view raw

logdemo.pas

hosted with ❤ by GitHub


PAGE 60, 132
TITLE 12 bit LZW Compression Scheme
LOCALS @@
Comment *
This unit is a modified version of Wilbert van Leijen's LZW unit,
to implement a stream type that automatically compresses data.
The original documentation:
This modules implements a 12-bit Lempel-Zev-Welch "crunch" (compress
data) and "uncrunch" (restore data in its original form) routines.
InBuffer and OutBuffer are untyped; you must pass pointers to arrays
(0..MaxRange) of Char or Byte to it, whereby MaxRange is limited to
2^16-16+1 = 65521 bytes.
You must also supply the size of the input buffer.
The LZW technique is well explained in the following reference:
Terry A. Welch, "A Technique for High Performance Data Compression"
IEEE Computer
Vol. 17, no. 6 (June 1984), pp. 8-19
Incorporate these routines as follows in a TP unit:
[ deleted ]
(C) Copyright Wilbert van Leijen, Amsterdam 1990.
Released to the Public Domain under the condition that this program
will not be sold for a profit except with written permission from
the author.
Stream additions (c) copyright D.J. Murdoch, 1991.
*
MaxStack = 4096; ; Decompression stack size
TableSize = MaxStack-1; ; Upper bound of 12 bit tables
HalfFull = MaxStack / 2
ProbeValue = 131; ; Preferably a prime number
True = 1
False = 0
EndList = -1; ; Marks end of a list
NoPrev = -2; ; Code for no previous character
Empty = -3; ; Indicates empty
DataSize = [BP+18] ; Number of bytes input
OutputSize = word ptr [BP+16] ; Max number to output
InputBuf = [BP+12] ; Input data buffer
OutputBuf = [BP+8] ; Output data buffer
Tables = [BP+4] ; Where the tables are
Table STRUC
Collision DB MaxStack DUP(?) ; Hash table entries
PrefixTable DW MaxStack DUP(?) ; Code for preceding stringf
SuffixTable DB MaxStack DUP(?) ; Code for current character
ChildTable DW MaxStack DUP(?) ; Next duplicate in collision list
CharStack DB MaxStack DUP(?) ; Decompression stack
StackPtr DW ? ; Decompression stack depth
Prefix DW ? ; Previous code string
TableUsed DW ? ; # string table entries used
InputPos DW ? ; Index in input buffer
OutputPos DW ? ; Index in output buffer
LastHit DW ? ; Last empty slot in collision table
CodeBuf DW ? ; Temporary code buffer
SaveIP DW ? ; Saved registers between calls
SaveAX DW ?
SaveCX DW ?
SaveDX DW ?
NotFound DB ? ; Character combination found flag
Table ENDS
; CH register is set aside for final output character (= Suffix)
Code SEGMENT Word Public
ASSUME CS:Code
Public Initialise
Public PutSignature
Public Crunch
Public FlushLZW
Public GetSignature
Public Uncrunch
; Initialise variables, fill tables
Initialise PROC near
PUSH BP
MOV BP,SP
PUSH DS ; save DS
LDS BX,Tables ; get DS:BX to point to the tables
XOR AX, AX
MOV [BX].InputPos, AX
MOV [BX].OutputPos, AX
MOV [BX].TableUsed, AX
MOV [BX].StackPtr, AX
MOV [BX].CodeBuf, Empty
; Loop:
; Clear collision table
; Set prefix to 'no previous character' code
; Set child nodes to 'end of list' code
MOV DX, Tablesize
@@1: MOV DI, DX
MOV [BX+DI+Collision], 0
SHL DI, 1
MOV [BX+DI+PrefixTable], NoPrev
MOV [BX+DI+ChildTable], EndList
DEC DX
JNS @@1
; Loop:
; Enter all single characters into the hash table
MOV DX, 255
MOV [BX].Prefix, NoPrev
@@2: MOV CH, DL
CALL MakeEntry
DEC DX
JNS @@2
MOV [BX].SaveCX,CX
POP DS
POP BP
RETN 4
Initialise ENDP
; Hash function: 'fold' number
; AX := (Prefix shl 5 xor Suffix) and TableSize
; uses CL,DX
HashNumber MACRO
XOR DX, DX
MOV DL, CH
MOV AX, [BX].Prefix
MOV CL, 5
SHL AX, CL
XOR AX, DX
AND AX, TableSize
ENDM
; Store a character combination in the hash table
MakeEntry PROC Near
PUSH DX
HashNumber
; Rehash is necessary if entry in the hash table is occupied
MOV DI, AX
CMP [BX+DI+Collision], False
JE @@6
; Loop:
; Advance index of ChildTable to last empty list
@@1: MOV DI, AX
SHL DI, 1
CMP [BX+DI+ChildTable], EndList
JE @@2
MOV AX, [BX+DI+ChildTable]
JMP Short @@1
; If the hash table is less than 50% loaded
; Increase index with the probing value
@@2: CMP [BX].TableUsed, HalfFull
JAE @@3
MOV SI, AX
ADD SI, ProbeValue
AND SI, TableSize
JMP Short @@4
; Else deal with the clustering problem
; A simple yet effective solution is to start probing at the
; empty slot of the hash table found during the previous run
@@3: MOV SI, [BX].LastHit
; Loop:
; Probe hash table until an empty slot is found
@@4: CMP [BX+SI+Collision], False
JE @@5
INC SI
AND SI, TableSize
JMP Short @@4
; Found an empty slot, save index in ChildTable
; Store index in LastHit
@@5: MOV DI, AX
SHL DI, 1
MOV [BX+DI+ChildTable], SI
MOV DI, SI
MOV [BX].LastHit, SI
; Return:
; Indicate hash table slot's been occupied
; Store character combination in PrefixTable, SuffixTable
; Indicate 'end of list' in ChildTable
; Bump table load counter
@@6: MOV [BX+DI+Collision], True
MOV [BX+DI+SuffixTable], CH
SHL DI, 1
MOV [BX+DI+ChildTable], EndList
MOV AX, [BX].Prefix
MOV [BX+DI+PrefixTable], AX
INC [BX].TableUsed
POP DX
RETN
MakeEntry ENDP
; Lookup a character combination in the hash table
LookupStr PROC Near
HashNumber
XCHG SI, AX
; Search through list of hash collision entries for one that match
; Loop
; Entry is found if prefix and suffix match
; If no match, advance index to entry in ChildTable
; Until entry is found or no such list exists in ChildTable
@@1: MOV DI, SI
MOV AL, [BX+DI+SuffixTable]
CMP AL, CH
JNE @@2
SHL DI, 1
MOV AX, [BX+DI+PrefixTable]
CMP AX, [BX].Prefix
JE @@3
@@2: MOV DI, SI
SHL DI, 1
MOV SI, [BX+DI+ChildTable]
CMP SI, EndList
JNE @@1
; Return index from ChildTable in AX
@@3: XCHG AX, SI
RETN
LookupStr ENDP
; Retrieve next character from the input buffer
GetChar MACRO
LES DI, InputBuf
ADD DI, [BX].InputPos
MOV AL, ES:[DI]
INC [BX].InputPos
ENDM
; Store next character in AL into the output buffer
PutChar MACRO
LES DI, OutputBuf
ADD DI, [BX].OutputPos
STOSB
INC [BX].OutputPos
ENDM
; Retrieve compressed code from input buffer
GetCode PROC Near
MOV SI, [BX].CodeBuf
; Get first character and store it in a temporary buffer
GetChar
XOR AH, AH
MOV DX, AX
; If input code is empty
CMP SI, Empty
JNE @@1
; Get next character
; Return 8 bits from first character + 4 bits from second character
; Save the remaining 4 bits of the second character for next time
GetChar
MOV SI, AX
MOV CL, 4
SHR AX, CL
MOV DI, AX
MOV AX, DX
SHL AX, CL
ADD AX, DI
JMP @@2
; Else
; Get the last 4 bits from the input code + 8 bits from the second char
@@1: MOV AX, SI
XCHG AH, AL
AND AH, 0Fh
ADD AX, DX
MOV SI, Empty
@@2:
MOV [BX].CodeBuf,SI
RETN
GetCode ENDP
; Store compressed code in the output buffer
PutCode PROC Near
MOV DI, [BX].CodeBuf
MOV DX, [BX].Prefix
; If output code is empty
CMP DI, Empty
JNE @@1
; Store first 8 bits in the output buffer
; Save last 4 bits for the next time through
MOV AX, DX
MOV CL, 4
SHR AX, CL
PutChar
MOV DI, DX
JMP @@2
; Else
; Put out last 4 bits of previous code + first 4 bits of this code
; Next, put out last 8 bits of this code
; Indicate output code as empty
@@1: MOV AX, DI
MOV CL, 4
SHL AX, CL
ADD AL, DH
PutChar
MOV AL, DL
PutChar
MOV DI, Empty
@@2: MOV [BX].CodeBuf,DI
RETN
PutCode ENDP
; Start the compressor by putting 'LZ'
PutSignature PROC Near
PUSH BP
MOV BP,SP
PUSH DS ; save DS
LDS BX,Tables ; get DS:BX to point to the tables
MOV [BX].OutputPos, 0
; Get first character and store it in Suffix
; There are no character combinations yet
MOV AL, 'L'
MOV CH, AL
MOV [BX].Prefix, NoPrev
CALL LookupStr
MOV [BX].Prefix, AX
; Get next character
MOV AL, 'Z'
MOV CH, AL
MOV [BX].SaveCX,CX
MOV AL,True ; Return success
POP DS
POP BP
RET 4
PutSignature ENDP
Crunch PROC Near
PUSH BP
MOV BP,SP
PUSH DS ; save DS
LDS BX,Tables ; get DS:BX to point to the tables
MOV CX,[BX].SaveCX ; get saved registers
MOV [BX].InputPos, 0
MOV [BX].OutputPos, 0
DEC OutputSize ; sometimes we write 2 bytes per loop,
; so reduce this for safety
; Loop:
; Process all characters from input buffer
@@1: MOV DX, [BX].InputPos
MOV AX, [BX].OutputPos
CMP DX, DataSize
JAE @@5
CMP AX, OutputSize
JAE @@5
; Lookup the character combination
; Store if not found and if empty slots are available in the hash table
CALL LookupStr
MOV DI, AX
CMP DI, EndList
JNE @@3
PUSH DI
CMP [BX].TableUsed, TableSize
JA @@2
CALL MakeEntry
; Store code in the output buffer
; If string is in table, keep looking for longer strings
@@2: CALL PutCode
POP DI
MOV [BX].Prefix, NoPrev
XCHG DX, DI
CALL LookupStr
XCHG DI, DX
MOV [BX].Prefix, AX
JMP Short @@4
; Get next character
@@3: MOV [BX].Prefix, DI
@@4: GetChar
MOV CH, AL
JMP Short @@1
@@5: MOV [BX].SaveCX,CX
; return number written in AX
; and number used in DX
POP DS
POP BP
RET 14
Crunch ENDP
; Make sure the last code will be written out
; If the output code <> Empty, store the last 4 pending bits
FlushLZW Proc Near
PUSH BP
MOV BP,SP
PUSH DS ; save DS
LDS BX,Tables ; get DS:BX to point to the tables
MOV CX,[BX].SaveCX ; get saved registers
MOV [BX].InputPos, 0
MOV [BX].OutputPos, 0
@@5: CALL PutCode
MOV SI,[BX].CodeBuf
CMP SI, Empty
JE @@7
MOV AX, SI
MOV CL, 4
SHL AX, CL
PutChar
; Return the number of bytes written to the output buffer
@@7: MOV AX, [BX].OutputPos
MOV [BX].SaveCX,CX
POP DS
POP BP
RET 8
FlushLZW ENDP
; Run through code extracting single characters from code string until
; no more characters can be removed. Push these onto the stack.
; They will be entered in reverse order, and will come out in forwards order
; when popped off
PushChar PROC Near
@@1: MOV DI, SI
SHL DI, 1
CMP [BX+DI+PrefixTable], NoPrev
JNE @@2
RETN
@@2: MOV AL, [BX+SI+SuffixTable]
INC [BX].StackPtr
MOV DI, [BX].StackPtr
MOV [BX+DI+CharStack], AL
SHL SI, 1
MOV SI, [BX+SI+PrefixTable]
JMP Short @@1
PushChar ENDP
; While StackPtr > 0
; Pop a character from the stack
PopChar PROC Near
PutChar
MOV DI, [BX].StackPtr
OR DI, DI
JE @@1
MOV AL, [BX+DI+CharStack]
DEC [BX].StackPtr
RETN
@@1: MOV AX, Empty
RETN
PopChar ENDP
; Check for correct start of buffer, and initialize registers
GetSignature PROC Near
PUSH BP
MOV BP, SP
PUSH DS ; save DS
LDS BX,Tables ; get DS:BX to point to the tables
; Get first string and check the corresponding character
; Keep a copy of this code
CALL GetCode
MOV [BX].Prefix, AX
MOV SI, AX
MOV CH, [BX+SI+SuffixTable]
CMP CH, 'L'
JNE @@2
CALL GetCode
MOV [BX].SaveDX, AX
; Do half a run through the old Uncrunch loop
; ( skip size check )
MOV [BX].Notfound, False
MOV SI, AX
; ( skip collision test, & PushChar call )
MOV CH, [BX+SI+SuffixTable]
CMP CH, 'Z'
JNE @@2
; ( do PopChar's MOV AX, Empty )
MOV [BX].SaveAX,Empty
MOV AL,True ; Success! We're ready for the loop.
JMP @@1
@@2: MOV AL,False ; It failed!
@@1: MOV [BX].SaveCX,CX
MOV [BX].SaveIP,OFFSET MainLoop
POP DS
POP BP
RET 14
GetSignature ENDP
UnCrunch PROC Near
PUSH BP
MOV BP,SP
PUSH DS ; save DS
LDS BX,Tables ; get DS:BX to point to the tables
MOV AX,[BX].SaveAX ; get saved registers
MOV CX,[BX].SaveCX
MOV DX,[BX].SaveDX
MOV [BX].InputPos, 0 ; set up string pointers & sizes
MOV [BX].OutputPos, 0
DEC Word Ptr DataSize ; sometimes we need to read two
JMP [BX].SaveIP
; Loop:
; Process all characters from input buffer
; While the stack is not empty, remove and output all characters from
; stack which are rest of characters in the string
@@1: MOV DI,[BX].OutputPos ; Check if there's room for more characters
CMP DI,OutputSize
JB @@3
CALL ExitLoop ; Exit from Uncrunch
Mainloop:
@@3: CMP AX, Empty
JE @@4
CALL PopChar
JMP Short @@1
; If code isn't known, store the follower character of last
; character of string
@@4: CMP [BX].NotFound, False
JE @@5
PUSH AX
MOV AL, CL
MOV CH, AL
PutChar
POP AX
; Check whether there's enough space for another char
@@8: MOV DI,[BX].OutputPos
CMP DI,OutputSize
JB @@5
; No space, so quit
CALL ExitLoop
; If the hash table is not full
; Enter code into table
; Make current code the previous code
; Get next code
@@5: CMP [BX].TableUsed, TableSize
JA @@6
CALL MakeEntry
@@6: MOV [BX].Prefix, DX
CALL GetCode
XCHG DX, AX
; Old top of loop
MOV AX, [BX].InputPos
CMP AX, DataSize
JB @@10
; Out of data, so exit
CALL ExitLoop
; Retrieve character from string
; Keep a copy of it in CL
@@10: MOV [BX].NotFound, False
MOV SI, DX
CMP [BX+SI+Collision], False
JNE @@2
MOV AL, CH
MOV CL, AL
MOV SI, [BX].Prefix
MOV [BX].NotFound, True
; Get first character from string
@@2: CALL PushChar
MOV AL, [BX+SI+SuffixTable]
MOV CH, AL
CALL PopChar
JMP @@1
UnCrunch ENDP
ExitLoop PROC Near ; allows exit from UnCrunch loop
; and resumption at several places.
POP [BX].SaveIP ; Get address
MOV [BX].SaveAX,AX ; Save registers
MOV [BX].SaveCX,CX
MOV [BX].SaveDX,DX
; Return the number of bytes written to the output buffer in AX
; and the number of bytes used in DX
MOV AX, [BX].OutputPos
MOV DX, [BX].InputPos
POP DS
POP BP
RETN 14
ExitLoop ENDP
Code ENDS
END

view raw

lzwstrea.asm

hosted with ❤ by GitHub


unit ovr1;
{$O+,F+}
interface
procedure proc1;
implementation
procedure proc1;
begin
writeln('This line is being printed by proc1 in unit ovr1.');
end;
end.

view raw

ovr1.pas

hosted with ❤ by GitHub


unit ovr2;
{$O+,F+}
interface
procedure proc2;
implementation
procedure proc2;
begin
writeln('This line is being printed by proc2 in unit ovr2.');
end;
end.

view raw

ovr2.pas

hosted with ❤ by GitHub


{$B-} { Use fast boolean evaluation. }
program ovrdemo;
{ Program to demonstrate use of two overlay files. }
{$i stdefine.inc}
{$ifndef overlays}
This program only works in modes that support overlays.
{$endif}
uses
overlay,objects,streams,
ovr1,ovr2;
{$O ovr1}
{$O ovr2}
type
PMessageStream = ^TMessageStream;
TMessageStream = object(TNamedBufStream)
{ This stream prints its name every time anything is read from it. }
procedure read(var buf; size:word); virtual;
end;
procedure TMessageStream.Read;
begin
writeln('Reading from ',filename^);
TNamedBufStream.Read(buf,size);
end;
var
stream1, stream2 : PMessageStream;
begin
ovrinit('ovrdemo.ovr');
writeln('The overlay streams aren''t being used yet.');
proc1;
proc2;
writeln('Now loading overlays to the two streams.');
ovrclearbuf; { Make sure no overlay is loaded. }
new(stream1, init('ovrdemo.1',stCreate,2048));
ovrinitstream(stream1);
proc1; { This loads proc1 to Stream1, but doesn't trigger a read
yet. }
new(stream2, init('ovrdemo.2',stCreate,2048));
ovrinitstream(stream2);
proc2; { This loads proc2 to Stream2, but again, no read. }
writeln('Now each unit is on a different stream; let''s call them a few ');
writeln('times.');
proc1;
proc2;
proc1;
proc2;
writeln('Now the overlay streams will be disposed of.');
OvrDisposeStreams;
writeln('These calls will use the old overlay mechanism.');
proc1;
proc2;
end.

view raw

ovrdemo.pas

hosted with ❤ by GitHub


{ This file sets some conditional compilation defines }
{$define overlays} { Assume we'll want the overlay code, but turn
it off in certain cases }
{$ifdef windows}
{$undef overlays}
{$endif}
{$ifdef dpmi}
{$undef overlays}
{$endif}
{ Only TPW uses "WObjects"; BP 7 calls the same unit "Objects" }
{$ifdef windows}
{$ifndef ver70}
{$define wobjects}
{$endif}
{$endif}

view raw

stdefine.inc

hosted with ❤ by GitHub


STREAMS - TP/BP/TPW unit to supplement TurboVision/ObjectWindows streams
Version 1.6. Copyright D.J. Murdoch (1992,1994).
DESCRIPTION
"Wierd Stream Tricks" might be a good name for this unit. It
contains a miscellaneous collection of objects and procedures, all
on a theme of adding functionality to the streams in Borland's
Turbo Pascal libraries TurboVision and ObjectWindows.
Most of my testing has been in TP 6 and BP 7 real mode; the code
and demos also appear to work in BP 7 protected mode, and compile
under Windows, but use it with care in those "foreign"
environments.
LICENSE
This unit is *not* public domain code. You may use it for
no charge if credit is granted to the author, but you may not sell
it, nor may you claim copyright on it. You may make copies of this
unit and give them to people, but may not charge more than $5 for
the distribution media. In particular, it may not be distributed
on a CD ROM costing more than $5 without prior written permission
from D.J. Murdoch. The Garbo and Simtel CD ROM collections have
permission to distribute it.
A lot of the code in this unit is code that's been made freely
available by others, some of it under their copyright, other parts
public domain. As far as I know, all code included here may be
used for free, provided you acknowledge the author. See the list of
credits at the end for all the (known) authors.
This is the fourth release of the STREAMS unit. There are probably
still bugs; I would really appreciate reports of any, or other
suggestions for improvement. Please send either one to me at one
of the following addresses:
dmurdoch@mast.queensu.ca (Internet)
71631,122 (Compuserve)
DJ Murdoch at 1:249/1.5 (Fidonet)
D. J. Murdoch
337 Willingdon Ave.
Kingston, Ontario, Canada
K7L 4J3
SUMMARY
Hierarchy
TStream (from Objects)
TFilter Base type for filters
TEncryptFilter Encrypts as it writes; decrypts as it reads
TLZWFilter Compresses as it writes; expands as it reads
TTextFilter Provides text file interface to stream
TLogFilter Provides logging of text file activity
TBitFilter Allows bit-oriented I/O
TDupFilter Duplicates output, checks for matching input
TConcatFilter Concatenates two streams together
TLimitFilter Limits I/O to a certain byte range
TLoopFilter Makes stream look like a tape loop
TReverseFilter Reads and writes a stream in reverse order
TSequential Filter that doesn't allow Seek
TChksumFilter Calculates 8 or 16 bit checksum for reads/writes
TCRC16Filter Calculates XMODEM style 16 bit CRC
TCRCARCFilter Calculates ARC style 16 bit CRC
TCRC32Filter Calculates ZIP & Zmodem style 32 bit CRC
TNulStream Eats writes, returns constant on reads
TRAMStream Stream in memory
TEMSStream2 Workaround stream to avoid Borland bug
TXMSStream Stream in XMS (extended) memory
TDOSStream (from Objects)
TBufStream (from Objects)
TNamedBufStream Buffered file stream that knows its name
TTempBufStream Buffered file stream that erases itself when done
TWorkStream Stream that grows as needed
Procedures & functions:
TempStream allocates a temporary stream
StreamName returns a stream type name (for debugging)
OvrInitStream like OvrInitEMS, but buffers overlays on a stream
May be called several times to buffer different
segments on different streams.
OvrDetachStream detaches stream from overlay system
OvrDisposeStreams detaches all streams from overlay system and disposes of
them
OvrSizeNeeded Calculates the size needed to load the rest of the segments
to a stream
OvrLoadAll immediately copies as many overlay segments to the stream
as will fit
xms_MemAvail returns the number of bytes of XMS memory available
xms_MaxAvail returns size in bytes of the largest block of XMS memory
ems_MemAvail returns the number of bytes of EMS memory available
ems_MaxAvail returns size in bytes of the largest block of EMS memory
disk_MemAvail returns the number of bytes of temp disk space available
disk_MaxAvail returns size in bytes of the largest block of disk space
FastCopy Like TStream.CopyFrom, but uses a larger buffer
Reassuring Note:
One concern I've heard from people about using this unit: it's
big. Won't 110K of source add a lot of code to my program, even if I
only need one little part of it? The simple answer is no. I've
tried very hard to write Streams so that cross-links between code
are minimized. If all you need are the XMS routines, that's all
that TP's "smart linker" will link into your .EXE. Same for most
of the other objects and functions. One exception is the TempStream
function (Chapter 20). Because it makes explicit references to 4
types of streams, one call to it will necessarily pull in support
code for all 4 types. That's only about 6K, though. StreamName is
much worse: it pulls in code for *every* stream type. It should
only be used for debugging.
CONTENTS
0. Files in archive
a list of the files that should accompany this one
1. TFilter
a generic object to act as a filter to a stream
2. TEncryptFilter
a filter which does simple encryption/decryption
3. TLZWFilter
a filter which does LZW compression/decompression
4. TTextFilter
a filter to provide the Read/ReadLn/Write/WriteLn
interface to a stream
5. TLogFilter
a filter to allow logging of activity on text files
6. TBitFilter
a filter to allow bit level I/O to a stream
7. TDupFilter
a filter to duplicate output, check for duplicate input
8. TConcatFilter
a filter to concatenate two streams
9. TLimitFilter
a filter to limit I/O to a certain byte range
10. TLoopFilter
a filter to make a stream look like a tape loop: things wrap
around when they reach the ends
11. TReverseFilter and ReverseBytes
a filter to reverse the apparent byte order of a stream and
a procedure to reverse the byte order of a buffer
12. TSequential
a generic filter that can't Seek
13. Checksum/CRC filters:
a collection of filters which calculate checksums and CRC
values as the data goes by
14. TNulStream
a stream which counts data written to it, and which
returns a constant if you read
15. TRAMStream
a stream which resides entirely in RAM
16. TXMSStream
a stream which keeps its data in XMS memory
17. xxx_MemAvail and xxx_MaxAvail
procedures to show how much memory is free
18. TNamedBufStream
a buffered file stream which knows its own name
19. TTempBufStream
a temporary buffered file stream, which deletes itself when
done
20. TempStream
a procedure to allocate a temporary stream, in RAM, EMS, or
on disk, according to a specified preference
21. TWorkStream
a temporary stream, which allocates new blocks of mixed
types as it grows
22. OvrInitStream and related procedures
procedures to allow overlays to be buffered on any
stream or combination of streams
23. TEMSStream2
EMS stream with fix for bug in TEMSStream.done
24. FastCopy
fast copy from one stream to another
25. Miscellaneous constants and types
26. Release history and credits
0. FILES IN ARCHIVE
Streams.doc - this file
Streams.pas - main source file for unit
Lzwstrea.asm - source for LZW compression
StDefine.inc - a few conditional compiler defines
Xmsstrm.inc - source for XMS stream
Crc16.asm - source for 16 bit CRC
Crc32.asm - source for 32 bit CRC
Crcarc.asm - source for ARC-style 16 bit CRC
Lzwstrea.obj - assembled code for external linking
Crc16.obj - " " " " "
Crcarc.obj - " " " " "
Crc32.obj - " " " " "
Demo programs:
Encrypt.pas - encryption program, using TEncryptFilter
Compress.pas - file compressor, using TLZWFilter
Huffman.pas - defines a Huffman encoding filter, using TBitFilter
HuffComp.pas - file compressor using THuffmanFilter
Logdemo.pas - simple demo of TLogFilter
Ovrdemo.pas - simple demo of multiple overlay files
ovr1.pas - one overlaid unit
ovr2.pas - a second overlaid unit
Textdemo.pas - simple demo of TTextFilter
1. TFilter = object(TStream)
"Filters" are programs which take a file as input and produce a new
file as output. TFilter is an adaptation of this idea to streams.
Every TFilter has a base stream, which can be any kind of stream.
Every TFilter is itself a stream, which means you can read and
write to it. When you do, it just relays your request to the base
stream.
One use of this is in the fact that you can make descendants
of TFilter which massage the data on the way to and from the Base.
Just override the Read and Write (and possibly other) methods, and
you can make changes to the data flowing to or from *any* kind of
stream. No need for special coding for an TEMSStream, or for a
TDOSStream, or whatever. Your code can act on any of them.
Examples of things to do are in the Streams unit: encryption
(TEncryptFilter) and LZW compression (TLZWFilter).
The other main use is to add other kinds of functionality to a
stream. You can't use the formatting capabilities of ReadLn and
WriteLn with standard streams, but if you use a TTextFilter (see
below) you can.
FIELDS
Base : PStream;
TFilter.Base holds the pointer to the base stream.
StartOfs : longint;
TFilter.StartOfs holds the offset in the base stream of offset 0
in the filter. This allows multiple filters to work on the same
stream; one could work at offset 0, another at offset 1000, etc.
Just position the base to the desired starting offset before
initializing the filter.
OwnsBase: Boolean;
If false, then the Base stream is assumed to be owned by some
other part of the program, so that when Done is called, it won't
be disposed of. Normally OwnsBase is true, and it's assumed
that all management of the Base stream will be done by the
TFilter.
METHODS
Constructor Init(ABase: PStream);
TFilter.Init sets Base to point to ABase^, and sets StartOfs to
the current position of the base stream. Sets ByReference to
false.
Destructor Done; virtual;
If Base is not nil, then TFilter.Done calls Flush, then if
OwnsBase is true, disposes of the base stream before calling
TStream.Done for itself.
Function CheckStatus : boolean; virtual;
Returns true if status is stOK. If it is, but the base status is
not stOK, then it assumes that someone has called a Reset for the
filter, so it calls Reset for the base stream. Borland should
have made Reset virtual, and this kludge wouldn't have been
necessary!
Procedure CheckBase;
Checks the base stream for an error. If Base^.status is not
stOK, then it calls Error with Code=stBaseError and
Info=Base^.status.
Function GetPos : longint; virtual;
Function GetSize : longint; virtual;
Procedure Read(var buf; count : word); virtual;
Procedure Seek(pos: longint); virtual;
Procedure Truncate; virtual;
Procedure Write(var buf; count: word); virtual;
Procedure Flush; virtual;
These methods all call the corresponding method in the base
stream. Offsets are translated using StartOfs. Before the call,
CheckStatus is called to propagate any Reset to the base; after
the call, CheckBase is called to propagate any errors to the
filter from the base.
2. TEncryptFilter = object(TFilter)
This is a filter which does simple encryption/decryption on the
base stream. The encryption method is to XOR each byte with a
Random(256) value; the starting RandSeed is the key for the
encryption.
FIELD
key : longint;
The key is used as a Randseed replacement value. Randseed itself
is left unmodified by Read and Write.
METHODS
Constructor Init(Akey:longint; ABase:PStream);
The value AKey is used as the starting key for byte 0 of the
filter. Anything read from ABase is decrypted using this key;
anything written to it is encrypted.
Procedure Read(var buf; count : word); virtual;
Procedure Seek(pos : longint); virtual;
Procedure Write(var buf; count: word); virtual;
These methods all encrypt/decrypt and update the value of Key to
correspond to the new position in the stream. The encryption
method uses the same algorithm for encryption as for decryption.
TEncryptFilter.Seek is fairly slow, because it updates the Key
once for every byte difference between the current position and
the new position. Moving backwards is slower, because the update
algorithm is written in Pascal, not assembler as is the forward
algorithm.
3. TLZWFilter = object(TFilter)
This is a filter which does LZW compression as it writes to and
decompression as it reads from the base stream. The LZW code is
an adaptation of Wilbert van Leijen's implementation of the 12
bit LZW algorithm. It's quite fast, though not as fast as
Wilbert's version; it gets slowed down a lot by having to save
its state after every Read and Write operation. You're best off
writing large chunks to it to take advantage of Wilbert's
excellent code. (Historical note: Trying to rewrite this was
what inspired me to write FULLDB, a program which allows source
level debugging of external .ASM files. -djm)
Each TLZWFilter takes over 28700 bytes of memory, because it
keeps extensive tables to record the current state.
One limitation of the TLZWFilter is that it can only be opened in
read or write mode, and Seek cannot be used in write mode. If
this doesn't suit your application, you might want to flesh out
the demo Huffman encoder (HUFFMAN.PAS), since it does allow
random access.
FIELDS
Mode : word;
One of stOpenRead or stOpenWrite; the mode under which this
filter was opened.
Size : longint;
The size of the expanded stream. This is the size that users of
the filter will see; if compression is working, it will generally
be bigger than Base^.GetSize.
Position : longint;
This is the position in the expanded stream.
Tables : PLZWTables;
This is a pointer to the tables used by the compression engine.
They're automatically allocated on the heap.
METHODS
Constructor Init(ABase:PStream; AMode:TOpenMode);
Allocates Tables from the heap, and opens the compressor in
a mode of either stOpenRead or stOpenWrite. If reading, a
signature and record of the uncompressed filesize is read from
the base to confirm that it is compressed by LZW, and to prime
the Tables. If writing, the signature is written to the stream.
Destructor Done; virtual;
Flushes all data to the stream, and writes the uncompressed
filesize to the head of it before calling TFilter.done.
Procedure Flush; virtual;
Function GetPos: longint; virtual;
Function GetSize:longint; virtual;
Procedure Read(var buf; count:word); virtual;
Procedure Seek(pos:longint); virtual;
Procedure Truncate; virtual;
Procedure Write(var buf; count: word); virtual;
These methods all override the basic filter methods and
compress/decompress the data. They check whether the operation
requested can be performed in the current mode, and call Error
with Code=stBadMode and Info=Mode if the operation is not
supported.
Seek is not supported at all in Write mode. In Read mode, it is
slow for seeking forwards, and very slow for seeking backwards:
it rewinds the file to the start and seeks forward from there by
expanding everything.
Truncate is not supported in either mode, and always causes a
call to Error.
Flush may only be called once; it changes Mode to 0, so any
further operations will fail.
4. TTextFilter = object(TFilter)
This is a filter which provides a Read/ReadLn/Write/WriteLn
interface to a stream through its Textfile field or through any
other Text variable. Once the filter is initialized, the
Textfile field acts exactly like a text file in the standard I/O
procedures, but reads come from the stream, and writes go to it.
All of the standard stream methods work as well.
You can also use the AssignStream method to redirect I/O for
another Text variable (e.g. System.Input or System.Output)
through the filter.
Warning: The mechanism for reporting errors on the stream uses
the standard Turbo run-time I/O errors. I've tried to map the
stream errors onto corresponding file errors, but sometimes the
error message may be a little misleading.
FIELD
Textfile : Text;
This is the dummy text file used by default in
Read/ReadLn/Write/WriteLn.
TextPtr : ^Text;
This points to the currently assigned text file; typically that
will be TextFile, but if you use the AssignStream method, it may
be different.
METHODS
Constructor Init(ABase:PStream; AName:String);
Initializes the filter with base ABase. The name AName is stored
as the name in the Textfile variable.
Destructor Done; virtual;
Closes the TextFile variable to flush any remaining data to the
stream, and then disposes of the base stream.
Procedure AssignStream(var NewText:text; AName:string);
Closes the current file attached to the stream, then assigns the
new one. You'll still need to open it for reading or writing, as
with the standard Assign procedure.
Procedure Flush; virtual;
Flushes the TextPtr^ variable to the base stream, then flushes the
base stream.
function GetPos : LongInt; virtual;
function GetSize : LongInt; virtual;
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count : Word); virtual;
Versions of the standard filter functions. These may be
intermixed with text access to the Text variable.
5. TLogFilter = object(TFilter)
This filter allows logging of activity on text files to a stream.
Logging is done very transparently. Once the TTextFilter is
initialized, you call the Log method to start logging a
particular text file, and the UnLog method to stop. When logging
is in effect, any data read from or written to the text file is
copied to the stream.
Multiple files may be logged to the same stream. For example,
you can log both Input and Output, and keep a record of an
interactive session on the stream.
It's also possible to log the same file to multiple streams.
Just create the different TLogFilter objects, and call their Log
methods with the same file as an argument. If you then call
Unlog, you must do it in the *reverse* order to the order you
called Log, e.g.
S1^.log(output);
S2^.log(output);
S2^.unlog(output);
S1^.unlog(output);
is the correct order to log and unlog.
One detail of the implementation may cause some trouble. The
data is logged to the stream at the time it is written to disk by
the text file. Since text files are buffered, this may not be
the time at which you write to the text file, and multiple text
files logged to the same stream may not have all data appearing
in the correct order. If this is a problem for you, call the
System unit Flush() procedure to flush output from the text file
to disk.
FIELD
LogList : ^Text;
This is a pointer to the first text file currently being logged.
METHODS
Constructor Init(ABase:PStream);
Initializes the filter with a LogList of nil.
Destructor done; virtual;
Stops logging all text files by calling UnLog for each, and
closes and disposes of the base stream.
Procedure Log(var F:text);
Starts logging the text file F. Continues until the UnLog method
is called or the file is closed or Assign'd.
Function UnLog(var F:text):boolean;
Stops logging the text file F. Returns true if successful, false
if not. Will fail if an Assign has been done to F, or F has been
closed, or F has already been Unlogged, or another stream has
started logging F and hasn't been UnLog'd yet.
6. TBitFilter = object(TFilter)
This filter allows you to do bit-oriented I/O to a stream,
instead of the usual byte-oriented I/O. A typical use might be
for a compression scheme: if a word only takes the values 0 or
1, you can use a TBitFilter to be sure that it only takes up one
bit of the output file.
If you use this filter, you can mix standard byte-oriented I/O
(Read, Write) with bit-oriented I/O (GetBit, GetBits, ReadBits,
PutBit, PutBits, WriteBits). There's a substantial performance
penalty however, if the bytes you write to the stream aren't
aligned with the actual bytes in the base stream.
One arbitrary choice was made: the order of bits in a byte.
This object follows the 80x86 convention of least significant
part first, and considers the least significant bit (low bit) to
come before the most significant bit (high bit) within a byte.
FIELDS
BitPos : shortint;
Position of stream relative to base file. Negative values signal
that the buffer is unchanged from the file, positive values signal
that the file needs to be updated. Zero signals an empty buffer.
Mask : byte;
The mask to use to extract the next bit from the buffer.
Buffer : byte;
A buffer to hold 8 bits.
AtEnd : boolean;
This flag is an efficiency hack. A TBitFilter can write a single
bit anywhere in a file; this means that it has to read the
existing byte before writing a new one. If it's doing a lot of
small writes at the end of the file, this can be incredibly slow,
because every one of those reads will fail. The AtEnd flag
signals that the current position of the stream is the end of the
file, and a read isn't necessary.
Normally, AtEnd is maintained internally, and you don't need to
worry about it. However, if you increase the length of the base
stream other than by writes through the TBitFilter, you
*must* set AtEnd to false, so that the bit buffer is properly
initialized. Calling Flush on the TBitFilter is sufficient to do
this, and would probably be a good idea before you fiddled with
the base anyways.
METHODS
Function GetBit : TBit;
Type TBit is a 0 or a 1. This function reads a single bit from
the stream.
Function GetBits(count : byte): longint;
This function reads up to 32 bits, and returns them in the
longint value. The first bit read ends up in the least
significant bit of the result, and bits higher than the count
are zeroed.
Procedure ReadBits(var buf; count : longint);
This procedure reads up to 524288 bits (64K bytes) from the
stream into the buffer. Reads are faster when they start on a
byte boundary. Only the bytes that are affected by the
read will be modified, with the high bits of the last byte zeroed
if necessary. For example, if you read fewer than 9 bits into a
word variable, the high byte of the word will be left untouched.
Procedure PutBit(ABit : TBit);
Write one bit to the stream.
Procedure PutBits(Abits : longint; count : byte);
Writes up to 32 bits to the stream. Since ABits is a value
parameter, you can write the value of an expression directly to
the stream without storing it in an intermediate variable.
Procedure WriteBits(var buf; count : longint);
This procedure writes up to 524288 bits (64K bytes) to the
stream. Writes are *much* faster if the starting bit is byte
aligned.
Procedure SeekBit(bitpos:longint);
Seek to a particular bit in the stream.
Function GetBitPos : longint;
Get the current stream position accurate to the nearest bit.
Procedure CopyBits(var S:TBitFilter; Count:longint);
Like CopyFrom, but for bits: copies Count bits from S.
Procedure ByteAlign;
Seeks forward to the next byte boundary. If the last byte
of the stream is only partially filled, it will be padded with
zero bits.
Procedure Read(var Buf; Count : Word); virtual;
Procedure Write(var Buf; Count : Word); virtual;
Procedure Seek(Pos : LongInt); virtual;
Procedure Flush; virtual;
Implement the standard byte-oriented functions. Note that if the
base stream is not byte-aligned at the start or a read/write,
they will split each byte between two in the output stream.
Procedure PrepareBuffer(ForRead:boolean);
Internal method to prepare the buffer for a read or a write.
7. TDupFilter = object(TFilter)
A filter which duplicates writes to two base streams, and checks
that data read from the two base streams matches. The match test
is a virtual method, so a descendant could implement a different
test if desired.
FIELDS
Base2 : PStream;
This is a pointer to the second base stream. I/O is done first
to Base^, then to Base2^.
Startofs2 : Longint;
Corresponds to TFilter.StartOfs, but applies to Base2^: gives
the offset corresponding to the filter's offset of 0.
METHODS
constructor Init(ABase, Abase2 : PStream);
Sets the two base streams and the start offset variables.
destructor Done; virtual;
Flushes the filter, then disposes of both bases if they're not
nil.
function MisMatch(var buf1,buf2; count:word):word; virtual;
Checks for a mismatch between the two buffers. Returns
the byte number of the mismatch (1 based), or 0 if they
test equal. This default method checks for an exact match.
procedure Read(var Buf; Count : Word); virtual;
Reads from Base into the buffer, then does a corresponding read
from Base2 into a local buffer calling MisMatch to check for a
mismatch. If one is found, calls the Error method to signal an
stMisMatch error, with the Info word equal to the position of
the mismatch in the current buffer.
Unless a base error occurs, the two bases will be left
synchronized at the position following the data just read.
procedure Seek(Pos : LongInt); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count : Word); virtual;
procedure Flush; virtual;
Standard methods applied to both bases.
function CheckStatus : Boolean; virtual;
Checks the status of the filter, and assures that both bases are
okay if status is stOK.
procedure CheckBase2;
Like TFilter.CheckBase, but operates on base2 and signals
stBase2Error.
8. TConcatFilter = object(TFilter)
This is another two-base filter. Unlike TDupFilter, however,
instead of treating the two bases as overlapping, this one
treats Base2 as if it follows directly after the end of Base.
Both reads and writes are directed to the appropriate base
stream.
FIELDS
Base2 : PStream;
This is a pointer to the second base stream, whose contents will
appear to follow those of the Base stream.
Startofs2 : Longint;
Corresponds to TFilter.StartOfs, but applies to Base2^: gives
the offset corresponding to the filter's offset of 0.
Position : Longint;
This is the current position of the TConcatFilter. The
corresponding base stream to this position is kept synchronized
with it.
Base1Size : Longint;
This is the size of the first base stream upon initialization,
and is used in determining when to switch. The first base will
never change in size; all writes to positions bigger than
Base1Size will be directed to the second stream.
METHODS
constructor Init(ABase, Abase2 : PStream);
Sets the two base streams and the fields. The initial position
of the stream is set to the beginning of Base2.
destructor Done; virtual;
Flushes the filter, then disposes of both bases if they're not
nil.
procedure Flush; virtual;
function GetPos:longint; virtual;
function GetSize:longint; virtual;
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count : Word); virtual;
These methods work directly on Base until its size is reached,
then switch over to Base2. Base will *never* grow from the size
at stream initialization.
function CheckStatus : Boolean; virtual;
Checks the status of the filter, and assures that both bases are
okay if status is stOK.
procedure CheckBase2;
Like TFilter.CheckBase, but operates on base2 and signals
stBase2Error.
9. TLimitFilter = object(TFilter)
This is a filter that applies upper and lower limits to the
bytes that may be accessed from the base stream. You can use it
in debugging, to detect out of range access; in programs that
allocate workspace, to limit their impact on the system; and
in other situations where you want to undo stream
concatenations.
FIELDS
LoLimit, HiLimit : longint;
These two fields define the limits for accesses. The current
position of the filter will always satisfy
LoLimit <= GetPos <= HiLimit
attempt to move it outside these limits will cause an error.
METHODS
constructor Init(ABase:PStream; ALoLimit,AHiLimit:Longint);
Does the usual TFilter.Init, sets the limits, then does a Seek
to ALoLimit if it is non-zero.
function GetSize:Longint;
Returns the smaller of HiLimit and TFilter.GetSize.
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Write(var Buf; Count : Word); virtual;
These check that the request won't move the current position
outside the limits, and raise an error if so. If not, the
request is passed on to the TFilter method.
10. TLoopFilter = object(TLimitFilter)
This filter makes a stream look like a tape loop: if you read
or write beyond the end, it loops back to the beginning. It's
descended from a TLimitFilter and uses the LoLimit and the
HiLimit as the ends of the part of the base stream that you can
see.
METHODS
function GetSize:Longint;
Returns the smaller of the length between the limits, or the
length from the lower limit to the end of the base stream.
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Write(var Buf; Count : Word); virtual;
These all act as though on an infinitely repeating stream, by
mapping all requests back into the stream range.
11. TReverseFilter = object(TFilter) and ReverseBytes
This filter lets you read or write a stream in reverse order:
both Read and Write act on the block of bytes *before* the
current file position. The GetPos and Seek methods also work in
the reversed byte order, i.e. counting bytes from the end of the
stream instead of from the beginning.
FIELD
ReverseBlocks : Boolean;
When you use a TReverseFilter, the question comes up as to
whether you want to read structures in the order in which they
were written, or whether you actually want to reverse the byte
order within each structure. This field is used to determine that.
If ReverseBlocks is true, then the byte order appears completely
reversed. If it's false, then when you do a read of more than 1
byte, the buffer gets the bytes in their original order.
METHODS
constructor init(ABase:PStream; AReverseBlocks:boolean);
The constructor calls the standard TFilter.Init constructor,
and initializes the AReverseBlocks field.
function GetPos:longint;
procedure Read(var Buf; Count : Word);
procedure Write(var Buf; Count : Word);
procedure Seek(Pos : LongInt);
These methods all act on the stream in the reverse byte order.
The action of Read and Write depends on the ReverseBlocks field
described above.
procedure Truncate;
Truncation is not supported, and a call to this method will
trigger an stUnsupported error.
PROCEDURE
procedure ReverseBytes(var Buf; Count : Word);
This procedure reverses the byte order within the buffer Buf.
It's not a TReverseFilter method, just a standard procedure.
12. TSequential = object(TFilter)
This is a very simple descendant of TFilter: the only
difference is that it signals stUnsupported if the Seek method
is called. It's used as a base for the filters below, which can
only work sequentially.
METHOD
procedure Seek(pos:longint); virtual;
Signals stUnsupported by calling Error if ever called.
13. Checksum/CRC filters
These are four filters, TChkSumFilter, TCRC16Filter,
TCRCARCFilter, and TCRC32Filter, which can be used to calculate
checksums and cyclic redundancy checks (CRCs) on the stream of
data passing through the filter in either reads or writes.
All three CRC filters are based on code by a collection of
authors: Stephen Satchell, Chuck Forsberg, Mark G. Mendel, R.
P. Byrne, J. R. Louvau and probably others. Edwin T. Floyd
collected them together and translated them to TASM. The
CRC*.ASM files include more comments about sources and usage.
The basic calculations are also available in the interfaced
procedures UpdateChksum, UpdateCRC16, UpdateCRCARC, UpdateCRC32.
See the source code for the calling details.
TChkSumFilter = object(TSequential)
TChkSumFilter calculates a 16 bit sum of all the bytes read from
or written to the stream.
TCRC16Filter = object(TSequential)
This filter calculates the same 16 bit CRC as used in XModem and
its descendants.
TCRCARCFilter = object(TSequential)
This filter calculates the 16 bit CRC used by ARC.
TCRC32Filter = object(TSequential)
This filter calculates the 32 bit CRC used by PKZIP and ZModem.
FIELDS
TChkSumFilter.Chksum : word;
The 16 bit sum of all bytes passing through the filter. If an 8
bit checksum is required, get the low byte of Chksum by using
Byte(Chksum).
TCRC16Filter.CRC16 : word;
The XModem-style 16 bit CRC of all bytes passing through the
filter.
TCRCARCFilter.CRCARC : word;
The ARC-style 16 bit CRC of all bytes passing through the
filter.
TCRC32Filter.CRC32 : longint;
The PKZIP and ZModem-style 32 bit CRC of all bytes passing
through the filter. Note that the value should be inverted
before use (i.e. use "not CRC32" rather than "CRC32") for
compatibility with those programs.
METHODS
constructor TChkSumFilter.Init(ABase : PStream;AChksum:word);
constructor TCRC16Filter.Init(ABase : PStream;ACRC16:word);
constructor TCRCARCFilter.Init(ABase : PStream;ACRCARC:word);
constructor TCRC32Filter.Init(ABase : PStream;ACRC32:word);
These constructors all initialize the filter, and set the
sum or CRC to the given value. Typically the first three would
start with a value of 0; PKZIP and ZModem start the 32 bit CRC
with a value of $FFFFFFFF.
procedure Read(var Buf; Count : Word); virtual;
procedure Write(var Buf; Count : Word); virtual;
All four filters override just these two methods. Both update
the sum or CRC if the Read/Write is successful.
14. TNulStream = object(TStream)
A stream which eats your writes, and returns a constant if you
read from it. (Suggested by Stefan Boether.)
I can see two uses for this stream. Stefan suggested using it to
count bytes: if you're not sure how much space something will
take when written out, write it to a TNulStream, and then read
the size to find out. I use it differently in the TempStream
code: there, it's used to initialize another stream to a fixed
value. I just copy as many bytes as I need from a TNulStream.
FIELDS
position : longint;
The current position of the stream. This is increased by both
reads and writes. It's also used as the current size of the
stream.
value : byte;
The value which will be used to fill any read request.
METHODS
Constructor init(Avalue : byte);
Initialize the stream with value=Avalue.
Destructor done; virtual;
Dispose of the stream.
Function getpos : longint; virtual;
Function getsize : longint; virtual;
Procedure read(var buf; count : word); virtual;
Procedure seek(pos: longint); virtual;
Procedure write(var buf; count: word); virtual;
Implement the basic stream functions.
15. TRAMStream = object(TStream)
A stream which resides entirely in RAM, either maintaining its
own buffer, or using a predefined buffer. The maximum length
is 65520 bytes.
FIELDS
cp : word;
The current pointer for the stream.
size : word;
The current size of the stream.
alloc : word;
The size of the allocated block of memory.
buffer : Pbyte_array;
A pointer to the block of memory holding the stream data.
OwnMem : Boolean;
Indicates whether the stream "owns" the buffer, and should dispose
of it in the Done destructor.
METHODS
Constructor init(ASize : word);
Attempt to initialize the stream to a block size of Asize;
initial stream size and position are 0.
Constructor UseBuf(Abuffer : pointer; Asize : word);
Set up the stream using the given buffer; OwnMem is set to false,
so that the memory will not be disposed when done. Initial
position is 0 and size is Asize.
Destructor done; virtual;
Dispose of the stream, and if OwnMem is true, the data buffer.
Function getpos : longint; virtual;
Function getsize : longint; virtual;
Procedure read(var buf; count : word); virtual;
Procedure seek(pos: longint); virtual;
Procedure truncate; virtual;
Procedure write(var buf; count: word); virtual;
Implement the basic stream functions.
16. TXMSStream = object(TStream)
A stream which keeps its data in XMS (extended) memory.
FIELDS
Handle : word;
The handle used by the XMS memory manager for the stream's block
of data.
MaxBlocks : word;
The maximum number of 1K blocks of memory to allocate.
BlocksUsed : word;
The number of 1K blocks of memory currently allocated. Always
allocates at least 1 byte more than Size.
Size : longint;
The current size of the stream.
Position : longint;
The current position of the stream.
METHODS
Constructor init(MinSize,MaxSize : longint);
Attempts to allocate a block of XMS memory of at least MinSize
bytes. MaxSize is treated like the MaxSize parameter of
TEMSStream.Init: the Init will try to allocate a block that can
grow to MaxSize, but won't signal an error if it gets a smaller
one. If you definitely need a certain size, specify it as
MinSize.
Destructor done; virtual;
Dispose of the stream, and release the XMS memory.
Function getpos : longint; virtual;
Function getsize : longint; virtual;
Procedure read(var buf; count : word); virtual;
Procedure seek(pos: longint); virtual;
Procedure truncate; virtual;
Procedure write(var buf; count: word); virtual;
Implement the basic stream functions.
Procedure NewBlock;
Internal method to increase the stream's allocation by one block.
Procedure FreeBlock;
Internal method to decrease the stream's allocation by one block.
Doesn't check if the allocated size falls below Size.
17. xms_MemAvail, xms_MaxAvail, ems_MemAvail, ems_MaxAvail,
disk_MemAvail, disk_MaxAvail
These procedures are analogous to the MemAvail and MaxAvail
procedures in the System unit. They report on available XMS and
EMS memory, and disk space on the drives mentioned in the
TempEnvVar directories. As of release 1.4, they report in bytes,
just as the standard functions do.
18. TNamedBufStream = object(TBufStream)
A simple descendant of TBufStream which knows its own name.
FIELD
filename : PString { PChar in TPW };
The name of the stream.
METHODS
Constructor Init(name:FNameStr;mode:TOpenMode;abufsize:word);
Open the file with the given name, and save the name.
Destructor Done; virtual;
Close the file.
19. TTempBufStream = object(TNamedBufStream)
A temporary buffered file stream, which deletes itself when done.
It's allocated in one of the directories specified by TempEnvVar.
METHODS
Constructor init(abufsize:word;InitSize,MaxSize : Longint);
Create a temporary file with a unique name, in a directory
pointed to by the environment variable named in TempEnvVar or in
the current directory, and open it in read/write mode. The
constructor will only be successful if the file can be set to
InitSize bytes. The directory chosen will be the first with
at least MaxSize bytes available, or, if none has that much
space, the one with the largest space available.
Destructor done; virtual;
Close and delete the temporary file.
20. Function TempStream(InitSize,MaxSize : longint;
Preference:TStreamRanking):PStream;
This procedure returns a pointer to a temporary stream from a
choice of 4, specified in the Preference array. The first stream
type listed in the Preference array which can be successfully
created with the given sizes will be returned, or Nil if none can
be made.
ARGUMENTS
Initsize : longint;
The initial size to allocate to the stream. This many nulls will
be written to the stream, and then the position will be set to
byte 0.
MaxSize : longint;
The maximum size to which the stream should be allowed to grow.
The stream will be allocated to a particular type only if there
are at least MaxSize bytes available at the time of the call to
TempStream. However, the space isn't reserved; there's no
guarantee that the space will still be available at the time your
stream grows to that size.
Preference : TStreamRanking;
An array of 4 entries specifying what sort of temporary stream is
desired. Supplied constants include:
ForSpeed = (RAMStream, EMSStream, XMSStream, FileStream);
ForSize = (FileStream,EMSStream, XMSStream, RAMStream);
ForSizeInMem = (EMSStream, XMSStream, RAMStream, NoStream);
ForOverlays = (EMSStream, XMSStream, FileStream, NoStream);
21. TWorkStream = object(TFilter)
This is a stream that can grow as you write to it. You can
allocate it small at first, and then if it turns out that you
need more space, it'll allocate additional blocks. The nice
feature of this stream as compared to the other kinds of stream
is that when it runs out of one kind of memory (RAM, EMS, XMS, or
disk) it'll move continue in the next.
Though a descendant of TFilter, this type is more of a stream
than a filter, because it manages its own base. It starts out by
allocating one block of the size you specify (see the Init method
for the details). If it has a write error on that block, it
allocates a new one, and uses a TConcatFilter to attach them
together. In effect, this creates a linked list of streams.
FIELDS
Allocate : TAllocator;
This is a procedural parameter pointing to the function which
will be used to allocate the next block. Typically TempStream
would be used for the allocations.
BlockMin,
BlockMax : longint;
Preference : TStreamRanking;
These are the parameters which will be passed to Allocate when a
new block is needed. If you don't use TempStream, your allocator
can interpret them however it likes.
The field Blockmax is also used by the TWorkStream when it does
its writes. It splits up any write that might cross offset
Blockmax in the current block into two writes, one on either
side. This means that any stream like a TRamStream that really
has a known physical size limit will be completely filled before
a write fails and a new block needs to be allocated.
BlockStart: longint;
This is the offset in the stream where the last block (the only
one which can be expanded) starts.
METHODS
constructor Init(Allocator:TAllocator;ABlockmin,ABlockMax:Longint;
APreference : TStreamRanking);
The arguments to Init serve as initial values to the fields with
corresponding names, described above. After those are set, Init
does the first allocation using Allocate, and sets the result as
the base stream.
procedure Write(var Buf; Count:Word); virtual;
This is the only TFilter method which TWorkStream overrides. It
passes most writes through to the base stream, but if an error
occurs, it allocates a new block, concatenates it on to the
existing part of the stream using TConcatFilter, and does the
write there. The only writes which don't go directly to the Base
first are those which would cross the ABlockMax byte of the
current block; they're split up into two parts.
22. Stream overlay procedures
These procedures allow overlays to be buffered on any stream or
combination of streams. Some overlays can be loaded into EMS,
others kept on disk, and others can be put onto any other
available stream.
PROCEDURES/FUNCTIONS
Procedure OvrInitStream(S:PStream);
Copies overlay segment code to S as new segments are loaded, and
does reloads from there. You may call OvrInitStream multiple
times, and different segments will be buffered on different
streams, depending on the order in which they are loaded by the
overlay loader.
On the first call, an exit handler is installed which will call
OvrDisposeStreams upon program termination.
Procedure OvrDetachStream(BadS:PStream);
Makes sure that the overlay system makes no references to BadS.
Call this before disposing of a stream which has been passed to
OvrInitStream, or you're very likely to crash.
Procedure OvrDisposeStreams;
Detaches and disposes of all streams being used by the overlay
system.
Function OvrSizeNeeded:longint;
Returns the additional size required to load any segments which
still haven't been loaded to a stream.
Function OvrLoadAll:boolean;
Forces all overlay segments to be copied into the stream; if
successful (true) then no more references to the overlay file
will be made.
Warning: This function calls OvrClearBuf, so that any overlay
files which are already in the regular overlay buffer will need
to be reloaded.
23. TEMSStream2 = object(TEMSStream)
Borland made a small mistake when they wrote TEMSStream. The
done destructor can leave the global variable EMSCurHandle
with the handle of a page that has been freed. If the next
EMS stream happens to get the same handle, TEMSStream won't
bother mapping it into the page frame, because it thinks it's
already there.
TEMSStream2 overrides the Done destructor to fix this problem.
Destructor Done;
Calls TEMSStream.done, then sets EMSCurhandle to $FFFF to signal
that the current page is no longer valid.
24. procedure FastCopy(var src,dest: TStream; size:longint);
This procedure behaves just like dest.copyfrom(src,size), but
will be quite a bit faster on large copies, because it tries to
use a large buffer on the heap. (Copyfrom uses a 512 byte buffer
on the stack.) If the heap space isn't there, it falls back to
using CopyFrom.
25. Miscellaneous constants and types
CONSTANTS
stBadMode = 1;
Error signalled when an operation is not permitted in the current
mode.
stStreamFail = 2;
Error signalled when a stream Init failed.
stBaseError = 3;
Error signalled by a TFilter when the base stream has an error;
the base stream's error number is put in the Info field.
stMemError = 4;
Not enough memory for operation.
stSigError = 5;
Problem with LZW file signature.
stUsedAll = 6;
XMS stream has used all of its allowed blocks.
stUnsupported = 7;
Operation unsupported in this stream. TSequential signals this
error if Seek is called.
stBase2Error = 8;
Error in second base in a TDupFilter; Info gets the Base2^.Error
value.
stMisMatch = 9;
The two bases don't match on a read. The Info field is set to
the position of the mismatch in the current read buffer.
BufSize : word = 2048;
Buffer size to use when creating a buffered file stream in
TempStream.
TempEnvVar : String[12] = 'TEMP';
This is the name of the environment variable to look in for a
list of directories when creating a TTempBufStream, or when
reporting on available space with disk_MaxAvail or disk_MemAvail.
If the environment variable doesn't exist, all the procedures
treat it as though it specifies the current directory.
TYPES
TOpenMode = $3C00..$3DFF;
This is the widest possible range of open modes for a TDOSStream
descendant. Values outside this range can cause very serious bugs in
programs, since the high byte is used as the DOS service number
when the file is opened.
PLZWTables = ^TLZWTables;
TLZWTables = record ...
These tables are used internally to maintain the state of a
TLZWFilter.
PByte_Array = ^TByte_Array;
TByte_Array = array[0..65520] of byte;
An array type used as a buffer in several places.
TStreamType = (NoStream, RAMStream, EMSStream, XMSStream, FileStream);
The types of streams that TempStream can create.
TStreamRanking = array[1..NumTypes] of TStreamType;
An array giving the order from most preferred to least preferred
for a temporary stream.
TAllocator = function (InitSize, MaxSize : LongInt;
Preference : TStreamRanking) : PStream;
A function like TempStream which allocates new streams. One of
these is used by TWorkStream to allocate new blocks. It should
create a stream which is at least InitSize bytes, and likely
capable of growing to MaxSize bytes, if condition don't change.
The Preference array indicates the desired strategy for
allocating.
26. Release history and credits
1.0 - First release, missing LZW. Immediately replaced by
1.1 - First correct release: TFilter, TEncryptFilter, TTextFilter,
TLogFilter, TRAMStream, TNamedBufStream, TTempBufStream,
TempStream, overlay procedures (my ideas), TLZWFilter
(from code by Wilbert van Leijen)
1.2 - TNulStream, TXMSStream added (from Stefan Boether)
TBitFilter added (suggestion of Rene Seguin)
TFilter.Done calls Flush
TRAMStream.UseBuf and OwnMem added.
1.3 - TDupFilter, TSequential, TChksumFilter added (my ideas),
TCRC16Filter, TCRCARCFilter, TCRC32Filter and related procedures
added (from code by Edwin T. Floyd, Stephen Satchell, Chuck
Forsberg, Mark G. Mendel, R. P. Byrne, J. R. Louvau and
probably others); TFilter.Flush added; HUFFMAN demo added.
1.4 - Recoded several of the TRAMStream methods in assembler for
more speed; fixed numerous TTextFilter bugs and added
TTextFilter.AssignStream and TextDemo.pas; fixed
TXMSStream.Seek bug. Changed xms_Memavail and xms_Maxavail
to report in bytes, and added ems_Memavail and ems_Maxavail
(based on code sent to me by Eyal Doron) and disk_Memavail
and disk_Maxavail. Changed TXMSStream.Init to match
TEMSStream.Init. Added TConcatFilter, TLimitFilter,
TLoopFilter, TReverseFilter and TWorkStream. Added OwnsBase
field to TFilter. Did some testing to assure that the unit
works in BP 7 protected mode. Thanks to Max Maschein, Eyal
Doron, and others for bug fix help.
1.5 - The first public release of the 1.4 enhancements.
1.6 - Fixed bugs: Getmem returning nil, Reversebytes, termination
of TLZWStream, workaround for Borland's TEMSStream bug,
improved speed of TTextFilter, added FastCopy

view raw

streams.doc

hosted with ❤ by GitHub


unit Streams;
{ Unit to provide enhancements to TV Objects unit streams in the form
of several filters, i.e. stream clients, and other streams. }
{#Z+} { These comments don't need to go into the help file. }
{$B-} { Use fast boolean evaluation. }
{ Version 1.2 - Adds TNulStream and TXMSStream, from suggestion and
code by Stefan Boether; TBitFilter, from suggestion
by Rene Seguin; added call to Flush to TFilter.Done;
UseBuf and OwnMem to TRAMStream.
TTextFilter fixed so that mixed access methods work.
1.3 - Added TDupFilter, TSequential, CRCs and Checksums
1.4 - Recoded several of the TRAMStream methods in assembler for
more speed; fixed numerous TTextFilter bugs and added
TTextFilter.AssignStream and TextDemo.pas; fixed
TXMSStream.Seek bug. Changed xms_Memavail and xms_Maxavail
to report in bytes, and added ems_Memavail and ems_Maxavail
(based on code sent to me by Eyal Doron) and disk_Memavail
and disk_Maxavail. Changed TXMSStream.Init to match
TEMSStream.Init. Added TConcatFilter, TLimitFilter,
TLoopFilter, TReverseFilter and TWorkStream. Added OwnsBase
field to TFilter. Did some testing to assure that the unit
works in BP 7 protected mode. Thanks to Max Maschein, Eyal
Doron, and others for bug fix help.
1.5 - The first public release of the 1.4 enhancements.
1.6 - fixed some bugs when Getmem returns nil
fixed bug in ReverseBytes
fixed bug in termination of TLZWstream
added workaround for TEMSStream bug, FastCopy }
{ Load some conditional defines }
{$i STDefine.inc}
{$ifdef overlays}
{$O-}
{ Don't overlay this unit; it contains code that needs to participate
in overlay management. }
{$endif}
{ Hierarchy:
TStream (from Objects)
TFilter Base type for filters
TEncryptFilter Encrypts as it writes; decrypts as it reads
TLZWFilter Compresses as it writes; expands as it reads
TTextFilter Provides text file interface to stream
TLogFilter Provides logging of text file activity
TBitFilter Allows reads & writes by the bit
TDupFilter Duplicates output, checks for matching input
TConcatFilter Concatenates two streams
TLimitFilter Limits I/O to a specific range
TLoopFilter Joins end of stream to start
TReverseFilter Reads and writes the stream in reverse order
TSequential Filter that doesn't allow Seek
TChksumFilter Calculates 16 bit checksum for reads and writes
TCRC16Filter Calculates XMODEM-style 16 bit CRC
TCRCARCFilter Calculates ARC-style 16 bit CRC
TCRC32Filter Calculates ZIP/ZModem-style 32 bit CRC
TNulStream Eats writes, returns constant on reads
TRAMStream Stream in memory
TEMSStream2 Bug workaround for Borland's TEMSStream
TXMSStream Stream in XMS
TDOSStream (from Objects)
TBufStream (from Objects)
TNamedBufStream Buffered file stream that knows its name
TTempBufStream Buffered file stream that erases itself when done
TWorkStream Stream that grows as needed
Procedures & functions:
TempStream allocates a temporary stream
OvrInitStream like OvrInitEMS, but buffers overlays on a stream
May be called several times to buffer different
segments on different streams.
OvrDetachStream detaches stream from overlay system
OvrDisposeStreams detaches all streams from overlay system and disposes of
them
OvrSizeNeeded Calculates the size needed to load the rest of the segments
to a stream
OvrLoadAll immediately copies as many overlay segments to the stream
as will fit
UpdateChkSum updates a 16 bit checksum value
UpdateCRC16 updates a CRC16 value
UpdateCRCARC updates a CRCARC value
UpdateCRC32 updates a CRC32 value
ReverseBytes reverses the byte order within a buffer
}
{#Z-}
interface
uses
{$ifdef windows}
strings,windos,winprocs,
{$else}
DOS,
{$endif}
{$ifdef overlays}
Overlay,
{$endif}
{$ifdef wobjects}
Wobjects;
{$else}
Objects;
{$endif}
const
stBadMode = 1; { Bad mode for stream - operation not
supported. ErrorInfo = mode. }
stStreamFail = 2; { Stream init failed }
stBaseError = 3; { Error in base stream. ErrorInfo = base error value }
stMemError = 4; { Not enough memory for operation }
stSigError = 5; { Problem with LZ file signature }
stUsedAll = 6; { Used limit of allocation }
stUnsupported = 7; { Operation unsupported in this stream }
stBase2Error = 8; { Error in second base. ErrorInfo = base2 error value }
stMisMatch = 9; { Two bases don't match. ErrorInfo = mismatch position
in current buffer. }
stIntegrity = 10; { Stream has detected an integrity error
in a self check. Info depends on
stream type. }
type
TOpenMode = $3C00..$3DFF; { Allowable DOS stream open modes }
{$ifdef windows}
FNameStr = PChar; { To make streams take names as in the manual. }
{$endif}
PFilter = ^TFilter;
TFilter =
object(TStream)
{ Generic object to filter another stream. TFilter just passes everything
through, and mirrors the status of the base stream }
Base : PStream;
{ Pointer to the base stream. }
Startofs : LongInt;
{ The offset of the start of the filter in the base stream. }
OwnsBase : Boolean;
{ Defaults true; if set to false, then #Done# won't dispose of
the base. }
constructor Init(ABase : PStream);
{ Initialize the filter with the given base. }
destructor Done; virtual;
{ Flush filter, then dispose of base if #OwnsBase#. }
function GetPos : LongInt; virtual;
function GetSize : LongInt; virtual;
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count : Word); virtual;
procedure Flush; virtual;
function CheckStatus : Boolean; virtual;
{ Return true if status is stOK.
If status is stOK, but base is not, then reset the base. This is a poor
substitute for a virtual Reset method. }
procedure CheckBase;
{ Check base stream for error, and copy status using own Error method. }
end;
PEncryptFilter = ^TEncryptFilter;
TEncryptFilter =
object(TFilter)
{ Filter which encrypts text going in or out; encrypting twice with the same
key decrypts. Not very sophisticated encryption. }
Key : LongInt;
{ Key is used as a Randseed replacement }
constructor Init(Akey : LongInt; ABase : PStream);
{ Init with a given key }
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
const
MaxStack = 4096; { Must match lzwstream.asm declaration! }
type
PLZWTables = ^TLZWTables;
TLZWTables =
record
Collision : array[0..MaxStack-1] of Byte; { Hash table entries }
PrefixTable : array[0..MaxStack-1] of Word; { Code for preceding stringf }
SuffixTable : array[0..MaxStack-1] of Byte; { Code for current character }
ChildTable : array[0..MaxStack-1] of Word; { Next duplicate in collision
list. }
CharStack : array[0..MaxStack-1] of Byte; { Decompression stack }
StackPtr : Word; { Decompression stack depth }
Prefix : Word; { Previous code string }
TableUsed : Word; { # string table entries used }
InputPos : Word; { Index in input buffer }
OutputPos : Word; { Index in output buffer }
LastHit : Word; { Last empty slot in collision
table. }
CodeBuf : Word;
SaveIP : Word;
SaveAX : Word;
SaveCX : Word;
SaveDX : Word;
NotFound : Byte; { Character combination found
flag. }
end;
PLZWFilter = ^TLZWFilter;
TLZWFilter =
object(TFilter)
Mode : Word; { Either stOpenRead or stOpenWrite. }
Size, { The size of the expanded stream. }
Position : LongInt; { The current position in the expanded stream }
Tables : PLZWTables; { Tables holding the compressor state. }
constructor Init(ABase : PStream; AMode : TOpenMode);
{ Create new compressor stream, to use ABase as the source/destination
for data. AMode must be stOpenRead or stOpenWrite. }
destructor Done; virtual;
{ Flushes all data to the stream, and writes the uncompressed
filesize to the head of it before calling TFilter.done. }
procedure Flush; virtual;
function GetPos : LongInt; virtual;
function GetSize : LongInt; virtual;
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
{ Seek is not supported at all in Write mode. In Read mode, it is
slow for seeking forwards, and very slow for seeking backwards:
it rewinds the file to the start and readforward from there. }
procedure Truncate; virtual;
{ Truncate is not supported in either mode, and always causes a
call to Error. }
procedure Write(var Buf; Count : Word); virtual;
end;
type
PTextFilter = ^TTextFilter;
TTextFilter =
object(TFilter)
{ A filter to provide ReadLn/WriteLn interface to a stream. First
open the stream and position it, then pass it to this filter;
then Reset, Rewrite, or Append the Textfile variable, and do all
reads and writes to it; they'll go to the stream through a TFDD.
You can also assign the stream to any other text variable using
the #AssignStream# method. }
TextFile : Text;
{ A fake text file to use with Read(ln)/Write(ln). }
TextPtr : ^text;
{ A pointer to the text file used by the filter. Initialized
to point to TextFile, but #AssignStream# will change TextPtr. }
constructor Init(ABase : PStream; AName : String);
{ Initialize the interface to ABase; stores AName in the name field of
#Textfile#. AName isn't used beyond this, but may be helpful
if you choose to watch the TextFile field in the debugger. }
destructor Done; virtual;
{ Flushes the text file, then closes and disposes of the base stream. }
procedure AssignStream(var NewText:text; AName : String);
{ Close the currently assigned text file, and assign a new one.
As with #Init#, the name is stored in NewText, but is not otherwise
used.}
function GetPos : LongInt; virtual;
function GetSize : LongInt; virtual;
procedure Flush; virtual;
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
type
PLogFilter = ^TLogFilter;
TLogFilter =
object(TFilter)
{ A filter to log activity on a text file. }
LogList : ^Text; { A pointer to the first logged file }
constructor init(ABase:PStream);
{ Initializes filter, but doesn't start logging anything }
destructor Done; virtual;
{ Stops logging all files, and closes & disposes of the base stream }
procedure Log(var F : Text);
{ Logs all input and output to F to the stream. You must do the Assign to
F first, and not do another Assign without closing F. }
function Unlog(var F : Text) : Boolean;
{ Stops logging of F. Called automatically if file is closed. Returns
false and does nothing on error. }
end;
TBit = 0..1; { A single bit }
PBitFilter = ^TBitFilter;
TBitFilter =
object(TFilter)
BitPos : ShortInt;
{ Position of stream relative to base file. Negative values signal
that the buffer is unchanged from the file, positive values signal
that the file needs to be updated. Zero signals an empty buffer. }
Mask : Byte; { Mask to extract next bit from buffer }
Buffer : Byte; { Buffer of next 8 bits from stream }
AtEnd : Boolean; { Flag to signal that we're at the end
of the base, and we shouldn't read
it. Bases that change in length should
set this to false. }
constructor Init(ABase : PStream);
procedure Flush; virtual; { Flush buffer to stream }
procedure Seek(Pos : LongInt); virtual; { Seek to bit at start of
pos byte. }
procedure Read(var Buf; Count : Word); virtual;
procedure Write(var Buf; Count : Word); virtual;
function GetBit : TBit; { Get next bit from stream }
function GetBits(Count : Byte) : LongInt; { Get up to 32 bits }
procedure ReadBits(var Buf; Count : LongInt); { Read bits from stream }
procedure PutBit(ABit : TBit); { Put one bit to stream }
procedure PutBits(ABits : LongInt; Count : Byte); { Put up to 32 bits,
low bits first. }
procedure WriteBits(var Buf; Count : LongInt); { Write count bits to stream }
procedure SeekBit(Pos : LongInt); { Seek to particular bit }
function GetBitPos : LongInt;
procedure CopyBits(var S : TBitFilter; Count : LongInt); { Copy bits from S }
procedure ByteAlign; { Seek forward to next byte boundary. }
procedure PrepareBuffer(ForRead : Boolean);
{ Internal method to assure that buffer is valid }
end;
PDupFilter = ^TDupFilter;
TDupFilter =
object(TFilter) { Duplicates output, confirms matching input }
Base2 : PStream;
{ Pointer to the second base. }
Startofs2 : LongInt;
{ The offset of the start of the filter in the second base. }
constructor Init(ABase, ABase2 : PStream);
{ Initialize the filter with the given bases. }
destructor Done; virtual;
{ Flush filter, then dispose of both bases. }
function MisMatch(var buf1,buf2; count:word):word; virtual;
{ Checks for a mismatch between the two buffers. Returns
the byte number of the mismatch (1 based), or 0 if they
test equal. This default method checks for an exact match. }
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count : Word); virtual;
procedure Flush; virtual;
function CheckStatus : Boolean; virtual;
{ Return true if status is stOK.
If status is stOK, but base is not, then reset the base. This is a poor
substitute for a virtual Reset method. }
procedure CheckBase2;
{ Check 2nd base stream for error, and copy status using own Error method. }
end;
PConcatFilter = ^TConcatFilter;
TConcatFilter =
object(TFilter)
{ A filter which acts to concatenate two streams (or parts of streams)
so that they appear as one.}
Base2 : PStream;
{ Pointer to the second base. This one logically follows the first.}
Startofs2 : LongInt;
{ The offset of the start of the filter in the second base. }
Position : Longint;
{ The current position of the filter. The corresponding
base stream is kept synchronized with this }
Base1Size : Longint;
{ This is used a lot to determine switching. }
constructor Init(ABase, ABase2 : PStream); { Initialize the filter with the given bases. }
destructor Done; virtual;
{ Flush filter, then dispose of both bases. }
function GetPos:longint; virtual;
function GetSize:longint; virtual;
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count : Word); virtual;
procedure Flush; virtual;
{ These methods work directly on Base until its size
is reached, then switch over to Base2. Base will *never* grow
from the size at stream initialization. }
function CheckStatus : Boolean; virtual;
procedure CheckBase2;
{ Check 2nd base stream for error, and copy status using own Error method. }
end;
PLimitFilter = ^TLimitFilter;
TLimitFilter =
object(TFilter)
{ Limits all access to the bytes between LoLimit and HiLimit. }
LoLimit,HiLimit : longint;
{ The lower and upper limit points. These are in the TFilter
scale, i.e. relative to #TFilter.Base#. }
constructor init(ABase:PStream;ALoLimit,AHiLimit:longint);
{ Does the usual init, sets the limits, then does a Seek to ALoLimit
if it is non-zero. }
function GetSize:longint; virtual;
{ Returns the smaller of HiLimit and the #TFilter.GetSize# value. }
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
PLoopFilter = ^TLoopFilter;
TLoopFilter =
object(TLimitFilter)
{ Moves all access to the bytes between LoLimit and HiLimit. }
function GetSize:longint; virtual;
{ Returns the smaller of the size between the limits, or from
the low limit to the end of the base }
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
PReverseFilter = ^TReverseFilter;
TReverseFilter =
object(TFilter)
{ Reads and writes the base in reverse order. }
ReverseBlocks : Boolean; { Whether to reverse the bytes within
a Read/Write block }
constructor init(ABase:PStream; AReverseBlocks:boolean);
{ Standard initialization }
function GetPos:longint; virtual;
{ Returns the position in bytes from the end of the base }
procedure Read(var Buf; Count : Word); virtual;
{ See #Write#. }
procedure Write(var Buf; Count : Word); virtual;
{ These methods read/write the block of bytes just previous to
the current base file pointer. The bytes themselves are
reversed if #ReverseBlocks# is true. }
procedure Seek(Pos : LongInt); virtual;
{ Does the Seek in the reversed byte order, i.e. count from the
end of the stream }
procedure Truncate; virtual;
{ Triggers an #stUnsupported# error. }
end;
procedure ReverseBytes(var Buf; Count : Word);
{ Reverses the order of the bytes in the buffer }
type
PSequential = ^TSequential;
TSequential =
object(TFilter) { Filter for sequential access only }
procedure Seek(pos:longint); virtual;{ Signals stUnsupported if a Seek is attempted }
end;
PChksumFilter = ^TChksumFilter;
TChksumFilter =
object(TSequential) { Calculates 16 bit checksum of
bytes read/written. }
Chksum : word;
constructor Init(ABase : PStream;AChksum:word);
{ Initialize the filter with the given base and starting checksum. }
procedure Read(var Buf; Count : Word); virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
PCRC16Filter = ^TCRC16Filter;
TCRC16Filter =
object(TSequential) { Calculates XMODEM style 16 bit CRC }
CRC16 : word;
constructor Init(ABase : PStream;ACRC16:word);
{ Initialize the filter with the given base and starting CRC. }
procedure Read(var Buf; Count : Word); virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
PCRCARCFilter = ^TCRCARCFilter;
TCRCARCFilter =
object(TSequential) { Calculates ARC-style 16 bit CRC }
CRCARC : word;
constructor Init(ABase : PStream;ACRCARC:word);
{ Initialize the filter with the given base and starting CRC. }
procedure Read(var Buf; Count : Word); virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
PCRC32Filter = ^TCRC32Filter;
TCRC32Filter =
object(TSequential) { Calculates PKZIP and ZModem style 32 bit CRC }
CRC32 : longint;
constructor Init(ABase : PStream;ACRC32:longint);
{ Initialize the filter with the given base and starting CRC. }
procedure Read(var Buf; Count : Word); virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
PNulStream = ^TNulStream;
TNulStream =
object(TStream)
Position : LongInt; { The current position for the stream. }
Value : Byte; { The value returned on reads. }
constructor Init(AValue : Byte);
function GetPos : LongInt; virtual;
function GetSize : LongInt; virtual;
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
Pbyte_array = ^Tbyte_array;
Tbyte_array = array[0..65520] of Byte; { Type used as a buffer. }
PRAMStream = ^TRAMStream;
TRAMStream =
object(TStream)
Position : Word; { The current position for the stream. }
Size : Word; { The current size of the stream. }
Alloc : Word; { The size of the allocated block of memory. }
Buffer : Pbyte_array; { Points to the stream data. }
OwnMem : Boolean; { Whether Done should dispose of data.}
constructor Init(Asize : Word);
{ Attempt to initialize the stream to a block size of Asize;
initial stream size and position are 0. }
constructor UseBuf(ABuffer : Pointer; Asize : Word);
{ Initialize the stream using the specified buffer. OwnMem is set
to false, so the buffer won't be disposed of. Initial position is 0,
size is Asize. }
destructor Done; virtual;
{ Dispose of the stream. }
function GetPos : LongInt; virtual;
function GetSize : LongInt; virtual;
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count : Word); virtual;
end;
PEMSStream2 = ^TEMSStream2;
TEMSStream2 = object(TEMSStream)
destructor done; virtual;
{ Corrects bug in #TEMSStream# that leaves #EMSCurPage# wrong when
done is called }
end;
PXMSStream = ^TXMSStream;
TXMSStream =
object(TStream)
Handle : Word; { XMS handle }
BlocksUsed : Word; { Number of 1K blocks used. Always allocates
at least one byte more than Size. }
Size : LongInt; { The current size of the stream }
Position : LongInt; { Current position }
constructor Init(MinSize,MaxSize:longint);
destructor Done; virtual;
function GetPos : LongInt; virtual;
function GetSize : LongInt; virtual;
procedure Read(var Buf; Count : Word); virtual;
procedure Seek(Pos : LongInt); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count : Word); virtual;
procedure NewBlock; { Internal method to allocate a block }
procedure FreeBlock; { Internal method to free one block }
end;
function xms_MemAvail : Longint;
{ Returns total of available XMS bytes. }
function xms_MaxAvail : Longint;
{ Returns size of largest available XMS block in bytes. }
function ems_MemAvail : Longint;
{ Returns total of available EMS in bytes. }
function ems_MaxAvail : Longint;
{ Returns size of largest available EMS block in bytes. }
const
TempEnvVar : String[12] = 'TEMP';
{ The name of an environment variable holding a directory list
where #TTempBufStream# should go looking for disk space. }
function disk_MemAvail : Longint;
{ Returns total of available disk space for temp streams, from the
list specified by #TempEnvVar#. }
function disk_MaxAvail : Longint;
{ Returns maximum available block of disk space for temp streams,
from the list specified by #TempEnvVar#. }
type
PNamedBufStream = ^TNamedBufStream;
TNamedBufStream =
object(TBufStream)
{ A simple descendant of TBufStream which knows its own name.}
{$ifdef windows}
filename : PChar;
{$else}
Filename : PString;
{$endif}
{ The name of the stream. }
constructor Init(Name : FNameStr; Mode : TOpenMode; ABufSize : Word);
{ Open the file with the given name, and save the name. }
destructor Done; virtual;
{ Close the file. }
end;
PTempBufStream = ^TTempBufStream;
TTempBufStream =
object(TNamedBufStream)
{ A temporary buffered file stream, which deletes itself when done.
It's allocated on one of the directories specified by #TempEnvVar#.}
constructor Init(ABufSize : Word;InitSize,MaxSize : Longint);
{ Create a temporary file with a unique name, in the directory
pointed to by the environment varable named in #TempEnvVar# or in
the current directory, open it in read/write mode, and try to grow
it to InitSize bytes. }
destructor Done; virtual;
{ Close and delete the temporary file. }
end;
TStreamType = (NoStream, RAMStream, EMSStream, XMSStream, FileStream);
{ The type of stream that a tempstream might be. }
const
NumTypes = Ord(FileStream);
type
TStreamRanking = array[1..NumTypes] of TStreamType;
{ A ranking of preference for a type of stream, from most to least preferred }
TAllocator = function (InitSize, MaxSize : LongInt;
Preference : TStreamRanking) : PStream;
{ This is a declaration just like the Streams.TempStream function.}
PWorkStream = ^TWorkStream;
TWorkStream =
object(TFilter)
{ This is a stream type that grows as you write to it by allocating new
blocks according to a specified strategy. Blocks may be of mixed
types. It's a descendant of a filter, but it manages its own base. }
Allocate : TAllocator;
BlockMin, { These fields are passed to Allocate }
BlockMax : longint;
Preference : TStreamRanking;
BlockStart: longint; { The offset in the stream where the
last block starts. }
constructor init(Allocator:TAllocator;ABlockmin,ABlockMax:Longint;
APreference : TStreamRanking);
{ ABlockmin to APreference are passed to the allocator to allocate
a new block whenever the current one gives a write error.
The TWorkStream will never try to write a single block that crosses
the ABlockMax boundary, so tests within the stream can be simple.}
procedure write(var Buf; Count:Word); virtual;
{ The write procedure checks whether the write would make the
current block grow too large; if so, it splits up the write. }
end;
const
BufSize : Word = 2048; { Buffer size if buffered stream is used. }
const ForSpeed : TStreamRanking = (RAMStream, EMSStream, XMSStream, FileStream);
{ Streams ordered for speed }
const ForSize : TStreamRanking = (FileStream, EMSStream, XMSStream, RAMStream);
{ Streams ordered for low impact on the heap }
const ForSizeInMem : TStreamRanking = (EMSStream, XMSStream, RAMStream, NoStream);
{ Streams in memory only, ordered as #ForSize#. }
const ForOverlays : TStreamRanking = (EMSStream, XMSStream, FileStream, NoStream);
{ Streams ordered for speed, but never in RAM. }
function TempStream(InitSize, MaxSize : LongInt;
Preference : TStreamRanking) : PStream;
{ This procedure returns a pointer to a temporary stream from a
choice of 3, specified in the Preference array. The first stream
type listed in the Preference array which can be successfully
created with the given sizes will be returned, or Nil if none can
be made. }
function StreamName(S:PStream):String;
{ This function returns a string naming the type of S^. It's useful for
debugging programs that use TempStream and TWorkStream. However,
it's for debugging only! It links every single stream type into your
.EXE. }
{$ifdef overlays}
procedure OvrInitStream(S : PStream);
{ Copies overlay segment code to S as new segments are loaded,
and does reloads from there. Allows multiple calls, to buffer
different segments on different streams. }
procedure OvrDetachStream(BadS : PStream);
{ Makes sure that the overlay system makes no references to BadS. }
procedure OvrDisposeStreams;
{ Detaches and disposes of all streams being used by the overlay system }
function OvrSizeNeeded : LongInt;
{ Returns the size required to load any segments which still haven't
been loaded to a stream. }
function OvrLoadAll : Boolean;
{ Forces all overlay segments to be copied into the stream; if successful
(true) then no more references to the overlay file will be made. }
{$endif windows}
Function UpdateChksum(Initsum: Word; Var InBuf; InLen : Word) : Word;
{ Updates the checksum Initsum by adding InLen bytes from InBuf }
Function UpdateCRC16(InitCRC : Word; Var InBuf; InLen : Word) : Word;
{ I believe this is the CRC used by the XModem protocol. The transmitting
end should initialize with zero, UpdateCRC16 for the block, Continue the
UpdateCRC16 for two nulls, and append the result (hi order byte first) to
the transmitted block. The receiver should initialize with zero and
UpdateCRC16 for the received block including the two byte CRC. The
result will be zero (why?) if there were no transmission errors. (I have
not tested this function with an actual XModem implementation, though I
did verify the behavior just described. See TESTCRC.PAS.) }
Function UpdateCRCArc(InitCRC : Word; Var InBuf; InLen : Word) : Word;
{ This function computes the CRC used by SEA's ARC utility. Initialize
with zero. }
Function UpdateCRC32(InitCRC : LongInt; Var InBuf; InLen : Word) : LongInt;
{ This function computes the CRC used by PKZIP and Forsberg's ZModem.
Initialize with high-values ($FFFFFFFF), and finish by inverting all bits
(Not). }
Procedure FastCopy(var Src,Dest:TStream;size:longint);
{ Like Dest.CopyFrom(Src,size), but tries to use a larger buffer }
implementation
function MinLong(x,y:longint):longint;
begin
if x<y then
MinLong := x
else
MinLong := y;
end;
function MaxLong(x,y:longint):longint;
begin
MaxLong := -MinLong(-x,-y);
end;
function MinWord(x,y:word):word;
begin
if x<y then
MinWord := x
else
MinWord := y;
end;
function MaxWord(x,y:word):word;
begin
MaxWord := -MinWord(-x,-y);
end;
{****** TFilter code *******}
constructor TFilter.Init(ABase : PStream);
begin
TStream.Init;
Base := ABase;
CheckBase;
if Status = stOK then
Startofs := Base^.GetPos;
OwnsBase := true;
end;
destructor TFilter.Done;
begin
if Base <> nil then
begin
Flush;
if OwnsBase then
Dispose(Base, Done);
end;
TStream.Done;
end;
function TFilter.GetPos : LongInt;
begin
if CheckStatus then
begin
GetPos := Base^.GetPos-Startofs;
CheckBase;
end;
end;
function TFilter.GetSize : LongInt;
begin
if CheckStatus then
begin
GetSize := Base^.GetSize-Startofs;
CheckBase;
end;
end;
procedure TFilter.Read(var Buf; Count : Word);
begin
if CheckStatus then
begin
Base^.Read(Buf, Count);
CheckBase;
end;
end;
procedure TFilter.Seek(Pos : LongInt);
begin
if CheckStatus then
begin
Base^.Seek(Pos+Startofs);
CheckBase;
end;
end;
procedure TFilter.Truncate;
begin
if CheckStatus then
begin
Base^.Truncate;
CheckBase;
end;
end;
procedure TFilter.Write(var Buf; Count : Word);
begin
if CheckStatus then
begin
Base^.Write(Buf, Count);
CheckBase;
end;
end;
procedure TFilter.Flush;
begin
if CheckStatus then
begin
Base^.Flush;
CheckBase;
end;
end;
function TFilter.CheckStatus : Boolean;
begin
if (Status = stOK) and (Base^.Status <> stOK) then
Base^.Reset;
CheckStatus := Status = stOK;
end;
procedure TFilter.CheckBase;
begin
if Base^.Status <> stOK then
Error(stBaseError, Base^.Status);
end;
constructor TEncryptFilter.Init(Akey : LongInt; ABase : PStream);
begin
TFilter.Init(ABase);
Key := Akey;
end;
procedure TEncryptFilter.Read(var Buf; Count : Word);
var
i : Word;
SaveSeed : LongInt;
Bytes : Tbyte_array absolute Buf;
begin
SaveSeed := RandSeed;
RandSeed := Key;
TFilter.Read(Buf, Count);
for i := 0 to Count-1 do
Bytes[i] := Bytes[i] xor Random(256);
Key := RandSeed;
RandSeed := SaveSeed;
end;
procedure CycleKey(Key, Cycles : LongInt);
{ For cycles > 0, mimics cycles calls to the TP random number generator.
For cycles < 0, backs it up the given number of calls. }
var
i : LongInt;
Junk : Integer;
SaveSeed : LongInt;
begin
if Cycles > 0 then
begin
SaveSeed := RandSeed;
RandSeed := Key;
for i := 1 to Cycles do
Junk := Random(0);
Key := RandSeed;
RandSeed := SaveSeed;
end
else
for i := -1 downto Cycles do
Key := (Key-1)*(-649090867);
end;
procedure TEncryptFilter.Seek(Pos : LongInt);
var
OldPos : LongInt;
begin
OldPos := GetPos;
TFilter.Seek(Pos);
CycleKey(Key, Pos-OldPos);
end;
procedure TEncryptFilter.Write(var Buf; Count : Word);
var
i : Word;
SaveSeed : LongInt;
BufPtr : Pointer;
BufPtrOffset : Word absolute BufPtr;
Buffer : array[0..255] of Byte;
begin
SaveSeed := RandSeed;
RandSeed := Key;
BufPtr := @Buf;
while Count > 256 do
begin
Move(BufPtr^, Buffer, 256);
for i := 0 to 255 do
Buffer[i] := Buffer[i] xor Random(256);
TFilter.Write(Buffer, 256);
Dec(Count, 256);
Inc(BufPtrOffset, 256);
end;
Move(BufPtr^, Buffer, Count);
for i := 0 to Count-1 do
Buffer[i] := Buffer[i] xor Random(256);
TFilter.Write(Buffer, Count);
Key := RandSeed;
RandSeed := SaveSeed;
end;
{ ******* LZW code ******* }
{$L LZWSTREAM.OBJ}
procedure Initialise(Tables : PLZWTables); External;
function PutSignature(Tables : PLZWTables) : Boolean; External;
function Crunch(InBufSize, OutBufSize : Word;
var InBuffer, OutBuffer;
Tables : PLZWTables) : Pointer; External;
{ Crunch some more text. Stops when Inbufsize bytes are used up, or
output buffer is full. Returns bytes used in segment, bytes written
in offset of result }
function FlushLZW(var OutBuffer;
Tables : PLZWTables) : Word; External;
{ Flush the remaining characters to signal EOF. Needs space for up to
3 characters. }
function GetSignature(var InBuffer, Dummy;
Tables : PLZWTables) : Boolean; External;
{ Initializes for reading, and checks for 'LZ' signature in start of compressed
code. Inbuffer must contain at least 3 bytes. Dummy is just there to put the
Inbuffer in the right spot }
function Uncrunch(InBufSize, OutBufSize : Word;
var InBuffer, OutBuffer;
Tables : PLZWTables) : Pointer; External;
{ Uncrunch some text. Will stop when it has done Outbufsize worth or has
exhausted Inbufsize worth. Returns bytes used in segment, bytes written
in offset of result }
constructor TLZWFilter.Init(ABase : PStream; AMode : TOpenMode);
{ Create new compressor stream, to use ABase as the source/destination
for data. Mode must be stOpenRead or stOpenWrite. }
var
Buffer : array[1..3] of Byte;
Info : Integer;
begin
Info := stBadMode;
if (AMode = stOpenRead) or (AMode = stOpenWrite) then
begin
Info := stStreamFail;
if TFilter.Init(ABase) then
begin
if Status = stOK then
begin
Info := stMemError;
Startofs := Base^.GetPos;
Position := 0;
Mode := AMode;
if MaxAvail >= SizeOf(TLZWTables) then
begin
Info := stSigError;
GetMem(Tables, SizeOf(TLZWTables));
if Tables <> nil then { !1.6}
begin
Initialise(Tables);
if Mode = stOpenRead then
begin
Base^.Read(Size, SizeOf(Size));
Base^.Read(Buffer, 3);
CheckBase;
if GetSignature(Buffer, Buffer, Tables) then
Exit; { Successfully opened for reading }
end
else if Mode = stOpenWrite then
begin
Size := 0;
Base^.Write(Size, SizeOf(Size)); { Put a place holder }
CheckBase;
if PutSignature(Tables) then
Exit; { Successful construction for writing! }
end;
end;
end;
end;
end;
end;
Error(stInitError, Info);
end;
destructor TLZWFilter.Done;
begin
Flush;
FreeMem(Tables, SizeOf(TLZWTables));
TFilter.Done;
end;
procedure TLZWFilter.Write(var Buf; Count : Word);
var
Inbuf : array[0..65520] of Byte absolute Buf;
Outbuf : array[0..255] of Byte;
Inptr : Word;
Sizes : record
OutSize, UsedSize : Word;
end;
begin
if CheckStatus then
begin
if Mode <> stOpenWrite then
Error(stBadMode, Mode);
Inptr := 0;
repeat
Pointer(Sizes) := Crunch(Count, SizeOf(Outbuf),
Inbuf[Inptr], Outbuf, Tables);
with Sizes do
begin
Base^.Write(Outbuf, OutSize);
Dec(Count, UsedSize);
Inc(Inptr, UsedSize);
Inc(Size, UsedSize);
Inc(Position, UsedSize);
end;
until Count = 0;
CheckBase;
end;
end;
procedure TLZWFilter.Flush;
var
Outbuf : array[0..255] of Byte;
Sizes : record
OutSize, UsedSize : Word;
end;
Pos : LongInt;
extra : word;
zero : byte;
begin
if CheckStatus then
begin
if Mode = stOpenWrite then
begin
{ Changes here in 1.6 }
extra := 0;
zero := 0;
repeat
Pointer(Sizes) := Crunch(1, Sizeof(Outbuf), zero, Outbuf, Tables);
with Sizes do
if OutSize > 0 then
begin
inc(extra,outsize);
Base^.Write(Outbuf, Outsize);
end;
until extra > 4;
Pos := Base^.GetPos;
Base^.Seek(Startofs);
Base^.Write(Size, SizeOf(Size));
Base^.Seek(Pos);
end;
Base^.Flush;
Mode := 0;
CheckBase;
end;
end;
procedure TLZWFilter.Read(var Buf; Count : Word);
var
Outbuf : array[0..65520] of Byte absolute Buf;
Inbuf : array[0..255] of Byte;
OutPtr : Word;
BlockSize : Word;
Sizes : record
OutSize, UsedSize : Word;
end;
BytesLeft : LongInt;
begin
if CheckStatus then
begin
if Mode <> stOpenRead then
Error(stBadMode, Mode);
OutPtr := 0;
BlockSize := SizeOf(Inbuf);
with Base^ do
BytesLeft := GetSize-GetPos;
if Position+Count > Size then
begin
Error(stReaderror, 0);
FillChar(Buf, Count, 0);
Exit;
end;
while Count > 0 do
begin
if BytesLeft < BlockSize then
BlockSize := BytesLeft;
Base^.Read(Inbuf, BlockSize);
Pointer(Sizes) := Uncrunch(BlockSize, Count, Inbuf,
Outbuf[OutPtr], Tables);
with Sizes do
begin
if OutSize = 0 then
begin
Error(stReaderror, 0);
FillChar(Outbuf[OutPtr], Count, 0);
Exit;
end;
Dec(BytesLeft, UsedSize);
Inc(Position, OutSize);
Dec(Count, OutSize);
Inc(OutPtr, OutSize);
if UsedSize < BlockSize then
with Base^ do { seek back to the first unused byte }
Seek(GetPos-(BlockSize-UsedSize));
end;
end;
CheckBase;
end;
end;
procedure TLZWFilter.Seek(Pos : LongInt);
var
Buf : array[0..255] of Byte;
Bytes : Word;
begin
if CheckStatus then
begin
if Mode <> stOpenRead then
begin
Error(stBadMode, Mode);
Exit;
end;
if Pos < Position then
begin
Base^.Seek(Startofs);
FreeMem(Tables, SizeOf(TLZWTables));
TLZWFilter.Init(Base, Mode); { Re-initialize everything. Will this cause
bugs in descendents? }
end;
while Pos > Position do
begin
if Pos-Position > SizeOf(Buf) then
Bytes := SizeOf(Buf)
else
Bytes := Pos-Position;
Read(Buf, Bytes);
end;
end;
end;
procedure TLZWFilter.Truncate;
begin
Error(stBadMode, Mode);
end;
function TLZWFilter.GetPos;
begin
GetPos := Position;
end;
function TLZWFilter.GetSize;
begin
GetSize := Size;
end;
{ ***** Text Filter Code ******* }
{ These declarations are used both by TTextFilter and TLogFilter }
type
TFDDfunc = function(var F : Text) : Integer;
PStreamTextRec = ^StreamTextRec;
PSaveText = ^TSaveText;
TSaveText =
record { Used when logging for original data values }
OpenFunc,
InOutFunc,
FlushFunc,
CloseFunc : TFDDfunc;
S : PLogFilter;
SaveData : PSaveText;
Next : PStreamTextRec;
Data : array[13..16] of Byte;
end;
StreamTextRec =
record
Handle : Word;
Mode : Word;
BufSize : Word;
private : Word;
BufPos : Word;
BufEnd : Word;
BufPtr : Pbyte_array;
OpenFunc,
InOutFunc,
FlushFunc,
CloseFunc : TFDDfunc;
S : PFilter; { This is a TTextFilter or a TLogFilter }
SaveData : PSaveText;
Next : PStreamTextRec;
OtherData : array[13..16] of Byte;
Name : array[0..79] of Char;
Buffer : array[0..127] of Byte;
end;
function XLATstatus(var S:TStream):integer;
const
TextErrors : array[0..6] of integer = (0,5,5,100,101,212,212);
var
status : integer;
begin
status := S.status;
if (status = stBaseError) or (status = stBase2Error) then
status := S.errorinfo;
if (-6 <= status) and (status <= 0) then
XLATstatus := TextErrors[-status]
else
XLATstatus := 5;
end;
function TextIn(var F : Text) : Integer; Far;
var
savemode : word;
begin
with StreamTextRec(F), S^ do
begin
if Status = 0 then
begin
savemode := mode;
mode := fmClosed; { This stops infinite loop }
if GetSize-GetPos > BufSize then
begin
Read(BufPtr^, BufSize);
BufEnd := BufSize;
end
else
begin
BufEnd := GetSize-GetPos;
if BufEnd > 0 then
Read(BufPtr^, BufEnd);
end;
BufPos := 0;
mode := savemode;
end;
TextIn := XLATStatus(S^);
end;
end;
function TextOut(var F : Text) : Integer; Far;
var
savemode : word;
begin
with StreamTextRec(F), S^ do
begin
if Status = 0 then
begin
savemode := mode;
mode := fmClosed;
Write(BufPtr^, BufPos);
mode := savemode;
BufPos := 0;
end;
TextOut := XLATStatus(S^);
end;
end;
function TextInFlush(var F : Text) : Integer; Far;
begin
TextInFlush := 0; { 1.3A bug fix }
end;
function TextOutFlush(var F : Text) : Integer; Far;
begin
TextOutFlush := 0; { 1.6 change from TextOut(F); }
end;
function TextClose(var F : Text) : Integer; Far;
begin
with StreamTextRec(F) do
begin
S^.Flush;
TextClose := XLATStatus(S^);
end;
end;
function TextOpen(var F : Text) : Integer; Far;
var
saveMode : word;
begin
with StreamTextRec(F) do
begin
case Mode of
fmInOut :
begin
Mode := fmClosed;
S^.Seek(S^.GetSize);
Mode := fmOutput;
end;
fmInput,fmOutput :
begin
saveMode := Mode;
Mode := fmClosed;
S^.Seek(0);
Mode := saveMode;
end;
end;
case Mode of
fmInput : begin
InOutFunc := TextIn;
FlushFunc := TextInFlush;
end;
fmOutput : begin
InOutFunc := TextOut;
FlushFunc := TextOutFlush;
end;
end;
TextOpen := XLATStatus(S^);
end;
end;
constructor TTextFilter.Init(ABase : PStream; AName : String);
begin
if not TFilter.Init(ABase) then
Fail;
TextPtr := nil;
AssignStream(TextFile,AName);
end;
destructor TTextFilter.Done;
begin
if StreamTextRec(TextPtr^).Mode <> fmClosed then
Close(Textptr^);
TFilter.Done;
end;
procedure TTextFilter.AssignStream(var NewText:text;AName:string);
begin
if (TextPtr <> nil) and (StreamTextRec(TextPtr^).Mode <> fmClosed) then
Close(TextPtr^);
with StreamTextRec(NewText) do
begin
Mode := fmClosed;
BufSize := SizeOf(Buffer);
BufPtr := PByte_Array(@Buffer);
OpenFunc := TextOpen;
CloseFunc := TextClose;
AName := Copy(AName, 1, 79);
Move(AName[1], Name, Length(AName));
Name[Length(AName)] := #0;
S := @Self;
end;
TextPtr := @NewText;
end;
function TTextFilter.GetPos : LongInt;
var
result : longint;
begin
result := TFilter.GetPos;
with StreamTextRec(Textptr^) do
case Mode of
fmInput : result := result - (BufEnd - BufPos);
fmOutput : result := result + (BufPos);
end;
GetPos := Result;
end;
function TTextFilter.GetSize : LongInt;
begin
if StreamTextRec(Textptr^).Mode <> fmClosed then
System.Flush(TextPtr^);
GetSize := TFilter.GetSize;
end;
procedure TTextFilter.Flush;
begin
with StreamTextRec(TextPtr^) do
begin
case Mode of
fmOutput : system.flush(TextPtr^);
fmInput :
begin
TFilter.Seek(TFilter.GetPos - BufEnd + BufPos);
BufPos := 0;
BufEnd := 0;
end;
end;
end;
TFilter.Flush;
end;
procedure TTextFilter.Read(var Buf; Count : Word);
var
outbuf : Tbyte_array absolute buf;
size : word;
begin
with StreamTextRec(TextPtr^) do
begin
if mode <> fmInput then { This means we've been called by the
TFDD, or while writing to the text file,
or the text file is closed }
begin
if mode = fmOutput then
Flush;
TFilter.Read(Buf,Count)
end
else
begin
size := minword(Count, BufEnd-BufPos);
move(bufptr^[BufPos],outbuf,size);
dec(count,size);
if count > 0 then
begin
bufpos := 0;
bufend := 0;
TFilter.Read(outbuf[size],count);
end
else
inc(bufpos,size);
end;
end;
end;
procedure TTextFilter.Seek(Pos : LongInt);
var
basepos : longint;
begin
with StreamTextRec(TextPtr^) do
begin
basepos := TFilter.GetPos;
case Mode of
fmInput : begin
if (basepos - bufend <= pos) and (pos < basepos) then
bufpos := pos-(basepos-bufend)
else
begin
Flush;
TFilter.Seek(Pos);
end;
end;
fmOutput : begin
if (basepos <= pos) and (pos < basepos + bufsize) then
bufpos := pos-basepos
else
begin
Flush;
TFilter.Seek(Pos);
end;
end;
else
TFilter.Seek(Pos);
end;
end;
end;
procedure TTextFilter.Truncate;
begin
Flush;
TFilter.Truncate;
end;
procedure TTextFilter.Write(var Buf; Count : Word);
var
inbuf : Tbyte_array absolute buf;
size : word;
begin
with StreamTextRec(TextPtr^) do
begin
if mode <> fmOutput then
begin
if mode = fmInput then
Flush;
TFilter.write(buf,count);
end
else
begin
size := minword(Count, BufSize-BufPos);
move(inbuf,bufptr^[BufPos],size);
dec(count,size);
inc(BufPos,size);
if count > 0 then
begin
Flush;
TFilter.write(inbuf[size],count);
end;
end;
end;
end;
function DoOldCall(Func : TFDDfunc; var F : Text) : Integer;
var
Save : TSaveText;
begin
if @Func <> nil then
with StreamTextRec(F) do
begin
Move(OpenFunc, Save, SizeOf(TSaveText));
Move(SaveData^, OpenFunc, SizeOf(TSaveText)); { Now using old functions }
DoOldCall := Func(F);
Move(OpenFunc, Save.SaveData^, SizeOf(TSaveText)); { Save any changes }
Move(Save, OpenFunc, SizeOf(TSaveText)); { Back to new ones }
end;
end;
function LogIn(var F : Text) : Integer; Far;
var
Result : Integer;
begin
with StreamTextRec(F) do
begin
Result := DoOldCall(SaveData^.InOutFunc, F);
if Result = 0 then
S^.Write(BufPtr^, BufEnd); { Might want to record errors
here }
LogIn := Result;
end;
end;
function LogOut(var F : Text) : Integer; Far;
begin
with StreamTextRec(F) do
begin
S^.Write(BufPtr^, BufPos);
LogOut := DoOldCall(SaveData^.InOutFunc, F);
end;
end;
function LogInFlush(var F : Text) : Integer; Far;
begin
with StreamTextRec(F) do
LogInFlush := DoOldCall(SaveData^.FlushFunc, F);
end;
function LogOutFlush(var F : Text) : Integer; Far;
var
OldPos : Word;
begin
with StreamTextRec(F) do
begin
OldPos := BufPos;
LogOutFlush := DoOldCall(SaveData^.FlushFunc, F);
if BufPos = 0 then
S^.Write(BufPtr^, OldPos);
end;
end;
function LogClose(var F : Text) : Integer; Far;
begin
with StreamTextRec(F) do
begin
LogClose := DoOldCall(SaveData^.CloseFunc, F);
if not PLogFilter(S)^.Unlog(F) then
{ Bug! } ;
end;
end;
function LogOpen(var F : Text) : Integer; Far;
begin
with StreamTextRec(F) do
begin
LogOpen := DoOldCall(SaveData^.OpenFunc, F);
case Mode of
fmInOut, fmOutput : begin
InOutFunc := LogOut;
if @FlushFunc <> nil then
FlushFunc := LogOutFlush;
end;
fmInput : begin
InOutFunc := LogIn;
if @FlushFunc <> nil then
FlushFunc := LogInFlush;
end;
end;
end;
end;
{ ******* TLogFilter methods ******** }
constructor TLogFilter.Init(Abase:PStream);
begin
if not TFilter.init(ABase) then
fail;
LogList := nil;
end;
destructor TLogFilter.Done;
begin
while (LogList <> nil) and Unlog(LogList^) do ;
TFilter.Done;
end;
procedure TLogFilter.Log(var F : Text);
var
Save : PSaveText;
OldOpen : TFDDfunc;
Junk : Integer;
begin
New(Save);
with StreamTextRec(F) do
begin
Move(OpenFunc, Save^, SizeOf(TSaveText)); { Save the original contents }
S := @Self;
SaveData := Save;
Next := PStreamTextRec(LogList);
LogList := @F; { Insert this file into the list of logged files }
OldOpen := SaveData^.OpenFunc;
Pointer(@SaveData^.OpenFunc) := nil; { Call LogOpen, but don't open. }
Junk := LogOpen(F);
SaveData^.OpenFunc := OldOpen;
CloseFunc := LogClose;
end;
end;
function TLogFilter.Unlog(var F : Text) : Boolean;
var
Save : PSaveText;
Prev : PStreamTextRec;
begin
Unlog := False; { Assume failure }
with StreamTextRec(F) do
begin
if S = PFilter(@Self) then
begin
{ First, delete it from the list. }
if LogList = @F then
LogList := Pointer(Next)
else
begin
Prev := PStreamTextRec(LogList);
while (Prev^.Next <> nil) and (Prev^.Next <> PStreamTextRec(@F)) do
Prev := Prev^.Next;
if Prev^.Next <> PStreamTextRec(@F) then
Exit; { Couldn't find it in the list!? }
Prev^.Next := Next;
end;
Save := SaveData;
Move(Save^, OpenFunc, SizeOf(TSaveText));
Dispose(Save);
Unlog := True;
end;
end;
end;
{$ifdef overlays}
{ ****** Overlay stream code ****** }
type
{ This is the structure at the start of each "thunk" segment }
POvrhead = ^TOvrhead;
TOvrhead = record
Signature : Word; { CD 3F - INT 3F call used on returns }
Ret_Ofs : Word; { The offset to jump to when a return triggers a
reload }
Offset : LongInt; { The offset to the segment in the .OVR file }
Code_Bytes, { Size of the code image }
Reloc_Bytes, { Number of relocation fixups times 2 }
Entry_Count, { The number of entry points }
NextSeg, { Next overlay segment - add prefixseg + $10 to find
thunks. List starts with System.ovrcodelist. }
LoadSeg, { The segment at which the overlay is loaded, or 0 }
Reprieve, { Set to 1 to if overlay used while on probation }
NextLoaded : Word; { The segment of the next loaded overlay. List starts
with System.ovrloadlist. Updated *after* call to
ovrreadbuf. }
case Integer of
1 : (EMSPage, { The EMS page where this overlay is stored }
EMSOffset : Word); { The offset within the EMS page }
2 : (S : PStream; { The stream holding this segment's code }
Soffset : LongInt); { The offset within S }
end;
var
OldReadFunc : OvrReadFunc;
OvrOldExitProc : Pointer;
OvrStream : PStream;
const
OvrStreamInstalled : Boolean = False;
OvrExitHandler : Boolean = False;
function OvrPtr(Seg : Word) : POvrhead;
{ Convert map style segment number, as used by overlay manager, to
pointer }
begin
OvrPtr := Ptr(Seg+PrefixSeg+$10, 0);
end;
function StdPtr(Seg : Word) : POvrhead;
{ Convert straight segment number to a pointer }
begin
StdPtr := Ptr(Seg, 0);
end;
function NewReadFunc(OvrSeg : Word) : Integer; Far;
var
Result : Integer;
begin
with StdPtr(OvrSeg)^ do
begin
if S = nil then
begin { Segment not yet loaded }
Result := OldReadFunc(OvrSeg);
if Result = 0 then
begin
{ Now copy the loaded code to our stream }
Soffset := OvrStream^.GetSize;
OvrStream^.Seek(Soffset);
OvrStream^.Write(Ptr(LoadSeg, 0)^, Code_Bytes);
Result := OvrStream^.Status;
if Result = stOK then
S := OvrStream
else
OvrStream^.Reset; { Something failed; hope we haven't messed
up the stream too much }
end;
end
else
begin { Segment has been loaded into the stream }
S^.Seek(Soffset);
S^.Read(Ptr(LoadSeg, 0)^, Code_Bytes);
Result := S^.Status;
if Result <> stOK then
begin
S^.Reset; { Fix the stream, and try a standard load }
Result := OldReadFunc(OvrSeg);
end;
end;
end;
NewReadFunc := Result;
end;
procedure OvrExitProc; Far;
{ Installed exit procedure; disposes of any streams that are still
handling overlays. }
begin
ExitProc := OvrOldExitProc;
OvrDisposeStreams;
end;
procedure OvrInitStream(S : PStream);
begin
if not OvrStreamInstalled then
begin
OldReadFunc := OvrReadBuf; { Install our reader function }
OvrReadBuf := NewReadFunc;
OvrStreamInstalled := True;
end;
if not OvrExitHandler then
begin
OvrOldExitProc := ExitProc;
ExitProc := @OvrExitProc;
OvrExitHandler := True;
end;
OvrStream := S; { And set stream to use }
end;
procedure OvrDetachStream(BadS : PStream);
var
OvrSeg : Word;
begin
if OvrStreamInstalled then
begin
if OvrStream = BadS then
OvrStream := nil; { Detach default stream }
OvrSeg := OvrCodeList;
while OvrSeg <> 0 do { Walk the overlay list }
with OvrPtr(OvrSeg)^ do
begin
if S <> nil then
begin
if S <> BadS then
begin
if OvrStream = nil then
OvrStream := S; { Set default stream to first found }
end
else
S := nil; { Blank out BadS references }
end;
OvrSeg := NextSeg;
end;
if OvrStream = nil then
begin
OvrStreamInstalled := False; { If we don't have a stream, better
uninstall. }
OvrReadBuf := OldReadFunc;
end;
end;
end;
procedure OvrDisposeStreams;
var
S : PStream;
begin
while OvrStreamInstalled and (OvrStream <> nil) do
begin
S := OvrStream;
OvrDetachStream(S);
Dispose(S, Done);
end;
end;
function OvrSizeNeeded : LongInt;
var
OvrSeg : Word;
Result : LongInt;
begin
OvrSeg := OvrCodeList;
Result := 0;
while OvrSeg <> 0 do { Walk the overlay list }
with OvrPtr(OvrSeg)^ do
begin
if S = nil then
Inc(Result, Code_Bytes);
OvrSeg := NextSeg;
end;
OvrSizeNeeded := Result;
end;
function OvrLoadAll : Boolean;
var
OvrSeg : Word;
Junk : Integer;
begin
if not OvrStreamInstalled then
OvrLoadAll := False
else
begin
OvrClearBuf;
OvrSeg := OvrCodeList;
while OvrSeg <> 0 do { Walk the overlay list }
with OvrPtr(OvrSeg)^ do
begin
if S = nil then
begin
LoadSeg := OvrHeapOrg; { load at start of overlay buffer }
Junk := NewReadFunc(OvrSeg+PrefixSeg+$10);
LoadSeg := 0; { Don't really want it loaded yet }
end;
OvrSeg := NextSeg;
end;
OvrLoadAll := OvrStream^.Status = stOK;
end;
end;
{$endif windows}
{ ****** Bit filter code ****** }
constructor TBitFilter.Init(ABase : PStream);
begin
TFilter.Init(ABase);
BitPos := 0;
AtEnd := false;
end;
procedure TBitFilter.PrepareBuffer(ForRead : Boolean);
begin
if BitPos = 8 then { Buffer full on write }
begin
Base^.Write(Buffer, 1);
BitPos := 0;
end;
if BitPos = 0 then { Buffer empty }
begin
if not AtEnd then
begin
if not ForRead then
AtEnd := (Base^.GetPos >= Base^.GetSize);
if (not AtEnd) or ForRead then
begin
Base^.Read(Buffer,1);
BitPos := -8
end;
end;
if AtEnd then
Buffer := 0;
Mask := 1;
end;
if (not ForRead) and (BitPos < 0) then
begin
Base^.Seek(Base^.GetPos-1);
Inc(BitPos, 8);
AtEnd := false;
end;
end;
function TBitFilter.GetBit : TBit;
begin
if CheckStatus then
begin
PrepareBuffer(True);
GetBit := TBit((Buffer and Mask) > 0);
Mask := Mask shl 1;
Inc(BitPos);
CheckBase;
end;
end;
function TBitFilter.GetBits(Count : Byte) : LongInt;
var
Result : LongInt;
begin
Result := 0;
ReadBits(Result, Count);
GetBits := Result;
end;
procedure TBitFilter.PutBit(ABit : TBit);
begin
if CheckStatus then
begin
PrepareBuffer(False);
if ABit = 1 then
Buffer := Buffer or Mask;
Mask := Mask shl 1;
Inc(BitPos);
end;
end;
procedure TBitFilter.PutBits(ABits : LongInt; Count : Byte);
begin
WriteBits(ABits, Count);
end;
procedure TBitFilter.ReadBits(var Buf; Count : LongInt);
var
w : Word;
b : array[1..2] of Byte absolute w;
bBuf : TByte_Array absolute Buf;
i, Bytes : Word;
Shift : Word;
begin
if (Count > 0) and CheckStatus then
begin
PrepareBuffer(True);
if BitPos > 0 then
begin
Base^.Write(Buffer, 1);
Dec(BitPos, 8);
end;
Shift := BitPos+8; { the number of bits to shift by }
Bytes := (Count+Shift-1) div 8; { Count of whole bytes to read }
if Bytes > 0 then
begin
TFilter.Read(Buf, Bytes);
b[1] := Buffer;
for i := 0 to Pred(Bytes) do
begin
b[2] := bBuf[i];
w := w shr Shift;
bBuf[i] := b[1];
w := w shr (8-Shift);
end;
Buffer := b[1];
end;
{ Now fix up the last few bits }
Dec(Count, 8*LongInt(Bytes));
if Count > 0 then
bBuf[Bytes] := (Buffer shr Shift) and not($FF shl Count)
else
if Count < 0 then
bBuf[Bytes-1] := bBuf[Bytes-1] and not($FF shl (8+Count));
BitPos := BitPos+Count;
Mask := 1 shl (BitPos+8);
end;
end;
procedure TBitFilter.WriteBits(var Buf; Count : LongInt);
var
w : Word;
b : array[1..2] of Byte absolute w;
bBuf : TByte_Array absolute Buf;
i, Bytes : Word;
Shift : Word;
SaveBuf : Byte;
SavePos : ShortInt;
begin
if CheckStatus then
begin
PrepareBuffer(False);
Bytes := (Count+BitPos-1) div 8; { Count of whole bytes to write }
Shift := 8-BitPos;
if Bytes > 0 then
begin
if Shift < 8 then
begin
b[1] := Buffer shl Shift;
for i := 0 to Pred(Bytes) do
begin
b[2] := bBuf[i];
w := w shr Shift;
Base^.Write(b[1], 1);
w := w shr (8-Shift);
end;
Buffer := b[1] shr Shift;
end
else
Base^.Write(Buf, Bytes);
end;
Dec(Count, 8*LongInt(Bytes));
if Count > 0 then
Buffer := (Buffer or (bBuf[Bytes] shl (8-Shift)));
BitPos := BitPos+Count;
if BitPos > 0 then { Fill in upper part of buffer }
begin
SaveBuf := Buffer;
SavePos := BitPos;
BitPos := 0; { signal empty buffer }
PrepareBuffer(False); { and load it }
Buffer := (Buffer and ($FF shl SavePos)) { old part }
or (SaveBuf and not($FF shl SavePos)); { new part }
BitPos := SavePos;
end;
Mask := 1 shl BitPos;
CheckBase;
end;
end;
procedure TBitFilter.Flush;
begin
if CheckStatus then
begin
if BitPos > 0 then
Base^.Write(Buffer, 1);
Dec(BitPos, 8);
AtEnd := false;
CheckBase;
end;
end;
procedure TBitFilter.Seek(Pos : LongInt);
begin
if CheckStatus then
begin
Flush;
TFilter.Seek(Pos);
BitPos := 0;
AtEnd := false;
end;
end;
procedure TBitFilter.Read(var Buf; Count : Word);
begin
ReadBits(Buf, 8*LongInt(Count));
end;
procedure TBitFilter.Write(var Buf; Count : Word);
begin
WriteBits(Buf, 8*LongInt(Count));
end;
procedure TBitFilter.SeekBit(Pos : LongInt);
var
i : Byte;
b : TBit;
begin
if CheckStatus then
begin
Seek(Pos div 8);
for i := 1 to (Pos and 7) do
b := GetBit;
end;
end;
function TBitFilter.GetBitPos : LongInt;
begin
GetBitPos := 8*TFilter.GetPos+BitPos; { Need TFilter override in
case descendants override
GetPos }
end;
procedure TBitFilter.CopyBits(var S : TBitFilter; Count : LongInt);
var
localbuf : array[1..256] of Byte;
begin
while Count > 2048 do
begin
S.ReadBits(localbuf, 2048);
WriteBits(localbuf, 2048);
Dec(Count, 2048);
end;
if Count > 0 then
begin
S.ReadBits(localbuf, Count);
WriteBits(localbuf, Count);
end;
end;
procedure TBitFilter.ByteAlign;
begin
SeekBit((GetBitPos+7) and $FFFFFFF8);
end;
{ ****** Duplicate filter code ****** }
constructor TDupFilter.Init(ABase, ABase2 : PStream);
{ Initialize the filter with the given bases. }
begin
if not TFilter.Init(Abase) then
fail;
Base2 := ABase2;
CheckBase2;
if Status = stOK then
Startofs2 := Base2^.GetPos;
end;
destructor TDupFilter.Done;
{ Flush filter, then dispose of both bases. }
begin
Flush;
if Base2 <> nil then
Dispose(Base2,done);
TFilter.Done;
end;
function TDupFilter.MisMatch(var buf1,buf2;count:word):word;
var
i : word;
bbuf1 : TByte_Array absolute buf1;
bbuf2 : TByte_Array absolute buf2;
begin
for i := 0 to pred(count) do
if bbuf1[i] <> bbuf2[i] then
begin
MisMatch := succ(i);
exit;
end;
MisMatch := 0;
end;
procedure TDupFilter.Read(var Buf; Count : Word);
var
bpos : word;
localbuf : array[0..255] of byte;
procedure CompareBuffer(size:word);
var
epos : word;
bbuf : TByte_Array absolute Buf;
begin
Base2^.Read(localbuf,size);
dec(count,size);
CheckBase2;
if status = stOK then
begin
epos := MisMatch(bbuf[bpos],localbuf,size);
if epos <> 0 then
Error(stMismatch,bpos+epos);
end;
inc(bpos,size);
end;
begin
TFilter.Read(buf, Count);
bpos := 0;
While (Status = stOK) and (Count >= sizeof(localbuf)) do
CompareBuffer(Sizeof(localbuf));
If (Status = stOK) and (Count > 0) then
CompareBuffer(Count);
{ Be sure the bases are synchronized }
Base2^.Seek(GetPos+StartOfs2);
end;
procedure TDupFilter.Seek(Pos : LongInt);
begin
TFilter.Seek(Pos);
if Status = stOK then
begin
base2^.Seek(pos+startofs2);
CheckBase2;
end;
end;
procedure TDupFilter.Truncate;
begin
TFilter.Truncate;
if Status = stOK then
begin
base2^.truncate;
CheckBase2;
end;
end;
procedure TDupFilter.Write(var Buf; Count : Word);
begin
TFilter.Write(buf,Count);
if Status = stOK then
begin
Base2^.write(buf,Count);
CheckBase2;
end;
end;
procedure TDupFilter.Flush;
begin
TFilter.Flush;
if Status = stOK then
begin
base2^.flush;
CheckBase2;
end;
end;
function TDupFilter.CheckStatus : Boolean;
begin
if TFilter.CheckStatus then
if Base2^.Status <> stOK then
Base2^.Reset;
CheckStatus := Status = stOK;
end;
procedure TDupFilter.CheckBase2;
begin
if Base2^.status <> stOk then
Error(stBase2Error,Base2^.status);
end;
{ ****** Concatenating Filter code ****** }
constructor TConcatFilter.Init(ABase, ABase2 : PStream);
{ Initialize the filter with the given bases. }
begin
if not TFilter.Init(ABase) then
fail;
Base2 := ABase2;
CheckBase2;
Base1Size := TFilter.GetSize;
if Status = stOK then
StartOfs2 := Base2^.GetPos;
Position := Base1Size;
end;
destructor TConcatFilter.done;
begin
Flush;
if Base2 <> nil then
Dispose(Base2,done);
if Base <> nil then
Dispose(Base,Done); { Can't call TFilter.Done!!!! }
TStream.done;
end;
function TConcatFilter.GetPos:longint;
begin
GetPos := Position;
end;
function TConcatFilter.GetSize:longint;
begin
if CheckStatus then
begin
GetSize := Base1Size + Base2^.GetSize;
CheckBase2;
end;
end;
procedure TConcatFilter.Read(var Buf; Count : Word);
var
Buffer : TByte_array absolute Buf;
base1part : word;
begin
{ First read the Base 1 portion }
if Position < Base1Size then
begin
base1part := Count;
if Position+base1part > Base1Size then
base1part := Base1Size - Position;
TFilter.Read(Buf, base1part);
dec(Count,base1part);
inc(Position,Base1part);
if Count > 0 then
Base2^.Seek(StartOfs2); { Be sure Base2 agrees with Pos now }
end
else
base1part := 0;
{ Now read the Base 2 portion }
if (Count > 0) and (status = stOK) then
begin
if Position = Base1Size then
Base2^.Seek(StartOfs2);
Base2^.Read(Buffer[base1part],Count);
CheckBase2;
inc(Position,count);
end;
end;
procedure TConcatFilter.Seek(Pos : LongInt);
begin
if Pos < Base1Size then
TFilter.Seek(Pos)
else
begin
if CheckStatus then
begin
Base2^.Seek(Pos-Base1Size+StartOfs2);
CheckBase2;
end;
end;
if Status = stOK then
Position := Pos;
end;
procedure TConcatFilter.Truncate;
begin
if Position < Base1Size then
Error(stUnsupported,0) { We don't allow Base to be truncated, only
Base2 }
else
if CheckStatus then
begin
Base2^.Truncate;
CheckBase2;
end;
end;
procedure TConcatFilter.Write(var Buf; Count : Word);
var
Buffer : TByte_array absolute Buf;
base1part : word;
begin
{ First write the Base 1 portion }
if Position < Base1Size then
begin
base1part := Count;
if Position+base1part > Base1Size then
base1part := Base1Size - Position;
TFilter.Write(Buf, base1part);
dec(Count,base1part);
inc(Position,Base1part);
if Count > 0 then
Base2^.Seek(StartOfs2); { Be sure Base2 agrees with Pos now }
end
else
base1part := 0;
{ Now write the Base 2 portion }
if (Count > 0) and (status = stOK) then
begin
Base2^.Write(Buffer[base1part],Count);
CheckBase2;
inc(Position,count);
end;
end;
procedure TConcatFilter.Flush;
begin
TFilter.Flush;
if status = stOK then
begin
Base2^.Flush;
CheckBase2;
end;
end;
function TConcatFilter.CheckStatus : Boolean;
begin
if TFilter.CheckStatus then
if Base2^.Status <> stOK then
Base2^.Reset;
CheckStatus := Status = stOK;
end;
procedure TConcatFilter.CheckBase2;
begin
if Base2^.status <> stOk then
Error(stBase2Error,Base2^.status);
end;
{ ****** Limit Filter code *****}
constructor TLimitFilter.init(ABase:PStream;ALoLimit,AHiLimit:longint);
{ Does the usual init, sets the limits, then does a Seek to ALoLimit
if it is non-zero. }
begin
if not TFilter.Init(ABase) then
fail;
LoLimit := ALoLimit;
HiLimit := AHiLimit;
if ALoLimit <> 0 then
Seek(ALoLimit);
end;
procedure TLimitFilter.Read(var Buf; Count : Word);
begin
if status = stOk then
begin
if GetPos + Count > HiLimit then
begin
Error(stReadError,0);
Fillchar(Buf,Count,0);
end
else
TFilter.Read(Buf,Count);
end;
end;
procedure TLimitFilter.Seek(Pos : LongInt);
begin
if Status = stOK then
begin
if (Pos < LoLimit) or (Pos > HiLimit) then
Error(stReadError,0)
else
TFilter.Seek(Pos);
end;
end;
procedure TLimitFilter.Write(var Buf; Count : Word);
begin
if Status = stOk then
begin
if GetPos + Count > HiLimit then
Error(stWriteError,0)
else
TFilter.Write(Buf,Count);
end;
end;
function TLimitFilter.GetSize:longint;
var
result : longint;
begin
result := TFilter.GetSize;
if result > HiLimit then
GetSize := HiLimit
else
GetSize := result;
end;
{ ****** Loop Filter code *****}
procedure TLoopFilter.Read(var Buf; Count : Word);
var
buffer : TByte_Array absolute Buf;
pos : word;
begin
if status = stOk then
begin
if GetPos + Count > HiLimit then
begin
pos := HiLimit - GetPos;
TFilter.Read(Buf,pos);
dec(count,pos);
TFilter.Seek(LoLimit);
Read(Buffer[pos],Count); { Recursive call! }
end
else
Tfilter.Read(Buf,Count);
end;
end;
procedure TLoopFilter.Seek(Pos : LongInt);
var
size : longint;
begin
size := HiLimit - LoLimit;
if Pos < LoLimit then
Pos := LoLimit + (Pos - LoLimit) mod Size + Size;
TFilter.Seek(LoLimit + (Pos - LoLimit) mod Size);
end;
procedure TLoopFilter.Write(var Buf; Count : Word);
var
buffer : TByte_Array absolute Buf;
pos : word;
begin
if status = stOk then
begin
if GetPos + Count > HiLimit then
begin
pos := HiLimit - GetPos;
TFilter.Write(Buf,pos);
dec(count,pos);
TFilter.Seek(LoLimit);
Write(Buffer[pos],Count); { Recursive call! }
end
else
Tfilter.Write(Buf,Count);
end;
end;
function TLoopFilter.GetSize:longint;
var
result : longint;
begin
result := TFilter.GetSize;
if result > HiLimit then
GetSize := HiLimit - LoLimit
else
GetSize := result - LoLimit;
end;
{ ****** TReverseFilter code ******}
constructor TReverseFilter.Init(ABase : PStream; AReverseBlocks:boolean);
begin
TFilter.Init(ABase);
ReverseBlocks := AReverseBlocks;
end;
function TReverseFilter.GetPos:longint;
begin
GetPos := TFilter.GetSize-TFilter.GetPos;
end;
procedure TReverseFilter.Read(var Buf;Count : word);
var
curpos : longint;
begin
curpos := TFilter.GetPos; { We call the Tfilter methods to propagate errors }
Base^.Seek(curpos-Count);
Base^.Read(Buf,Count);
if ReverseBlocks then
ReverseBytes(Buf,Count);
TFilter.Seek(curpos-Count);
end;
procedure TReverseFilter.Write(var Buf;Count : word);
var
curpos : longint;
begin
curpos := TFilter.GetPos; { We call the Tfilter methods to propagate errors }
Base^.Seek(curpos-Count);
if ReverseBlocks then
ReverseBytes(Buf,Count);
Base^.Write(Buf,Count);
if ReverseBlocks then
ReverseBytes(Buf,Count);
TFilter.Seek(curpos-Count);
end;
procedure TReverseFilter.Seek(Pos:Longint);
begin
TFilter.Seek(TFilter.GetSize-Pos);
end;
procedure TReverseFilter.Truncate;
begin
Error(stUnsupported,0);
end;
procedure ReverseBytes(var Buf; Count:Word);
var
buffer : TByte_Array absolute Buf;
i,j : word;
t : byte;
begin
if Count > 1 then
begin
j := Count-1;
for i:=0 to (Count div 2) - 1 do
begin
t := buffer[i];
buffer[i] := buffer[j];
buffer[j] := t;
dec(j);
end;
end;
end;
{ ****** Checksum/CRC code ******}
Function UpdateChksum(initsum:word; var Inbuf; inlen:word):word;
var
i : word;
bbuf : TByte_Array absolute inbuf;
begin
for i:=0 to pred(inlen) do
inc(initsum,bbuf[i]);
UpdateChksum := initsum;
end;
{ From the original CRC.PAS: }
{ This unit provides three speed-optimized functions to compute (or continue
computation of) a Cyclic Redundency Check (CRC). These routines are
contributed to the public domain (with the limitations noted by the
original authors in the TASM sources).
Each function takes three parameters:
InitCRC - The initial CRC value. This may be the recommended initialization
value if this is the first or only block to be checked, or this may be
a previously computed CRC value if this is a continuation.
InBuf - An untyped parameter specifying the beginning of the memory area
to be checked.
InLen - A word indicating the length of the memory area to be checked. If
InLen is zero, the function returns the value of InitCRC.
The function result is the updated CRC. The input buffer is scanned under
the limitations of the 8086 segmented architecture, so the result will be
in error if InLen > 64k - Offset(InBuf).
These conversions were done on 10-29-89 by:
Edwin T. Floyd [76067,747]
#9 Adams Park Court
Columbus, GA 31909
(404) 576-3305 (work)
(404) 322-0076 (home)
}
Function UpdateCRC16(InitCRC : Word; Var InBuf; InLen : Word) : Word;
external; {$L crc16.obj}
{ I believe this is the CRC used by the XModem protocol. The transmitting
end should initialize with zero, UpdateCRC16 for the block, Continue the
UpdateCRC16 for two nulls, and append the result (hi order byte first) to
the transmitted block. The receiver should initialize with zero and
UpdateCRC16 for the received block including the two byte CRC. The
result will be zero (why?) if there were no transmission errors. (I have
not tested this function with an actual XModem implementation, though I
did verify the behavior just described. See TESTCRC.PAS.) }
Function UpdateCRCArc(InitCRC : Word; Var InBuf; InLen : Word) : Word;
external; {$L crcarc.obj}
{ This function computes the CRC used by SEA's ARC utility. Initialize
with zero. }
Function UpdateCRC32(InitCRC : LongInt; Var InBuf; InLen : Word) : LongInt;
external; {$L crc32.obj}
{ This function computes the CRC used by PKZIP and Forsberg's ZModem.
Initialize with high-values ($FFFFFFFF), and finish by inverting all bits
(Not). }
{ ****** Sequential filter code ****** }
procedure TSequential.Seek(pos:longint);
begin
Error(stUnsupported,0);
end;
{ ****** Chksum filter code ******}
constructor TChkSumFilter.init(ABase:PStream; AChksum:word);
begin
if not TSequential.init(ABase) then
fail;
Chksum := AChksum;
end;
procedure TChkSumFilter.Read(var buf; Count:word);
begin
TSequential.Read(buf,count);
if status = stOK then
ChkSum := UpdateChksum(ChkSum,buf,Count);
end;
procedure TChkSumFilter.Write(var buf; Count:word);
begin
TSequential.Write(buf,count);
if status = stOk then
ChkSum := UpdateChksum(ChkSum,buf,Count);
end;
{ ***** CRC16 filter code ***** }
constructor TCRC16Filter.init(ABase:PStream; ACRC16:word);
begin
if not TSequential.init(ABase) then
fail;
CRC16 := ACRC16;
end;
procedure TCRC16Filter.Read(var buf; Count:word);
begin
TSequential.Read(buf,count);
if status = stOK then
CRC16 := UpdateCRC16(CRC16,buf,count);
end;
procedure TCRC16Filter.Write(var buf; Count:word);
begin
TSequential.Write(buf,count);
if status = stOk then
CRC16 := UpdateCRC16(CRC16,buf,count);
end;
{ ***** CRCARC filter code ***** }
constructor TCRCARCFilter.init(ABase:PStream; ACRCARC:word);
begin
if not TSequential.init(ABase) then
fail;
CRCARC := ACRCARC;
end;
procedure TCRCARCFilter.Read(var buf; Count:word);
begin
TSequential.Read(buf,count);
if status = stOK then
CRCARC := UpdateCRCARC(CRCARC,buf,count);
end;
procedure TCRCARCFilter.Write(var buf; Count:word);
begin
TSequential.Write(buf,count);
if status = stOk then
CRCARC := UpdateCRCARC(CRCARC,buf,count);
end;
{ ***** CRC32 filter code ***** }
constructor TCRC32Filter.init(ABase:PStream; ACRC32:longint);
begin
if not TSequential.init(ABase) then
fail;
CRC32 := ACRC32;
end;
procedure TCRC32Filter.Read(var buf; Count:word);
begin
TSequential.Read(buf,count);
if status = stOK then
CRC32 := UpdateCRC32(CRC32,buf,count);
end;
procedure TCRC32Filter.Write(var buf; Count:word);
begin
TSequential.Write(buf,count);
if status = stOk then
CRC32 := UpdateCRC32(CRC32,buf,count);
end;
{ ****** Null stream code ****** }
constructor TNulStream.Init;
begin
TStream.Init;
Position := 0;
Value := AValue;
end;
function TNulStream.GetPos;
begin
GetPos := Position;
end;
function TNulStream.GetSize;
begin
GetSize := Position;
end;
procedure TNulStream.Read;
begin
FillChar(Buf, Count, Value);
Inc(Position, Count);
end;
procedure TNulStream.Seek;
begin
Position := Pos;
end;
procedure TNulStream.Write;
begin
Inc(Position, Count);
end;
{ ****** RAM stream code ****** }
constructor TRAMStream.Init(Asize : Word);
begin
TStream.Init;
Position := 0;
Size := 0;
Alloc := Asize;
if MaxAvail < Alloc then
Fail;
GetMem(Buffer, Alloc);
if Buffer = nil then { !1.6 }
Fail;
OwnMem := True;
FillChar(Buffer^, Alloc, 0);
end;
constructor TRAMStream.UseBuf(ABuffer : Pointer; Asize : Word);
begin
TRAMStream.Init(0);
Alloc := Asize;
Size := Asize;
Buffer := ABuffer;
OwnMem := False;
end;
destructor TRAMStream.Done;
begin
if OwnMem then
FreeMem(Buffer, Alloc);
TStream.Done;
end;
function TRAMStream.GetPos;
{ begin Replaced with assembler for speed.
GetPos := Position;
end; }
assembler;
asm
les di,self
mov ax,es:di[Position];
xor dx,dx
end;
function TRAMStream.GetSize;
{ begin Replaced with assembler for speed.
GetSize := Size;
end; }
assembler;
asm
les di,self
mov ax,es:di[size]
xor dx,dx
end;
function CheckInc(var pos:word;count,limit:word):boolean; assembler;
{ Increments pos by count, returns false if limit is exceeded }
asm
les di,pos
mov bx,count
mov al,true
add bx,es:[di]
jc @1 { Carry means error }
mov es:[di],bx
sub bx,limit
jbe @2
@1:
dec ax { Set AX to false }
@2:
end;
procedure TRAMStream.Read;
begin
Move(Buffer^[Position], Buf, Count);
if not CheckInc(Position,Count,Size) then
begin
Error(stReadError,0);
Dec(Position,Count);
FillChar(Buf,Count,0);
end;
end;
procedure TRAMStream.Seek;
begin
if Pos > Size then
Error(stReaderror, 0)
else
Position := Pos;
end;
procedure TRAMStream.Truncate;
begin
Size := Position;
end;
procedure TRAMStream.Write;
begin
if not CheckInc(Position,Count,Alloc) then
Error(stWriteError, 0)
else
begin
Move(Buf, Buffer^[Position-Count], Count);
if Position > Size then
Size := Position;
end;
end;
{ ***** EMS stream code ***** }
destructor TEMSStream2.done;
begin
TEMSStream.done;
EMSCurpage := $FFFF;
end;
{ ***** XMS stream code ***** }
{$I xmsstrm.inc}
{ ***** EMS size code ***** }
function exist_ems:boolean;
const
ems_found : boolean = false; { Used as initialized var }
var
S : TEMSStream2;
begin
if not ems_found then
begin
S.init(1,1);
ems_found := S.status = stOk;
S.done;
end;
exist_ems := ems_found;
end;
function ems_maxavail: longint;
begin
if not exist_ems then
ems_maxavail:=0
else
asm
mov ah,$42;
int $67
mov ax,16384
mul bx
mov word ptr @result,ax
mov word ptr @result[2],dx
end;
end;
function ems_memavail: longint;
begin
ems_memavail := ems_maxavail;
end;
function GetTempList:String;
{ Function to get the list of directories for temp files }
var
{$ifdef windows}
p : PChar;
{$endif}
result : string;
begin
{$ifdef windows}
p := GetEnvVar(@TempEnvVar[1]);
if p <> nil then
result := StrPas(p)
else
result := '';
{$else}
result := GetEnv(TempEnvVar);
{$endif}
if Length(result) = 0 then
result := '.\';
GetTempList := result;
end;
function GetTempDir(var TempList:string):string;
{ Strip one temp directory off the front of the list, and
return it fully qualified, with a '\' at the end. }
var
Semicolon : byte;
result : string;
curdir : string;
begin
Semicolon := Pos(';',TempList);
if Semicolon > 0 then
begin
result := Copy(TempList,1,Semicolon-1);
TempList := Copy(TempList,Semicolon+1,255);
end
else
begin
result := TempList;
TempList := '';
end;
if result[Length(result)] <> '\' then
result := result+'\';
if (length(result) < 2) or (result[2] <> ':') then
GetDir(0,curdir)
else
begin
GetDir(ord(upcase(result[1]))-ord('A')+1,curdir);
result := copy(result,3,255);
end;
if (length(result) > 1) and (result[1] <> '\') then
result := curdir + '\' + result
else
result := copy(curdir,1,2) + result;
GetTempDir := result;
end;
function disk_maxavail: longint;
var
templist,tempname : string;
result : longint;
begin
result := 0;
templist := GetTempList;
repeat
tempname := GetTempDir(templist);
result := MaxLong(result,
DiskFree(ord(upcase(tempname[1]))-ord('A')+1))
until templist = '';
disk_maxavail := result;
end;
function disk_memavail: longint;
var
templist,tempname : string;
result,space : longint;
disk : byte;
disks : array[1..32] of boolean;
begin
fillchar(disks,sizeof(disks),false);
result := 0;
templist := GetTempList;
repeat
tempname := GetTempDir(templist);
disk := ord(upcase(tempname[1]))-ord('A')+1;
if not disks[disk] then
begin
disks[disk] := true;
space := DiskFree(disk);
end
else
space := 0;
if space > 0 then
inc(result,space);
until templist = '';
disk_memavail := result;
end;
{ ***** Named Buffered file stream code ***** }
constructor TNamedBufStream.Init(Name : FNameStr; Mode : TOpenMode; ABufSize : Word);
begin
if TBufStream.Init(Name, Mode, ABufSize) then
{$ifdef windows}
filename := StrNew(name)
{$else}
Filename := NewStr(Name)
{$endif}
else
Fail;
end;
destructor TNamedBufStream.Done;
begin
{$ifdef windows}
StrDispose(filename);
{$else}
DisposeStr(Filename);
{$endif}
TBufStream.Done;
end;
constructor TTempBufStream.Init(ABufSize : Word;
InitSize,MaxSize : Longint);
var
TempList,TempName : String;
Okay : Boolean;
NewHandle : Word;
F : File;
begin
if not TStream.Init then
Fail;
if MaxAvail < ABufSize then
Fail;
BufSize := ABufSize;
GetMem(Buffer, BufSize);
if Buffer = Nil then { !1.6 }
Fail;
MaxSize := MaxLong(MinLong(MaxSize,Disk_MaxAvail),InitSize);
TempList := GetTempList;
repeat
TempName := GetTempDir(TempList);
FillChar(TempName[Length(TempName)+1], 255-Length(TempName), #0);
asm
push ds
push ss
pop ds
lea dx,TempName[1]
mov ah, $5a
xor cx,cx
{$ifdef windows}
call dos3call
{$else}
int $21 { Create temporary file. }
{$endif}
pop ds
jc @failed
mov Okay,True
mov NewHandle,ax
jmp @done
@failed:
mov Okay,False
@done:
end;
if okay then
begin
Handle := NewHandle;
while TempName[Length(TempName)+1] <> #0 do
Inc(TempName[0]);
{$ifdef windows}
Filename := StrNew(StrPCopy(@tempname[1],tempname));
{$else}
Filename := NewStr(TempName);
{$endif}
Seek(MaxSize-1);
Write(okay,1); { Write a 0 }
Flush;
Seek(InitSize);
Truncate;
Seek(0); { !1.6}
okay := Status = stOK;
if not okay and (TempList <> '') then
begin
asm
mov ah,$3E
mov bx,NewHandle
int $21 { Close file }
end;
assign(F,filename^);
Erase(F);
Reset;
{$ifdef windows}
StrDispose(Filename);
{$else}
DisposeStr(Filename);
{$endif}
Filename := nil;
end;
end;
until okay or (TempList = '');
end;
destructor TTempBufStream.Done;
var
F : file;
begin
{$ifdef windows}
assign(f,StrPas(Filename));
{$else}
Assign(F, Filename^);
{$endif}
TNamedBufStream.Done;
Erase(F);
end;
{******** TWorkStream code ******* }
constructor TWorkStream.init(Allocator:TAllocator;ABlockmin,ABlockMax:Longint;
APreference : TStreamRanking);
begin
TFilter.init(Allocator(ABlockmin,ABlockmax,APreference));
Allocate := Allocator;
Blockmin := ABlockmin;
Blockmax := ABlockmax;
Preference := APreference;
BlockStart := 0;
end;
procedure TWorkStream.write(var Buf; Count:Word);
var
Buffer : TByte_array absolute Buf;
firstpart : word;
byteswritten : word;
pos : longint;
NewBase : PStream;
saveStatus, saveInfo : integer;
begin
pos := GetPos;
byteswritten := 0;
if CheckStatus then
repeat
firstpart := Count;
if (Pos < BlockStart+BlockMax) and (Pos+firstpart > BlockStart+BlockMax) then
firstpart := BlockStart+BlockMax-Pos;
TFilter.Write(Buffer[byteswritten], firstpart);
{ **** crummy code to get around problems with TBufStream **** }
{ The test is an efficiency hack - we don't want to flush every
segment of the stream, just the last one. }
if typeof(Base^) = typeof(TConcatFilter) then
PConcatFilter(Base)^.Base2^.Flush
else
Base^.Flush; { Must flush all writes to see TBufStream
errors immediately :-( }
CheckBase; { 1.6 fix }
{ **** end of crummy code :-) ***** }
if Status = stOK then
begin
dec(Count,firstpart);
inc(Pos,firstpart);
inc(byteswritten,firstpart);
end
else
begin
saveStatus := Status;
saveInfo := ErrorInfo;
Reset;
if Pos = GetSize then
begin
{ If write failed at eof, allocate a new block }
Seek(0);
NewBase := Allocate(BlockMin,BlockMax,Preference);
if (NewBase = nil) or (NewBase^.Status <> stOK) then
begin
error(stBaseError, stWriteError);
exit;
end;
Base := New(PConcatFilter,init(Base,NewBase));
BlockStart := Pos;
end
else { Some other kind of write failure; restore the error status }
begin
error(saveStatus,saveInfo);
exit;
end;
end;
until count = 0;
end;
{ ***** Temp Stream Code ******* }
function TempStream(InitSize, MaxSize : LongInt;
Preference : TStreamRanking) : PStream;
var
Choice : Integer;
Result : PStream;
StreamType : TStreamType;
Nulls : TNulStream;
begin
Result := nil;
Nulls.Init(0);
for Choice := 1 to NumTypes do
begin
StreamType := Preference[Choice];
case StreamType of
RAMStream :
if MaxSize < $10000 then
Result := New(PRAMStream, Init(MaxSize));
EMSStream :
if ems_MaxAvail >= MaxSize then
Result := New(PEMSStream2, Init(InitSize, MaxSize));
XMSStream :
if xms_MaxAvail >= MaxSize then
Result := New(PXMSStream, Init(InitSize, MaxSize));
FileStream :
if disk_MaxAvail >= MaxSize then
Result := New(PTempBufStream, Init(2048, InitSize, MaxSize));
end;
if (Result <> nil) and (Result^.Status = stOK) then
begin
FastCopy(Nulls, Result^, InitSize);
Result^.Seek(0);
if Result^.Status = stOK then
begin
Nulls.Done;
TempStream := Result;
Exit;
end;
end;
if Result <> nil then
Dispose(Result, Done); { Clean up and start over } ;
Result := nil;
end;
TempStream := nil;
end;
function StreamName(S:PStream):String;
{ This function is for debugging only! It links every single stream
type into your .EXE. }
var
t : pointer;
begin
if S=nil then
StreamName := 'nil'
else
begin
t := typeof(S^);
if t = typeof(TStream) then StreamName := 'TStream'
else if t = typeof(TEMSStream) then StreamName := 'TEMSStream'
else if t = typeof(TDOSStream) then StreamName := 'TDOSStream'
else if t = typeof(TBufStream) then StreamName := 'TBufStream'
else if t = typeof(TFilter) then StreamName := 'TFilter'
else if t = typeof(TEncryptFilter) then StreamName := 'TEncryptFilter'
else if t = typeof(TLZWFilter) then StreamName := 'TLZWFilter'
else if t = typeof(TTextFilter) then StreamName := 'TTextFilter'
else if t = typeof(TLogFilter) then StreamName := 'TLogFilter'
else if t = typeof(TBitFilter) then StreamName := 'TBitFilter'
else if t = typeof(TDupFilter) then StreamName := 'TDupFilter'
else if t = typeof(TConcatFilter) then StreamName := 'TConcatFilter'
else if t = typeof(TLimitFilter) then StreamName := 'TLimitFilter'
else if t = typeof(TLoopFilter) then StreamName := 'TLoopFilter'
else if t = typeof(TReverseFilter) then StreamName := 'TReverseFilter'
else if t = typeof(TSequential) then StreamName := 'TSequential'
else if t = typeof(TChksumFilter) then StreamName := 'TChksumFilter'
else if t = typeof(TCRC16Filter) then StreamName := 'TCRC16Filter'
else if t = typeof(TCRCARCFilter) then StreamName := 'TCRCARCFilter'
else if t = typeof(TCRC32Filter) then StreamName := 'TCRC32Filter'
else if t = typeof(TNulStream) then StreamName := 'TNulStream'
else if t = typeof(TRAMStream) then StreamName := 'TRAMStream'
else if t = typeof(TEMSStream2) then StreamName := 'TEMSStream2'
else if t = typeof(TXMSStream) then StreamName := 'TXMSStream'
else if t = typeof(TNamedBufStream) then StreamName := 'TNamedBufStream'
else if t = typeof(TTempBufStream) then StreamName := 'TTempBufStream'
else if t = typeof(TWorkStream) then StreamName := 'TWorkStream'
else StreamName := 'Unknown (or uninitialized) stream';
end;
end;
{ ******* Fast copy code ******** }
procedure FastCopy(var src,dest:TStream; size:longint);
var
buffer : pbyte_array;
bufsize : word;
begin
bufsize := minlong(minlong(65536-512, maxavail), size);
if bufsize < 512 then
dest.copyfrom(src,size)
else
begin
getmem(buffer,bufsize);
if buffer = nil then
dest.copyfrom(src,size)
else
begin
while size >= bufsize do
begin
src.read(buffer^,bufsize);
dest.write(buffer^,bufsize);
dec(size,bufsize);
end;
if size > 0 then
begin
src.read(buffer^,size);
dest.write(buffer^,size);
end;
freemem(buffer,bufsize);
end;
end;
end;
end.

view raw

streams.pas

hosted with ❤ by GitHub


{$B-} { Use fast boolean evaluation. }
program textdemo;
{ Demonstrates use of TTextFilter and TWorkStream }
{$i stdefine.inc}
uses
{$ifdef windows} wincrt, {$endif}
{$ifdef wobjects} wobjects, {$else} objects, {$endif}
streams;
var
i : integer;
S : PWorkStream;
T : PTextFilter;
offsets : array[1..15000] of longint;
line : string;
startmem : longint;
function MyTempStream(MinSize,MaxSize:Longint;
Preference:TStreamRanking):PStream; far;
var
result : PStream;
begin
Write('S is ',S^.GetSize:6,' bytes, Memavail=',memavail:6);
result := TempStream(MinSize,MaxSize,Preference);
Writeln(', allocated ',StreamName(result));
MyTempStream := result;
end;
begin
TempEnvVar := 'TMP';
startmem := Memavail;
{ Create a temporary file with blocks in EMS, XMS or on the heap: }
S := New(PWorkStream, Init(TempStream,2048,65520,ForSpeed));
S^.Allocate := MyTempStream;
if (S=nil) or (S^.status <> stOK) then
begin
writeln('Failed to create temporary stream.');
halt(99);
end;
{ Insert it into a text filter }
New(T, init(S, 'TempStream'));
if (T=nil) or (T^.status <> stOK) then
begin
writeln('Failed to create text filter.');
halt(98);
end;
{ Now write 15000 lines to it. }
Rewrite(T^.TextFile);
for i:=1 to 15000 do
begin
offsets[i] := T^.GetPos;
writeln(T^.TextFile, '------------- Line number ',i:5,' --------------');
end;
writeln('Have written 15000 lines (',T^.Getsize,' bytes) to work stream.');
{ Now read them back in a strange order. }
Reset(T^.TextFile);
writeln('The first line is ');
Readln(T^.TextFile,line);
writeln(line);
for i:=5 downto 1 do
begin
writeln('Line ',i*100,' is:');
T^.Seek(offsets[i*100]);
readln(T^.TextFile,line);
writeln(line);
end;
writeln('Lines 14995 onwards are:');
T^.seek(offsets[14995]);
while not eof(T^.Textfile) do
begin
readln(T^.TextFile,line);
writeln(line);
end;
{ All done; dispose of the filter to release the memory }
dispose(T,done);
if memavail <> startmem then
writeln('Error! ',startmem-memavail,' bytes of memory left allocated.');
writeln('All done!');
end.

view raw

textdemo.pas

hosted with ❤ by GitHub


{ This include file is a slightly modified version of XMSSTRM.PAS, by Stefan
Boether, included here with his kind permission. -djm }
(*****************************************************************************)
(* *)
(* Filename : XMSSTRM.INC *)
(* Autor : Stefan Boether / Compuserve Id : 100023,275 *)
(* System : TURBO 6.00 / MS-DOS 3.2 / Netzwerk *)
(* Aenderung : *)
(* wann was wer *)
(*---------------------------------------------------------------------------*)
(* 22.03.92 Error fixed with NewBlock and UsedBlocks Stefc *)
(* 28.04.92 Size field added, BlockSize made constant DJM *)
(* 15.10.92 Off-by-one bug fixed in Seek method DJM *)
(*****************************************************************************)
(* Beschreibung: Object for an Stream in XMS-Memory *)
(*****************************************************************************)
{Header-End}
{!!!!!!!!!!!!!!!
program Test;
uses objects, XmsStrm;
var T : TXmsStream;
P : PString;
begin
writeln( xms_MaxAvail, ' ', xms_MemAvail );
T.Init( 20, 20 );
T.WriteStr( NewStr( 'Hello' ));
T.WriteStr( NewStr( 'World' ));
T.Seek( 0 );
P := T.ReadStr;
writeln( P^ );
P := T.ReadStr;
writeln( P^ );
T.Done;
end.
!!!!!!!!!!!!!!!!}
var xms_IOsts : Byte;
xms_Addr : Pointer;
const
xms_Initialized : Boolean = False;
{ This allows us to avoid a unit initialization section }
xms_BlockSize = 1024;
{ - Some Xms - Procedures that I need ! -}
(* /////////////////////////////////////////////////////////////////////// *)
procedure MoveMem(ToAddress : Pointer; ToHandle : Word;
FromAddress : Pointer; FromHandle : Word;
Size : LongInt);
begin
asm
mov byte ptr xms_IOsts,0
mov ah,$0B
lea si,Size
push ds
pop es
push ss
pop ds
call es:[xms_Addr]
push es
pop ds
or ax,ax
jnz @@1
mov byte ptr xms_IOsts,bl
@@1:
end;
end;
(* /////////////////////////////////////////////////////////////////////// *)
function GetByte(Handle : Word; FromAddress : LongInt) : Byte;
var TempBuf : array[0..1] of Byte;
begin
MoveMem(@TempBuf, 0, Pointer(FromAddress and $FFFFFFFE), Handle, 2);
GetByte := TempBuf[FromAddress and $00000001];
end;
(* /////////////////////////////////////////////////////////////////////// *)
procedure SetByte(Handle : Word; ToAddress : LongInt; Value : Byte);
var TempBuf : array[0..1] of Byte;
begin
MoveMem(@TempBuf, 0, Pointer(ToAddress and $FFFFFFFE), Handle, 2);
TempBuf[ToAddress and $00000001] := Value;
MoveMem(Pointer(ToAddress and $FFFFFFFE), Handle, @TempBuf, 0, 2);
end;
(* /////////////////////////////////////////////////////////////////////// *)
procedure xms_Init;
begin
if not xms_Initialized then
begin
xms_IOsts := 0;
xms_Addr := nil;
asm
mov ax,$4300
int $2F
cmp al,$80
jne @@1
mov ax,$4310
int $2F
mov word ptr xms_Addr,bx
mov word ptr xms_Addr+2,es
jmp @@2
@@1:
mov byte ptr xms_IOsts,$80
@@2:
end;
if xms_IOsts = 0 then
xms_Initialized := True;
end;
end;
(* /////////////////////////////////////////////////////////////////////// *)
function xms_GetMem(KB : Word) : Word; Assembler;
asm
mov xms_IOsts,0
mov ah,$09
mov dx,word ptr KB
call [xms_Addr]
or ax,ax
jz @@1
mov ax,dx
jmp @@2
@@1:
mov byte ptr xms_IOsts,bl
@@2:
end;
(* /////////////////////////////////////////////////////////////////////// *)
procedure xms_FreeMem(Handle : Word);
begin
asm
mov xms_IOsts,0
mov ah,$0A
mov dx,word ptr Handle
call [xms_Addr]
or ax,ax
jnz @@1
mov byte ptr xms_IOsts,bl
@@1:
end;
end;
(* /////////////////////////////////////////////////////////////////////// *)
procedure xms_ResizeMem(Size, Handle : Word);
begin
asm
mov ah,$0F
mov bx,word ptr Size
mov dx,word ptr Handle
call [xms_Addr]
or ax,ax
jnz @@1
mov byte ptr xms_IOsts,bl
@@1:
end;
end;
(* /////////////////////////////////////////////////////////////////////// *)
procedure xms_MoveFrom(Size, Handle : Word; FromAddress : LongInt;
ToAddress : Pointer);
type ByteArr = array[0..MaxInt] of Byte;
BytePtr = ^ByteArr;
begin
if Size = 0 then Exit;
if Odd(FromAddress) then begin
BytePtr(ToAddress)^[0] := GetByte(Handle, FromAddress);
if xms_IOsts <> 0 then Exit;
Dec(Size);
Inc(FromAddress);
Inc(LongInt(ToAddress));
end;
MoveMem(ToAddress, 0, Pointer(FromAddress), Handle, Size and $FFFE);
if xms_IOsts <> 0 then Exit;
if Odd(Size)
then BytePtr(ToAddress)^[Size-1] := GetByte(Handle, FromAddress+Size-1);
if xms_IOsts <> 0 then Exit;
end;
(* /////////////////////////////////////////////////////////////////////// *)
procedure xms_MoveTo(Size, Handle : Word; FromAddress : Pointer;
ToAddress : LongInt);
type ByteArr = array[0..MaxInt] of Byte;
BytePtr = ^ByteArr;
begin
if Size = 0 then Exit;
if Odd(ToAddress) then begin
SetByte(Handle, ToAddress, BytePtr(FromAddress)^[0]);
if xms_IOsts <> 0 then Exit;
Dec(Size);
Inc(LongInt(FromAddress));
Inc(ToAddress);
end;
MoveMem(Pointer(ToAddress), Handle, FromAddress, 0, Size and $FFFE);
if xms_IOsts <> 0 then Exit;
if Odd(Size)
then SetByte(Handle, ToAddress+Size-1, BytePtr(FromAddress)^[Size-1]);
if xms_IOsts <> 0 then Exit;
end;
(* /////////////////////////////////////////////////////////////////////// *)
constructor TXMSStream.Init(MinSize, MaxSize : longint);
var
MinBlocks,MaxBlocks : word;
begin
TStream.Init;
xms_Init;
BlocksUsed := 0;
Size := 0;
Position := 0;
Handle := 0;
MaxSize := MinLong(MaxSize,xms_Maxavail);
MaxBlocks := (MaxSize + xms_Blocksize -1) div xms_Blocksize;
MinBlocks := (MinSize + xms_Blocksize -1) div xms_Blocksize;
if MinBlocks < 1 then
MinBlocks := 1;
if MaxBlocks < MinBlocks then
MaxBlocks := MinBlocks;
if xms_IOsts <> $00 then
Error(stInitError, xms_IOsts)
else
begin
Handle := xms_GetMem(MaxBlocks);
if xms_IOsts <> $00 then
Error(stInitError, xms_IOsts)
else
begin
xms_ResizeMem(MinBlocks,Handle);
BlocksUsed := MinBlocks;
if xms_IOsts <> $00 then
Error(stInitError, xms_IOsts);
end;
end;
end;
function TXMSStream.GetPos : LongInt;
begin
GetPos := Position;
end;
function TXMSStream.GetSize : LongInt;
begin
GetSize := Size;
end;
procedure TXMSStream.Read(var Buf; Count : Word);
begin
if Status = stOK then
if Position+Count > Size then
Error(stReaderror, 0)
else
begin
xms_MoveFrom(Count, Handle, Position, @Buf);
if xms_IOsts <> 0 then
Error(stReaderror, xms_IOsts)
else
Inc(Position, Count);
end;
end;
procedure TXMSStream.Seek(Pos : LongInt);
begin
if Status = stOK then
if Pos > Size then { 1.4: bug fix }
Error(stReaderror, Pos)
else
Position := Pos;
end;
procedure TXMSStream.Truncate;
begin
if Status = stOK then
begin
Size := Position;
while (BlocksUsed > (Size div xms_BlockSize+1)) do FreeBlock;
end;
end;
procedure TXMSStream.Write(var Buf; Count : Word);
begin
while (Status = stOK)
and (Position+Count > LongMul(xms_BlockSize, BlocksUsed)) do
NewBlock;
if Status = stOK then
begin
xms_MoveTo(Count, Handle, @Buf, Position);
if xms_IOsts <> 0 then
Error(stWriteError, xms_IOsts)
else
Inc(Position, Count);
if Position > Size then
Size := Position;
end;
end;
procedure TXMSStream.NewBlock;
begin
xms_ResizeMem(Succ(BlocksUsed), Handle);
if xms_IOsts <> 0 then
Error(stWriteError, xms_IOsts)
else
Inc(BlocksUsed);
end;
procedure TXMSStream.FreeBlock;
begin
Dec(BlocksUsed);
xms_ResizeMem(BlocksUsed, Handle);
end;
function xms_MaxAvail : Longint;
begin
xms_Init;
if xms_IOsts = 0 then
asm
xor bx, bx { for better error checking, since qemm
6.0 leaves bl unchanged on success }
mov ah,$08
call [xms_Addr]
or bl, bl { extended error checking by MM 22.02.93 }
jz @OK
mov byte ptr xms_IOsts,bl
xor ax,ax
@OK:
mov dx,xms_Blocksize
mul dx
mov word ptr @result,ax
mov word ptr @result[2],dx
end
else
xms_MaxAvail := 0;
end;
(* /////////////////////////////////////////////////////////////////////// *)
function xms_MemAvail : Longint;
begin
xms_Init;
if xms_IOsts = 0 then
asm
xor bx, bx { for better error checking, since qemm
6.0 leaves bl unchanged on success }
mov ah,$08
call [xms_Addr]
or bl, bl { extended error checking by MM 22.02.93 }
jz @OK
mov byte ptr xms_IOsts,bl
xor dx,dx
@OK:
mov ax,dx
mov dx,xms_blocksize
mul dx
mov word ptr @result,ax
mov word ptr @result[2],dx
end
else
xms_MemAvail := 0;
end;
destructor TXMSStream.Done;
begin
{ Seek(0);
Truncate; }
if xms_Initialized and (BlocksUsed > 0) then
xms_FreeMem(Handle);
end;

view raw

xmsstrm.inc

hosted with ❤ by GitHub

This entry was posted on 2017/05/16 at 06:00 and is filed under Delphi, Development, Software Development. You can follow any responses to this entry through the RSS 2.0 feed. You can leave a response, or trackback from your own site.

2 Responses to “On the design of the Delphi TStream classes – why aren’t they decomposed better?”

  1. KMorwath's avatar

    KMorwath said

    2017/05/17 at 08:50

    One of the reasons, IMHO, is that while TurboPascal streams were designed as a general I/O mechanism, when Delphi was designed they were tied too much to the form serialization task, losing the big picture. It was one of the (bad) surprise I had when I moved from TP7 to D1.

    Reply

Leave a comment

This site uses Akismet to reduce spam. Learn how your comment data is processed.

«
»