{*******************************************************}
{                                                       }
{       Turbo Pascal Version 7.0                        }
{       Turbo Vision Unit                               }
{                                                       }
{       Copyright (c) 1992 Borland International        }
{                                                       }
{*******************************************************}
{modified by MCH by adding a bunch of menu modifying methods}

unit Menus;

{$O+,F+,X+,I-,S-}

interface

uses Objects,
			{$IFDEF Windows} windrvrs, {$ELSE}drivers, {$ENDIF}
			Views;

const

{ Color palettes }

	CMenuView   = #2#3#4#5#6#7;
	CStatusLine = #2#3#4#5#6#7;

type

{ TMenu types }

	TMenuStr = string[31];

	PMenu = ^TMenu;

	PMenuItem = ^TMenuItem;
	TMenuItem = record
		Next: PMenuItem;
		Name: PString;
		Command: Word;
		Disabled: Boolean;
		KeyCode: Word;
		HelpCtx: Word;
{    case Integer of
			0: (Param: PString);
			1: (SubMenu: PMenu);{Commented out by Martin to allow param AND submenu}
		Param: PString;
		SubMenu: PMenu;{}
	end;

	TMenu = record
		Items: PMenuItem;
		Default: PMenuItem;
	end;

{ TMenuView object }

	{ Palette layout }
	{ 1 = Normal text }
	{ 2 = Disabled text }
	{ 3 = Shortcut text }
	{ 4 = Normal selection }
	{ 5 = Disabled selection }
	{ 6 = Shortcut selection }

	PMenuView = ^TMenuView;
	TMenuView = object(TView)
		ParentMenu: PMenuView;
		Menu: PMenu;
		Current: PMenuItem;
		constructor Init(var Bounds: TRect);
		constructor Load(var S: TStream);
		function Execute: Word; virtual;
		function FindItem(Ch: Char): PMenuItem;
		procedure GetItemRect(Item: PMenuItem; var R: TRect); virtual;
		function GetHelpCtx(const Level : byte): Word; virtual;
		function GetPalette: PPalette; virtual;
		procedure HandleEvent(var Event: TEvent); virtual;
		function HotKey(KeyCode: Word): PMenuItem;
		function NewSubView(var Bounds: TRect; AMenu: PMenu;
			AParentMenu: PMenuView): PMenuView; virtual;
		procedure Store(var S: TStream);
	end;

{ TMenuBar object }

	{ Palette layout }
	{ 1 = Normal text }
	{ 2 = Disabled text }
	{ 3 = Shortcut text }
	{ 4 = Normal selection }
	{ 5 = Disabled selection }
	{ 6 = Shortcut selection }

	PMenuBar = ^TMenuBar;
	TMenuBar = object(TMenuView)
		constructor Init(var Bounds: TRect; AMenu: PMenu);
    destructor Done; virtual;
    procedure Draw; virtual;
		procedure GetItemRect(Item: PMenuItem; var R: TRect); virtual;
  end;

{ TMenuBox object }

  { Palette layout }
  { 1 = Normal text }
  { 2 = Disabled text }
  { 3 = Shortcut text }
  { 4 = Normal selection }
  { 5 = Disabled selection }
  { 6 = Shortcut selection }

  PMenuBox = ^TMenuBox;
  TMenuBox = object(TMenuView)
    constructor Init(var Bounds: TRect; AMenu: PMenu;
      AParentMenu: PMenuView);
    procedure Draw; virtual;
    procedure GetItemRect(Item: PMenuItem; var R: TRect); virtual;
  end;

{ TMenuPopup object }

  { Palette layout }
  { 1 = Normal text }
  { 2 = Disabled text }
  { 3 = Shortcut text }
  { 4 = Normal selection }
  { 5 = Disabled selection }
	{ 6 = Shortcut selection }

  PMenuPopup = ^TMenuPopup;
  TMenuPopup = object(TMenuBox)
		constructor Init(var Bounds: TRect; AMenu: PMenu);
    procedure HandleEvent(var Event: TEvent); virtual;
  end;

{ TStatusItem }

  PStatusItem = ^TStatusItem;
  TStatusItem = record
    Next: PStatusItem;
    Text: PString;
    KeyCode: Word;
    Command: Word;
  end;

{ TStatusDef }

  PStatusDef = ^TStatusDef;
  TStatusDef = record
    Next: PStatusDef;
    Min, Max: Word;
    Items: PStatusItem;
  end;

{ TStatusLine }

  { Palette layout }
  { 1 = Normal text }
  { 2 = Disabled text }
	{ 3 = Shortcut text }
	{ 4 = Normal selection }
  { 5 = Disabled selection }
  { 6 = Shortcut selection }

	PStatusLine = ^TStatusLine;
  TStatusLine = object(TView)
    Items: PStatusItem;
    Defs: PStatusDef;
    constructor Init(var Bounds: TRect; ADefs: PStatusDef);
    constructor Load(var S: TStream);
    destructor Done; virtual;
    procedure Draw; virtual;
    function GetPalette: PPalette; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    function Hint(AHelpCtx: Word): String; virtual;
    procedure Store(var S: TStream);
    procedure Update; virtual;
	private
		procedure DrawSelect(Selected: PStatusItem);
		procedure FindItems;
	end;

{ TMenuItem routines }

function NewItem(Name, Param: TMenuStr; KeyCode: Word; Command: Word;
	AHelpCtx: Word; Next: PMenuItem): PMenuItem;
function NewLine(Next: PMenuItem): PMenuItem;
function NewSubMenu(Name: TMenuStr; KeyCode : word; AHelpCtx: Word; SubMenu: PMenu;
	Next: PMenuItem): PMenuItem;

{ TMenu routines }

function NewMenu(Items: PMenuItem): PMenu;
procedure DisposeMenu(Menu: PMenu);

{ TStatusLine routines }

function NewStatusDef(AMin, AMax: Word; AItems: PStatusItem;
	ANext: PStatusDef): PStatusDef;
function NewStatusKey(const AText: String; AKeyCode: Word; ACommand: Word;
	ANext: PStatusItem): PStatusItem;

{ Menus registration procedure }

procedure RegisterMenus;

{ Stream registration records }

const
	RMenuBar: TStreamRec = (
		 ObjType: 40;
		 VmtLink: Ofs(TypeOf(TMenuBar)^);
		 Load:    @TMenuBar.Load;
		 Store:   @TMenuBar.Store
	);

const
	RMenuBox: TStreamRec = (
		 ObjType: 41;
		 VmtLink: Ofs(TypeOf(TMenuBox)^);
		 Load:    @TMenuBox.Load;
		 Store:   @TMenuBox.Store
	);

const
	RStatusLine: TStreamRec = (
		 ObjType: 42;
		 VmtLink: Ofs(TypeOf(TStatusLine)^);
		 Load:    @TStatusLine.Load;
		 Store:   @TStatusLine.Store
	);

const
	RMenuPopup: TStreamRec = (
		 ObjType: 43;
		 VmtLink: Ofs(TypeOf(TMenuPopup)^);
		 Load:    @TMenuPopup.Load;
		 Store:   @TMenuPopup.Store
	);

{============ Martin's extensions =================}

{menu handling routines}
function FindItem(const Menu : PMenu; const Title : string; var Prev : PMenuItem) : PMenuItem;
function CopyItem(const Source : PMenuItem) : PMenuItem;
procedure AddItemStart(var Menu : PMenu; const ITem : PMenuItem); {Adds to Menu chain}
procedure AddItemEnd(var Menu : PMenu; const ITem : PMenuItem); {Adds to Menu chain}
procedure AddItem(var Menu : PMenu; const ITem : PMenuItem); {Adds to Menu chain}
procedure SetItemKey(var Menu : PMenu; const Title : string; const kbType : word);
procedure RenameItem(Menu : PMenu; const OldName, NewName : string);
procedure DeleteItem(var Menu : PMenu; Name : string);
procedure ReplaceItem(Menu : PMenu; OldName : string; NewItem : PmenuItem);

procedure AddItemSubMenu(var Menu : PMenu; const SubMenuTitle : string; const Item : PMenuItem);
procedure AddItemSubSubMenu(var Menu : PMenu; const SubMenuTitle, SubSubMenuTitle : string; const Item : PMEnuItem);{}

function CommandInMenu(const Menu : PMenu; const COmmand : word) : boolean;

{---- Dialog box menus ---------}
{change of palette to fit dialog box palette}
type
	PDlgMenuBox = ^TDlgMenuBox;
	TDlgMenuBox = object(TMenuBox)
		function GetPalette : PPalette; virtual;
		function NewSubView(var Bounds: TRect; AMenu: PMenu; AParentMenu: PMenuView): PMenuView; virtual;
	end;

	PDlgMenuBar = ^TDlgMenuBar;
	TDlgMenuBar = object(TMenuBar)
		function GetPalette : PPalette; virtual;
		function NewSubView(var Bounds: TRect; AMenu: PMenu; AParentMenu: PMenuView): PMenuView; virtual;
	end;


implementation

uses minilib; {for mch extensions - menu finditem}

{ TMenuItem routines }

function NewItem(Name, Param: TMenuStr; KeyCode: Word; Command: Word;
	AHelpCtx: Word; Next: PMenuItem): PMenuItem;
const
	T: PView = nil;
var
	P: PMenuItem;
begin
	if (Name <> '') and (Command <> 0) then
	begin
		New(P);
		P^.Next := Next;
		P^.Name := NewStr(Name);
		P^.Command := Command;
		P^.Disabled := not T^.CommandEnabled(Command);
		P^.KeyCode := KeyCode;
		P^.HelpCtx := AHelpCtx;
    P^.Param := NewStr(Param);
    P^.SubMenu := nil;  {MCH Dec 94, not here in the original - *required* now for the hotkeyed submenus}
    NewItem := P;
  end else
  NewItem := Next;
end;

function NewLine(Next: PMenuItem): PMenuItem;
var
	P: PMenuItem;
begin
	New(P);
	P^.Next := Next;
	P^.Name := nil;
	P^.SubMenu := nil;  {MCH Dec 94, not here in original - *required* for the hotkeyed submenus}
	P^.Param := nil;
	P^.HelpCtx := hcNoContext;
	NewLine := P;
end;

function NewSubMenu(Name: TMenuStr; KeyCode : word; AHelpCtx: Word; SubMenu: PMenu;
	Next: PMenuItem): PMenuItem;
var
	P: PMenuItem;
begin
	if (Name <> '') and (SubMenu <> nil) then
	begin
		New(P);
		P^.Next := Next;
		P^.Name := NewStr(Name);
		P^.Command := 0;
		P^.Disabled := False;
		P^.HelpCtx := AHelpCtx;
		P^.KeyCode := KeyCode;
		P^.Param := nil; {MCH Dec 94 - req for new submenuing & params}
		P^.SubMenu := SubMenu;
		NewSubMenu := P;
	end else
	NewSubMenu := Next;
end;

{ TMenu routines }

function NewMenu(Items: PMenuItem): PMenu;
var
	P: PMenu;
begin
	New(P);
	P^.Items := Items;
	P^.Default := Items;
	NewMenu := P;
end;

procedure DisposeMenu(Menu: PMenu);
var
	P, Q: PMenuItem;
begin
	if Menu <> nil then
	begin
		P := Menu^.Items;
		while P <> nil do
		begin
			if P^.Name <> nil then
			begin
				DisposeStr(P^.Name);
				if P^.Command <> 0 then
					DisposeStr(P^.Param) else
					DisposeMenu(P^.SubMenu);
			end;
			Q := P;
			P := P^.Next;
			Dispose(Q);
		end;
    Dispose(Menu);
  end;
end;


{MCH - was inside HotKey proc, but I use it in TMenuView.execute, so better out here...}
function FindHotKey(P: PMenuItem; KeyCode : word): PMenuItem;
var
  T: PMenuItem;
begin
  while P <> nil do
  begin
    if P^.Name <> nil then
      {check item}
      if not P^.Disabled and (P^.KeyCode <> kbNoKey) and
				 (P^.KeyCode = KeyCode) then
      begin
        FindHotKey := P;
        Exit;
      end;
      {if it's a submenu, check submenu items}
      if (P^.SubMenu<>nil) then
      begin
        T := FindHotKey(P^.SubMenu^.Items, KeyCode);
        if T <> nil then
        begin
          FindHotKey := T;
          Exit;
        end;
      end;

    P := P^.Next;
  end;
  FindHotKey := nil;
end;

{ TMenuView }

constructor TMenuView.Init(var Bounds: TRect);
begin
  TView.Init(Bounds);
  EventMask := EventMask or evBroadcast;
end;

constructor TMenuView.Load(var S: TStream);

function DoLoadMenu: PMenu;
var
  Item: PMenuItem;
  Last: ^PMenuItem;
  Menu: PMenu;
  Tok: Byte;
begin
  New(Menu);
  Last := @Menu^.Items;
  Item := nil;
  S.Read(Tok,1);
  while Tok <> 0 do
  begin
    New(Item);
    Last^ := Item;
    Last := @Item^.Next;
    with Item^ do
    begin
      Name := S.ReadStr;
      S.Read(Command, SizeOf(Word) * 3 + SizeOf(Boolean));
      if (Name <> nil) then
        if Command = 0 then SubMenu := DoLoadMenu
        else Param := S.ReadStr;
    end;
    S.Read(Tok, 1);
  end;
  Last^ := nil;
  Menu^.Default := Menu^.Items;
  DoLoadMenu := Menu;
end;

begin
  TView.Load(S);
  Menu := DoLoadMenu;
end;

function TMenuView.Execute: Word;
type
  MenuAction = (DoNothing, DoSelect, DoReturn);
var
  AutoSelect: Boolean;
  Action: MenuAction;
  Ch: Char;
  Result: Word;
  ItemShown, T, P: PMenuItem;
  Target: PMenuView;
  R: TRect;
  E: TEvent;
  MouseActive: Boolean;

procedure TrackMouse;
var
  Mouse: TPoint;
  R: TRect;
begin
  MakeLocal(E.Where, Mouse);
  Current := Menu^.Items;
  while Current <> nil do
  begin
    GetItemRect(Current, R);
    if R.Contains(Mouse) then
    begin
      MouseActive := True;
      Exit;
    end;
    Current := Current^.Next;
  end;
end;

procedure TrackKey(FindNext: Boolean);

procedure NextItem;
begin
  Current := Current^.Next;
  if Current = nil then Current := Menu^.Items;
end;

procedure PrevItem;
var
  P: PMenuItem;
begin
  P := Current;
  if P = Menu^.Items then P := nil;
  repeat NextItem until Current^.Next = P;
end;

begin
  if Current <> nil then
    repeat
      if FindNext then NextItem else PrevItem;
    until Current^.Name <> nil;
end;

function MouseInOwner: Boolean;
var
  Mouse: TPoint;
  R: TRect;
begin
  MouseInOwner := False;
  if (ParentMenu <> nil) and (ParentMenu^.Size.Y = 1) then
  begin
    ParentMenu^.MakeLocal(E.Where, Mouse);
    ParentMenu^.GetItemRect(ParentMenu^.Current, R);
    MouseInOwner := R.Contains(Mouse);
  end;
end;

function MouseInMenus: Boolean;
var
  P: PMenuView;
begin
  P := ParentMenu;
  while (P <> nil) and not P^.MouseInView(E.Where) do P := P^.ParentMenu;
  MouseInMenus := P <> nil;
end;

function TopMenu: PMenuView;
var
  P: PMenuView;
begin
  P := @Self;
  while P^.ParentMenu <> nil do P := P^.ParentMenu;
  TopMenu := P;
end;

begin
  AutoSelect := False;
  Result := 0;
  ItemShown := nil;
  Current := Menu^.Default;
  MouseActive := False;
  repeat
    Action := DoNothing;
    GetEvent(E);
    case E.What of
      evMouseDown:
        if MouseInView(E.Where) or MouseInOwner then
        begin
          TrackMouse;
          if Size.Y = 1 then AutoSelect := True;
        end else Action := DoReturn;
      evMouseUp:
        begin
          TrackMouse;
          if MouseInOwner then
            Current := Menu^.Default
          else
            if (Current <> nil) and (Current^.Name <> nil) then
              Action := DoSelect
            else
              if MouseActive or MouseInView(E.Where) then Action := DoReturn
              else
              begin
                Current := Menu^.Default;
                if Current = nil then Current := Menu^.Items;
                Action := DoNothing;
              end;
        end;
      evMouseMove:
        if E.Buttons <> 0 then
        begin
          TrackMouse;
          if not (MouseInView(E.Where) or MouseInOwner) and
            MouseInMenus then Action := DoReturn;
        end;
      evKeyDown:
        case CtrlToArrow(E.KeyCode) of
          kbUp, kbDown:
            if Size.Y <> 1 then
              TrackKey(CtrlToArrow(E.KeyCode) = kbDown) else
              if E.KeyCode = kbDown then AutoSelect := True;
          kbLeft, kbRight:
            if ParentMenu = nil then
              TrackKey(CtrlToArrow(E.KeyCode) = kbRight) else
              Action := DoReturn;
          kbHome, kbEnd:
            if Size.Y <> 1 then
            begin
              Current := Menu^.Items;
              if E.KeyCode = kbEnd then TrackKey(False);
            end;
          kbEnter:
            begin
              if Size.Y = 1 then AutoSelect := True;
              Action := DoSelect;
            end;
          kbEsc:
            begin
              Action := DoReturn;
              if (ParentMenu = nil) or (ParentMenu^.Size.Y <> 1) then
                ClearEvent(E);
            end;
        else
          {look for alt key/hot key}
          Target := @Self;
          Ch := GetAltChar(E.KeyCode);
          if Ch = #0 then Ch := E.CharCode else Target := TopMenu;
          P := Target^.FindItem(Ch);
          if P = nil then
          begin
            P := TopMenu^.HotKey(E.KeyCode); {look for hot key}
            if (P <> nil) then
							if P^.Command<>0 then begin
								if CommandEnabled(P^.Command) then  {valid command?}
		            begin
		            	Result := P^.Command;
		            	Action := DoReturn;
 								end
              end else begin
                {command found and it's a menu.  Key thing now is, is it a
                direct submenu of this menu, in which case we just do a
                select, or is it somewhere else, in which case do we need to
                "back out" or burrow deeper?}
                {now locate which of the items/submenus is the desired one
                or contains the desired one}
                P := Menu^.Items; Action := DoReturn; {if not found, must be higher so return}
								while (P<>nil) and (Action = DoReturn) do begin
									if not P^.Disabled and (P^.KeyCode=E.KeyCode) then begin
                    {found in this list, so select it & list it}
										Current := P;
										Action := DoSelect;
										if Size.Y=1 then AutoSelect := True;
                  end;
                  {look to see if in submenu}
                  if (P^.SubMenu<>nil) then begin
										T := FindHotKey(P^.SubMenu^.Items, E.KeyCode);
										if T<>nil then begin {it is! select submenu}
                    	Current := P;
                      Action := DoSelect;
                      if Size.Y=1 then AutoSelect := True;
                    	PutEvent(E); {keep putting back event until we actually reach it!}
                    end;
                  end;
                	P := P^.NExt;
                end; {while}
          		end;
          end else
            {Altchar found item}
            if Target = @Self then {shortcut key in self}
            begin
              if Size.Y = 1 then AutoSelect := True;
              Action := DoSelect;
              Current := P;
            end else
              if (ParentMenu <> Target) or (ParentMenu^.Current <> P) then
                Action := DoReturn;
        end; {case key of...}
      evCommand:
        if E.Command = cmMenu then
        begin
          AutoSelect := False;
          if ParentMenu <> nil then Action := DoReturn;
        end else Action := DoReturn;
    end;
    if ItemShown <> Current then
    begin
      ItemShown := Current;
      DrawView;
    end;
    if (Action = DoSelect) or ((Action = DoNothing) and AutoSelect) then
      if Current <> nil then with Current^ do if Name <> nil then
        if Command = 0 then
        begin
          if E.What and (evMouseDown + evMouseMove) <> 0 then PutEvent(E);
          GetItemRect(Current, R);
          R.A.X := R.A.X + Origin.X;
          R.A.Y := R.B.Y + Origin.Y;
          R.B := Owner^.Size;
          if Size.Y = 1 then Dec(R.A.X);
          Target := TopMenu^.NewSubView(R, SubMenu, @Self);
          Result := Owner^.ExecView(Target);
          Dispose(Target, Done);
        end else if Action = DoSelect then Result := Command;
    if (Result <> 0) and CommandEnabled(Result) then
    begin
      Action := DoReturn;
      ClearEvent(E);
    end
    else
      Result := 0;
  until Action = DoReturn;
  if E.What <> evNothing then
    if (ParentMenu <> nil) or (E.What = evCommand) then PutEvent(E);
  if Current <> nil then
  begin
    Menu^.Default := Current;
    Current := nil;
    DrawView;
  end;
  Execute := Result;
end;

function TMenuView.FindItem(Ch: Char): PMenuItem;
var
  P: PMenuItem;
  I: Integer;
begin
  Ch := UpCase(Ch);
  P := Menu^.Items;
  while P <> nil do
  begin
    if (P^.Name <> nil) and not P^.Disabled then
    begin
      I := Pos('~', P^.Name^);
      if (I <> 0) and (Ch = UpCase(P^.Name^[I + 1])) then
      begin
        FindItem := P;
        Exit;
      end;
    end;
    P := P^.Next;
  end;
  FindItem := nil;
end;

procedure TMenuView.GetItemRect(Item: PMenuItem; var R: TRect);
begin
end;

function TMenuView.GetHelpCtx(const Level : byte): Word;
var
  C: PMenuView;
begin
  C := @Self;
  while (C <> nil) and
     ((C^.Current = nil) or (C^.Current^.HelpCtx = hcNoContext) or
      (C^.Current^.Name = nil)) do
    C := C^.ParentMenu;
	if C <> nil then GetHelpCtx := C^.Current^.HelpCtx
	else GetHelpCtx := hcNoContext;
end;

function TMenuView.GetPalette: PPalette;
const
  P: string[Length(CMenuView)] = CMenuView;
begin
  GetPalette := @P;
end;

procedure TMenuView.HandleEvent(var Event: TEvent);
var
  CallDraw: Boolean;
  P: PMenuItem;

procedure UpdateMenu(Menu: PMenu);
var
  P: PMenuItem;
  CommandState: Boolean;
begin
  P := Menu^.Items;
  while P <> nil do
  begin
    if P^.Name <> nil then
      if P^.Command = 0 then UpdateMenu(P^.SubMenu)
      else
      begin
        CommandState := CommandEnabled(P^.Command);
        if P^.Disabled = CommandState then
        begin
          P^.Disabled := not CommandState;
          CallDraw := True;
        end;
      end;
    P := P^.Next;
  end;
end;

procedure DoSelect;
begin
  PutEvent(Event);
  Event.Command := Owner^.ExecView(@Self);
  if (Event.Command <> 0) and CommandEnabled(Event.Command) then
  begin
    Event.What := evCommand;
    Event.InfoPtr := nil;
    PutEvent(Event);
  end;
  ClearEvent(Event);
end;

begin
  if Menu <> nil then
    case Event.What of
      evMouseDown:
        DoSelect;
      evKeyDown:
        if (FindItem(GetAltChar(Event.KeyCode)) <> nil) then
					DoSelect
        else
        begin
          P := HotKey(Event.KeyCode);
          if (P <> nil) then
						if P^.Command=0 then
            	DoSelect {it's a menu}
            else if	(CommandEnabled(P^.Command)) then
		          begin
 		           	Event.What := evCommand;
		            Event.Command := P^.Command;
  		          Event.InfoPtr := nil;
     						PutEvent(Event);
            		ClearEvent(Event);
              end;

        end;
      evCommand:
        if Event.Command = cmMenu then DoSelect;
      evBroadcast:
        if Event.Command = cmCommandSetChanged then
        begin
          CallDraw := False;
          UpdateMenu(Menu);
          if CallDraw then DrawView;
        end;
    end;
end;



function TMenuView.HotKey(KeyCode: Word): PMenuItem;

begin
  HotKey := FindHotKey(Menu^.Items, KeyCode);
end;

function TMenuView.NewSubView(var Bounds: TRect; AMenu: PMenu;
  AParentMenu: PMenuView): PMenuView;
begin
  NewSubView := New(PMenuBox, Init(Bounds, AMenu, AParentMenu));
end;

procedure TMenuView.Store(var S: TStream);

procedure DoStoreMenu(Menu: PMenu);
var
  Item: PMenuItem;
  Tok: Byte;
begin
  Tok := $FF;
  Item := Menu^.Items;
  while Item <> nil do
  begin
    with Item^ do
    begin
      S.Write(Tok, 1);
      S.WriteStr(Name);
      S.Write(Command, SizeOf(Word) * 3 + SizeOf(Boolean));
      if (Name <> nil) then
        if Command = 0 then DoStoreMenu(SubMenu)
        else S.WriteStr(Param);
    end;
    Item := Item^.Next;
  end;
  Tok := 0;
  S.Write(Tok, 1);
end;

begin
  TView.Store(S);
  DoStoreMenu(Menu);
end;

{ TMenuBar }

constructor TMenuBar.Init(var Bounds: TRect; AMenu: PMenu);
begin
  TMenuView.Init(Bounds);
  GrowMode := gfGrowHiX;
  Menu := AMenu;
  Options := Options or ofPreProcess;
end;

destructor TMenuBar.Done;
begin
  TMenuView.Done;
  DisposeMenu(Menu);
end;

procedure TMenuBar.Draw;
var
  X, L: Integer;
  CNormal, CSelect, CNormDisabled, CSelDisabled, Color: Word;
  P: PMenuItem;
  B: TDrawBuffer;
begin
  CNormal := GetColor($0301);
  CSelect := GetColor($0604);
  CNormDisabled := GetColor($0202);
  CSelDisabled := GetColor($0505);
  MoveChar(B, ' ', Byte(CNormal), Size.X);
  if Menu <> nil then
  begin
    X := 1;
    P := Menu^.Items;
    while P <> nil do
    begin
      if P^.Name <> nil then
      begin
        L := CStrLen(P^.Name^);
        if X + L < Size.X then
        begin
          if P^.Disabled then
            if P = Current then
              Color := CSelDisabled else
              Color := CNormDisabled else
            if P = Current then
              Color := CSelect else
              Color := CNormal;
          MoveChar(B[X], ' ', Byte(Color), 1);
          MoveCStr(B[X + 1], P^.Name^, Color);
          MoveChar(B[X + L + 1], ' ', Byte(Color), 1);
        end;
        Inc(X, L + 2);
      end;
      P := P^.Next;
    end;
  end;
  WriteBuf(0, 0, Size.X, 1, B);
end;

procedure TMenuBar.GetItemRect(Item: PMenuItem; var R: TRect);
var
  P: PMenuItem;
begin
  R.Assign(1, 0, 1, 1);
  P := Menu^.Items;
  while True do
  begin
    R.A.X := R.B.X;
    if P^.Name <> nil then Inc(R.B.X, CStrLen(P^.Name^)+2);
    if P = Item then Exit;
    P := P^.Next;
  end;
end;

{ TMenuBox }

constructor TMenuBox.Init(var Bounds: TRect; AMenu: PMenu;
  AParentMenu: PMenuView);
var
  W, H, L: Integer;
  P: PMenuItem;
  R: TRect;
begin
  W := 10;
  H := 2;
  if AMenu <> nil then
  begin
    P := AMenu^.Items;
    while P <> nil do
    begin
      if P^.Name <> nil then
      begin
        L := CStrLen(P^.Name^) + 6;
        if P^.Command = 0 then Inc(L, 3) else
          if P^.Param <> nil then Inc(L, CStrLen(P^.Param^) + 2);
        if L > W then W := L;
      end;
      Inc(H);
      P := P^.Next;
    end;
  end;
  R.Copy(Bounds);
  if R.A.X + W < R.B.X then R.B.X := R.A.X + W else R.A.X := R.B.X - W;
  if R.A.Y + H < R.B.Y then R.B.Y := R.A.Y + H else R.A.Y := R.B.Y - H;
  TMenuView.Init(R);
  State := State or sfShadow;
  Options := Options or ofPreProcess;
  Menu := AMenu;
  ParentMenu := AParentMenu;
end;

procedure TMenuBox.Draw;
var
  CNormal, CSelect, CNormDisabled, CSelDisabled, Color: Word;
  Y: Integer;
  P: PMenuItem;
  B: TDrawBuffer;

procedure FrameLine(N: Integer);
const
  FrameChars: array[0..19] of Char = ' ÚÄ¿  ÀÄÙ  ³ ³  ÃÄ´ ';
begin
  MoveBuf(B[0], FrameChars[N], Byte(CNormal), 2);
  MoveChar(B[2], FrameChars[N + 2], Byte(Color), Size.X - 4);
  MoveBuf(B[Size.X - 2], FrameChars[N + 3], Byte(CNormal), 2);
end;

procedure DrawLine;
begin
  WriteBuf(0, Y, Size.X, 1, B);
  Inc(Y);
end;

begin
  CNormal := GetColor($0301);
  CSelect := GetColor($0604);
  CNormDisabled := GetColor($0202);
  CSelDisabled := GetColor($0505);
  Y := 0;
  Color := CNormal;
  FrameLine(0);
  DrawLine;
  if Menu <> nil then
  begin
    P := Menu^.Items;
    while P <> nil do
    begin
      Color := CNormal;
      if P^.Name = nil then FrameLine(15) else
      begin
        if P^.Disabled then
          if P = Current then
            Color := CSelDisabled else
            Color := CNormDisabled else
          if P = Current then Color := CSelect;
        FrameLine(10);
        MoveCStr(B[3], P^.Name^, Color);
        if P^.Command = 0 then
          MoveChar(B[Size.X - 4], #16, Byte(Color), 1) else
          if P^.Param <> nil then
            MoveStr(B[Size.X - 3 - Length(P^.Param^)],
              P^.Param^, Byte(Color));
      end;
      DrawLine;
      P := P^.Next;
    end;
  end;
  Color := CNormal;
  FrameLine(5);
  DrawLine;
end;

procedure TMenuBox.GetItemRect(Item: PMenuItem; var R: TRect);
var
  Y: Integer;
  P: PMenuItem;
begin
  Y := 1;
  P := Menu^.Items;
  while P <> Item do
  begin
    Inc(Y);
    P := P^.Next;
  end;
  R.Assign(2, Y, Size.X - 2, Y + 1);
end;


constructor TMenuPopup.Init(var Bounds: TRect; AMenu: PMenu);
begin
  inherited Init(Bounds, AMenu, nil);
end;

procedure TMenuPopup.HandleEvent(var Event: TEvent);
var
  P: PMenuItem;
begin
  case Event.What of
    evKeyDown:
      begin
        P := FindItem(GetCtrlChar(Event.KeyCode));
        if P = nil then
          P := HotKey(Event.KeyCode);
        if (P <> nil) and (CommandEnabled(P^.Command)) then
        begin
          Event.What := evCommand;
          Event.Command := P^.Command;
          Event.InfoPtr := nil;
          PutEvent(Event);
          ClearEvent(Event);
        end
        else
          if GetAltChar(Event.KeyCode) <> #0 then
            ClearEvent(Event);
      end;
  end;
  inherited HandleEvent(Event);
end;

{ TStatusLine }

constructor TStatusLine.Init(var Bounds: TRect; ADefs: PStatusDef);
begin
  TView.Init(Bounds);
  Options := Options or ofPreProcess;
  EventMask := EventMask or evBroadcast;
  GrowMode := gfGrowLoY + gfGrowHiX + gfGrowHiY;
  Defs := ADefs;
  FindItems;
end;

constructor TStatusLine.Load(var S: TStream);

function DoLoadStatusItems: PStatusItem;
var
  Count: Integer;
  Cur, First: PStatusItem;
  Last: ^PStatusItem;
begin
  Cur := nil;
  Last := @First;
  S.Read(Count, SizeOf(Integer));
  while Count > 0 do
  begin
    New(Cur);
    Last^ := Cur;
    Last := @Cur^.Next;
    Cur^.Text := S.ReadStr;
    S.Read(Cur^.KeyCode, SizeOf(Word) * 2);
    Dec(Count);
  end;
  Last^ := nil;
  DoLoadStatusItems := First;
end;

function DoLoadStatusDefs: PStatusDef;
var
  Cur, First: PStatusDef;
  Last: ^PStatusDef;
  Count: Integer;
begin
  Last := @First;
  S.Read(Count, SizeOf(Integer));
  while Count > 0 do
  begin
    New(Cur);
    Last^ := Cur;
    Last := @Cur^.Next;
    S.Read(Cur^.Min, 2 * SizeOf(Word));
    Cur^.Items := DoLoadStatusItems;
    Dec(Count);
  end;
  Last^ := nil;
  DoLoadStatusDefs := First;
end;

begin
  TView.Load(S);
  Defs := DoLoadStatusDefs;
  FindItems;
end;

destructor TStatusLine.Done;
var
  T: PStatusDef;

procedure DisposeItems(Item: PStatusItem);
var
  T: PStatusItem;
begin
  while Item <> nil do
  begin
    T := Item;
    Item := Item^.Next;
    DisposeStr(T^.Text);
    Dispose(T);
  end;
end;

begin
  while Defs <> nil do
  begin
    T := Defs;
    Defs := Defs^.Next;
    DisposeItems(T^.Items);
    Dispose(T);
  end;
  TView.Done;
end;

procedure TStatusLine.Draw;
begin
  DrawSelect(nil);
end;

procedure TStatusLine.DrawSelect(Selected: PStatusItem);
var
  B: TDrawBuffer;
  T: PStatusItem;
  I, L: Integer;
  CSelect, CNormal, CSelDisabled, CNormDisabled: Word;
  Color: Word;
  HintBuf: String;
begin
  CNormal := GetColor($0301);
  CSelect := GetColor($0604);
  CNormDisabled := GetColor($0202);
  CSelDisabled := GetColor($0505);
  MoveChar(B, ' ', Byte(CNormal), Size.X);
  T := Items;
  I := 0;
  while T <> nil do
  begin
    if T^.Text <> nil then
    begin
      L := CStrLen(T^.Text^);
      if I + L < Size.X then
      begin
        if CommandEnabled(T^.Command) then
          if T = Selected then
            Color := CSelect else
            Color := CNormal else
          if T = Selected then
            Color := CSelDisabled else
            Color := CNormDisabled;
        MoveChar(B[I], ' ', Byte(Color), 1);
        MoveCStr(B[I + 1], T^.Text^, Color);
        MoveChar(B[I + L + 1], ' ', Byte(Color), 1);
      end;
      Inc(I, L + 2);
    end;
    T := T^.Next;
  end;
  if I < Size.X - 2 then
  begin
    HintBuf := Hint(HelpCtx);
    if HintBuf <> '' then
    begin
      MoveChar(B[I], #179, Byte(CNormal), 1);
      Inc(I, 2);
      if I + Length(HintBuf) > Size.X then HintBuf[0] := Char(Size.X - I);
      MoveStr(B[I], HintBuf, Byte(CNormal));
    end;
  end;
  WriteLine(0, 0, Size.X, 1, B);
end;

procedure TStatusLine.FindItems;
var
  P: PStatusDef;
begin
  P := Defs;
  while (P <> nil) and ((HelpCtx < P^.Min) or (HelpCtx > P^.Max)) do
    P := P^.Next;
  if P = nil then Items := nil else Items := P^.Items;
end;

function TStatusLine.GetPalette: PPalette;
const
  P: string[Length(CStatusLine)] = CStatusLine;
begin
  GetPalette := @P;
end;

procedure TStatusLine.HandleEvent(var Event: TEvent);
var
  Mouse: TPoint;
  T: PStatusItem;

function ItemMouseIsIn: PStatusItem;
var
  I,K: Word;
  T: PStatusItem;
begin
  ItemMouseIsIn := nil;
  if Mouse.Y <> 0 then Exit;
  I := 0;
  T := Items;
  while T <> nil do
  begin
    if T^.Text <> nil then
    begin
      K := I + CStrLen(T^.Text^) + 2;
      if (Mouse.X >= I) and (Mouse.X < K) then
      begin
        ItemMouseIsIn := T;
        Exit;
      end;
      I := K;
    end;
    T := T^.Next;
  end;
end;

begin
  TView.HandleEvent(Event);
  case Event.What of
    evMouseDown:
      begin
        T := nil;
        repeat
          MakeLocal(Event.Where, Mouse);
          if T <> ItemMouseIsIn then
          begin
            T := ItemMouseIsIn;
            DrawSelect(T);
          end;
        until not MouseEvent(Event, evMouseMove);
        if (T <> nil) and CommandEnabled(T^.Command) then
        begin
          Event.What := evCommand;
          Event.Command := T^.Command;
          Event.InfoPtr := nil;
          PutEvent(Event);
        end;
        ClearEvent(Event);
        DrawView;
      end;
    evKeyDown:
      begin
        T := Items;
        while T <> nil do
        begin
          if (Event.KeyCode = T^.KeyCode) and
            CommandEnabled(T^.Command) then
          begin
            Event.What := evCommand;
            Event.Command := T^.Command;
            Event.InfoPtr := nil;
            Exit;
          end;
          T := T^.Next;
        end;
      end;
    evBroadcast:
      if Event.Command = cmCommandSetChanged then DrawView;
  end;
end;

function TStatusLine.Hint(AHelpCtx: Word): String;
begin
  Hint := '';
end;

procedure TStatusLine.Store(var S: TStream);

procedure DoStoreStatusItems(Cur: PStatusItem);
var
  T: PStatusItem;
  Count: Integer;
begin
  Count := 0;
  T := Cur;
  while T <> nil do
  begin
    Inc(Count);
    T := T^.Next
  end;
  S.Write(Count, SizeOf(Integer));
  while Cur <> nil do
  begin
    S.WriteStr(Cur^.Text);
    S.Write(Cur^.KeyCode, SizeOf(Word) * 2);
    Cur := Cur^.Next;
  end;
end;

procedure DoStoreStatusDefs(Cur: PStatusDef);
var
  Count: Integer;
  T: PStatusDef;
begin
  Count := 0;
  T := Cur;
  while T <> nil do
  begin
    Inc(Count);
    T := T^.Next
  end;
  S.Write(Count, SizeOf(Integer));
  while Cur <> nil do
  begin
    with Cur^ do
    begin
      S.Write(Min, SizeOf(Word) * 2);
      DoStoreStatusItems(Items);
    end;
    Cur := Cur^.Next;
  end;
end;

begin
  TView.Store(S);
  DoStoreStatusDefs(Defs);
end;

procedure TStatusLine.Update;
var
  H: Word;
  P: PView;
begin
	P := TopView;
	if P <> nil then
		H := P^.GetHelpCtx(hlDetail) else
    H := hcNoContext;
  if HelpCtx <> H then
  begin
    HelpCtx := H;
    FindItems;
    DrawView;
  end;
end;

function NewStatusDef(AMin, AMax: Word; AItems: PStatusItem;
  ANext:PStatusDef): PStatusDef;
var
  T: PStatusDef;
begin
  New(T);
  with T^ do
  begin
    Next := ANext;
    Min := AMin;
    Max := AMax;
    Items := AItems;
  end;
  NewStatusDef := T;
end;

function NewStatusKey(const AText: String; AKeyCode: Word; ACommand: Word;
  ANext: PStatusItem): PStatusItem;
var
  T: PStatusItem;
begin
  New(T);
  T^.Text := NewStr(AText);
  T^.KeyCode := AKeyCode;
  T^.Command := ACommand;
  T^.Next := ANext;
  NewStatusKey := T;
end;

procedure RegisterMenus;
begin
  RegisterType(RMenuBar);
  RegisterType(RMenuBox);
  RegisterType(RStatusLine);
	RegisterType(RMenuPopup);
end;

{*************************************************************
 ***                                                       ***
 ***                  MARTIN'S EXTENSIONS                  ***
 ***mch                                                    ***
{*************************************************************}
{---- Find Item matching string -----}
{make sure menu is not nil!}
function FindItem(const Menu : PMenu; const Title : string; var Prev : PMenuItem) : PMenuItem;
var Work : PMenuItem;
begin
	Prev := nil; FindItem := nil;
	if Menu <> nil then begin
		Work := Menu^.Items;
		while Work<>nil do begin
			{remember that if a work item is a line, work^.name is nil}
			if (Work^.Name<>nil) and (ucase(Work^.Name^)=ucase(Title)) then begin
				FindItem := Work;
				Work := nil;
			end else begin
				Prev := Work;
				Work := Work^.Next;
			end;
		end;
	end;
end;

function FindEnd(const Menu : PMenu) : PMenuItem;
var Work : PMenuItem;
begin
	FindEnd := nil;
	if Menu<>nil then begin
		Work := Menu^.Items;
		if Work<>nil then while Work^.Next<>nil do Work := Work^.Next;
		FindEnd := Work;
	end;
end;


{--- Adds item to start of PMenu chain ----}
procedure AddItemStart(var Menu : PMenu; const ITem : PMenuItem); {Adds to Menu chain}
begin
	if Menu = nil then Menu := NewMenu(Item)
		else begin
			Item^.Next := Menu^.Items;   {Set next to what was first}
			Menu^.Items := Item;         {Set first to new one}
			Menu^.Default := Item;				{set default to new one}
		end;
	if Menu^.Default = nil then Menu^.Default := Item;
end;

{--- Adds item to end of PMenu chain ----}
procedure AddItemEnd(var Menu : PMenu; const ITem : PMenuItem); {Adds to Menu chain}
begin
	if Menu = nil then Menu := NewMenu(Item)
		else if Menu^.Items = nil then Menu^.Items := Item
			else FindEnd(Menu)^.Next := Item;
	if Menu^.Default = nil then Menu^.Default := Item;
end;

{--- Adds item to PMenu chain sorted alphabetically ----}
procedure AddItem(var Menu : PMenu; const ITem : PMenuItem); {Adds to Menu chain}
var Work,Prev : PMenuItem;
begin
	if Menu = nil then Menu := NewMenu(Item)
		else if Menu^.Items = nil then Menu^.Items := Item
			else begin
				Work := FindItem(Menu, Item^.Name^, Prev);

				{insert}
				Item^.Next := Work;
				Prev^.Next := Item;
			end;
	if Menu^.Default = nil then Menu^.Default := Item;
end;

{---- Adds item to end of submenu -----------}
procedure AddItemSubMenu(var Menu : PMenu; const SubMenuTitle : string; const Item : PMenuItem);
var Work,Prev : PMenuItem;
begin
	if Menu = nil then Menu := NewMenu(NewSubMenu(SubMenuTitle, 0, hcNoContext, NewMenu(Item), nil))
	else begin
		Work := FindItem(Menu, SubMenuTitle, Prev);
		if (Work=nil) then begin
			{sub menu not there - insert}
			AddItemEnd(Menu, NewSubMenu(SubMenuTitle, 0, hcNoContext, NewMenu(Item), nil));
		end else begin
			{found}
			Work^.Command :=0; {has to be zero if a submenu present}
			AddItemEnd(Work^.SubMenu, Item);
		end;
	end;
end;


{---- Adds item to end of submenu of a submenu ----}
{Adds menu option to end of sub menu box}
procedure AddItemSubSubMenu(var Menu : PMenu; const SubMenuTitle, SubSubMenuTitle : string; const Item : PMEnuItem);
var work,Prev : PMenuItem;
begin
	if Menu = nil then
		Menu := NewMenu(NewSubMenu(SubMenuTitle, 0, hcNoContext,
												NewMenu(NewSubMenu(subsubMenuTitle, 0, hcNoContext, NewMenu(Item), nil)), nil))
	else	begin
		Work := FindItem(Menu, SubMenuTitle,Prev);
		if (Work=nil) then
			{sub menu not there - insert}
			AddItemEnd(Menu, NewSubMenu(SubMenuTitle, 0, hcNoContext,
												NewMenu(NewSubMenu(SubSubMenuTitle, 0, hcNoContext, NewMenu(Item), nil)),nil))
		else begin
			{found}
			Work^.Command := 0; {has to be zero if submenu to be used}
			AddItemSubMenu(Work^.SubMenu, SubSubMenuTitle, Item);
		end;
	end;
end;{}


{======== SET KEY ============================}
procedure SetItemKey(var Menu : PMenu; const Title : string; const kbType : word);
var Work,Prev : PMenuItem;
begin
	Work := FindItem(Menu, Title, Prev);
	if Work<>nil then Work^.KeyCode := kbType;
end;

{=== RENAME ITEM NAME =====================}
{renames menu item string}
procedure RenameItem(Menu : PMenu; const OldName, NewName : string);
var Work,Prev : PMenuItem;

begin
	Work := FindItem(Menu, OldName,Prev); {find one to match last}

	{Rename}
	if Work<>nil then begin
		 DisposeStr(Work^.Name);       {Free up space on heap for old name}
		 Work^.Name := NewStr(NewName); {Reserve space & set for new name}
	end;
end;

{=== DELETE ITEM (Given Name) ===============================}
procedure DeleteItem(var Menu : PMenu; Name : string);
var Work,Prev : PMenuItem;
begin
	Work := FindItem(Menu, Name, Prev);

	if Work<>nil then begin
		if Prev=nil then
			Menu^.Items := Work^.Next	{First item}
		else
			Prev^.Next := Work^.Next;

		dispose(Work);
	end;
end;

{=== REPLACE "NAME" ITEM WITH NEW ITEM =====================}
procedure ReplaceItem(Menu : PMenu; OldName : string; NewItem : PmenuItem);
var Prev,Work : PMenuItem;

begin
	Work := FindItem(Menu, OldName, Prev);

	if Work<>nil then begin

		if Prev=nil then
			Menu^.Items := NewItem {first item}
		else
			Prev^.Next := NewItem;

		NewItem^.Next := Work^.Next;
		dispose(Work);
	end;
end;

{===== CREATE NEW MENU ITEM ======================}
function CopyItem(const Source : PMenuItem) : PMenuItem;
var WName, WParam : string[30];
begin
	if Source = nil then CopyItem := nil
	else with Source^ do begin
		if name = nil then WName := '' else WName := Name^; {doing a deref on a nil causes a 216..}
		if param = nil then WParam := '' else WParam := Param^;
		CopyItem := NewItem(WName, WParam, KeyCode, Command, HelpCtx, CopyItem(Next)); {Create new item}
	end;
end;


function COmmandInMenu(const Menu : PMenu; const COmmand : word) : boolean;
var Work : PMenuItem;
begin
	CommandInMenu := False;
	if (Menu<>nil) then begin
		Work := Menu^.Items;
		while (Work<>nil) and (Work^.Command<>Command) do Work := Work^.Next;
		if (Work<>nil) and (Work^.Command = Command) then CommandInMenu := true;
	end;
end;


{=============== DIALOG BOX MENUS =====================}
{Dialog palettes are extended so that menus can be inserted.  This palette
sits at the end of the normal CDialog, and follows for six chars...:}
const CDlgMenu : string[6] = #33#34#35#36#37#38;

{-- Boxes --}
function TDlgMenuBox.GetPalette;
begin GetPalette := @CDlgMenu; end;{}

{and make sure submenus have the right palette}
function TDlgMenuBox.NewSubView(var Bounds: TRect; AMenu: PMenu; AParentMenu: PMenuView): PMenuView;
begin	NewSubView := New(PDlgMenuBox, Init(Bounds, AMenu, AParentMenu)); end;

{-- Bar --}
function TDlgMenuBar.GetPalette;
begin GetPalette := @CDlgMenu; end;{}

{and make sure submenus have the right palette}
function TDlgMenuBar.NewSubView(var Bounds: TRect; AMenu: PMenu; AParentMenu: PMenuView): PMenuView;
begin NewSubView := New(PDlgMenuBox, Init(Bounds, AMenu, AParentMenu)); end;


end.
