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

     $RCSfile: GadToolsMenu.mod $
  Description: Example illustrating the use of GadTools menus.

   Created by: fjc (Frank Copeland)
    $Revision: 1.3 $
      $Author: fjc $
        $Date: 1994/08/08 16:54:30 $

  Copyright © 1994, Frank Copeland.
  This example program is part of Oberon-A.
  See Oberon-A.doc for conditions of use and distribution.

  Log entries are at the end of the file.

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

MODULE GadToolsMenu;

(*
** $C= CaseChk       $I= IndexChk  $L= LongAdr   $N= NilChk
** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
** $V= OvflChk       $Z= ZeroVars
*)

IMPORT
  SYS := SYSTEM,
  e   := Exec,
  u   := Utility,
  i   := Intuition,
  gt  := GadTools;

CONST
  VersionTag = "\0$VER: GadToolsMenu 1.0 (20.6.94)\r\n";

VAR

  mynewmenu : ARRAY 16 OF gt.NewMenu;

(*------------------------------------*)
PROCEDURE Init ();

BEGIN (* Init *)
  (* Making the assumption that unitialised fields are zeroed... *)

  mynewmenu[0].type := gt.nmTitle;
  mynewmenu[0].label := SYS.ADR ("Project");

  mynewmenu[1].type := gt.nmItem;
  mynewmenu[1].label := SYS.ADR ("Open...");
  mynewmenu[1].commKey := SYS.ADR ("O");

  mynewmenu[2].type := gt.nmItem;
  mynewmenu[2].label := SYS.ADR ("Save");
  mynewmenu[2].commKey := SYS.ADR ("S");

  mynewmenu[3].type := gt.nmItem;
  mynewmenu[3].label := gt.nmBarLabel;

  mynewmenu[4].type := gt.nmItem;
  mynewmenu[4].label := SYS.ADR ("Print");

  mynewmenu[5].type := gt.nmSub;
  mynewmenu[5].label := SYS.ADR ("Draft");

  mynewmenu[6].type := gt.nmSub;
  mynewmenu[6].label := SYS.ADR ("NLQ");

  mynewmenu[7].type := gt.nmItem;
  mynewmenu[7].label := gt.nmBarLabel;

  mynewmenu[8].type := gt.nmItem;
  mynewmenu[8].label := SYS.ADR ("Quit...");
  mynewmenu[8].commKey := SYS.ADR ("Q");

  mynewmenu[9].type := gt.nmTitle;
  mynewmenu[9].label := SYS.ADR ("Edit");

  mynewmenu[10].type := gt.nmItem;
  mynewmenu[10].label := SYS.ADR ("Cut");
  mynewmenu[10].commKey := SYS.ADR ("X");

  mynewmenu[11].type := gt.nmItem;
  mynewmenu[11].label := SYS.ADR ("Copy");
  mynewmenu[11].commKey := SYS.ADR ("C");

  mynewmenu[12].type := gt.nmItem;
  mynewmenu[12].label := SYS.ADR ("Paste");
  mynewmenu[12].commKey := SYS.ADR ("V");

  mynewmenu[13].type := gt.nmItem;
  mynewmenu[13].label := gt.nmBarLabel;

  mynewmenu[14].type := gt.nmItem;
  mynewmenu[14].label := SYS.ADR ("Undo");
  mynewmenu[14].commKey := SYS.ADR ("Z");

  mynewmenu[15].type := gt.nmEnd;
END Init;

(*------------------------------------
** Watch the menus and wait for the user to select the close gadget
** or quit from the menus.
*)
PROCEDURE HandleWindowEvents (win : i.WindowPtr; menuStrip : i.MenuPtr);

  VAR
    msg : i.IntuiMessagePtr;
    done : BOOLEAN;
    menuNumber : INTEGER;
    menuNum : INTEGER;
    itemNum : INTEGER;
    subNum : INTEGER;
    item : i.MenuItemPtr;
    signals : SET;

BEGIN (* HandleWindowEvents *)
  done := FALSE;
  WHILE ~done DO
    (* We only have one signal bit, so we do not have to check which
    ** bit broke the Wait().
    *)
    signals := e.base.Wait ({win.userPort.sigBit});
    LOOP
      IF done THEN EXIT END;
      msg := SYS.VAL (i.IntuiMessagePtr, e.base.GetMsg (win.userPort));
      IF msg = NIL THEN EXIT END;
      IF msg.class = {i.idcmpCloseWindow} THEN
        done := TRUE
      ELSIF msg.class = {i.idcmpMenuPick} THEN
        menuNumber := msg.code;
        WHILE (menuNumber # (*i.menuNull*) -1) & ~done DO
          item := i.base.ItemAddress (menuStrip^, menuNumber);

          (* Process the item here *)
          menuNum := i.MenuNum (menuNumber);
          itemNum := i.ItemNum (menuNumber);
          subNum := i.SubNum (menuNumber);

          (* stop if quit is selected *)
          IF (menuNum = 0) & (itemNum = 5) THEN
            done := TRUE
          END;

          menuNumber := item.nextSelect
        END
      END;
      e.base.ReplyMsg (msg)
    END
  END
END HandleWindowEvents;

(*------------------------------------*)
PROCEDURE Main ();

  VAR
    win : i.WindowPtr;
    myVisualInfo : gt.VisualInfo;
    menuStrip : i.MenuPtr;

BEGIN (* Main *)
  IF i.base.version >= 37 THEN
    gt.OpenLib(TRUE);
    win := i.base.OpenWindowTagsA
      ( NIL,
        i.waWidth,  400, i.waActivate, e.LTRUE,
        i.waHeight, 100, i.waCloseGadget, e.LTRUE,
        i.waTitle,  SYS.ADR ("Menu Test Window"),
        i.waIDCMP,  {i.idcmpCloseWindow, i.idcmpMenuPick},
        u.tagEnd );
    IF win # NIL THEN
      myVisualInfo := gt.base.GetVisualInfo (win.wScreen, u.tagEnd);
      IF myVisualInfo # NIL THEN
        menuStrip := gt.base.CreateMenus (mynewmenu, u.tagEnd);
        IF menuStrip # NIL THEN
          IF gt.base.LayoutMenus (menuStrip, myVisualInfo, u.tagEnd) THEN
            IF i.base.SetMenuStrip (win, menuStrip^) THEN
              HandleWindowEvents (win, menuStrip);
              i.base.ClearMenuStrip (win)
            END;
            gt.base.FreeMenus (menuStrip)
          END;
        END;
        i.base.CloseWindow (win)
      END;
    END;
  END;
END Main;

BEGIN (* GadToolsMenu *)
  Init ();
  Main ();
END GadToolsMenu.

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

  $Log: GadToolsMenu.mod $
  Revision 1.3  1994/08/08  16:54:30  fjc
  Release 1.4

  Revision 1.2  1994/07/03  15:11:10  fjc
  - Incorporated changes in 3.1 Interfaces

  Revision 1.1  1994/06/20  20:10:34  fjc
  Initial revision

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