home *** CD-ROM | disk | FTP | other *** search
/ Chip 2004 July / Chip_2004-07_cd1.bin / tema / aos / files / Oberon.exe / Oberon / Docu.exe / Docu / Suitcases.Mod (.txt) < prev    next >
Oberon Text  |  2000-02-29  |  13KB  |  335 lines
  1. Oberon10.Scn.Fnt
  2. Syntax10.Scn.Fnt
  3. (* ETH Oberon, Copyright 2000 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
  4. Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
  5. MODULE Suitcases; (** portable *)    (** jm 22.2.95 *)
  6. (** Suitcase gadgets allow you to pack files and texts in a gadget. Storing the gadget, will also
  7. store its contents, keeping the gadget and its contents together.
  8. Usage:
  9.     Suitcases.PackText *        Pack the marked text document and insert the suitcase at the caret.
  10.     Suitcases.PackFiles filenames ~        Pack the named files and insert the suitcases at the caret.
  11. Clicking on a suitcase will open its contents as a document, but NOT overwrite any files on the local
  12. disk. This makes them ideal to be mailed.
  13. IMPORT Files, Display, Display3, Fonts, Printer, Printer3, Effects, Attributes, Objects, Gadgets,
  14.     Oberon, Texts, TextGadgets, Desktops, TextDocs, Documents, Out;
  15.     (** FileObj's store complete files *)
  16.     FileObj* = POINTER TO FileObjDesc;
  17.     FileObjDesc* = RECORD (Gadgets.ObjDesc)
  18.         F*: Files.File;    (** carrier file *)
  19.         beg*, len*: LONGINT;    (** file offset and length *)
  20.     END;
  21.     Suitcase* = POINTER TO SuitcaseDesc;
  22.     SuitcaseDesc* = RECORD (Gadgets.FrameDesc)
  23.         col*: INTEGER;
  24.         label*: ARRAY 64 OF CHAR;    (** caption *)
  25.     END;
  26. (* --- FileObj --- *)
  27. PROCEDURE FileObjHandler*(obj: Objects.Object; VAR M: Objects.ObjMsg);
  28. VAR obj0: FileObj; len: LONGINT; R: Files.Rider; ch: CHAR;
  29. BEGIN
  30.     WITH obj: FileObj DO
  31.         IF M IS Objects.AttrMsg THEN
  32.             WITH M: Objects.AttrMsg DO
  33.                 IF M.id = Objects.get THEN
  34.                     IF M.name = "Gen" THEN M.class := Objects.String; COPY("Suitcases.NewFileObj", M.s); M.res := 0
  35.                     ELSE Gadgets.objecthandle(obj, M)
  36.                     END
  37.                 ELSIF M.id = Objects.set THEN Gadgets.objecthandle(obj, M)
  38.                 ELSIF M.id = Objects.enum THEN Gadgets.objecthandle(obj, M)
  39.                 END
  40.             END
  41.         ELSIF M IS Objects.CopyMsg THEN
  42.             WITH M: Objects.CopyMsg DO
  43.                 IF M.stamp = obj.stamp THEN M.obj := obj.dlink    (* copy msg arrives again *)
  44.                 ELSE (* first time copy message arrives *)
  45.                     NEW(obj0); obj.stamp := M.stamp; obj.dlink := obj0;
  46.                     obj0.handle := obj.handle;
  47.                     obj0.F := obj.F; obj0.beg := obj.beg; obj0.len := obj.len;
  48.                     M.obj := obj0
  49.                 END
  50.             END
  51.         ELSIF M IS Objects.FileMsg THEN
  52.             WITH M: Objects.FileMsg DO
  53.                 IF M.id = Objects.store THEN
  54.                     len := obj.len;
  55.                     Files.WriteLInt(M.R, obj.len);
  56.                     Files.Set(R, obj.F, obj.beg);
  57.                     Files.Read(R, ch);
  58.                     WHILE len > 0 DO
  59.                         Files.Write(M.R, ch);
  60.                         Files.Read(R, ch); DEC(len)
  61.                     END;
  62.                     Files.WriteLInt(M.R, 42);
  63.                     Gadgets.objecthandle(obj, M)
  64.                 ELSIF M.id = Objects.load THEN
  65.                     obj.F := Files.Base(M.R);
  66.                     Files.ReadLInt(M.R, obj.len); 
  67.                     obj.beg := Files.Pos(M.R);
  68.                     Files.Set(M.R, Files.Base(M.R), obj.beg + obj.len);
  69.                     Files.ReadLInt(M.R, len); ASSERT(len = 42);
  70.                     Gadgets.objecthandle(obj, M)
  71.                 END
  72.             END
  73.         ELSE Gadgets.objecthandle(obj, M)
  74.         END
  75. END FileObjHandler;
  76. (** Initialize a file object with a file *)
  77. PROCEDURE OpenFileObj*(obj: FileObj; F: Files.File);
  78. BEGIN
  79.     obj.handle := FileObjHandler;
  80.     obj.F := F;
  81.     IF F # NIL THEN
  82.         obj.beg := 0;
  83.         obj.len := Files.Length(F)
  84. END OpenFileObj;
  85. PROCEDURE NewFileObj*;
  86. VAR obj: FileObj;
  87. BEGIN
  88.     NEW(obj); OpenFileObj(obj, NIL); Objects.NewObj := obj;
  89. END NewFileObj;
  90. (** unpack a file object into the named file *)
  91. PROCEDURE UnpackFileObj*(obj: FileObj; filename: ARRAY OF CHAR);
  92. VAR F: Files.File; R, r: Files.Rider; ch: CHAR; len: LONGINT;
  93. BEGIN
  94.     F := Files.New(filename); Files.Set(r, F, 0);
  95.     len := obj.len;
  96.     Files.Set(R, obj.F, obj.beg);
  97.     Files.Read(R, ch);
  98.     WHILE len > 0 DO
  99.         Files.Write(r, ch);
  100.         Files.Read(R, ch); DEC(len)
  101.     END;
  102.     Files.Register(F);
  103. END UnpackFileObj;
  104. (* --- Suitcases --- *)
  105. PROCEDURE SuitcaseAttr(F: Suitcase; VAR M: Objects.AttrMsg);
  106. BEGIN
  107.     IF M.id = Objects.get THEN
  108.         IF M.name = "Gen" THEN M.class := Objects.String; COPY("Suitcases.NewSuitcase", M.s); M.res := 0
  109.         ELSIF M.name = "Color" THEN M.class := Objects.Int; M.i := F.col; M.res := 0 
  110.         ELSIF M.name = "Label" THEN M.class := Objects.String; COPY(F.label, M.s); M.res := 0
  111.         ELSE Gadgets.framehandle(F, M)
  112.         END
  113.     ELSIF M.id = Objects.set THEN
  114.         IF M.name = "Color" THEN
  115.             IF M.class = Objects.Int THEN F.col := SHORT(M.i); M.res := 0 END
  116.         ELSIF M.name = "Label" THEN 
  117.             IF M.class = Objects.String THEN COPY(M.s, F.label); M.res := 0 END
  118.         ELSE Gadgets.framehandle(F, M);
  119.         END
  120.     ELSIF M.id = Objects.enum THEN
  121.         M.Enum("Color"); M.Enum("Label"); Gadgets.framehandle(F, M)
  122. END SuitcaseAttr;
  123. PROCEDURE RestoreSuitcase(F: Suitcase; M: Display3.Mask; x, y, w, h: INTEGER);
  124. VAR j: INTEGER;
  125. BEGIN
  126.     j := w DIV 2 - 10;
  127.     Display3.Rect3D(M, Display3.topC, Display3.bottomC, x + j, y + h - 12, 20, 10, 1, Display.replace);
  128.     Display3.Rect3D(M, Display3.bottomC, Display3.topC, x + j + 2, y + h - 10, 16, 6, 1, Display.replace);
  129.     Display3.FilledRect3D(M, Display3.topC, Display3.bottomC, F.col, x, y, w, h - 10, 1, Display.replace);
  130.     Display3.CenterString(M, Display3.FG, x, y, w, h - 10, Fonts.Default, F.label, Display.paint);
  131.     IF Gadgets.selected IN F.state THEN
  132.         Display3.FillPattern(M, Display3.white, Display3.selectpat, x, y, x, y, w, h, Display.paint)
  133. END RestoreSuitcase;
  134. PROCEDURE Print(F: Suitcase; VAR M: Display.DisplayMsg);
  135. VAR R: Display3.Mask;
  136.     PROCEDURE P(x: INTEGER): INTEGER;
  137.     BEGIN RETURN SHORT(x * Display.Unit DIV Printer.Unit)
  138.     END P;
  139. BEGIN
  140.     Gadgets.MakePrinterMask(F, M.x, M.y, M.dlink, R);
  141.     Printer3.ReplConst(R, F.col, M.x, M.y, P(F.W), P(F.H), Display.replace);
  142. END Print;
  143. PROCEDURE CopySuitcase*(VAR M: Objects.CopyMsg; from, to: Suitcase);
  144. BEGIN
  145.     to.col := from.col; COPY(from.label, to.label);
  146.     Gadgets.CopyFrame(M, from, to);
  147. END CopySuitcase;
  148. PROCEDURE OpenSuitcase(F: Suitcase; obj: Objects.Object);
  149. VAR D: Documents.Document; f: TextGadgets.Frame; res: INTEGER;
  150. BEGIN
  151.     IF obj # NIL THEN
  152.         IF obj IS Texts.Text THEN
  153.             WITH obj: Texts.Text DO
  154.                 NEW(D); TextDocs.InitDoc(D); (* make document wrapper *)
  155.                 NEW(f); TextGadgets.Init(f, obj, FALSE);    (* create content *)
  156.                 Documents.Init(D, f); (* and merge together *)
  157.                 D.W := Display.Width DIV 8 * 3 + 20;
  158.                 COPY(F.label, D.name);
  159.                 Desktops.ShowDoc(D)
  160.             END
  161.         ELSIF obj IS FileObj THEN
  162.             WITH obj: FileObj DO
  163.                 UnpackFileObj(obj, "Suitcases.Tmp");
  164.                 D := Documents.Open("Suitcases.Tmp");
  165.                 IF D = NIL THEN Out.String("   document cannot be opened"); Out.Ln
  166.                 ELSE
  167.                     COPY(F.label, D.name);
  168.                     Desktops.ShowDoc(D);
  169.                     Files.Delete("Suitcases.Tmp", res);
  170.                 END
  171.             END
  172.         END
  173. END OpenSuitcase;
  174. PROCEDURE SuitcaseHandler*(F: Objects.Object; VAR M: Objects.ObjMsg);
  175. VAR x, y, w, h: INTEGER; F0: Suitcase; R: Display3.Mask;
  176. BEGIN
  177.     WITH F: Suitcase DO
  178.         IF M IS Display.FrameMsg THEN
  179.             WITH M: Display.FrameMsg DO
  180.                 IF (M.F = NIL) OR (M.F = F) THEN    (* message addressed to this frame *)
  181.                     x := M.x + F.X; y := M.y + F.Y; w := F.W; h := F.H; (* calculate display coordinates *)
  182.                     IF M IS Display.DisplayMsg THEN
  183.                         WITH M: Display.DisplayMsg DO
  184.                             IF M.device = Display.screen THEN
  185.                                 IF (M.id = Display.full) OR (M.F = NIL) THEN
  186.                                     Gadgets.MakeMask(F, x, y, M.dlink, R);
  187.                                     RestoreSuitcase(F, R, x, y, w, h)
  188.                                 ELSIF M.id = Display.area THEN
  189.                                     Gadgets.MakeMask(F, x, y, M.dlink, R);
  190.                                     Display3.AdjustMask(R, x + M.u, y + h - 1 + M.v, M.w, M.h);
  191.                                     RestoreSuitcase(F, R, x, y, w, h)
  192.                                 END
  193.                             ELSIF M.device = Display.printer THEN Print(F, M)
  194.                             END
  195.                         END
  196.                     ELSIF M IS Oberon.InputMsg THEN
  197.                         WITH M: Oberon.InputMsg DO
  198.                             IF (M.id = Oberon.track) & Gadgets.InActiveArea(F, M) & (M.keys = {1}) THEN
  199.                                 Gadgets.MakeMask(F, x, y, M.dlink, R);
  200.                                 Effects.TrackHighlight(R, M.keys, M.X, M.Y, x, y, w, h);
  201.                                 IF Gadgets.InActiveArea(F, M) & (M.keys = {1}) THEN (* activated *)
  202.                                     IF F.obj # NIL THEN OpenSuitcase(F, F.obj)
  203.                                     ELSE Out.String("Suitcase is empty"); Out.Ln;
  204.                                     END
  205.                                 END;
  206.                                 M.res := 0;
  207.                             ELSE Gadgets.framehandle(F, M)
  208.                             END
  209.                         END
  210.                     ELSE Gadgets.framehandle(F, M)
  211.                     END
  212.                 END
  213.             END
  214.         (* Object messages *)
  215.         ELSIF M IS Objects.AttrMsg THEN SuitcaseAttr(F, M(Objects.AttrMsg))
  216.         ELSIF M IS Objects.FileMsg THEN
  217.             WITH M: Objects.FileMsg DO
  218.                 IF M.id = Objects.store THEN (* store private data here *)
  219.                     Files.WriteInt(M.R, F.col);
  220.                     Files.WriteString(M.R, F.label);
  221.                     Gadgets.framehandle(F, M)
  222.                 ELSIF M.id = Objects.load THEN (* load private data here *)
  223.                     Files.ReadInt(M.R, F.col);
  224.                     Files.ReadString(M.R, F.label);
  225.                     Gadgets.framehandle(F, M)
  226.                 END
  227.             END
  228.         ELSIF M IS Objects.CopyMsg THEN
  229.             WITH M: Objects.CopyMsg DO
  230.                 IF M.stamp = F.stamp THEN M.obj := F.dlink    (* copy msg arrives again *)
  231.                 ELSE    (* first time copy message arrives *)
  232.                     NEW(F0); F.stamp := M.stamp; F.dlink := F0; CopySuitcase(M, F, F0); M.obj := F0
  233.                 END
  234.             END
  235.         ELSIF M IS Objects.BindMsg THEN
  236.             IF F.obj # NIL THEN F.obj.handle(F.obj, M) END;
  237.             Gadgets.framehandle(F, M);
  238.         ELSE    (* unknown msg, framehandler might know it *)
  239.             Gadgets.framehandle(F, M)
  240.         END
  241. END SuitcaseHandler;
  242. PROCEDURE InitSuitcase*(F: Suitcase); (* provided for later type extensions *)
  243. BEGIN F.W := 80; F.H := 30; F.col := Display3.groupC; INCL(F.state, Gadgets.transparent); COPY("Empty", F.label); F.handle := SuitcaseHandler
  244. END InitSuitcase;
  245. PROCEDURE NewSuitcase*;
  246. VAR F: Suitcase;
  247. BEGIN NEW(F); InitSuitcase(F); Objects.NewObj := F;
  248. END NewSuitcase;
  249. (* --- text handling --- *)
  250. PROCEDURE GetLabel(T: Texts.Text; VAR label: ARRAY OF CHAR);
  251. VAR R: Texts.Reader; ch: CHAR; keyw: ARRAY 6 OF CHAR; 
  252.     PROCEDURE ReadLine;
  253.     VAR i, j: INTEGER;
  254.     BEGIN
  255.         Texts.Read(R, ch); i := 0; j := 0;
  256.         WHILE ~R.eot & (ch # 0DX) DO
  257.             IF i < LEN(keyw) - 1 THEN keyw[i] := ch; INC(i);
  258.                 IF ch = ":" THEN i := LEN(keyw) END; (* cut off *)
  259.             ELSE
  260.                 IF (j < LEN(label) - 1) & (ch > " ") THEN label[j] := ch; INC(j) END;
  261.             END;
  262.             Texts.Read(R, ch);
  263.         END;
  264.         keyw[i] := 0X; label[j] := 0X;
  265.     END ReadLine;
  266. BEGIN
  267.     Texts.OpenReader(R, T, 0);
  268.     ReadLine;
  269.     WHILE ~R.eot & (keyw # "") DO
  270.         IF (keyw = "From:") OR (keyw = "Re:") THEN RETURN END;
  271.         ReadLine;
  272.     END;
  273.     label[0] := 0X
  274. END GetLabel;
  275. (** Make a suitcase out of a text *)
  276. PROCEDURE MakeTextSuitcase*(F: Suitcase; label: ARRAY OF CHAR; T: Texts.Text);
  277. VAR buf: Texts.Buffer; text: Texts.Text; d: INTEGER; maillabel: ARRAY 128 OF CHAR;
  278. BEGIN
  279.     NEW(buf); Texts.OpenBuf(buf);
  280.     Texts.Save(T, 0, T.len, buf);
  281.     GetLabel(T, maillabel);
  282.     IF maillabel # "" THEN COPY(maillabel, label) END;
  283.     NEW(text); Texts.Open(text, "");
  284.     Texts.Insert(text, 0, buf);
  285.     InitSuitcase(F); COPY(label, F.label); F.obj := text;
  286.     Display3.StringSize(F.label, Fonts.Default, F.W, F.H, d);
  287.     INC(F.W, 10); INC(F.H, 20);
  288. END MakeTextSuitcase;
  289. (** Make a suitcase out of a file *)
  290. PROCEDURE MakeFileSuitcase*(F: Suitcase; filename: ARRAY OF CHAR);
  291. VAR d: INTEGER; f: FileObj;
  292. BEGIN
  293.     InitSuitcase(F); COPY(filename, F.label);
  294.     NEW(f); OpenFileObj(f, Files.Old(filename)); F.obj := f;
  295.     Display3.StringSize(F.label, Fonts.Default, F.W, F.H, d);
  296.     INC(F.W, 10); INC(F.H, 20);
  297. END MakeFileSuitcase;
  298. (* --- *)
  299. (** Pack the marked text document and insert it at caret *)
  300. PROCEDURE PackText*;
  301. VAR doc: Documents.Document; M: Objects.LinkMsg; F: Suitcase;
  302. BEGIN
  303.     doc := Documents.MarkedDoc();
  304.     IF (doc # NIL) & (doc.dsc # NIL) THEN
  305.         M.id := Objects.get; M.name := "Model"; M.obj := NIL; M.res := -1; doc.dsc.handle(doc.dsc, M);
  306.         IF (M.obj # NIL) & (M.obj IS Texts.Text) THEN
  307.             NEW(F); MakeTextSuitcase(F, doc.name, M.obj(Texts.Text));
  308.             Gadgets.Integrate(F)
  309.         END
  310. END PackText;
  311. (** Suitcases.PackFile filelist ~
  312. Pack the named files and insert the suitcases at the caret. *)
  313. PROCEDURE PackFiles*;
  314. VAR S: Attributes.Scanner; F: Files.File; s: Suitcase; l: Display.Frame;
  315. BEGIN l := NIL;
  316.     Attributes.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
  317.     Attributes.Scan(S);
  318.     WHILE (S.class = Attributes.Name) OR (S.class = Attributes.String) DO
  319.         F := Files.Old(S.s);
  320.         IF F # NIL THEN
  321.             NEW(s); MakeFileSuitcase(s, S.s); s.slink := l; l := s;
  322.         ELSE Out.String(S.s); Out.String("  file not found"); Out.Ln
  323.         END;
  324.         Attributes.Scan(S)
  325.     END;
  326.     Gadgets.Integrate(l);
  327. END PackFiles;
  328. END Suitcases.
  329. System.Free Suitcases ~
  330. Gadgets.Insert Suitcases.NewSuitcase ~
  331. Suitcases.PackText *
  332. Suitcases.PackFile t.Mod
  333. Suitcases.PackFiles Gadgets.Panel ~
  334. Suitcases.PackFiles ^ ~ Gadgets.Panel
  335.