{$S-,R-,I-,V-,B-}

{*********************************************************}
{*                   TPMENU.PAS 4.03                     *}
{*        Copyright (c) TurboPower Software 1987.        *}
{* Portions copyright (c) Sunny Hill Software 1985, 1986 *}
{*     and used under license to TurboPower Software     *}
{*                 All rights reserved.                  *}
{*********************************************************}

unit TPMenu;
  {-Pulldown menu routines}

interface

uses
  TPString,
  TPCrt;

type

  MenuStatusType =           {Status of a menu operation}
  (MenuSuccess,              {Operation successful}
   MenuNoMem,                {Insufficient memory}
   MenuFileNotFound,         {Menu library file not found}
   MenuNotLibraryFile,       {File is not a library file}
   MenuIdNotFound,           {Specified library element not found}
   MenuFileReadError,        {Error while reading menu file}
   MenuFileWriteError,       {Error while writing menu file}
   MenuFileCreationError,    {Unable to create library file}
   MenuFileCorrupt,          {Menu file is corrupt}
   MenuLibraryFull           {No room in library index to add a new entry}
   );

  MenuCharSet = set of Char; {User-defined keys to exit menu selection}

  MenuKey = LongInt;         {What a menu selection returns as identification}

  Orientation =              {Which direction scrolling proceeds}
  (Vertical, Horizontal, NoOrient);

  FrameArray = array[FrameCharType] of Char; {Elements of a window frame}

  MenuColorType =            {Colors used by the menu system}
  (FrameColor, HeaderColor, BodyColor, SelectColor, HiliteColor, HelpColor);
  MenuColorArray = array[MenuColorType] of Byte;

const
  {Tag denotes unframed submenus}
  LotusFrame = #255#255#255#255#255#255;
  NoFrame = LotusFrame;      {Synonym for LotusFrame}
  NoHelp = 0;                {Help row to skip help altogether}
  FrameDelta : array[Boolean] of Byte = (1, 0);
  HideCursor : Boolean = True;  {False to leave hardware cursor on while menus displayed}


type
  Menu = ^MenuRec;
  ItemP = ^ItemRec;
  SubMenuP = ^SubMenuRec;
  MenuStackP = ^MenuStackRec;
  BufP = ^BufferArray;

  BufferArray = array[1..MaxInt] of Char;

  ItemRec =                  {27 bytes+name+help}
  record
    DisplayPos : Byte;       {Offset from top left corner of menu for display}
    SelectPos : Byte;        {Byte in string to highlight and cause selection, 0 for none}
    Key : MenuKey;           {Key returned when item is selected}
    Name : Pointer;          {Pointer to string to display for item}
    Help : Pointer;          {Pointer to string to display for item help}
    Next : ItemP;            {Pointer to next item in list}
    Prev : ItemP;            {Pointer to previous item in list}
    Sub : SubMenuP;          {Pointer to submenu, nil if none}
    OnHeap : Boolean;        {True if name/help is allocated on heap}
  end;

  ItemList =
  record
    First : ItemP;           {First item in menu}
    Last : ItemP;            {Last item in menu}
    Current : ItemP;         {Current item in menu}
  end;

  SubMenuRec =               {43 bytes+header+screen buffers}
  record
    XL, YL : Byte;           {Upper left corner of window frame}
    XH, YH : Byte;           {Actual bottom right corner of window frame}
    YHelp : Byte;            {Row where a help line starts}
    Orient : Orientation;    {Horizontal or vertical scroll}
    Frame : FrameArray;      {Characters for frame}
    Colors : MenuColorArray; {Colors for parts of menu}
    LotusStyle : Boolean;    {True for menus without frames, ala Lotus}
    Header : Pointer;        {Title string for frame}
    Items : ItemList;        {Linked list of entries}
    Covers : BufP;           {Points to buffer for screen covered by submenu}
    HelpCovers : BufP;       {Points to buffer for screen covered by help}
  end;

  MenuStackRec =
  record
    Top : SubMenuP;          {Points to active submenu}
    Next : MenuStackP;       {Remainder of the stack}
  end;

  MenuRec =
  record
    Root : SubMenuP;         {Root of menu}
    Active : SubMenuP;       {Currently active submenu}
    Stack : MenuStackP;      {Points to stack of active menus}
    UserFunc : Pointer;      {Points to user-supplied function}
    SelectKeys : MenuCharSet; {User-defined keys to perform selection}
    Visible : Boolean;       {True when menus are onscreen}
  end;


procedure CheckMenuStatus(Mstatus : MenuStatusType);
  {-Check menu status, report and halt on any error}

function MenuStatus : MenuStatusType;
  {-Return status of previous operation}

function NewMenu(SelectKeys : MenuCharSet; UserFunc : Pointer) : Menu;
  {-Initialize a new menu system by returning a pointer to a new menu}

procedure SetMenuSelectKeys(Mnu : Menu; Skeys : MenuCharSet);
  {-Change the select key set of existing menu system as specified}

procedure SubMenu(XL1, YL1, Yhelp1 : Byte;
                  Orient1 : Orientation;
                  Frame1 : FrameArray;
                  Colors1 : MenuColorArray;
                  HeaderStr : string
                  );
  {-Add a submenu to currently active item of currently active submenu
    of currently active menu}

procedure PopSubLevel;
  {-Pop active menu from top of menu stack}

procedure MenuItem(NameStr : string; {Name of item}
                   DisplayPos1 : Byte; {Offset from upper left corner of menu for item}
                   SelectPos1 : Byte; {Position within namestr to hilite and select from}
                   Key1 : MenuKey; {Key to return when item is selected}
                   HelpStr : string {Help string for item}
                   );
  {-Add an item to currently active submenu of currently active menu.
    name space is allocated on heap}

procedure MenuItemPtr(NamePtr : Pointer; {Pointer to name of item}
                      DisplayPos1 : Byte;
                      SelectPos1 : Byte;
                      Key1 : MenuKey;
                      HelpPtr : Pointer {Pointer to help for item}
                      );
  {-Add an item to currently active submenu of currently active menu.
    name space is NOT allocated on heap}

procedure DisposeMenu(Mnu : Menu);
  {-Dispose of all menu heap space}

procedure ResetMenu(Mnu : Menu);
  {-Set all selections to first item}

function MenuChoice(Mnu : Menu; var SelectKey : Char) : MenuKey;
  {-Display menu system, let user browse it, return menukey of selected item,
    return keystroke used to select item, leave menu on screen}

procedure EraseMenu(Mnu : Menu; ResetSelections : Boolean);
  {-Erase active menus from the screen, reset selections to base if desired}

procedure EraseMenuOntoStack(Mnu : Menu; var TStack : MenuStackP);
  {-Erase a menu system, saving the path of current selection on a stack}

procedure DrawMenuFromStack(Mnu : Menu; var TStack : MenuStackP);
  {-Draw a menu system using previously saved stack of items}

procedure WriteMenuLib(Mnu : Menu; Fname : string; ID : string);
  {-Write a menu system to a binary menu library}

function ReadMenuLib(Fname : string; ID : string; UserFunc : Pointer) : Menu;
  {-Read a menu system from a binary menu library}

procedure PackMenuLib(iname, oname : string);
  {-Remove obsolete menu entries from library iname, creating oname}

  {--------------------------------------------------------------------------}
  {Following routines are primarily for internal use, interfaced for MAKEMENU}

procedure ClearWindow(XL, YL, XH, YH, Attr : Byte);
  {-Clear a region with specified attribute}

procedure DrawFrame(XL, YL, XH, YH, Attr : Byte; Frame : FrameArray);
  {-Draw a frame around a window}

procedure PushSubMenu(Mnu : Menu; SubMnu : SubMenuP);
  {-Put submenu onto active stack of the menu}

procedure PopSubMenu(Mnu : Menu);
  {-Remove submenu from active stack}

procedure DisposeSubMenu(var SubMnu : SubMenuP);
  {-Dispose of submenu and its children}

procedure DrawItem(SubMnu : SubMenuP; Item : ItemP; UserFunc : Pointer);
  {-Draw one item in a submenu}

procedure DrawSubMenu(SubMnu : SubMenuP; UserFunc : Pointer);
  {-Draw a submenu on-screen}

procedure EraseSubMenu(SubMnu : SubMenuP);
  {-Erase a submenu from the screen}

  {==========================================================================}

implementation

const
  FirstColor = FrameColor;
  LastColor = HelpColor;

const
  {Keystrokes for menu browsing}
  Kup = #200;                {Up arrow OR $80}
  Kdown = #208;              {Down arrow OR $80}
  Kleft = #203;              {Left arrow OR $80}
  Kright = #205;             {Right arrow OR $80}
  Khome = #199;              {Home OR $80}
  Kend = #207;               {End OR $80}
  Kenter = #13;
  Kescape = #27;

type
  {Commands for menu browsing}
  CommandType =
  (Mup,                      {Select the item above current}
   Mdown,                    {Select the item below current}
   MsubUp,                   {Select the submenu above current}
   MsubDown,                 {Select the submenu below current}
   Mright,                   {Select the item to the right of current}
   Mleft,                    {Select the item to the left of current}
   MsubLeft,                 {Select the submenu to the left of current}
   MsubRight,                {Select the submenu to the right of current}
   Mhome,                    {Select first item}
   Mend,                     {Select last item}
   Mexit,                    {Exit the menu system}
   Mselect,                  {Select the next submenu or item}
   Mdeselect,                {Deselect the current submenu}
   Mnul                      {No command}
   );

var
  PrevMenuStatus : MenuStatusType; {Error status}
  CurrentUserFunc : Pointer; {Pointer to item display function currently in use}
  CurrMenu : Menu;           {Menu currently being built}

  procedure CheckMenuStatus(Mstatus : MenuStatusType);
    {-Check menustatus, report error and halt}
  begin
    case Mstatus of
      MenuSuccess : Exit;
      MenuNoMem : WriteLn('insufficient memory to allocate menu');
      MenuFileNotFound : WriteLn('Menu library file not found');
      MenuNotLibraryFile : WriteLn('File is not a library file');
      MenuIdNotFound : WriteLn('Specified library element not found');
      MenuFileCreationError : WriteLn('Unable to create library file');
      MenuFileReadError : WriteLn('Error while reading menu file');
      MenuFileWriteError : WriteLn('Error while writing menu file');
      MenuFileCorrupt : WriteLn('Menu file is corrupt');
      MenuLibraryFull : WriteLn('No room in library index to add a new entry');
    end;
    Halt(1);
  end;

  function MenuStatus : MenuStatusType;
    {-Return status of previous operation}

  begin
    MenuStatus := PrevMenuStatus;
    {Reset previous status}
    PrevMenuStatus := MenuSuccess;
  end;

  function NewMenu(SelectKeys : MenuCharSet; UserFunc : Pointer) : Menu;
    {-Initialize a new menu system and return a pointer to it}
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;
    if MaxAvail < SizeOf(MenuRec) then
      PrevMenuStatus := MenuNoMem
    else begin
      {Allocate the space}
      GetMem(CurrMenu, SizeOf(MenuRec));
      {Initialize the fields to nil}
      FillChar(CurrMenu^, SizeOf(MenuRec), 0);
      {Initialize the selection keys}
      CurrMenu^.SelectKeys := SelectKeys;
      {Store the UserFunc pointer}
      CurrMenu^.UserFunc := UserFunc;
      NewMenu := Menu(CurrMenu);
    end;
  end;

  procedure SetMenuSelectKeys(Mnu : Menu; Skeys : MenuCharSet);
    {-Change the select key set of existing menu system as specified}
  begin
    with Mnu^ do
      SelectKeys := Skeys;
  end;

  procedure PushSubMenu(Mnu : Menu; SubMnu : SubMenuP);
    {-Put submenu onto active stack of the menu}
  var
    P : MenuStackP;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;
    if MaxAvail < SizeOf(MenuStackRec) then
      PrevMenuStatus := MenuNoMem
    else
      with Mnu^ do begin
        {Initialize the root if this is the first submenu}
        if Root = nil then
          Root := SubMnu;
        {Specified menu is now active}
        Active := SubMnu;
        {Allocate space for stack record}
        GetMem(P, SizeOf(MenuStackRec));
        {Link in the new top of stack}
        P^.Top := SubMnu;
        P^.Next := Stack;
        Stack := P;
      end;
  end;

  procedure PopSubMenu(Mnu : Menu);
    {-Remove submenu from active stack}
  var
    P : MenuStackP;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;
    with Mnu^ do
      if Stack <> nil then begin
        P := Stack^.Next;
        {Deallocate space}
        FreeMem(Stack, SizeOf(MenuStackRec));
        Stack := P;
        {Make the current top of stack active}
        Active := Stack^.Top;
      end;
  end;

  procedure PopSubLevel;
    {-Pop current submenu while building a new menu system}
  begin
    PopSubMenu(CurrMenu);
  end;

  procedure ClearMenuStack(Mnu : Menu);
    {-Clear the active stack}
  begin
    while Mnu^.Stack <> nil do
      PopSubMenu(Mnu);
  end;

  procedure Clip(var XH, YH : Byte);
    {-Assure dimensions don't exceed screen}
  begin
    if XH > CurrentWidth then
      XH := CurrentWidth;
    if YH > Succ(CurrentHeight) then
      YH := Succ(CurrentHeight);
  end;

  procedure SubMenu(XL1, YL1, Yhelp1 : Byte;
                    Orient1 : Orientation;
                    Frame1 : FrameArray;
                    Colors1 : MenuColorArray;
                    HeaderStr : string
                    );
    {-Add a submenu to currently active item and submenu of root menu}
  var
    P : SubMenuP;
    c : MenuColorType;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;
    if MaxAvail < SizeOf(SubMenuRec) then
      PrevMenuStatus := MenuNoMem
    else begin

      {Allocate space for the submenu}
      GetMem(P, SizeOf(SubMenuRec));

      {Initialize the fields of the submenu}
      FillChar(P^, SizeOf(SubMenuRec), 0);
      with P^ do begin

        {Store the header string}
        if HeaderStr = '' then
          Header := nil
        else begin
          Header := StringToHeap(HeaderStr);
          if Header = nil then begin
            PrevMenuStatus := MenuNoMem;
            Exit;
          end;
        end;

        {Initialize simple fields}
        Orient := Orient1;
        Frame := Frame1;
        LotusStyle := (Frame1 = LotusFrame);
        XL := XL1;
        YL := YL1;
        YHelp := Yhelp1;

        if MapColors then
          {Map colors for different video modes}
          for c := FirstColor to LastColor do
              Colors[c] := MapColor(Colors1[c])
        else
          {Take the colors as given}
          Colors := Colors1;

        {Automatic window sizing}
        {Space for two vertical bars plus two padding spaces}
        XH := XL+3*FrameDelta[LotusStyle];

        if Orient = Vertical then
          {Space for two horizontal bars}
          YH := Pred(YL)+(FrameDelta[LotusStyle] shl 1)
        else
          {Space for two horizontal bars plus one row of items}
          YH := YL+(FrameDelta[LotusStyle] shl 1);

        {Assure dimensions don't exceed screen}
        Clip(XH, YH);

      end;

      with CurrMenu^ do
        if Active <> nil then
          {Link to parent menu}
          Active^.Items.Current^.Sub := P;

      {Push submenu onto active stack of submenus}
      PushSubMenu(CurrMenu, P);
    end;
  end;

  procedure MenuItemPtr(NamePtr : Pointer;
                        DisplayPos1 : Byte;
                        SelectPos1 : Byte;
                        Key1 : MenuKey;
                        HelpPtr : Pointer
                        );
    {-Add an item to currently active menu of root menu. name is not
      allocated on heap}
  var
    P : ItemP;
    MinH : Byte;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;

    if MaxAvail < SizeOf(ItemRec) then
      PrevMenuStatus := MenuNoMem

    else begin
      {Allocate space for the item}
      GetMem(P, SizeOf(ItemRec));

      {Initialize its fields}
      with P^ do begin
        Name := NamePtr;
        OnHeap := False;
        DisplayPos := DisplayPos1;
        SelectPos := SelectPos1;
        Key := Key1;
        Sub := nil;
        Help := HelpPtr;
      end;

      with CurrMenu^.Active^ do begin

        {Connect it to the linked list of items, after the current selection}
        with Items do begin
          if Current = nil then begin
            {First item in list}
            P^.Prev := nil;
            P^.Next := nil;
            First := P;
            Last := P;
          end else begin
            {Link after current}
            P^.Prev := Current;
            P^.Next := Current^.Next;
            if Current^.Next <> nil then
              Current^.Next^.Prev := P;
            Current^.Next := P;
            if Current = Last then
              Last := P;
          end;
          Current := P;
        end;

        {Handle automatic window sizing}
        case Orient of
          Horizontal :
            with Items.Last^ do
              MinH := FrameDelta[LotusStyle]+XL+DisplayPos+Byte(Name^);
          Vertical :
            begin
              {Add a row for the new item}
              Inc(YH);
              with Items.Current^ do
                MinH := 4*FrameDelta[LotusStyle]+Pred(XL)+Byte(Name^);
            end;
        end;
        if XH < MinH then
          XH := MinH;

        {Assure dimensions don't exceed screen}
        Clip(XH, YH);

      end;
    end;
  end;

  procedure MenuItem(NameStr : string;
                     DisplayPos1 : Byte;
                     SelectPos1 : Byte;
                     Key1 : MenuKey;
                     HelpStr : string
                     );
    {-Add an item to currently active menu of root menu. name space is
      allocated on heap}
  var
    NamePtr : Pointer;
    HelpPtr : Pointer;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;

    {Allocate heap space for the name and help}
    NamePtr := StringToHeap(NameStr);
    if NamePtr = nil then begin
      PrevMenuStatus := MenuNoMem;
      Exit;
    end;
    HelpPtr := StringToHeap(HelpStr);
    if HelpPtr = nil then begin
      PrevMenuStatus := MenuNoMem;
      Exit;
    end;

    {Add item to menu structure}
    MenuItemPtr(NamePtr, DisplayPos1, SelectPos1, Key1, HelpPtr);

    {Note that the item is allocated on the heap}
    CurrMenu^.Active^.Items.Current^.OnHeap := True;
  end;

  procedure DisposeSubMenu(var SubMnu : SubMenuP);
    {-Dispose of submenu and its children}
  var
    P, N : ItemP;
  begin
    with SubMnu^ do begin

      {Screen buffers should be disposed by EraseMenu first}

      {Dispose header string}
      if Header <> nil then
        DisposeString(Header);

      {Scan the list of items}
      P := Items.First;
      while P <> nil do begin
        with P^ do begin
          if OnHeap then begin
            {Dispose heap space for item name and help}
            DisposeString(Name);
            DisposeString(Help);
          end;
          if Sub <> nil then begin
            {Dispose of this item's submenu}
            DisposeSubMenu(Sub);
            Sub := nil;
          end;
          N := Next;
        end;
        {Dispose of this item}
        FreeMem(P, SizeOf(ItemRec));
        {Get next item}
        P := N;
      end;

    end;

    {Dispose of the submenu itself}
    FreeMem(SubMnu, SizeOf(SubMenuRec));
    SubMnu := nil;
  end;

  procedure DisposeMenu(Mnu : Menu);
    {-Dispose of all menu heap space}
  begin
    if (PrevMenuStatus <> MenuSuccess) or (Mnu = nil) then
      Exit;

    with Mnu^ do begin
      {Get rid of active stack}
      ClearMenuStack(Mnu);
      {Get rid of all submenus recursively}
      DisposeSubMenu(Root);
    end;

    {Get rid of main menu structure}
    FreeMem(Mnu, SizeOf(MenuRec));
  end;

  procedure ResetSubMenu(SubMnu : SubMenuP);
    {-Set submenu selection to first item}
  var
    P : ItemP;
  begin
    with SubMnu^ do begin
      {Reset current item to first item}
      Items.Current := Items.First;
      {Scan the list of items}
      P := Items.First;
      while P <> nil do begin
        with P^ do
          if Sub <> nil then
            {Reset this item's submenu}
            ResetSubMenu(Sub);
        P := P^.Next;
      end;
    end;
  end;

  procedure ResetMenu(Mnu : Menu);
    {-Set all selections to first item}
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;
    {Reset all submenus}
    ResetSubMenu(Mnu^.Root);
  end;

  procedure ReadCharScan(var Ch : Char);
    {-Read a character the keyboard. Extended scans return the high bit set}
  begin
    Ch := ReadKey;
    if Ch = #0 then
      {Get extended scan and set high bit}
      Ch := Chr(Ord(ReadKey) or $80);
  end;

  function CallUserFunc(S : string; Key : MenuKey) : string;
    {-Call the user-supplied function to modify s}
    inline($FF/$1E/CurrentUserFunc); {CALL DWORD PTR [CurrentUserFunc]}

  procedure DrawItem(SubMnu : SubMenuP; Item : ItemP; UserFunc : Pointer);
    {-Draw one item in a submenu}
  var
    S : string;
    HiPos : Word;
    Row : Word;
    Col : Word;
  begin
    with SubMnu^, Item^ do begin

      {Prepare name string and positioning}
      if Orient = Vertical then begin
        if LotusStyle then
          S := Pad(StringFromHeap(Name), Succ(XH-XL))
        else
          S := Pad(' '+StringFromHeap(Name), Pred(XH-XL));
        HiPos := SelectPos+FrameDelta[LotusStyle];
        Row := YL+DisplayPos;
        Col := XL+FrameDelta[LotusStyle];
      end else begin
        S := StringFromHeap(Name);
        HiPos := SelectPos;
        Row := YL+FrameDelta[LotusStyle];
        Col := XL+DisplayPos;
      end;

      {Don't write off bottom of screen}
      if Row > Succ(CurrentHeight) then
        Exit;

      {Call a user supplied routine to customize the displayed string}
      if UserFunc <> nil then begin
        CurrentUserFunc := UserFunc;
        S := CallUserFunc(S, Key);
      end;

      {Don't write off edge of screen}
      if Col+Length(S) > Succ(CurrentWidth) then
        S[0] := Chr(Succ(CurrentWidth)-Col);

      {Write to the screen}
      if Item = Items.Current then begin
        {Item is currently selected}
        FastWrite(S, Row, Col, Colors[SelectColor]);
        {Move the cursor to the start of the item}
        GotoXYAbs(Col,Row);
        {Draw help row if specified}
        if YHelp <> 0 then begin
          S := Pad(StringFromHeap(Help), CurrentWidth);
          FastWrite(S, YHelp, 1, Colors[HelpColor]);
        end;

      end else if SelectPos = 0 then
        {No highlighted character to display}
        FastWrite(S, Row, Col, Colors[BodyColor])

      else begin
        {Highlighted character to display}
        FastWrite(Copy(S, 1, Pred(HiPos)), Row, Col, Colors[BodyColor]);
        FastWrite(S[HiPos], Row, Col+Pred(HiPos), Colors[HiliteColor]);
        FastWrite(Copy(S, Succ(HiPos), Length(S)), Row, Col+HiPos, Colors[BodyColor]);
      end;
    end;
  end;

  procedure ClearWindow(XL, YL, XH, YH, Attr : Byte);
    {-Clear a region with specified attribute}
  var
    WordsPerRow : Word;
    Row : Word;
    Span : string;
  begin
    WordsPerRow := Succ(XH-XL);
    Span[0] := Chr(WordsPerRow);
    FillChar(Span[1], WordsPerRow, ' ');
    for Row := YL to YH do
      FastWrite(Span, Row, XL, Attr);
  end;

  procedure DrawFrame(XL, YL, XH, YH, Attr : Byte; Frame : FrameArray);
    {-Draw a frame around a window}
  begin
    SetFrameChars(Frame[Vert], Frame[Horiz], Frame[LRight], Frame[URight], Frame[LLeft], Frame[ULeft]);
    FrameWindow(XL, YL, XH, YH, Attr, Attr, '');
  end;

  procedure DrawSubMenu(SubMnu : SubMenuP; UserFunc : Pointer);
    {-Draw a submenu on-screen}
  var
    S : string;
    DX : Integer;
    Item : ItemP;
  begin
    with SubMnu^ do begin
      {!!!}
      Clip(XH, YH);

      {Save and clear screen area for menu}
      if not(SaveWindow(XL, YL, XH, YH, True, Pointer(Covers))) then begin
        PrevMenuStatus := MenuNoMem;
        Exit;
      end;
      ClearWindow(XL, YL, XH, YH, Colors[BodyColor]);
      {Save and clear screen area for help row}
      if YHelp <> 0 then begin
        if not(SaveWindow(1, YHelp, CurrentWidth, YHelp, True, Pointer(HelpCovers))) then begin
          PrevMenuStatus := MenuNoMem;
          Exit;
        end;
        ClearWindow(1, YHelp, CurrentWidth, YHelp, Colors[HelpColor]);
      end;

      if not(LotusStyle) then begin
        {Draw frame around window}
        DrawFrame(XL, YL, XH, YH, Colors[FrameColor], Frame);
        {Draw header for window}
        if Header <> nil then begin
          S := StringFromHeap(Header);
          DX := succ(xh-xl);
          if DX >= length(s) then
            {Title will fit}
            FastWrite(S, YL, XL+((DX-length(s)) shr 1), Colors[HeaderColor])
          else
            {Truncate title}
            FastWrite(copy(s,1,dx), yl, xl, Colors[HeaderColor]);
        end;
      end;

      {Draw the items on the menu}
      Item := Items.First;
      while Item <> nil do begin
        DrawItem(SubMnu, Item, UserFunc);
        Item := Item^.Next;
      end;
    end;
  end;

  procedure EraseSubMenu(SubMnu : SubMenuP);
    {-Erase a submenu from the screen}
  begin
    with SubMnu^ do begin
      if Covers <> nil then
        RestoreWindow(XL, YL, XH, YH, True, Pointer(Covers));
      if HelpCovers <> nil then
        RestoreWindow(1, YHelp, CurrentWidth, YHelp, True, Pointer(HelpCovers));
    end;
  end;

  function TopOrientation(Stack : MenuStackP) : Orientation;
    {-Return the orientation at the top of the stack}
  begin
    if Stack = nil then
      TopOrientation := NoOrient
    else
      TopOrientation := Stack^.Top^.Orient;
  end;

  function MenuCommand(Mnu : Menu;
                       SelectKey : Char;
                       var Mcmd : CommandType) : Boolean;
    {-Return true and command type if selectkey is a built-in menu command}
  var
    Ori : Orientation;
    NewSub : SubMenuP;
  begin
    {Default returns}
    MenuCommand := True;
    Mcmd := Mnul;

    with Mnu^ do begin

      Ori := Active^.Orient;
      NewSub := Active^.Items.Current^.Sub;

      case SelectKey of

        Kup :                {Up}
          if Ori = Vertical then
            Mcmd := Mup
          else if NewSub <> nil then
            Mcmd := Mselect
          else if TopOrientation(Stack^.Next) = Vertical then
            Mcmd := MsubUp;

        Kdown :              {Down}
          if Ori = Vertical then
            Mcmd := Mdown
          else if NewSub <> nil then
            Mcmd := Mselect
          else if TopOrientation(Stack^.Next) = Vertical then
            Mcmd := MsubDown;

        Kleft :              {Left}
          if Ori = Horizontal then
            Mcmd := Mleft
          else if TopOrientation(Stack^.Next) = Horizontal then
            Mcmd := MsubLeft
          else if NewSub <> nil then
            Mcmd := Mselect;

        Kright :             {Right}
          if Ori = Horizontal then
            Mcmd := Mright
          else if TopOrientation(Stack^.Next) = Horizontal then
            Mcmd := MsubRight
          else if NewSub <> nil then
            Mcmd := Mselect;

        Khome :              {Home}
          Mcmd := Mhome;

        Kend :               {End}
          Mcmd := Mend;

        Kenter :             {Enter}
          Mcmd := Mselect;

        Kescape :            {Escape}
          Mcmd := Mdeselect;

      else
        if SelectKey in SelectKeys then
          {A user-defined exit command}
          Mcmd := Mexit
        else
          {Not a menu command}
          MenuCommand := False;
      end;                   {Case SelectKey of}

    end;                     {With Mnu^ do}
  end;

  procedure UpdateItems(SubMnu : SubMenuP; OldI, NewI : ItemP);
    {-Update the display of the OldI and NewI items}
  begin
    SubMnu^.Items.Current := NewI;
    if OldI <> NewI then
      DrawItem(SubMnu, OldI, CurrentUserFunc);
    DrawItem(SubMnu, NewI, CurrentUserFunc);
  end;

  procedure DecItem(SubMnu : SubMenuP);
    {-Move to the previous item and update the display}
  var
    Old : ItemP;
    New : ItemP;
  begin
    with SubMnu^.Items do begin
      if Current = nil then
        Exit;
      Old := Current;
      if Old = First then
        New := Last
      else
        New := Current^.Prev;
    end;
    {Redraw the old and new items}
    UpdateItems(SubMnu, Old, New);
  end;

  procedure IncItem(SubMnu : SubMenuP);
    {-Move to the previous item and update the display}
  var
    Old : ItemP;
    New : ItemP;
  begin
    with SubMnu^.Items do begin
      if Current = nil then
        Exit;
      Old := Current;
      if Old = Last then
        New := First
      else
        New := Current^.Next;
    end;
    {Redraw the old and new items}
    UpdateItems(SubMnu, Old, New);
  end;

  function EvaluateCommand(Mnu : Menu;
                           Mcmd : CommandType;
                           var Key : MenuKey) : Boolean;
    {-Evaluate a built-in menu command}
  var
    NewSub : SubMenuP;
    Done : Boolean;
  begin
    Done := False;

    with Mnu^ do begin

      {Store a global pointer to current user function}
      CurrentUserFunc := UserFunc;

      case Mcmd of

        Mup, Mleft :
          DecItem(Active);

        Mdown, Mright :
          IncItem(Active);

        MsubUp, MsubLeft, MsubDown, MsubRight :
          begin
            {Erase the active menu}
            EraseSubMenu(Active);
            PopSubMenu(Mnu);

            {Increment or decrement as requested}
            case Mcmd of
              MsubUp, MsubLeft : DecItem(Active);
              MsubDown, MsubRight : IncItem(Active);
            end;

            {Select its submenu, if any}
            NewSub := Active^.Items.Current^.Sub;
            if NewSub <> nil then begin
              PushSubMenu(Mnu, NewSub);
              DrawSubMenu(NewSub, CurrentUserFunc);
            end;
          end;

        Mhome :
          with Active^.Items do
            if Current <> nil then
              UpdateItems(Active, Current, First);

        Mend :
          with Active^.Items do
            if Current <> nil then
              UpdateItems(Active, Current, Last);

        Mexit :
          begin
            Done := True;
            Key := Active^.Items.Current^.Key;
          end;

        Mselect :
          if Active^.Items.Current <> nil then begin
            {Select submenu, if any}
            NewSub := Active^.Items.Current^.Sub;
            if NewSub = nil then begin
              {No submenus, quit and return menu key}
              Done := True;
              Key := Active^.Items.Current^.Key;
            end else begin
              {Select the new submenu}
              PushSubMenu(Mnu, NewSub);
              DrawSubMenu(NewSub, CurrentUserFunc);
            end;
          end;

        Mdeselect :
          if Active = Root then begin
            {Deselecting the top level menu}
            Done := True;
            if Active^.Items.Current = nil then
              Key := 00
            else
              Key := Active^.Items.Current^.Key;
          end else begin
            {Erase the current menu}
            EraseSubMenu(Active);
            PopSubMenu(Mnu);
            {Redraw the current item to update the cursor}
            DrawItem(Active, Active^.Items.Current, CurrentUserFunc);
          end;

      end;
    end;

    EvaluateCommand := Done;
  end;

  function MatchesItem(Mnu : Menu; SelectKey : Char) : Boolean;
    {-Return true and pointer to item if selectkey matches a submenu item}
  var
    Item : ItemP;
    S : string;
    Ch : Char;
  begin
    {Ignore control and high-bit characters}
    if (SelectKey > #31) and (SelectKey < #128) then
      with Mnu^ do begin
        Ch := Upcase(SelectKey);
        Item := Active^.Items.First;

        {Scan the list of items for a match}
        while Item <> nil do begin
          with Item^ do
            if SelectPos <> 0 then begin
              S := StringFromHeap(Name);
              if Upcase(S[SelectPos]) = Ch then begin
                {Update the screen}
                UpdateItems(Active, Active^.Items.Current, Item);
                MatchesItem := True;
                Exit;
              end;
            end;
          Item := Item^.Next;
        end;
      end;
    MatchesItem := False;
  end;

  function MenuChoice(Mnu : Menu; var SelectKey : Char) : MenuKey;
    {-Display menu system, let user browse it, return menukey of selected item,
      return keystroke used to select item, leave menu on screen}
  var
    Done : Boolean;
    Key : MenuKey;
    Mcmd : CommandType;
    Cursor : Word;
    XY : Word;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;

    {Get current cursor state}
    GetCursorState(XY, Cursor);
    if HideCursor then
      HiddenCursor;

    with Mnu^ do begin

      {Store a global pointer to current user function}
      CurrentUserFunc := UserFunc;

      {Draw the root menu if none is currently on screen}
      if Visible then
        {Update the cursor position}
        DrawItem(Active, Active^.Items.Current, CurrentUserFunc)
      else begin
        {Assure the active stack is clear}
        ClearMenuStack(Mnu);
        {Draw the root menu}
        DrawSubMenu(Root, CurrentUserFunc);
        PushSubMenu(Mnu, Root);
        Visible := True;
      end;

      {Loop reading keys}
      repeat

        if PrevMenuStatus <> MenuSuccess then begin
          {Keep watch for errors}
          Done := True;
          SelectKey := #0;
          Key := 0;

        end else begin
          {Get the next keystroke and extended scan}
          ReadCharScan(SelectKey);

          if MenuCommand(Mnu, SelectKey, Mcmd) then
            {Selectkey matches one of the built-in menu commands}
            Done := EvaluateCommand(Mnu, Mcmd, Key)

          else if MatchesItem(Mnu, SelectKey) then begin
            {Selectkey matches one of the selection letters in the current menu}
            {Treat as if Enter were pressed}
            SelectKey := Kenter;
            Done := EvaluateCommand(Mnu, Mselect, Key);

          end else
            {Inactive keystroke}
            Done := False;

        end;

      until Done;

    end;

    {Return the menu key}
    MenuChoice := Key;

    {Restore cursor}
    RestoreCursorState(XY, Cursor);
  end;

  procedure EraseMenu(Mnu : Menu; ResetSelections : Boolean);
    {-Erase active menus from the screen, reset selections to base if desired}
  begin
    with Mnu^ do begin
      {Trace and erase the active stack}
      while Stack <> nil do begin
        EraseSubMenu(Active);
        PopSubMenu(Mnu);
      end;
      Visible := False;
    end;

    {Reset all selections if requested}
    if ResetSelections then
      ResetMenu(Mnu);
  end;

  procedure EraseMenuOntoStack(Mnu : Menu; var TStack : MenuStackP);
    {-Erase a menu but save its active stack for later redraw}
  var
    P : MenuStackP;
    S : MenuStackP;
  begin
    TStack := nil;
    with Mnu^ do begin
      {Erase the current menus}
      S := Stack;
      while S <> nil do begin
        {Push the current submenu onto another stack}
        GetMem(P, SizeOf(MenuStackRec));
        P^.Top := S^.Top;
        P^.Next := TStack;
        TStack := P;

        {Erase the submenu}
        EraseSubMenu(S^.Top);
        S := S^.Next;
      end;
    end;
  end;

  procedure DrawMenuFromStack(Mnu : Menu; var TStack : MenuStackP);
    {-Draw a menu system using stack of items}
  var
    P : MenuStackP;
  begin
    with Mnu^ do begin
      {Redraw the menus}
      while TStack <> nil do begin
        DrawSubMenu(TStack^.Top, UserFunc);
        P := TStack^.Next;
        FreeMem(TStack, SizeOf(MenuStackRec));
        TStack := P;
      end;
    end;
  end;

  {--------------------------------------------------------------------------}
  {Declarations and code for menu libraries on disk}
const
  IdStringLen = 12;          {Length of individual menu names in a menu library}
  MaxMenusInLib = 10;        {Maximum number of menus in a library}

  LibId : string[IdStringLen] = 'TPROMENULIB1'; {ID at beginning of library}
  ObsoleteId : string[1] = #255; {ID for obsolete menu in library}

type
  LibHeaderRec =
  record
    IdString : string[IdStringLen]; {Name of particular menu}
    StartPos : LongInt;      {Position in file of menu}
  end;

  LibHeaderArray = array[1..MaxMenusInLib] of LibHeaderRec;

  LibHeader =
  record
    HeaderId : string[IdStringLen];
    Index : LibHeaderArray;
  end;

  FileElement =
  (Fskeys,                   {Selection keys}
   Fsubmenu,                 {Submenu record}
   Fitem,                    {Item record}
   Fpop,                     {Pop to prior level}
   Fend                      {End of menu}
   );

  {Fields in FsubMenuRec must match those at beginning of SubMenuRec}
  FsubMenuRec =
  record
    XL, YL, XH, YH : Byte;
    YHelp : Byte;
    Orient : Orientation;
    Frame : FrameArray;
    Colors : MenuColorArray;
  end;

  {Fields in FitemRec must match those at beginning of ItemRec}
  FitemRec =
  record
    DisplayPos, SelectPos : Byte;
    Key : MenuKey;
  end;

  function CharSet2Str(ChS : MenuCharSet) : string;
    {-Convert a MenuCharSet into a String}
  var
    Ch : Char;
    S : string;
  begin
    S := '';
    for Ch := #0 to #255 do
      if Ch in ChS then
        S := S+Ch;
    CharSet2Str := S;
  end;

  procedure Str2CharSet(S : string; var ChS : MenuCharSet);
    {-Convert a String into a MenuCharSet}
  var
    I : Word;
  begin
    ChS := [];
    for I := 1 to Length(S) do
      ChS := ChS+[S[I]];
  end;

  function ExistFile(Fname : string) : Boolean;
    {-Return true if file is found}
  var
    F : file;
  begin
    Assign(F, Fname);
    Reset(F, 1);
    if IoResult = 0 then begin
      ExistFile := True;
      Close(F);
    end else
      ExistFile := False;
  end;

  procedure ReadString(var F : file; var S : string);
    {-Read a string from an untyped file}
  var
    Len : Byte;
    BytesRead : Word;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;
    BlockRead(F, Len, 1, BytesRead);
    if BytesRead <> 1 then begin
      PrevMenuStatus := MenuFileReadError;
      Exit;
    end;
    S[0] := Chr(Len);
    BlockRead(F, S[1], Len, BytesRead);
    if BytesRead <> Len then
      PrevMenuStatus := MenuFileReadError;
  end;

  procedure WriteString(var F : file; S : string);
    {-Write a string to an untyped file}
  var
    BytesWritten : Word;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;
    BlockWrite(F, S, Succ(Length(S)), BytesWritten);
    if BytesWritten <> Succ(Length(S)) then
      PrevMenuStatus := MenuFileWriteError;
  end;

  procedure ReadStruct(var F : file; var Buffer; Bytes : Word);
    {-Read a fixed size structure from the library file}
  var
    BytesRead : Word;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;
    BlockRead(F, Buffer, Bytes, BytesRead);
    if BytesRead <> Bytes then
      PrevMenuStatus := MenuFileReadError;
  end;

  procedure WriteStruct(var F : file; var Buffer; Bytes : Word);
    {-Write a fixed size structure to the library file}
  var
    BytesWritten : Word;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;
    BlockWrite(F, Buffer, Bytes, BytesWritten);
    if BytesWritten <> Bytes then
      PrevMenuStatus := MenuFileWriteError;
  end;

  function StUpcase(S : string) : string;
    {-Convert lower case letters in string to uppercase}
  var
    I : Word;
  begin
    for I := 1 to Length(S) do
      S[I] := Upcase(S[I]);
    StUpcase := S;
  end;

  function FindId(var Header : LibHeader; ID : string) : Integer;
    {-Search a header for the ID string, returning 0 or entry number}
  var
    S : string[IdStringLen];
    I : Integer;
  begin
    S := StUpcase(Copy(ID, 1, IdStringLen));
    for I := 1 to MaxMenusInLib do
      if S = Header.Index[I].IdString then begin
        FindId := I;
        Exit;
      end;
    FindId := 0;
  end;

  procedure OpenLibrary(var F : file; {Opened file variable}
                        Fname : string; {Library file name to open}
                        ID : string; {Menu identifier string}
                        Create : Boolean; {True to create a new file}
                        var StPos : LongInt {File start position for menu}
                        );
    {-Open or create a library file}
  var
    Header : LibHeader;
    Entry : Integer;
  begin
    if PrevMenuStatus <> MenuSuccess then
      Exit;

    if ExistFile(Fname) then begin

      {Open existing file}
      Assign(F, Fname);
      Reset(F, 1);

      {Read the current header}
      ReadStruct(F, Header, SizeOf(LibHeader));
      if PrevMenuStatus <> MenuSuccess then
        Exit;

      {See if a library file}
      if Header.HeaderId <> LibId then begin
        PrevMenuStatus := MenuNotLibraryFile;
        Exit;
      end;

      {See if menu already in library}
      Entry := FindId(Header, ID);

      if Create then begin
        if Entry <> 0 then
          {Obsolete the existing entry}
          Header.Index[Entry].IdString := ObsoleteId;

        {Find first available entry}
        Entry := FindId(Header, '');
        if Entry = 0 then begin
          {All entries are filled}
          PrevMenuStatus := MenuLibraryFull;
          Exit;
        end;

        {Prepare to write a new header}
        StPos := FileSize(F);
        Reset(F, 1);

      end else if Entry = 0 then begin
        {Entry not in library}
        PrevMenuStatus := MenuIdNotFound;
        Exit;

      end else begin
        {Entry in library for read}
        StPos := Header.Index[Entry].StartPos;
        Exit;
      end;

    end else if Create then begin

      {Create a new library file}
      Assign(F, Fname);
      Rewrite(F, 1);
      if IoResult <> 0 then begin
        PrevMenuStatus := MenuFileCreationError;
        Exit;
      end;

      {Initialize the header}
      with Header do begin
        HeaderId := LibId;
        FillChar(Index, SizeOf(LibHeaderArray), 0);
      end;

      Entry := 1;
      StPos := SizeOf(LibHeader);

    end else begin
      {File not found}
      PrevMenuStatus := MenuFileNotFound;
      Exit;
    end;

    {Update the header}
    with Header.Index[Entry] do begin
      IdString := StUpcase(Copy(ID, 1, IdStringLen));
      StartPos := StPos;
    end;
    WriteStruct(F, Header, SizeOf(LibHeader));
  end;

  procedure WriteElement(var F : file; Element : FileElement; var Buffer);
    {-Write a file element to a menu file}
  var
    SKS : MenuCharSet absolute Buffer;
  begin
    {Write the identifier}
    WriteStruct(F, Element, 1);
    case Element of
      Fskeys :               {Selection keys}
        WriteString(F, CharSet2Str(SKS));
      Fsubmenu :             {Submenu record}
        WriteStruct(F, Buffer, SizeOf(FsubMenuRec));
      Fitem :                {Item record}
        WriteStruct(F, Buffer, SizeOf(FitemRec));
    end;
  end;

  procedure WriteSubMenu(var F : file; SubMnu : SubMenuP);
    {-Write a submenu and its children to file}
  var
    Item : ItemP;
    Junk : Byte;
  begin
    {Write FsubMenuRec to file}
    WriteElement(F, Fsubmenu, SubMnu^);

    with SubMnu^ do begin

      {Write header string}
      WriteString(F, StringFromHeap(Header));

      {Scan the items}
      Item := Items.First;
      while Item <> nil do begin
        {Write FitemRec to file}
        WriteElement(F, Fitem, Item^);
        with Item^ do begin
          {Write name string}
          WriteString(F, StringFromHeap(Name));
          {Write help string}
          WriteString(F, StringFromHeap(Help));
          {Write submenu, if any}
          if Sub <> nil then
            WriteSubMenu(F, Sub);
        end;
        Item := Item^.Next;
      end;
    end;

    {Write pop element to exit this level of submenu}
    WriteElement(F, Fpop, Junk);
  end;

  procedure WriteMenuLib(Mnu : Menu; Fname : string; ID : string);
    {-Write a menu system to a binary menu library}
  var
    F : file;
    StartPos : LongInt;
    Junk : Word;
  begin
    {Open or create the library file}
    OpenLibrary(F, Fname, ID, True, StartPos);

    if PrevMenuStatus = MenuSuccess then begin
      {Position the file pointer to add the new element}
      Seek(F, StartPos);

      {Write selection keys for the menu}
      WriteElement(F, Fskeys, Mnu^.SelectKeys);

      {Write the submenus}
      WriteSubMenu(F, Mnu^.Root);

      {Write the end marker}
      WriteElement(F, Fend, Junk);
    end;

    Close(F);
    {Clear ioresult}
    Junk := IoResult;
  end;

  function ReadMenuLib(Fname : string;
                       ID : string;
                       UserFunc : Pointer) : Menu;
    {-Read a menu system from a binary menu library}
  var
    P : Menu;
    F : file;
    StartPos : LongInt;
    Junk : Word;
    FE : FileElement;
    S : string;
    H : string;
    ChS : MenuCharSet;
    FMR : FsubMenuRec;
    IR : FitemRec;
  begin
    {Open the library and find the menu entry}
    OpenLibrary(F, Fname, ID, False, StartPos);

    P := nil;

    if PrevMenuStatus = MenuSuccess then begin

      {Position the file to read the new element}
      Seek(F, StartPos);

      repeat

        {Read the record type}
        ReadStruct(F, FE, 1);

        case FE of

          Fskeys :           {Selection keys}
            if P <> nil then
              PrevMenuStatus := MenuFileCorrupt
            else begin
              {Read the SelectKeys string}
              ReadString(F, S);
              {Convert to a set}
              Str2CharSet(S, ChS);
              {Initialize the menu}
              P := NewMenu(ChS, UserFunc);
            end;

          Fsubmenu :         {Submenu record}
            if P = nil then
              PrevMenuStatus := MenuFileCorrupt
            else begin
              {Read the submenu record}
              ReadStruct(F, FMR, SizeOf(FsubMenuRec));
              {Read the header string}
              ReadString(F, S);
              {Add the submenu}
              with FMR do
                SubMenu(XL, YL, YHelp, Orient, Frame, Colors, S);
            end;

          Fitem :            {Item record}
            if P = nil then
              PrevMenuStatus := MenuFileCorrupt
            else begin
              {Read the item record}
              ReadStruct(F, IR, SizeOf(FitemRec));
              {Read the name}
              ReadString(F, S);
              {Read the help}
              ReadString(F, H);
              {Add the item}
              with IR do
                MenuItem(S, DisplayPos, SelectPos, Key, H);
            end;

          Fpop :             {Pop to prior level}
            if P = nil then
              PrevMenuStatus := MenuFileCorrupt
            else
              PopSubLevel;

          Fend :             {End of menu}
            ;

        else
          PrevMenuStatus := MenuFileCorrupt;
        end;

      until (PrevMenuStatus <> MenuSuccess) or (FE = Fend);

    end;

    ReadMenuLib := Menu(P);
    Close(F);
    {Clear ioresult}
    Junk := IoResult;
  end;

  procedure PackMenuLib(iname, oname : string);
    {-Remove obsolete menu entries from library iname, creating oname}
  label
    ExitPoint1,
    ExitPoint2;
  var
    InF : file;
    OutF : file;
    InHeader : LibHeader;
    OutHeader : LibHeader;
    MenuLen : array[1..MaxMenusInLib] of Word;
    InEntry : array[1..MaxMenusInLib] of Integer;
    StPos : LongInt;
    Entry : Integer;
    OutEntry : Integer;
    Junk : Word;
    MLen : Word;
    MaxLen : Word;
    Bytes : Word;
    CopyBuf : Pointer;
  begin
    {Open the library and see if any obsolete entries}
    OpenLibrary(InF, iname, ObsoleteId, False, StPos);

    if PrevMenuStatus <> MenuSuccess then
      {File not found, or no obsolete entry was found}
      goto ExitPoint1;

    {Read the existing header}
    Reset(InF, 1);
    ReadStruct(InF, InHeader, SizeOf(LibHeader));

    {Determine the length of each menu in the existing library}
    MaxLen := 0;
    with InHeader do
      for Entry := 1 to MaxMenusInLib do begin
        if Index[Entry].IdString = '' then
          MLen := 0
        else if Entry = MaxMenusInLib then
          MLen := FileSize(InF)-Index[Entry].StartPos
        else if Index[Succ(Entry)].IdString = '' then
          MLen := FileSize(InF)-Index[Entry].StartPos
        else
          MLen := Index[Succ(Entry)].StartPos-Index[Entry].StartPos;
        if MLen > MaxLen then
          MaxLen := MLen;
        MenuLen[Entry] := MLen;
      end;

    {Build a new header}
    with OutHeader do begin
      HeaderId := LibId;
      FillChar(Index, SizeOf(LibHeaderArray), 0);
    end;
    OutEntry := 0;
    StPos := SizeOf(LibHeaderArray);
    with InHeader do
      for Entry := 1 to MaxMenusInLib do
        if Index[Entry].IdString <> '' then
          {Not an empty entry}
          if Index[Entry].IdString <> ObsoleteId then begin
            {Not an obsolete entry}
            Inc(OutEntry);
            with OutHeader.Index[OutEntry] do begin
              IdString := Index[Entry].IdString;
              StartPos := StPos;
              Inc(StPos, MenuLen[Entry]);
            end;
            {Store the input file entry for this output entry}
            InEntry[OutEntry] := Entry;
          end;

    {Create the new library file}
    Assign(OutF, oname);
    Rewrite(OutF, 1);
    if IoResult <> 0 then begin
      PrevMenuStatus := MenuFileCreationError;
      goto ExitPoint1;
    end;

    {Allocate a copy buffer}
    if MaxAvail < MaxLen then begin
      PrevMenuStatus := MenuNoMem;
      Close(OutF);
      {Clear ioresult}
      Junk := IoResult;
      goto ExitPoint1;
    end;
    GetMem(CopyBuf, MaxLen);

    {Write the header}
    WriteStruct(OutF, OutHeader, SizeOf(LibHeader));
    if PrevMenuStatus <> MenuSuccess then
      goto ExitPoint2;

    {Copy the non-obsolete entries to the new library}
    with OutHeader do
      for OutEntry := 1 to MaxMenusInLib do
        if Index[OutEntry].IdString <> '' then begin
          {Not an empty entry}
          Entry := InEntry[OutEntry];
          Seek(InF, InHeader.Index[Entry].StartPos);
          if IoResult <> 0 then begin
            PrevMenuStatus := MenuFileReadError;
            goto ExitPoint2;
          end;
          BlockRead(InF, CopyBuf^, MenuLen[Entry], Bytes);
          if Bytes <> MenuLen[Entry] then begin
            PrevMenuStatus := MenuFileReadError;
            goto ExitPoint2;
          end;
          Seek(OutF, Index[OutEntry].StartPos);
          if IoResult <> 0 then begin
            PrevMenuStatus := MenuFileWriteError;
            goto ExitPoint2;
          end;
          BlockWrite(OutF, CopyBuf^, MenuLen[Entry], Bytes);
          if Bytes <> MenuLen[Entry] then begin
            PrevMenuStatus := MenuFileWriteError;
            goto ExitPoint2;
          end;
        end;

ExitPoint2:
    Close(OutF);
    {Clear ioresult}
    Junk := IoResult;
    {Dispose of copy buffer}
    FreeMem(CopyBuf, MaxLen);

ExitPoint1:
    Close(InF);
    {Clear ioresult}
    Junk := IoResult;
  end;

begin
  {Initialize the status flag}
  PrevMenuStatus := MenuSuccess;
end.
