home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / os20 / devicelock-1.2.lha / DeviceLock-1.2 / txt / DeviceLock.mod < prev    next >
Text File  |  1994-03-21  |  18KB  |  564 lines
  1. (*---------------------------------------------------------------------------
  2.  :Program.    DeviceLock.mod
  3.  :Author.     Thomas Wagner
  4.  :Address.    Mühlenweg 7, 90602 Pyrbaum, Germany
  5.  :Address.    E-Mail: tom@oberon.nbg.sub.org
  6.  :Copyright.  © 1994 by Thomas Wagner [tom], see DeviceLock.guide
  7.  :Language.   Oberon
  8.  :Translator. Amiga Oberon Compiler V3.11d
  9.  :Import.     HotKey.mod         V2.0 Thomas Igracki, [tom]  (on this disk)
  10.  :Import.     MoreIntuition.mod  V1.3 [mick]                 (Amok 78)
  11.  :Import.     WBReadArgs.mod     V1.0 [hG]                   (Amok 83)
  12.  :Import.     PrintF.mod         V1.4 Volker Rudolph, [hG]   (Amok 82)
  13.  :Contents.   Lock with Intuition-Interface (2.04 or higher ONLY!)
  14. ---------------------------------------------------------------------------*)
  15.  
  16. MODULE DeviceLock;
  17.  
  18. (*-------------------------------------------------------------------------*)
  19.  
  20. IMPORT c  := Conversions,
  21.        d  := Dos,
  22.        DLd:= DLdrives,
  23.        DLr:= DLrequester,
  24.        DLs:= DLstrings,
  25.        DLp:= DLprefs,
  26.        e  := Exec,
  27.        g  := Graphics,
  28.        gt := GadTools,
  29.        hot:= HotKey,
  30.        I  := Intuition,
  31.        MI := MoreIntuition,
  32.        ol := OberonLib,
  33.        s  := Strings,
  34.        sys:= SYSTEM,
  35.        t  := Timer,
  36.        u  := Utility;
  37.  
  38. (*-------------------------------------------------------------------------*)
  39.  
  40. CONST
  41.  
  42.   comName  *= "DeviceLock\o$VER: DeviceLock 1.2 (17.3.94)";
  43.   comTitle *= "DeviceLock, 1.2 © 1994 [tom]";
  44.   comDescr *= "Intuition-Interface for CLI-Lock";
  45.  
  46.   scrtitle = "DeviceLock, 1.2 - © 1994 by Thomas Wagner. All Rights reserved.";
  47.  
  48.   about    = "DeviceLock 1.2\n\n"
  49.              "© 1994 by Thomas Wagner, Pyrbaum [tom].\n"
  50.               "%s";
  51.  
  52.   topadd = 5 ;
  53.  
  54.   checkscal = 2421;
  55.  
  56. (*-------------------------------------------------------------------------*)
  57.  
  58. TYPE
  59.  
  60.     NewMenus = ARRAY 10 OF gt.NewMenu;
  61.  
  62. (*-------------------------------------------------------------------------*)
  63.  
  64. CONST
  65.  
  66.   menuLock     = 1;
  67.   menuUnlock   = 2;
  68.   menuNorm     = 3;
  69.   menuAbout    = 4;
  70.   menuHide     = 5;
  71.   menuQuit     = 6;
  72.  
  73.  
  74.   myNewMenuConst = NewMenus(
  75.     gt.title, NIL,         NIL,          {}, LONGSET{}, NIL,
  76.     gt.item , NIL,         sys.ADR("L"), {}, LONGSET{}, menuLock,
  77.     gt.item , NIL,         sys.ADR("U"), {}, LONGSET{}, menuUnlock,
  78.     gt.item , NIL,         sys.ADR("U"), {}, LONGSET{}, menuNorm,
  79.     gt.item , gt.barLabel, NIL,          {}, LONGSET{}, NIL,
  80.     gt.item , NIL,         sys.ADR("?"), {}, LONGSET{}, menuAbout,
  81.     gt.item , gt.barLabel, NIL,          {}, LONGSET{}, NIL,
  82.     gt.item , NIL,         sys.ADR("H"), {}, LONGSET{}, menuHide,
  83.     gt.item , NIL,         sys.ADR("Q"), {}, LONGSET{}, menuQuit,
  84.     gt.end  , NIL,         NIL,          {}, LONGSET{}, NIL);
  85. (*-------------------------------------------------------------------------*)
  86.  
  87. VAR
  88.   font          : g.TextFontPtr;
  89.   ng            : gt.NewGadget;
  90.   glist         : I.GadgetPtr;
  91.   gad           : I.GadgetPtr;
  92.   vi            : e.APTR;
  93.   terminated    : BOOLEAN;
  94.   imsg          : I.IntuiMessagePtr;
  95.   imsgClass     : LONGSET;
  96.   imsgCode      : INTEGER;
  97.   count         : INTEGER;
  98.   TimerPort     : e.MsgPortPtr;
  99.   TimeReq       : t.TimeRequestPtr;
  100.   OpenDev       : SHORTINT;
  101.   signals       : LONGSET;
  102.   allock        : BOOLEAN;
  103.   allunlock     : BOOLEAN;
  104.   quickquit     : BOOLEAN;
  105.   keepquit      : BOOLEAN;
  106.   gheight       : INTEGER;
  107.   wheight       : INTEGER;
  108.   wwidth        : INTEGER;
  109.   windowopen    : BOOLEAN;
  110.   HotSig        : SHORTINT;
  111.   HotType    : LONGSET;
  112.   HotID         : LONGINT;
  113.   closewin      : BOOLEAN;
  114.   myNewMenu     : NewMenus;
  115.   menu          : I.MenuPtr;
  116.   topborder     : INTEGER;
  117.   zoom          : ARRAY 4 OF INTEGER;
  118.   force         : BOOLEAN;
  119.  
  120.  
  121. (*------ Append one Gadget to Gadget-List ---------------------------------*)
  122.  
  123. PROCEDURE * MakeGad(VAR n: DLp.driveT);
  124. BEGIN
  125.   ng.topEdge := topborder + topadd + 2 + (count)*gheight;
  126.   ng.gadgetText := sys.ADR(n.PrintName);
  127.   ng.gadgetID := count;
  128.   gad := gt.CreateGadget(gt.checkBoxKind, gad, ng,
  129.                          I.gaDisabled, sys.VAL(SHORTINT,n.disabled),
  130.                          gt.cbChecked, sys.VAL(SHORTINT,n.locked),
  131.                          gt.cbScaled, I.LTRUE,
  132.                          u.done);
  133.   n.GadPtr:=gad;
  134. END MakeGad;
  135.  
  136.  
  137. (*------ Prepare and Send IO ----------------------------------------------*)
  138.  
  139. PROCEDURE psIO();
  140. BEGIN
  141.   TimeReq.time.secs  := DLp.Prefs.CheckTime;
  142.   TimeReq.time.micro := 0;
  143.   e.SendIO(TimeReq);
  144. END psIO;
  145.  
  146.  
  147. (*------ Do something on response to a pressed Gadget ---------------------*)
  148.  
  149. PROCEDURE HandleGadgetEvent(gad: I.GadgetPtr; code: INTEGER);
  150. BEGIN
  151.   IF gad.gadgetID =  0 THEN
  152.     DLd.LockAll(FALSE);
  153.   ELSE
  154.     IF gad.gadgetID<=DLp.Prefs.DriveNum THEN
  155.       IF I.selected IN gad.flags THEN
  156.         DLd.LckOne(DLp.drive[gad.gadgetID-1])
  157.       ELSE
  158.         DLd.UnLckOne(DLp.drive[gad.gadgetID-1])
  159.       END;
  160.     END;
  161.     force := FALSE;
  162.   END;
  163. END HandleGadgetEvent;
  164.  
  165. (*------ Response to Menu-select ------------------------------------------*)
  166.  
  167. PROCEDURE HandleMenuEvent(code: INTEGER);
  168.  
  169. VAR
  170.   item: I.MenuItemPtr;
  171.  
  172. BEGIN
  173.   WHILE (code # I.menuNull) AND ~ terminated DO
  174.     item := I.ItemAddress(menu^, code);
  175.     CASE sys.VAL(LONGINT,gt.MenuItemUserData(item)) OF
  176.       menuLock   : DLd.LockAll(FALSE); |
  177.       menuUnlock : DLd.UnlockAll(FALSE); |
  178.       menuNorm   : DLd.NormAll(); |
  179.       menuAbout  : DLr.RequestNotify(DLs.GetString(DLs.MsgAbout),
  180.                                    sys.ADR(about),
  181.                                    DLs.GetString(DLs.MsgAllRightsReserved)); |
  182.       menuHide   : closewin   := TRUE; |
  183.       menuQuit   : terminated := TRUE; quickquit := FALSE |
  184.     ELSE END;
  185.  
  186.     code := item.nextSelect;
  187.  
  188.   END;
  189.  
  190. END HandleMenuEvent;
  191.  
  192. (*------ Lock all window-specific resources and open window ---------------*)
  193.  
  194. PROCEDURE OpenWindow(hijackfront: BOOLEAN);
  195. VAR    twidth  : INTEGER;
  196.        mysc    : I.ScreenPtr;
  197.        gadwidth: LONGINT;
  198.  
  199.   (*------ Starts Gadget-List and calls MakeGadget --------------------------*)
  200.  
  201.   PROCEDURE CreateAllGadgets(VAR glist: I.GadgetPtr;
  202.                                  vi: e.APTR;
  203.                                  topborder: INTEGER;
  204.                                  mysc: I.ScreenPtr): BOOLEAN;
  205.   BEGIN
  206.     gad := gt.CreateContext(glist);
  207.     ng.textAttr := mysc.font;
  208.     ng.leftEdge := 8;
  209.     ng.topEdge := topadd + topborder;
  210.     ng.width := wwidth-15;
  211.     ng.height := gheight + 2;
  212.     ng.gadgetText := DLs.GetString(DLs.GadLockAll);
  213.     ng.flags := LONGSET{};
  214.     ng.gadgetID := 0;
  215.     ng.visualInfo := vi;
  216.     gad := gt.CreateGadget(gt.buttonKind, gad, ng, u.done);
  217.  
  218.     ng.flags := LONGSET{gt.placeTextRight};
  219.     ng.height := gheight;
  220.     ng.width := SHORT(gadwidth);
  221.     FOR count := 1 TO DLp.Prefs.DriveNum DO
  222.       MakeGad(DLp.drive[count-1]);
  223.     END;
  224.  
  225.     RETURN gad#NIL;
  226.  
  227.   END CreateAllGadgets;
  228.  
  229.   (*---- Check and FailOut if FALSE   +  Unlock PubScreen! ----------------*)
  230.   PROCEDURE CheckAndFail(test: BOOLEAN; error: ARRAY OF CHAR); (* $CopyArrays- *)
  231.   BEGIN
  232.     IF ~test THEN
  233.       (* Save to call with mysc=NIL ! *) I.UnlockPubScreen(NIL,mysc);
  234.       DLr.FailOut(error);
  235.     END;
  236.   END CheckAndFail;
  237.  
  238.   (*---- Swaps two INTEGER's ----------------------------------------------*)
  239.   PROCEDURE SwapInt(VAR x,y: INTEGER);
  240.   VAR s: INTEGER;
  241.   BEGIN
  242.     s := x;
  243.     x := y;
  244.     y := s;
  245.   END SwapInt;
  246.  
  247.   (*---- Max of two INTEGER's ---------------------------------------------*)
  248.   PROCEDURE Max(x,y: INTEGER):INTEGER;
  249.   BEGIN
  250.   IF x > y THEN RETURN(x) ELSE RETURN(y) END;
  251.   END Max;
  252.  
  253.   (*---- Min of two INTEGER's ---------------------------------------------*)
  254.   PROCEDURE Min(x,y: INTEGER):INTEGER;
  255.   BEGIN
  256.   IF x < y THEN RETURN(x) ELSE RETURN(y) END;
  257.   END Min;
  258.  
  259.  
  260. BEGIN
  261.   IF hijackfront THEN
  262.     DLp.Buffer1 := "\o";
  263.     mysc := MI.LockFrontPubScr(DLp.Buffer1);
  264.   ELSE
  265.     mysc := I.LockPubScreen(DLp.Prefs.PubScreen);
  266.   END;
  267.   IF mysc=NIL THEN mysc := I.LockPubScreen(NIL) END;
  268.   CheckAndFail(mysc#NIL,"LockPubScreen()");
  269.  
  270.   font := g.OpenFont(mysc.font^);
  271.   CheckAndFail(font#NIL,"OpenFont()");
  272.  
  273.   zoom[0] := DLp.Prefs.LeftEdgeZoomed;
  274.   zoom[1] := DLp.Prefs.TopEdgeZoomed;
  275.  
  276.   gheight := mysc.font.ySize;
  277.   IF gheight <