IMPLEMENTATION MODULE DM_USER;
(* Demo f�r die Erstellung eigener DLL's zur Benutzung mit DiskMaster *)
(* Peter Engels, im August 1994 *)
(*# call (near_call => on,
          o_a_copy => off) *)
(*# call (inline_max => 2000) *)
(*# option (bit_opr => on) *)

  IMPORT Lib,FIO;

  CONST Version_Low = 0;
        Version_High = 1;
        BufferSize = 8 * 1024;
        Mask = {1,2,5,7}; (* XOR - Maske *)

  TYPE DM_Id_str = ARRAY [0..7] OF CHAR;
       hdrTp = RECORD
                 DM_Id : DM_Id_str;
                 majorVersion,
                 minorVersion : SHORTCARD;
               END;
       fbuf = POINTER TO ARRAY [0..BufferSize - 1] OF BYTE;
       BufferedFile = RECORD
                        f : File;
                        fsize : LONGCARD;
                        buf : fbuf;
                        idx : CARDINAL;
                        cnt : LONGCARD
                      END;

  VAR TheGuard : GuardProc;
      ALLOCATE,
      DEALLOCATE : StoreProc;
      InPut,
      OutPut : BufferedFile;
      JmpBuffer : Lib.LongLabel;

  CONST DM_ID = DM_Id_str ('DM_USER');

  PROCEDURE WrHdr (f : File) : BOOLEAN;

    VAR hdr : hdrTp;

  BEGIN
    Lib.Fill (ADR (hdr),SIZE (hdr),0C);
    WITH hdr DO
      DM_Id := DM_ID;
      majorVersion := Version_High;
      minorVersion := Version_Low;
    END;
    FIO.WrBin (f,hdr,SIZE (hdr));
    RETURN FIO.IOresult () = 0
  END WrHdr;

  PROCEDURE IsPacked (f : File) : BOOLEAN;

    VAR hdr : hdrTp;
        n : CARDINAL;

  BEGIN
    FIO.Seek (f,0);
    n := FIO.RdBin (f,hdr,SIZE (hdr));
    IF FIO.IOresult () = 0 THEN
      WITH hdr DO
        IF DM_ID # DM_Id THEN
          RETURN FALSE;
        END;
        IF (Version_High # majorVersion) THEN
          RETURN FALSE
        END
      END
    ELSE
      RETURN FALSE
    END;
    FIO.Seek (f,0);
    RETURN TRUE;
  END IsPacked;

  INLINE PROCEDURE InByte () : SHORTCARD;

    VAR b : SHORTCARD;
        n : CARDINAL;

  BEGIN
    WITH InPut DO
      IF idx = BufferSize THEN
        n := FIO.RdBin (f,buf^,BufferSize);
        INC (cnt,BufferSize);
        IF (FIO.IOresult () # 0) OR ~ TheGuard (CARDINAL ((100 * cnt) DIV
           fsize)) THEN
          Lib.LongJmp (JmpBuffer,1)
        END;
        idx := 0
      END;
      b := buf^ [idx];
      INC (idx);
      RETURN b
    END
  END InByte;

  INLINE PROCEDURE OutByte (b : SHORTCARD);

  BEGIN
    WITH OutPut DO
      IF idx = BufferSize THEN
        FIO.WrBin (f,buf^,BufferSize);
        IF FIO.IOresult () # 0 THEN
          Lib.LongJmp (JmpBuffer,1)
        END;
        idx := 0
      END;
      buf^ [idx] := b;
      INC (idx)
    END
  END OutByte;

  PROCEDURE Flush;

  BEGIN
    WITH OutPut DO
      IF idx > 0 THEN
        FIO.WrBin (f,buf^,idx);
        IF FIO.IOresult () # 0 THEN
          Lib.LongJmp (JmpBuffer,1)
        END;
      END
    END
  END Flush;

  PROCEDURE InitFile (theFile : File;
                      VAR bf : BufferedFile) : BOOLEAN;

  BEGIN
    WITH bf DO
      f := theFile;
      fsize := FIO.Size (f);
      idx := 0;
      ALLOCATE (buf,BufferSize);
      RETURN buf # NIL
    END
  END InitFile;

  PROCEDURE CloseFileBuffer (VAR bf : BufferedFile);

  BEGIN
    DEALLOCATE (bf.buf,BufferSize)
  END CloseFileBuffer;

  PROCEDURE Compress (input,output : File;
                      Guard : GuardProc) : BOOLEAN;

    VAR ok : BOOLEAN;
        i : LONGCARD;

  BEGIN
    IF Lib.SetJmp (JmpBuffer) = 0 THEN
      ok := FALSE;
      IF WrHdr (output) THEN
        IF InitFile (input,InPut) THEN
          InPut.idx := BufferSize;
          IF InitFile (output,OutPut) THEN
            TheGuard := Guard;
            FOR i := 1 TO InPut.fsize DO
              OutByte (SHORTCARD (BITSET (InByte ()) / Mask))
            END;
            Flush;
            CloseFileBuffer (OutPut);
            ok := TRUE
          END;
          CloseFileBuffer (InPut)
        END
      END;
      RETURN ok
    ELSE
      RETURN FALSE
    END
  END Compress;

  PROCEDURE Expand (input,output : File;
                    Guard : GuardProc) : BOOLEAN;

    VAR ok : BOOLEAN;
        i,
        fsize : LONGCARD;

  BEGIN
    IF Lib.SetJmp (JmpBuffer) = 0 THEN
      ok := FALSE;
      IF IsPacked (input) THEN
        IF InitFile (input,InPut) THEN
          InPut.idx := BufferSize;
          IF InitFile (output,OutPut) THEN
            TheGuard := Guard;
            FIO.Seek (input,SIZE (hdrTp));
            fsize := InPut.fsize - SIZE (hdrTp);
            FOR i := 1 TO fsize DO
              OutByte (SHORTCARD (BITSET (InByte ()) / Mask))
            END;
            Flush;
            CloseFileBuffer (OutPut);
            ok := TRUE
          END;
          CloseFileBuffer (InPut)
        END
      END;
      RETURN ok
    ELSE
      RETURN FALSE
    END
  END Expand;

  PROCEDURE InitModule (GetMem,FreeMem : StoreProc);

  BEGIN
    ALLOCATE := GetMem;
    DEALLOCATE := FreeMem;
    FIO.IOcheck := FALSE
  END InitModule;

  PROCEDURE CloseModule;

  BEGIN
(* tut nichts *)
  END CloseModule;

END DM_USER.