ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/STORAGE.ZIP/STORAGE.PAS

Pascal/Delphi Source File | 1991-02-09 | 17.4 KB | 615 lines

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;

 *--------------------------------------------------------------------------*)