Unit Storage;
{ STORAGE.PAS - 13 Jan 91
This unit was created to replace the original system storage that was
created for the DMG. It is designed to be object oriented and will
also alow for external compression routines to be designed into the
system with a registration code for each.
The system will take a buffer pointer and run it through the compressor
until it reaches "BufBytes" number of characters in the buffer. Once the
compressor is finished, the resulting bitstream is then written to the
disk. An index number is returned for where this was written.
The system that reads the messages only needs an index and filename.
It will create a buffer for the message up to the memory restraints.
You MUST do a .done when you are through with the buffer or the space
will not be released to the heap.
__________________________________________________________________________
MODIFICATIONS:
09 Feb 91 - Removed the original compression routines (The old code is
still at the end of the listing it anyone cares) and replaced
them with a technique based on the SPLAY tree algorithms. The
original code for this came from the file SPLAY2.ZIP written by Kim
Kokkonen from TurboPower Software. Documentation on this compression
routine can be found from an article by Douglas W. Jones, "Application
of Splay Trees to Data Compression", in Communications of the ACM,
August 1988, page 996.
Other changes include creating a message header for each compressed
message with an overhead of (currently) nine bytes. Note that I am
reserving compression types 0..10 for myself and anyone can use the
others to their hears desires.
Also removed the internal disk buffers that I created... Forgot that if
your using TBufStream, its already buffered. Why waste the memory
buffering it twice?!?
NOTE: This version is no longer compatable with those published before it.
}
{$F+,O+,S-,R-}
Interface
Uses Dos, Objects, Memory;
CONST stStoreError = -120;
stStoreReadErr = 197;
stStoreWriteErr = 198;
stStoreUnknownErr = 199;
MemOverflow = 1005;
TYPE PBuffer = ^BBuffer;
BBuffer = ARRAY [0..65530] OF BYTE;
PList = ^LList;
LList = RECORD
OldItem : LONGINT;
NewItem : LONGINT;
Next : PList;
END;
PStorage = ^TStorage;
TStorage = OBJECT(TBufStream)
SFileName : FNameStr;
SCleanName : FNameStr;
SCleanIndex : PList;
SMode : WORD;
SHoldBuf : POINTER;
SHoldBufLen : WORD;
CONSTRUCTOR Init(AFileName : FNameStr; AMode, Size : WORD);
DESTRUCTOR Done; VIRTUAL;
FUNCTION WriteMsg(BufBytes : WORD; VAR Buf) : LONGINT;
FUNCTION ReadMsg(Index : LONGINT; VAR Buf : POINTER) : WORD;
PROCEDURE DeleteMsg(Index : LONGINT);
PROCEDURE CleanUpMsg;
FUNCTION NewIndex(Index : LONGINT) : LONGINT;
PROCEDURE DeleteCleanUp;
PROCEDURE InitCompress; VIRTUAL;
FUNCTION Compress(NumBytes : WORD; VAR CompType : BYTE;
VAR Buf) : WORD; VIRTUAL;
PROCEDURE DeCompress(NumBytes : WORD; CompType : BYTE; VAR Buf); VIRTUAL;
END;
Implementation
CONST MarkerWord = $114D4410; {Some sort of magic number!}
TYPE Header = RECORD
Marker : LONGINT;
ExpandSize : WORD;
CompressSize : WORD;
CompressType : BYTE
END;
VAR Head : Header;
{----------------------------------------------------------------------------}
CONSTRUCTOR TStorage.Init;
BEGIN
TBufStream.Init(AFileName,AMode,Size);
IF Status <> stOk THEN
Status := stStoreError
ELSE
BEGIN
SFileName := FEXPAND(AFileName);
SCleanName := '';
SCleanIndex := NIL;
SMode := AMode;
SHoldBuf := NIL;
SHoldBufLen := 0
END
END;
{----------------------------------------------------------------------------}
FUNCTION TStorage.WriteMsg;
VAR SIndex : LONGINT;
BEGIN
SIndex := GetSize;
WriteMsg := SIndex;
WITH Head DO BEGIN
Marker := MarkerWord;
ExpandSize := BufBytes;
CompressSize := 0;
CompressType := 0
END;
TBufStream.Seek(SIndex);
TBufStream.Write(Head,SIZEOF(Head));
Head.CompressSize := Compress(BufBytes,Head.CompressType,Buf);
TBufStream.Seek(SIndex);
TBufStream.Write(Head,SIZEOF(Head));
TBufStream.Flush;
IF Status <> stOk THEN
Status := stStoreError
END;
{----------------------------------------------------------------------------}
FUNCTION TStorage.ReadMsg;
VAR DeleteCheck : BYTE;
BEGIN
IF (SHoldBuf <> NIL) AND (SHoldBufLen > 0) THEN
FREEMEM(SHoldBuf,SHoldBufLen);
SHoldBuf := NIL;
SHoldBufLen := 0;
ReadMsg := 0;
TBufStream.Seek(Index);
TBufStream.Read(Head,SIZEOF(Head));
IF Head.Marker <> MarkerWord THEN
BEGIN
Head.ExpandSize := TBufStream.GetSize - Index;
IF Head.ExpandSize > 65530 THEN
Head.ExpandSize := 65530;
Head.CompressSize := Head.ExpandSize;
Head.CompressType := 0;
TBufStream.Seek(Index)
END
ELSE
IF Head.CompressType = $FF THEN
EXIT;
SHoldBuf := MemAlloc(Head.ExpandSize);
IF SHoldBuf <> NIL THEN
BEGIN
SHoldBufLen := Head.ExpandSize;
DeCompress(Head.CompressSize,Head.CompressType,SHoldBuf^);
ReadMsg := Head.ExpandSize
END
ELSE
Error(stStoreError,MemOverflow);
Buf := SHoldBuf;
IF Status <> stOk THEN
Status := stStoreError
END;
{----------------------------------------------------------------------------}
PROCEDURE TStorage.DeleteMsg;
VAR CompressType : BYTE;
BEGIN
Seek(Index);
Read(Head,SIZEOF(Head));
IF Head.Marker = MarkerWord THEN
BEGIN
Seek(Index);
Head.CompressType := $FF; {Mark Compression Type as Deleted!}
Write(Head,SIZEOF(Head))
END;
IF Status <> stOk THEN
Status := stStoreError
END;
{----------------------------------------------------------------------------}
PROCEDURE TStorage.CleanUpMsg;
VAR Dir : DirStr;
FName : NameStr;
Ext : ExtStr;
T : TBufStream;
TmpPtr : POINTER;
TFile : FILE;
OldItem : LONGINT;
NewItem : LONGINT;
LinkPtr : PList;
BEGIN
FSplit(SFileName,Dir,FName,Ext);
SCleanName := Dir + FName + '.$$$';
T.Init(SCleanName,stCreate,1024);
Seek(0);
OldItem := 0;
WHILE (OldItem < GetSize - 1) AND (Status = stOk) DO BEGIN
Read(Head,SIZEOF(Head));
IF Head.Marker <> MarkerWord THEN
Error(stStoreError,stStoreUnknownErr)
ELSE
BEGIN
TmpPtr := MemAlloc(Head.CompressSize);
IF TmpPtr = NIL THEN
Error(stStoreError,MemOverflow)
ELSE
BEGIN
Read(TmpPtr^,Head.CompressSize);
IF (Status = stOk) AND (Head.CompressType < $FF) THEN
BEGIN
NewItem := T.GetPos;
T.Write(Head,SIZEOF(Head));
T.Write(TmpPtr^,Head.CompressSize);
GETMEM(LinkPtr,SIZEOF(LList));
LinkPtr^.OldItem := OldItem;
LinkPtr^.NewItem := NewItem;
LinkPtr^.Next := SCleanIndex;
SCleanIndex := LinkPtr
END;
FREEMEM(TmpPtr,Head.CompressSize);
OldItem := GetPos
END
END
END;
T.Done;
IF Status <> stOk THEN
BEGIN
ASSIGN(TFile,SCleanName);
ERASE(TFile);
SCleanName := '';
Status := stStoreError
END
END;
{----------------------------------------------------------------------------}
FUNCTION TStorage.NewIndex;
VAR PLink : PList;
BEGIN
PLink := SCleanIndex;
NewIndex := -1;
WHILE (PLink <> NIL) AND (PLink^.OldItem <> Index) DO
PLink := PLink^.Next;
IF (PLink <> NIL) AND (PLink^.OldItem = Index) THEN
NewIndex := PLink^.NewItem
END;
{----------------------------------------------------------------------------}
PROCEDURE TStorage.DeleteCleanUp;
VAR TFile : FILE;
PLink : PList;
BEGIN
IF SCleanName <> '' THEN
BEGIN
{$I-} ASSIGN(TFile,SCleanName);
ERASE(TFile); {$I+}
ErrorInfo := IOResult;
IF ErrorInfo <> stOk THEN
Status := stStoreError;
SCleanName := '';
WHILE SCleanIndex <> NIL DO BEGIN
PLink := SCleanIndex;
SCleanIndex := PLink^.Next;
FREEMEM(PLink,SIZEOF(LList))
END
END
END;
{----------------------------------------------------------------------------}
CONST BitMask : ARRAY[0..7] OF BYTE = (1,2,4,8,16,32,64,128);
VAR Up : ARRAY[0..512] OF BYTE;
Left : ARRAY[0..255] OF WORD;
Right : ARRAY[0..255] OF WORD;
PROCEDURE Splay(Code : WORD); {Note 0..255 are characters, 256 is EOF}
VAR a : WORD;
b : WORD;
c : BYTE;
d : BYTE;
BEGIN
a := Code + 256;
REPEAT
c := Up[a];
IF c <> 0 THEN
BEGIN
d := Up[c];
b := Left[d];
IF c = b THEN
BEGIN
b := Right[d];
Right[d] := a
END
ELSE
Left[d] := a;
IF a = Left[c] THEN
Left[c] := b
ELSE
Right[c] := b;
Up[a] := d;
Up[b] := c;
a := d
END
ELSE
a := c
UNTIL a = 0
END;
{----------------------------------------------------------------------------}
FUNCTION TStorage.Compress;
VAR i : WORD;
NumWritten : WORD;
BitPos : BYTE;
OutByte : BYTE;
PROCEDURE WriteByte;
BEGIN
TBufStream.Write(OutByte,1);
INC(NumWritten);
BitPos := 0;
OutByte := 0
END;
PROCEDURE Comp(Code : WORD);
VAR a : WORD;
u : BYTE;
sp : WORD;
Stack : ARRAY[0..255] OF BOOLEAN;
BEGIN
a := Code + 256;
sp := 0;
REPEAT
u := Up[a];
Stack[sp] := (Right[u] = a);
INC(sp);
a := u
UNTIL a = 0;
REPEAT
DEC(sp);
IF Stack[sp] THEN
OutByte := OutByte OR BitMask[BitPos];
IF BitPos = 7 THEN
WriteByte
ELSE
INC(BitPos)
UNTIL sp = 0;
Splay(Code)
END;
BEGIN
InitCompress;
BitPos := 0;
OutByte := 0;
CompType := 2;
Compress := 0;
NumWritten := 0;
FOR i := 0 TO NumBytes - 1 DO
Comp(BBuffer(Buf)[i]);
Comp(256); {EOF Marker}
IF BitPos <> 0 THEN
WriteByte;
Compress := NumWritten
END;
{----------------------------------------------------------------------------}
PROCEDURE TStorage.DeCompress;
VAR NumWritten : WORD;
BufRead : WORD;
InByte : BYTE;
OutByte : WORD;
BitPos : BYTE;
FUNCTION Expand : WORD;
VAR a : WORD;
BEGIN
a := 0;
REPEAT
IF BitPos = 7 THEN
BEGIN
TBufStream.Read(InByte,1);
BitPos := 0
END
ELSE
INC(BitPos);
IF InByte AND BitMask[BitPos] = 0 THEN
a := Left[a]
ELSE
a := Right[a]
UNTIL a > 255;
DEC(a,256);
Splay(a);
Expand := a
END;
BEGIN
CASE CompType OF
0 : TBufStream.Read(Buf,NumBytes);
2 : BEGIN
InitCompress;
BitPos := 7;
BufRead := 0;
NumWritten := 0;
OutByte := Expand;
WHILE OutByte <> 256 DO BEGIN
BBuffer(Buf)[NumWritten] := OutByte;
INC(NumWritten);
OutByte := Expand
END
END
END
END;
{----------------------------------------------------------------------------}
PROCEDURE TStorage.InitCompress;
VAR i : WORD;
j : BYTE;
k : WORD;
BEGIN
FOR i := 1 TO 512 DO
Up[i] := (i - 1) SHR 1;
FOR j := 0 TO 255 DO BEGIN
k := (j + 1) SHL 1;
Left[j] := k - 1;
Right[j] := k
END
END;
{----------------------------------------------------------------------------}
DESTRUCTOR TStorage.Done;
VAR TFile : FILE;
PLink : PList;
BEGIN
IF (SHoldBuf <> NIL) AND (SHoldBufLen > 0) THEN
FREEMEM(SHoldBuf,SHoldBufLen);
TBufStream.Done;
IF SCleanName <> '' THEN
BEGIN
ASSIGN(TFile,SFileName);
ERASE(TFile);
ASSIGN(TFile,SCleanName);
RENAME(TFile,SFileName);
SCleanName := ''
END;
WHILE SCleanIndex <> NIL DO BEGIN
PLink := SCleanIndex;
SCleanIndex := PLink^.Next;
FREEMEM(PLink,SIZEOF(LList))
END
END;
{----------------------------------------------------------------------------}
END.
(*--------------------------------------------------------------------------*)
(*-- OLDER METHOD OF COMPRESSION/DECOMPRESSION --*
{----------------------------------------------------------------------------}
PROCEDURE TStorage.Compress;
VAR p : PBuffer;
ReadPosn : WORD;
WritePosn : WORD;
SpaceCount : WORD;
BEGIN
p := PBuffer(@Buf);
ReadPosn := 0;
WritePosn := 0;
WHILE (p^[ReadPosn] <> 0) AND (ReadPosn < 65530) DO BEGIN
SpaceCount := 0;
WHILE (p^[ReadPosn + SpaceCount] = 32) DO
INC(SpaceCount);
IF SpaceCount > 1 THEN
BEGIN
INC(ReadPosn,SpaceCount);
WHILE SpaceCount > 0 DO
IF SpaceCount > 255 THEN
BEGIN
p^[WritePosn] := 255;
p^[WritePosn + 1] := 255;
INC(WritePosn,2);
DEC(SpaceCount,255)
END
ELSE
BEGIN
p^[WritePosn] := 255;
p^[WritePosn + 1] := SpaceCount;
INC(WritePosn,2);
SpaceCount := 0
END;
SpaceCount := 2
END;
IF SpaceCount = 1 THEN
IF (p^[ReadPosn + 1] >= 64) AND (p^[ReadPosn + 1] <= 127) THEN
BEGIN
p^[WritePosn] := p^[ReadPosn + 1] + 128;
INC(WritePosn);
INC(ReadPosn,2)
END
ELSE
SpaceCount := 0;
IF SpaceCount = 0 THEN
BEGIN
IF p^[ReadPosn + 1] = 101 THEN
BEGIN
p^[WritePosn] := p^[ReadPosn] + 64;
INC(ReadPosn,2)
END
ELSE
BEGIN
p^[WritePosn] := p^[ReadPosn];
INC(ReadPosn)
END;
INC(WritePosn)
END
END;
p^[WritePosn] := 0;
MOVE(p^[0],p^[1],WritePosn + 1);
p^[0] := 1
END;
{----------------------------------------------------------------------------}
PROCEDURE TStorage.DeCompress;
VAR p : PBuffer;
ReadPosn : WORD;
Count : WORD;
Total : WORD;
BEGIN
p := PBuffer(@Buf);
ReadPosn := 0;
Total := 0;
WHILE (p^[Total + 1] <> 0) DO
INC(Total);
IF p^[0] = 1 THEN
BEGIN
MOVE(p^[1],p^[0],Total);
p^[Total] := 0;
WHILE (p^[ReadPosn] <> 0) AND (ReadPosn < SholdBufLen) DO BEGIN
CASE p^[ReadPosn] OF
255 : BEGIN
Count := p^[ReadPosn + 1];
MOVE(p^[ReadPosn + 2],p^[ReadPosn + Count],SHoldBufLen - ReadPosn - 2);
FILLCHAR(p^[ReadPosn],Count,32);
INC(ReadPosn,Count)
END;
192..254 : BEGIN
MOVE(p^[ReadPosn],p^[ReadPosn + 1],SHoldBufLen - ReadPosn);
p^[ReadPosn] := 32;
DEC(p^[ReadPosn + 1],128);
INC(ReadPosn,2)
END;
160..191 : BEGIN
MOVE(p^[ReadPosn],p^[ReadPosn + 1],SHoldBufLen - ReadPosn);
p^[ReadPosn + 1] := 101;
DEC(p^[ReadPosn],64);
INC(ReadPosn,2)
END;
000..159 : INC(ReadPosn)
END
END
END
END;
*--------------------------------------------------------------------------*)
