(*************************************************************************

:Program.       SupLib.mod
:Contents.      collection of some routines
:Author.        Hartmut Goebel [hG]
:Copyright.     Public Domain
:Language.      Oberon
:Translator.    AmigaOberon V2.00
:History.       V1.0, 21.01.90, Hartmut Goebel
:History.       V1.1, 18 Oct 1991 [hG] -Bug in StripIntuiMsg
:Date.          18 Oct 1991 22:49:50

:Support.       einige Routinen von M.Dillon (Oberon-Impl. von hG)
:Support.       einige andere aus ARKM Libs&Devs 1.3

*************************************************************************)

MODULE SupLib;

IMPORT
  d:   Dos,
  df:  DiskFont,
  e:   Exec,
  g:   Graphics,
  con: Console,
  I:   Intuition,
  ie:  InputEvent,
  km:  KeyMap,
  ol:  OberonLib,
  str: Strings,
  sys: SYSTEM;

TYPE
  StringPtr = POINTER TO ARRAY 256 OF CHAR;

(*-------------------------------------------------------------------------*)
(*
 *  Win = GetConWindow()
 *
 *  Returns console window associated with the current task or NULL if
 *  no console task associated.
 *
 *  Return the window used by the console of the current process.  We can
 *  use our process's message port as the reply port since it is a
 *  synchronous packet (we wait for the result to come back).  WARNING:
 *  This routine does not check if the 'console' of the current process
 *  is really a console device.
 *
 *  The DISK_INFO packet is sent to the console device.  Although this
 *  packet is normally used to retrieve disk information from disk
 *  devices, the console device recognizes the packet and places a pointer
 *  to the window in id_VolumeNode of the infodata structure.  A pointer
 *  to the console unit is also placed in id_InUse of the infodata structure.
 *)

PROCEDURE GetConWindow(): I.WindowPtr;
CONST
  ClearPublic = LONGSET{e.memClear,e.public};
VAR
  proc: d.ProcessPtr;
  packet: d.StandardPacketPtr;
  infodata: d.InfoDataPtr;
  result: LONGINT;
  win: I.WindowPtr;
BEGIN
  proc := sys.VAL(d.ProcessPtr,e.FindTask(NIL));
  IF proc.consoleTask = NIL THEN
      RETURN NIL; END;
  (*
   *  NOTE: Since DOS requires the packet and infodata structures to
   *  be longword aligned, we cannot declare them globally or on the
   *  stack (word aligned).  AllocMem() always returns longword
   *  aligned pointers.
   *)

  packet := e.AllocMem(sys.SIZE(d.StandardPacket),ClearPublic);
  infodata := e.AllocMem(sys.SIZE(d.InfoData),ClearPublic);

  packet.msg.node.name := sys.ADR(packet.pkt);
  packet.pkt.link := sys.ADR(packet.msg);
  packet.pkt.port := sys.ADR(proc.msgPort);
  packet.pkt.type := d.diskInfo;
  packet.pkt.arg1 := sys.LSH(sys.VAL(LONGINT,infodata),-2); (* BPointer *)
  e.PutMsg(proc.consoleTask, packet);
  e.WaitPort(sys.ADR(proc.msgPort));
  IF e.GetMsg(sys.ADR(proc.msgPort)) = NIL THEN END;

  result := packet.pkt.res1;
  win := sys.VAL(I.WindowPtr,infodata.volumeNode);
  (* note: inUse holds a pointer to the console unit also *)
  e.FreeMem(packet  , sys.SIZE(d.StandardPacket));
  e.FreeMem(infodata, sys.SIZE(d.InfoData));
  IF result = NIL THEN
      RETURN NIL; END;
  RETURN win;
END GetConWindow;

(*-------------------------------------------------------------------------*)

PROCEDURE DeadKeyConvert*(msg: I.IntuiMessagePtr;VAR buf: ARRAY OF CHAR;
                          bufsize: LONGINT; keymap: km.KeyMapPtr): LONGINT;
VAR
  iEvent: ie.InputEventAdr;
BEGIN
  IF NOT (I.rawKey IN msg.class) THEN RETURN -2; END;
  IF con.base = NIL THEN HALT(20); END;
  iEvent.nextEvent := NIL;
  iEvent.class := ie.rawkey;
  iEvent.code := msg.code;
  iEvent.qualifier := msg.qualifier;
  iEvent.addr := msg.iAddress;
  RETURN con.RawKeyConvert(sys.ADR(iEvent),buf,bufsize,keymap);
END DeadKeyConvert;

(*-------------------------------------------------------------------------*)

(*
*
*  GetDEnv(name: StringPtr): StringPtr;
*  SetDEnv(name, string: StringPtr): BOOLEAN;
*
*    If the enviroment variable 'name' exists, NEW and return a copy
*    of it. The user program must DISPOSE it (or allow the standard
*    OBERON exit routine to DISPOSE it).
*)

PROCEDURE GetDEnv*(name: ARRAY OF CHAR): e.ADDRESS;
(* $CopyArrays- *)
VAR
  nlen: INTEGER;
  ptr, res: StringPtr;
  fh: d.FileHandlePtr;
  len: LONGINT;
BEGIN
  nlen := str.Length(name) + 5;
  ptr := e.AllocMem(nlen,LONGSET{e.public});
  res := NIL;
  IF ptr # NIL THEN
    ptr^ := "ENV:";
    str.Append(ptr^,name);
    fh := d.Open(ptr^, d.oldFile);
    IF fh # NIL THEN
      len := d.Seek(fh, 0, d.end);
      len := d.Seek(fh, 0, d.current);
      IF len >= 0 THEN
        ol.New(res,len+1);
        IF res # NIL THEN
          IF d.Seek(fh, 0, d.beginning) #0 THEN END;
          IF d.Read(fh, res^, len) # len THEN
            len := 0; END;
          res[len] := 0X;
        END;
      END;
      IF d.Close(fh) THEN END;
    END;
    e.FreeMem(ptr, nlen);
  END;
  RETURN res;
END GetDEnv;


PROCEDURE UnSetDEnv*(name: ARRAY OF CHAR): BOOLEAN;
(* $CopyArrays- *)
VAR
  nlen: INTEGER;
  ptr: StringPtr;
  res: BOOLEAN;
BEGIN
  nlen := str.Length(name) + 5;
  ptr := e.AllocMem(nlen,LONGSET{e.public});
  IF ptr # NIL THEN
    ptr^ := "ENV:";
    str.Append(ptr^, name);
    res := d.DeleteFile(ptr^);
    e.FreeMem(ptr, nlen);
  ELSE
    res := FALSE;
  END;
  RETURN res;
END UnSetDEnv;


PROCEDURE SetDEnv*(name, string: ARRAY OF CHAR): BOOLEAN;
(* $CopyArrays- *)
VAR
  nlen: INTEGER;
  ptr: StringPtr;
  res: BOOLEAN;
  fh: d.FileHandlePtr;
  slen: LONGINT;
BEGIN
  IF string = "" THEN
    RETURN UnSetDEnv(name);
  END;
  nlen := str.Length(name) + 5;
  slen := str.Length(string);
  ptr := e.AllocMem(nlen,LONGSET{e.public});
  res := FALSE;
  IF ptr # NIL THEN
    ptr^ := "ENV:";
    str.Append(ptr^, name);
    fh := d.Open(ptr^, d.newFile);
    IF fh # NIL THEN
      IF d.Write(fh, string, slen) = slen THEN
        res := TRUE; END;
      IF d.Close(fh) THEN END;
    END;
    e.FreeMem(ptr, nlen);
  END;
  RETURN res;
END SetDEnv;

(*-------------------------------------------------------------------------*)

PROCEDURE GetFont*(name: ARRAY OF CHAR; size: INTEGER): g.TextFontPtr;
(* $CopyArrays- *)
VAR
  font1,font2: g.TextFontPtr;
  Ta: g.TextAttr;
BEGIN
  Ta.name  := sys.ADR(name);
  Ta.ySize := size;
  Ta.style := SHORTSET{};
  Ta.flags := SHORTSET{};

  font1 := g.OpenFont(Ta);
  IF (font1 = NIL) OR (font1.ySize # Ta.ySize) THEN
    font2 := df.OpenDiskFont(Ta);
    IF font2 # NIL  THEN
      IF font1 # NIL THEN
        g.CloseFont(font1); END;
      font1 := font2;
    END;
  END;
  RETURN font1;
END GetFont;

(*-------------------------------------------------------------------------*)

(*
(* keine Ahnung, was das macht. hG 12 Mar 1991 *)
(* unterdrückt wahrscheinlich die Ausgabe in StdIO *)

PROCEDURE MountRequest*(bool: BOOLEAN): I.WindowPtr;
VAR
  proc: d.ProcessPtr;
  originalPrWindowPtr: e.ADDRESS;
BEGIN
  proc := sys.VAL(d.ProcessPtr,e.FindTask(NIL));
  IF NOT bool AND (proc.windowPtr # LONG(-1)) THEN
    originalPrWindowPtr := proc.windowPtr;
    proc.windowPtr := LONG(-1);
    RETURN originalPrWindowPtr;
  ELSIF bool AND (proc.windowPtr = LONG(-1)) THEN
     proc.windowPtr := originalPrWindowPtr;
     RETURN LONG(-1);
  END;
END MountRequest;
*)

(*-------------------------------------------------------------------------*)

PROCEDURE StripIntuiMessages(mp: e.MsgPortPtr; win: I.WindowPtr);
VAR
  msg, succ: I.IntuiMessagePtr;
BEGIN
  msg := mp.msgList.head;
  WHILE msg.execMessage.node.succ # NIL DO
    succ := msg.execMessage.node.succ;
    IF msg.idcmpWindow = win THEN
      e.Remove(msg);
      e.ReplyMsg(msg);
    END;
    msg := succ;
  END;
END StripIntuiMessages;


(* this function closes an intuition window that *)
(* shares a port with other intuition windows.   *)

PROCEDURE CloseWindowSafely*(VAR win: I.WindowPtr);
BEGIN
  I.ClearMenuStrip(win);
  e.Forbid();
  StripIntuiMessages(win.userPort,win);
  win.userPort := NIL;
  IF I.ModifyIDCMP(win,LONGSET{}) THEN END;
  e.Permit();
  I.CloseWindow(win);
  win := NIL;
END CloseWindowSafely;


(* Opens a window and sets it's userPort to the specified Port *)

PROCEDURE OpenPortWindow*(nw: I.NewWindow; port: e.MsgPortPtr): I.WindowPtr;
(* $CopyArrays- *)
VAR
  win: I.WindowPtr;
  IDCMPs: LONGSET;
BEGIN
  IDCMPs := nw.idcmpFlags;
  nw.idcmpFlags := LONGSET{};
  win := I.OpenWindow(nw);
  IF (win # NIL) AND (IDCMPs # LONGSET{}) THEN
    win.userPort := port;
    sys.SETREG(0,I.ModifyIDCMP(win,IDCMPs));
  END;
  RETURN win;
END OpenPortWindow;

END SupLib.