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

May 2017
M	T	W	T	F	S	S
1	2	3	4	5	6	7
8	9	10	11	12	13	14
15	16	17	18	19	20	21
22	23	24	25	26	27	28
29	30	31

	{$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

	Mike Verhagen on geerlingguy/my-backup-plan: Ho…
	Attila Kovacs on docs.embarcadero.com unreachab…
	David Blue on MacOS: converting a man page t…
	jpluimers on How do I pretty-print JSON in…
	jpluimers on Delphi 10.2 Tokyo Godzilla ISO…

The Wiert Corner – irregular stream of stuff

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

Subscribe

Archives

Recent Comments

Recent Posts

Blog Stats

Meta title

Tag Cloud Title

Top Clicks

Top Posts

My badges

Twitter Updates

My Flickr Stream

Pages

All categories

Email Subscription

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