(* --------------------------------------------------------------------------
  :Program.       SteamyWindows.mod
  :Contents.      raises the priority of the active window's task (comdity)
  :Author.        Franz Schwarz
  :Copyright.     Freeware (freely distributable, copyrighted software)
  :Language.      Oberon-2
  :Translator.    Amiga Oberon 3.00
  :History.       v1.0 26.10.93 [fSchwarz]
  :Address.       Mühlenstraße 2, D-78591 Durchhausen, Germany / R.F.A.
  :Address.       uucp: Franz_Schwarz@mil.ka.sub.org - Fido: 2:2476/506.18
  :Remark.        Requires OS3.0 interface modules update by hartmut Goebel
  :Remark.        Amiga-Oberon 3.00 checks string pointers to be even if
  :Remark.        OddChk is enabled; thus don't compile with OddChk.
  :Usage.         SteamyWindows (CLI or wbstart) no args
-------------------------------------------------------------------------- *)

MODULE SteamyWindows;

IMPORT
  co: Commodities, e: Exec, I: Intuition, d: Dos, H: Hardware, 
  o: OberonLib, y: SYSTEM;

CONST
  verTag = "\000$VER: SteamyWindows 1.0 (26.10.93) © Franz_Schwarz@mil.ka.sub.org - Freeware";

CONST
  true = TRUE; false = FALSE; (* adapt to common lower case CONST style *)

          (* ** Interface module bug fixes: ** *)
VAR
  coBase: e.LibraryPtr;
(* CxBroker err parameter register mismatch in Commodities.mod! *)
PROCEDURE CxBroker {coBase, -36} (VAR nb{8}: co.NewBroker;
                                  err{0}   : UNTRACED POINTER TO LONGINT): co.CxObjPtr;
CONST
  unique = 0;          (* misdefinition in Commodities.mod *)


CONST
  cnb = co.NewBroker (co.nbVersion, y.ADR ("SteamyWindows"), y.ADR (verTag[7]),
                      y.ADR ("Raises the priority of the active window's task"),
                      {unique}, {}, 0, NIL, 0);

  cfakenb = co.NewBroker (co.nbVersion, y.ADR ("Angie"), y.ADR (verTag[7]),
                      y.ADR ("Fake broker to exclude usage of Angie"),
                      {unique}, {}, 0, NIL, 0);

VAR
  active            : BOOLEAN;
  nb                : co.NewBroker;
  fakenb            : co.NewBroker;
  br                : co.CxObjPtr; 
  fakebr            : co.CxObjPtr; 


VAR 
  vblanksig: INTEGER;
  oldwin   : I.WindowPtr;
  win      : I.WindowPtr;

PROCEDURE VBlankSignaller * (a5{9}: e.APTR): LONGINT;
(* $SaveRegs+ $StackChk- *)
BEGIN
  y.SETREG (13, a5);
  oldwin := win; win := I.int.activeWindow;
  IF oldwin # win THEN
    e.Signal (o.Me, LONGSET {vblanksig-1});
  END;  
  RETURN 0; (* set Z flag *)
END VBlankSignaller;
(* $StackChk= *)

CONST
  cvblint = e.Interrupt (NIL, NIL, e.interrupt, -100, y.ADR ("SteamyWindows Snooper"), 
                         NIL, y.VAL (e.PROC, VBlankSignaller));

VAR
  vblint: e.Interrupt;                         

PROCEDURE ActivateBroker (b: BOOLEAN);
VAR
  lb: LONGINT;
BEGIN
  IF b THEN lb := -1; ELSE lb := 0; END;
  IF co.ActivateCxObj (br, lb) = e.false THEN END;
  active := b;
END ActivateBroker;

VAR
  OldPri : INTEGER;
  IncTask: e.TaskPtr;
  
CONST
  invalidPri = 4000H;
  incPri = 4001H;

PROCEDURE SecureSetTaskPri (task: e.TaskPtr; pri: INTEGER): INTEGER;
VAR
  t: e.TaskPtr;
  r: INTEGER;
BEGIN
  r := invalidPri;
  IF (task = NIL) OR (pri = invalidPri) THEN RETURN r; END;
  e.Disable ();
  LOOP
    t := e.exec.taskReady.head;
    WHILE (t.node.succ # NIL) & (t # task) DO t := t.node.succ; END;
    IF t.node.succ # NIL THEN EXIT; END;
    t := e.exec.taskWait.head;
    WHILE (t.node.succ # NIL) & (t # task) DO t := t.node.succ; END;
    EXIT;
  END;  
  IF (t.node.succ # NIL) & (e.FindTask (NIL) # t) THEN 
    IF pri = incPri THEN
      pri := LONG (t.node.pri)+1;
    ELSE  
      IF pri+1 # t.node.pri THEN pri := invalidPri; END;
    END;
    IF pri # invalidPri THEN
      IF pri > MAX (SHORTINT) THEN pri := MAX (SHORTINT); END;
      IF pri < MIN (SHORTINT) THEN pri := MIN (SHORTINT); END;
      r := e.SetTaskPri (t, SHORT (pri)); 
    END;  
  END;
  e.Enable ();
  RETURN r;
END SecureSetTaskPri;

PROCEDURE Init();
BEGIN
  coBase := co.base;
  IF coBase = NIL THEN HALT (20); END;
  nb := cnb;
  fakenb := cfakenb;
  nb.port := e.CreateMsgPort();
  fakenb.port := e.CreateMsgPort();
  IF (nb.port = NIL) OR (fakenb.port = NIL) THEN HALT (20); END;
  br := CxBroker (nb, NIL);
  fakebr := CxBroker (fakenb, NIL);
  IF (br = NIL) OR (fakebr = NIL) THEN HALT (20); END;
  vblanksig := e.AllocSignal (-1) + 1;
  IF vblanksig = 0 THEN HALT (20); END;
  vblint := cvblint;
  vblint.data := y.REG (13);
  e.AddIntServer (H.vertb, y.ADR (vblint));
  ActivateBroker (true);
END Init;

  
PROCEDURE CleanUp();
VAR
  msg: e.MessagePtr;
BEGIN
  IF vblint.code # NIL THEN
    e.RemIntServer (H.vertb, y.ADR (vblint)); vblint.code := NIL;
  END;
  y.SETREG (0, SecureSetTaskPri (IncTask, OldPri)); IncTask := NIL; 
  e.FreeSignal (vblanksig-1); vblanksig := 0;
  co.DeleteCxObjAll (br); br := NIL;
  co.DeleteCxObjAll (fakebr); fakebr := NIL;
  IF nb.port # NIL THEN
    LOOP
      msg := e.GetMsg (nb.port);
      IF msg = NIL THEN EXIT; END;
      e.ReplyMsg (msg);
    END;
  END;      
  e.DeleteMsgPort (nb.port); nb.port := NIL;  
  IF fakenb.port # NIL THEN
    LOOP
      msg := e.GetMsg (fakenb.port);
      IF msg = NIL THEN EXIT; END;
      e.ReplyMsg (msg);
    END;
  END;      
  e.DeleteMsgPort (fakenb.port); fakenb.port := NIL;  
  IF o.Result > 5 THEN I.DisplayBeep (NIL); END;
END CleanUp;  

PROCEDURE ChangePri ();
VAR
  newtask: e.TaskPtr;
  lk     : LONGINT;
  w      : I.WindowPtr;
  tmpport: e.MsgPortPtr;
BEGIN
  lk := I.LockIBase (0);
  w := I.int.activeWindow;
  IF active THEN
    newtask := NIL;
    e.Disable();
    IF w # NIL THEN
      tmpport := w.userPort;
      IF (y.VAL (LONGSET, tmpport) * LONGSET {0,31} = LONGSET {}) &
         (tmpport # NIL) & (e.public IN e.TypeOfMem (tmpport)) &
         (e.public IN e.TypeOfMem (y.ADR (tmpport.msgList))) THEN
        newtask := tmpport.sigTask;
      END;  
    END;  
    e.Enable();
    IF newtask # IncTask THEN 
      y.SETREG (0, SecureSetTaskPri (IncTask, OldPri));
      IncTask := newtask;
      OldPri := SecureSetTaskPri (IncTask, incPri);
      IF OldPri = invalidPri THEN IncTask := NIL; END;
    END;
  ELSE
    y.SETREG (0, SecureSetTaskPri (IncTask, OldPri)); IncTask := NIL;
  END;
  I.UnlockIBase (lk);
END ChangePri;


PROCEDURE Server ();
VAR
  flgs: LONGSET;
  msg : e.APTR;
  msgtype: LONGSET;
  msgid  : LONGINT;
BEGIN  
  LOOP
    flgs := e.Wait (LONGSET {d.ctrlC, nb.port.sigBit, fakenb.port.sigBit, 
                             vblanksig-1});
    IF vblanksig-1 IN flgs THEN
      ChangePri();
    END;    
    IF nb.port.sigBit IN flgs THEN
      LOOP
        msg := e.GetMsg (nb.port);
        IF msg = NIL THEN EXIT; END;
        msgtype := co.CxMsgType (msg);
        msgid := co.CxMsgID (msg);
        e.ReplyMsg (msg);
        IF msgtype = LONGSET {co.cxmCommand} THEN
          CASE msgid OF
          co.cmdKill:
            HALT (0); |
          co.cmdEnable:
            ActivateBroker (true); 
            win := NIL; (* this is an atomic operation! *) |
          co.cmdDisable:
            ActivateBroker (false); 
            y.SETREG (0, SecureSetTaskPri (IncTask, OldPri)); IncTask := NIL;
          ELSE END;  
        END;
      END; (* LOOP *)
    END;
    IF fakenb.port.sigBit IN flgs THEN
      LOOP
        msg := e.GetMsg (fakenb.port);
        IF msg = NIL THEN EXIT; END;
        e.ReplyMsg (msg);
        IF co.ActivateCxObj (fakebr, e.false) = e.false THEN END;
      END;  
    END;  
    IF d.ctrlC IN flgs THEN HALT (5); END;
  END;
END Server;


BEGIN
  Init();

  Server();

CLOSE
  CleanUp();

END SteamyWindows.