home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / UTILITY / ENCODE.M < prev    next >
Encoding:
Text File  |  1990-12-14  |  4.1 KB  |  158 lines
  1. MODULE Encode;
  2.  
  3. (* Komprimiert Dateien.
  4.  *
  5.  * Eine komprimierte Datei hat folgenden Header:
  6.  * 8 Zeichen: "MM2Comp"+0C
  7.  * ...die komprimierten Daten
  8.  *)
  9.  
  10. IMPORT GEMIO;
  11. FROM EasyGEM1 IMPORT SelectFile;
  12. FROM MOSGlobals IMPORT fNoMatchingFiles, PathStr, FileStr;
  13. FROM BinOps IMPORT LowerLCard;
  14. IMPORT Files, Binary;
  15. FROM Directory IMPORT Delete, DirQuery, DirQueryProc, DirEntry, FileAttrSet,
  16.         SetFileAttr;
  17. FROM FileNames IMPORT SplitPath, PathConc;
  18. FROM InOut IMPORT Write, WriteString, WriteCard, WriteLn, Read, WritePg,
  19.         BusyRead, ReadString, GotoXY;
  20. FROM Strings IMPORT Space, Length, Empty, Append, String, Compare, Relation;
  21. FROM SYSTEM IMPORT ADDRESS, ADR, TSIZE, BYTE, WORD, LONGWORD;
  22. FROM Storage IMPORT ALLOCATE, DEALLOCATE;
  23. IMPORT Compressions;
  24.  
  25. TYPE Ascii = SET OF CHAR;
  26.  
  27. VAR ok: BOOLEAN;
  28.     r: INTEGER;
  29.     all: BOOLEAN;
  30.     destPath: PathStr;
  31.  
  32. PROCEDURE get (a: Ascii): CHAR;
  33.   VAR c: CHAR;
  34.   BEGIN
  35.     REPEAT
  36.       Read (c);
  37.       IF c >= ' ' THEN Write (CHR (8)) END;
  38.       c:= CAP (c);
  39.     UNTIL c IN a;
  40.     RETURN c
  41.   END get;
  42.  
  43. PROCEDURE wait;
  44.   VAR c: CHAR;
  45.   BEGIN
  46.     WriteLn;
  47.     WriteLn;
  48.     WriteString ('Taste zum Beenden...');
  49.     Read (c)
  50.   END wait;
  51.  
  52. PROCEDURE error;
  53.   VAR s: ARRAY [0..31] OF CHAR;
  54.   BEGIN
  55.     WriteLn;
  56.     Files.GetStateMsg (r, s);
  57.     WriteString ('Fehler: ');
  58.     WriteString (s);
  59.     WriteLn;
  60.     r:= 0
  61.   END error;
  62.  
  63. PROCEDURE ferror (f: Files.File);
  64.   BEGIN
  65.     r:= Files.State (f);
  66.     error
  67.   END ferror;
  68.  
  69.  
  70. PROCEDURE insFile (REF path: ARRAY OF CHAR; e: DirEntry): BOOLEAN;
  71.  
  72.   VAR c: CHAR; dam: BOOLEAN;
  73.       f: Files.File;
  74.       n: LONGCARD;
  75.       source, dest: ADDRESS;
  76.       dlen: LONGCARD;
  77.       str: POINTER TO ARRAY [0..7] OF CHAR;
  78.  
  79.   BEGIN
  80.     WriteLn;
  81.     WriteString (e.name);
  82.     IF ~all THEN
  83.       WriteString (' ? (Ja/Nein/Alle/Fertig) ');
  84.       c:= get (Ascii{'J','N','A','F'});
  85.       IF c='F' THEN
  86.         RETURN FALSE
  87.       ELSIF c='N' THEN
  88.         RETURN TRUE
  89.       ELSIF c='A' THEN
  90.         all:= TRUE
  91.       END
  92.     END;
  93.     ALLOCATE (source, e.size);
  94.     Files.Open (f, PathConc (path, e.name), Files.readOnly);
  95.     Binary.ReadBytes (f, source, e.size, n);
  96.     IF n # e.size THEN HALT END;
  97.     Files.Close (f);
  98.     str:= source;
  99.     IF Compare ("MM2Comp", str^) = equal THEN
  100.       WriteString (' ist bereits komprimiert!')
  101.     ELSE
  102.       ALLOCATE (dest, e.size+14L);  (* 8 Byte f. "MM2Comp" & 6 Byte Reserve *)
  103.       str:= dest;
  104.       str^:= "MM2Comp";
  105.       str^[7]:= 0C;
  106.       Compressions.Encode (0, source, e.size,
  107.                            dest+8L, e.size+Compressions.DestOverhead, dlen);
  108.       Files.Create (f, PathConc (destPath, e.name),
  109.                     Files.writeOnly, Files.replaceOld);
  110.       Binary.WriteBytes (f, dest, dlen + 8L);
  111.       Files.Close (f);
  112.       DEALLOCATE (dest, 0);
  113.       IF Files.State (f) < 0 THEN ferror (f); RETURN FALSE END;
  114.       (* Datum/Zeit der komprimierten Datei übernehmen *)
  115.       Files.Open (f, PathConc (destPath, e.name), Files.readWrite);
  116.       Files.SetDateTime (f, e.date, e.time);
  117.       Files.Close (f);
  118.       WriteString ('   ');
  119.       WriteCard (100L * (dlen + 8L) DIV e.size, 3);
  120.       Write ('%');
  121.     END;
  122.     DEALLOCATE (source, 0);
  123.     RETURN TRUE
  124.   END insFile;
  125.  
  126. PROCEDURE newFile;
  127.   VAR s: FileStr; dummy: ARRAY [0..11] OF CHAR;
  128.   BEGIN
  129.     WriteString ('Name der zu komprimierenden Datei (Wildcards sind erlaubt, z.B "*.DEF")? ');
  130.     WriteLn;
  131.     s:= '';
  132.     SelectFile ('', s, ok);
  133.     IF NOT ok THEN RETURN END;
  134.     WriteString (s);
  135.     WriteLn;
  136.     WriteLn;
  137.     WriteString ('Ziel-Pfad: ');
  138.     destPath:= '';
  139.     SelectFile ('Ziel-Pfad?', destPath, ok);
  140.     IF NOT ok THEN RETURN END;
  141.     SplitPath (destPath, destPath, dummy);
  142.     WriteString (destPath);
  143.     all:= FALSE;
  144.     DirQuery (s, FileAttrSet {}, insFile, r);
  145.     IF r < 0 THEN error END
  146.   END newFile;
  147.  
  148. BEGIN
  149.   WriteLn ();
  150.   WriteString (' Kodierer für Megamax Modula-2');
  151.   WriteLn ();
  152.   WriteString (' Erstellt 8/1989 von Gabi Keller, Manuel Chakravarty & Thomas Tempelmann');
  153.   WriteLn ();
  154.   WriteLn ();
  155.   newFile;
  156.   wait;
  157. END Encode.
  158.