module MenuUtils;
{ Abstract:
{ The procedure GetPList invokes the menues, starting with the
{ root menu, and returns a 'parse list' containing the
{ selections the user has made when traversing the menu tree
{ out to a leaf.
{ The user may enter the selections either by typing the commands,
{ or by invoking PopUp-menues. Online help will always be available,
{ and the user will never have committed himself to any choice before
{ the last choice (i.e. the leaf) has been done.
}
{==============================} exports {===================================}
imports PopUp from PopUp;
type
NodeType = ( MenuNode, ParmNode, EndNode );
HelpAddress = record
BlockNo : integer;
Offset : integer;
end;
pMenuEntry = ^MenuEntry; { Pointer to menu hierarchy }
MenuEntry = record
{ Where to find help on this item }
Help : HelpAddress;
{ How to prompt for next selection }
Prompt : S25;
case Node : NodeType of
MenuNode: { A real menu }
(MPtr : pNameDesc;
NextLevel : array [1..1]
of pMenuEntry);
ParmNode: { A leaf, expecting a parameter }
();
EndNode: { A leaf, no parameter }
()
end;
pPListEntry = ^PListEntry; { Parse list pointer }
PListEntry = record { Parse list item }
PrevPList : pPListEntry;
CurrMenu : pMenuEntry;
CmdI : integer;
case Node : NodeType of
{ Menu selection }
MenuNode : ( NextPList : pPListEntry;
Selection : integer);
{ The possible tails of the list }
ParmNode : ( Arg : String );
EndNode : ()
end;
procedure InitMenues;
procedure DestroyMenues;
function GetMenu( MenuFName, HelpFName : String ) : pMenuEntry;
exception NoMenuFile( MenuFName : String );
exception BadMenuFile( AtLine : Integer );
function GetMenuAnswer(MPtr:pNameDesc; NPix:integer):integer;
function PushCmdFile( FileName : String ) : Boolean;
procedure GetPList( root : pMenuEntry; var PListPtr : pPListEntry );
procedure DestroyPList( var PListPtr : pPListEntry );
{===========================================================================}
{==============================} private {==================================}
imports Memory from Memory;
imports FileSystem from FileSystem;
imports System from System;
imports Screen from Screen;
imports Perq_String from Perq_String;
imports MultiRead from MultiRead;
imports IO_Unit from IO_Unit;
imports IO_Others from IO_Others;
imports IOErrors from IOErrors;
imports Stream from Stream;
const
HelpCommand = 'HELP';
DefSeg = 0;
UseCursorPos = -1;
NotList = false;
ColWidth = 8;
ScreenWidth = 75;
MenuSize = 200; { Max. height of menu }
CommentChar = '!';
NumLevels = 20;
Fold = true;
MaxCLine = 132; { Max. length of command line }
TabKey = Chr(128);
CR = Chr( 13);
Escape = Chr( 27);
BS = Chr( 8);
DEL = Chr(127);
CtrlU = Chr( 21);
CtrlW = Chr( 23);
CtrlX = Chr( 24);
KeyChar = Chr( 24);
CmdFChar = Chr( 26);
type
pInt = ^Integer;
CLine = packed array [1..MaxCLine] of char;
CBuff = record
Prompt : String;
Cmd : CLine;
BufCur : 0..MaxCLine; { character index in buffer}
CurrPList : pPListEntry; { last entry in parse list }
Comment : Boolean;
CommPos,
HelpPos : Integer;
end;
ParseResult =
( ParsedOK, WantHelp, NotFound, NotUnique );
var
NullMenu : pNameDesc;
ShowMenues : boolean;
CmdStack : Array [1..NumLevels] of text;
CmdLevel : 0..NumLevels;
PromptChar : Char;
EndMenu,
ParmMenu : pNameDesc;
{===========================================================================}
procedure RefreshCBuff( VAR CB : CBuff );
VAR I : Integer;
begin
with CB do begin
write( Prompt, PromptChar );
for I := 1 to BufCur-1 do write( Cmd[I] );
end;
end;
{===========================================================================}
function CmdEndCBuff( VAR CB : CBuff ) : integer;
VAR I : Integer;
begin
with CB do
if CurrPList=NIL then
CmdEndCBuff := 1
else begin
I := CurrPList^.CmdI;
while (Cmd[i]<>' ') and (Cmd[i]<>CR) and
(Cmd[i]<>CommentChar) and (I<BufCur) do
I := I + 1;
CmdEndCBuff := I;
end;
end;
{===========================================================================}
function PushCmdFile( FileName : String ) : Boolean;
handler ResetError( FileName : PathName );
begin
PushCmdFile := False;
exit( PushCmdFile );
end;
begin
PushCmdFile := True;
if CmdLevel<NumLevels then begin
Reset( CmdStack[CmdLevel+1], FileName );
CmdLevel := CmdLevel + 1;
PromptChar := CmdFChar;
end;
end;
{===========================================================================}
function GetChar : Char;
var C : Char;
Done : Boolean;
begin
if CmdLevel=0 then begin
SCurOn;
Done := False;
while not Done do begin
if (IOCRead( TransKey, C )=IOEIOC) then begin
Done := True;
end else if TabSwitch then begin
Done := True;
C := TabKey;
end;
end;
SCurOff;
end else begin
if EOF( CmdStack[CmdLevel] ) then begin { Pop stack }
Close( CmdStack[CmdLevel] );
CmdLevel := CmdLevel - 1;
if CmdLevel=0 then PromptChar := KeyChar;
C := CR;
end else
if EOLn( CmdStack[CmdLevel] ) then begin
Read( CmdStack[CmdLevel] , C );
C := CR;
end else
Read( CmdStack[CmdLevel], C );
end;
GetChar := C;
end; { GetChar }
{=============================================================================}
function FieldWidth( L : integer ):integer;
begin
FieldWidth := (( L + ColWidth ) div ColWidth ) * ColWidth;
end;
{===========================================================================}
procedure PushPList( VAR CB : CBuff; NewMenu : PMenuEntry );
var P : pPListEntry;
I : Integer;
begin
with CB do begin
case NewMenu^.Node of
MenuNode: New( P, MenuNode );
ParmNode: New( P, ParmNode );
EndNode: New( P, EndNode );
end;
with P^ do begin
Node := NewMenu^.Node;
CurrMenu := NewMenu;
PrevPList := CurrPList;
I := CmdEndCBuff( CB );
while ((Cmd[i]=' ') or (Cmd[i]=CR)) and (I<BufCur) do I := I + 1;
CmdI := I;
if Node=MenuNode then begin
NextPList := NIL;
Selection := 0;
end else if Node=ParmNode then
Arg := '';
end;
if CurrPList<>NIL then
CurrPList^.NextPList := P;
CurrPList := P;
end;
end;
{===========================================================================}
procedure InitCBuff( VAR CB : CBuff; M : pMenuEntry );
begin
with CB do begin
Prompt := M^.Prompt;
BufCur := 1;
CurrPList := NIL;
Comment := False;
CommPos := 0;
HelpPos := 0;
end;
PushPList( CB, M );
end;
{===========================================================================}
function CComp( C1, C2 : Char ) : Boolean;
begin
if C1=C2 then
CComp := true
else
if not Fold then
CComp := false
else begin
if (C1>='a') and (C1<='z') then
C1 := Chr( Ord(C1)-Ord('a')+Ord('A') );
if (C2>='a') and (C2<='z') then
C2 := Chr( Ord(C2)-Ord('a')+Ord('A') );
CComp := C1=C2;
end;
end;
{===========================================================================}
procedure IntoCBuff( VAR CB : CBuff; C : Char );
begin
with CB do begin
if BufCur<MaxCLine then begin
Cmd[BufCur] := C;
if C>=' ' then { Echo character }
write(C);
with CurrPList^ do
if (CmdI=BufCur) and (C=' ') then
CmdI := CmdI + 1;
BufCur := BufCur + 1;
end;
end;
end;
{===========================================================================}
procedure BackCBuff( VAR CB : CBuff; ToPos : Integer );
VAR I : Integer;
begin
with CB do begin
if ToPos>BufCur then ToPos := BufCur;
if ToPos<1 then ToPos := 1;
if Comment and (ToPos<=CommPos) then
Comment := False;
for I := BufCur-1 downto ToPos do begin
if Cmd[I]>=' ' then { Character was echoed to screen }
SClearChar( Cmd[I], RXor );
end;
BufCur := ToPos;
{ Pop the last entries off the parse list, if necessary }
while (CurrPList^.CmdI>BufCur) and (CurrPList^.PrevPList<>NIL) do begin
CurrPList := CurrPList^.PrevPList;
end;
with CurrPList^ do begin
if CmdI>BufCur then { Could not pop last item }
CmdI := BufCur; { Just note that there are no chars }
if (NextPList<>NIL) and (Node=MenuNode) then begin
Selection := 0;
DestroyPList( NextPList );
NextPList := NIL;
end;
end;
if ToPos<=HelpPos then
HelpPos := 0;
end;
end;
{===========================================================================}
procedure NextCmdCBuff( VAR CB : CBuff );
{ Push to next command in buffer }
VAR I : Integer;
begin
with CB, CurrPList^, CurrMenu^ do begin
I := CmdEndCBuff( CB );
if (I<BufCur) then
if (Selection>1) and (Selection<=MPtr^.NumCommands) then
begin
{$Range-}
PushPList( CB, NextLevel[Selection] );
{$Range=}
end else if Selection=1 then begin
if HelpPos=0 then
HelpPos := CurrPList^.CmdI;
PushPList( CB, CurrMenu );
end;
end;
end;
{===========================================================================}
function FindMatch( VAR CB : CBuff;
VAR Pos : integer ) : Boolean;
{ Abbreviated command lookup. Starting from "Pos", see if any command in }
{ command table matches the word starting at CmdI in CB and ending at }
{ BufCur -1 or first space or other delimiting character. }
var GiveUp : Boolean;
CmdEnd, CmdLen, I, J : Integer;
begin
with CB, CurrPList^.CurrMenu^.MPtr^ do begin
CmdEnd := CmdEndCBuff( CB );
GiveUp := True;
while (Pos<NumCommands) and (GiveUp) do begin
{ Look if Cmd matches command in table }
Pos := Pos + 1;
I := CurrPList^.CmdI;
J := 1;
{$Range-}
CmdLen := Length(Commands[Pos]);
GiveUp := False;
while (I<CmdEnd) and (not GiveUp) do begin
if CComp( Commands[Pos][J], Cmd[I] ) then begin
J := J+1; { Matching characters, step both }
I := I+1; { indices forward in commands }
if (J>CmdLen) and (I<CmdEnd) then
GiveUp := True;
end else
if Cmd[I]='-' then begin { Cmd is abbreviated, just }
J := J+1; { step the other index forward }
if J>CmdLen then { Need something to match }
GiveUp := True; { this character to! }
end else begin
GiveUp := True;
end;
end;
{$Range=}
end;
FindMatch := not GiveUp;
end;
end; { FindMatch }
{===========================================================================}
procedure ShowWord( VAR CB : CBuff );
VAR I : Integer;
begin
with CB do begin
write('''');
I := CurrPList^.CmdI;
while (Cmd[I]<>' ') and (I<BufCur) do begin
write(Cmd[I]);
I := I + 1;
end;
write('''');
end;
end;
{===========================================================================}
function ParseCBuff( VAR CB : CBuff ) : ParseResult;
VAR I, J : Integer;
begin
with CB, CurrPList^ do
Case Node of
MenuNode:
begin
I := 0;
if not FindMatch( CB, I ) then begin
ParseCBuff := NotFound;
CurrPList^.Selection := 0;
end else begin
CurrPList^.Selection := I;
J := I;
if FindMatch( CB, J ) then begin
ParseCBuff := NotUnique;
end else begin
NextCmdCBuff( CB );
ParseCBuff := ParsedOK;
end;
end;
end;
ParmNode:
begin
if BufCur>1 then
if (Cmd[BufCur-1]=CR) or (Cmd[BufCur-1]=' ') then begin
Adjust( Arg, BufCur-1-CurrPList^.CmdI );
I := 1;
for J := CurrPList^.CmdI to BufCur-2 do begin
Arg[I] := Cmd[J];
I := I + 1;
end;
end;
ParseCBuff := ParsedOK;
end;
EndNode:
begin
if BufCur>1 then
if Cmd[BufCur-1]=CR then
if BufCur>CurrPList^.CmdI then begin
writeln;
write('?Garbage at end of line, ignored ''');
for I := CurrPList^.CmdI to BufCur-2 do
write( Cmd[I] );
writeln('''');
RefreshCBuff( CB );
end;
ParseCBuff := ParsedOK;
end;
end;
end;
{===========================================================================}
function ParseAll( VAR CB : CBuff ) : ParseResult;
{ -- Reparse command buffer as far as possible }
var PRes : ParseResult;
PrevCmdI,
TempPos : Integer;
TempChar : Char;
begin
with CB do begin
if Comment then begin
TempPos := BufCur;
BufCur := CommPos + 1;
TempChar := Cmd[CommPos];
Cmd[CommPos] := ' ';
end;
if (CmdEndCBuff(CB)<>CurrPList^.CmdI) then begin
repeat
PrevCmdI := CurrPList^.CmdI;
PRes := ParseCBuff(CB);
until (PRes<>ParsedOK) or (PrevCmdI=CurrPList^.CmdI)
or (CmdEndCBuff(CB)=CurrPList^.CmdI);
ParseAll := PRes;
end else
ParseAll := ParsedOK;
if Comment then begin
Cmd[CommPos] := TempChar;
BufCur := TempPos;
end;
end;
end;
{===========================================================================}
procedure ParseCommand( root : pMenuEntry;
var PListPtr : pPListEntry;
HelpMode,
RootLevel : Boolean );
const
MoreInfo = 'More info on:';
SelPrompt = 'Select item:';
SelectOne = 'Select one of the following: ';
CommNotUnique = '?Command is not unique: ';
var
C : Char;
Done, QuestionMark : boolean;
NextMatch,
I, J, CmdEnd : integer;
Matching : S25;
CB : CBuff; { Command buffer to use}
TabPress : Boolean; { Select done by menu? }
PRes : ParseResult;
Dummy, ArgEntry : pPListEntry;
HelpFile : pInt;
HelpFID : integer;
HFBuff : pDirBlk;
HFAddr : HelpAddress;
MM : MMPointer;
handler HelpKey( var retStr : Sys9s );
begin
retStr := 'HELP';
end;
{------------------------------------------------------------------------}
procedure PrintHelpText;
var PrevCR : boolean;
begin
if HelpFID=0 then
writeln('No helptext found!')
else
with CB.CurrPList^.CurrMenu^ do begin
if HFaddr.BlockNo<>Help.BlockNo then
FSBlkRead( HelpFID, Help.BlockNo, HFBuff );
HFAddr := Help;
PrevCR := true;
with HFAddr, HFBuff^ do
while not( PrevCR and (ByteBuffer[Offset]=ord('>'))) do
begin
PrevCR := ByteBuffer[Offset]=13;
write( chr(ByteBuffer[Offset]) );
if PrevCR then write( chr(10) );
Offset := Offset+1;
if Offset>511 then begin
Offset := 0;
BlockNo := BlockNo + 1;
FSBlkRead( HelpFID, BlockNo, HFBuff );
end;
end;
end;
end; { PrintHelpText }
{------------------------------------------------------------------------}
procedure PrintAlts;
var i,l,w,s : integer;
Matching : S25;
begin
L := 0;
with CB.CurrPList^.CurrMenu^, MPtr^ do
if Node=MenuNode then begin
if HelpMode then
writeln( MoreInfo )
else
writeln( SelectOne );
for i := 2 to NumCommands do begin
{$range-}
Matching := Commands[i];
S := Length( Matching );
W := FieldWidth( S );
L := L+W;
if L < ScreenWidth then
write( Matching, ' ':(W-S) )
else if L = ScreenWidth then begin
writeln( Matching );
L := 0;
end else begin
writeln;
write( Matching, ' ':(W-S) );
L := W;
end;
{$range=}
end;
end;
if L<>0 then writeln;
end;
{------------------------------------------------------------------------}
procedure PrintMatching;
var i,l,w,s : integer;
Matching : S25;
begin
L := 0;
I := 0;
writeln( SelectOne );
with CB.CurrPList^.CurrMenu^.MPtr^ do
while FindMatch( CB, I ) do begin
{$Range-}
Matching := Commands[I];
{$Range=}
S := Length( Matching );
W := FieldWidth( S );
L := L+W;
if L < ScreenWidth then
write( Matching, ' ':(W-S) )
else if L = ScreenWidth then begin
writeln( Matching );
L := 0;
end else begin
writeln;
write( Matching, ' ':(W-S) );
L := W;
end;
end;
if L<>0 then writeln;
end;
{------------------------------------------------------------------------}
procedure DoHelp;
begin
writeln;
writeln;
PrintHelpText;
writeln;
PrintAlts;
writeln;
end;
{------------------------------------------------------------------------}
procedure ExplainHelp;
begin
writeln;
writeln;
write('HELP - online help facility');
writeln;
writeln('Use the "HELP" command to obtain command explanations');
writeln('"HELP" may replace any command, and the effect will be to');
writeln('explain this command and list the various alternatives.');
writeln;
writeln('"HELP" may be used in different ways: ');
writeln('"HELP" as the last command on the line, before RETURN, will');
writeln('enter the help mode, where every command entered not is ');
writeln('executed, but explained. Exit help mode by entering an ');
writeln('empty line.');
writeln('When the "HELP" command is not at the end of the line, ');
writeln('the result will be to explain the commands after HELP ');
writeln('and then continue entering commands to execute.');
writeln;
writeln('Function keys:');
writeln('RETURN (CR) terminates the command and executes it. If ');
writeln(' the command is partially entered, the command tail will ');
writeln(' be prompted for. The command may then be aborted by ');
writeln(' entering a blank line.');
writeln('INS (ESC) expands the last command on the line, if it is ');
writeln(' abbreviated, and it is unique. Use to check if a valid');
writeln(' command is entered, and that the abbreviation really');
writeln(' identifies the correct command.');
writeln('''?'' lists the commands that matches an abbreviation. ');
writeln('''??'' enters help mode. ');
writeln('''!'' is a comment delimiter. (Most useful in command ');
writeln(' files.) Everything between ''!'' and end of line is ');
writeln(' ignored.');
writeln('BACKSPACE, DEL deletes the last character on the line.');
writeln('OOPS, Ctrl-U, Ctrl-X deletes the whole line.');
writeln('Ctrl-W deletes the last word (back to previous space) ');
writeln;
end; { ExplainHelp }
{------------------------------------------------------------------------}
begin { GetPList }
MM := recast( Root, MMPointer );
HelpFile := MakePtr( MM.Segmen, 0, pInt );
HelpFID := HelpFile^;
HFAddr.BlockNo := -1; { Note help buffer is empty }
new( HFBuff);
Done := false;
InitCBuff( CB, Root );
if HelpMode then begin
DoHelp;
CB.Prompt := SelPrompt;
end;
RefreshCBuff( CB );
PListPtr := CB.CurrPList;
QuestionMark := False;
with CB do
while not Done do begin
C := GetChar;
if (C=TabKey) then begin { Insert dummy space to }
IntoCBuff( CB, ' ' ); { make parse go all the way }
PRes := ParseAll(CB); { to the end of buffer. }
BackCBuff( CB, BufCur-1 ); { Remove the dummy space. }
if BufCur>CurrPList^.CmdI then
BackCBuff( CB, CurrPList^.CmdI ); { ..partial command }
Dummy := CurrPList;
repeat
case CurrPList^.Node of
MenuNode:
begin
I := GetMenuAnswer( CurrPList^.CurrMenu^.MPtr,
MenuSize );
if I>1 then begin
CurrPList^.Selection := I;
{$Range-}
Matching := CurrPList^.CurrMenu^.MPtr^.Commands[i];
{$Range=}
for J := 1 to length(Matching) do begin
IntoCBuff(CB,Matching[j]);
end;
IntoCBuff(CB, ' ');
NextCmdCBuff(CB);
end;
end;
EndNode:
begin
if HelpMode then begin
I := 1;
end else
I := GetMenuAnswer( EndMenu, MenuSize );
if I=2 then I := -1;
end;
ParmNode:
begin
if HelpMode then begin
I := 1;
end else
I := GetMenuAnswer( ParmMenu, MenuSize );
if I=2 then begin
writeln;
ParseCommand( CurrPList^.CurrMenu, ArgEntry,
HelpMode, false );
CurrPList^.Arg := ArgEntry^.Arg;
DestroyPList( ArgEntry );
I := -1;
end else if I=3 then begin
CurrPList^.Arg := '';
I := -1;
end;
end;
end;
if I=1 then begin
writeln;
writeln;
PrintHelpText;
writeln;
write('Press tabswitch to get menu back: ');
while TabSwitch do ;
while not TabSwitch do ;
writeln(CR,' ' );
RefreshCBuff(CB);
end;
if (I=0) or ((I=1) and (CurrPList^.Node<>MenuNode))
then begin { Pop off command }
if CurrPList<>Dummy then begin
BackCBuff( CB, CurrPList^.PrevPList^.CmdI );
end;
end;
if (I=-1) and not HelpMode then begin
writeln;
Done := True;
end;
until Done or (CurrPList=Dummy);
end else
if (C=CommentChar) then begin
if not Comment then begin
Comment := True;
CommPos := BufCur;
end;
IntoCBuff( CB, C );
end else
if (C=CR) then
begin
IntoCBuff( CB, ' ' );
case ParseAll( CB ) of
ParsedOK:
if HelpMode then begin
Done := CurrPList^.PrevPList=NIL;
if CurrPList^.Selection=1 then
ExplainHelp
else begin
writeln;
if not Done then begin
DoHelp;
if CurrPList^.Node<>MenuNode then
BackCBuff( CB, CurrPList^.PrevPList^.CmdI )
else
BackCBuff( CB, BufCur-1 );
RefreshCBuff(CB);
end;
end;
end else begin
writeln;
with CurrPList^ do
if HelpPos>0 then begin
if PrevPList^.CmdI=HelpPos then begin { HELP last com.}
writeln;
ParseCommand( CurrPList^.CurrMenu, Dummy,
True, false );
DestroyPList( Dummy );
end else begin
writeln;
PrintHelpText;
writeln;
if Node=MenuNode then begin
PrintMatching;
writeln;
end;
end;
RefreshCBuff(CB);
end else if (CurrMenu=Root) and (Node=MenuNode) then
PListPtr := NIL { Nothing parsed (or a new}
{ entry would have been pushed)}
else begin
if Node=MenuNode then begin
{ OK so far, but haven't got all of command }
ParseCommand( CurrMenu, Dummy,
false, false );
if (Dummy=NIL) then begin { Quit command }
DestroyPList(PListPtr);
PListPtr := NIL;
end else begin { link in cmd tail }
CurrPList^.PrevPList^.NextPList := Dummy;
Dummy^.PrevPList := CurrPList^.PrevPList;
DestroyPList(CurrPList);
CurrPList := Dummy;
end;
end;
end;
if HelpPos>0 then
BackCBuff( CB, HelpPos )
else
Done := true;
end;
NotUnique:
begin
BackCBuff( CB, BufCur-1 );
writeln;
write( CommNotUnique );
ShowWord( CB );
writeln;
PrintMatching;
if CmdLevel>0 then begin
RefreshCBuff( CB );
BackCBuff( CB, 1 )
end else begin
BackCBuff(CB, CmdEndCBuff(CB));
RefreshCBuff( CB );
end;
end;
NotFound:
begin
BackCBuff( CB, BufCur-1 );
writeln;
write('?No match for word: ');
ShowWord(CB);
writeln;
PrintAlts;
RefreshCBuff( CB ); { ... and start over }
if CmdLevel>0 then
BackCBuff( CB, 1 );
end;
end;
QuestionMark := false;
end else
if (C='?') and (not Comment) then begin
PRes := ParseAll( CB );
if QuestionMark and not HelpMode then begin
writeln;
ParseCommand( CurrPList^.CurrMenu, Dummy, True, false );
DestroyPList( Dummy );
QuestionMark := False;
RefreshCBuff( CB );
end else begin
case PRes of
ParsedOK:
if HelpMode then begin
writeln('?');
DoHelp;
RefreshCBuff(CB);
end else if BufCur=CurrPList^.CmdI then
begin
writeln('?');
PrintAlts;
RefreshCBuff(CB);
end;
NotFound:
begin
writeln('?');
write('?No match for word: ');
ShowWord(CB);
writeln;
if CmdLevel>0 then begin
RefreshCBuff( CB );
BackCBuff( CB, 1 )
end else begin
PrintAlts;
RefreshCBuff( CB ); { ... and start over }
end;
end;
NotUnique:
begin
writeln('?');
PrintMatching;
QuestionMark := True;
if CmdLevel>0 then begin
RefreshCBuff( CB );
BackCBuff( CB, 1 );
end else begin
BackCBuff(CB, CmdEndCBuff(CB));
RefreshCBuff( CB );
end;
end;
end;
QuestionMark := True;
end;
end else
if (C=Escape) and (not Comment) then begin
QuestionMark := False;
if BufCur>CurrPList^.CmdI then begin
PRes := ParseAll(CB);
case PRes of
ParsedOK:
begin
CmdEnd := CmdEndCBuff(CB);
if CmdEnd=BufCur then
with CurrPList^ do begin
{$Range-}
Matching :=
CurrMenu^.MPtr^.Commands[Selection];
{$Range=}
I := CmdI;
J := 1;
while (I<CmdEnd) and (J<=Length(Matching))
do begin
if CComp( Matching[J], Cmd[I] ) then begin
J := J+1;
I := I+1;
end else begin
if Cmd[I]='-' then begin
J := J+1;
end;
end;
end;
for I := J to Length(Matching) do begin
IntoCBuff( CB, Matching[I] );
end;
if PRes=ParsedOK then { expect more commands }
begin
IntoCBuff( CB, ' ' );
end;
end;
end;
NotFound:
begin
write('?No match for word: ');
ShowWord(CB);
writeln;
if CmdLevel>0 then begin
RefreshCBuff( CB ); { ... and start over }
BackCBuff( CB, 1 );
end else begin
PrintAlts;
RefreshCBuff( CB ); { ... and start over }
end;
end;
NotUnique:
begin
writeln;
write(CommNotUnique);
ShowWord(CB);
writeln;
if CmdLevel>0 then begin
RefreshCBuff( CB );
BackCBuff( CB, 1 )
end else begin
BackCBuff(CB, CmdEndCBuff(CB));
PrintMatching;
RefreshCBuff( CB );
end;
end;
end;
end;
end else
if (C=BS) or (C=DEL) then begin
if BufCur=1 then
write( chr(7) )
else
BackCBuff( CB, BufCur-1 );
QuestionMark := False;
end else
if (C=CtrlW) then begin
if (CurrPList^.CmdI=BufCur) then begin
if CurrPList^.PrevPList<>NIL then
BackCBuff( CB, CurrPList^.PrevPList^.CmdI );
end else
BackCBuff(CB, CurrPList^.CmdI );
QuestionMark := False;
end else
if (C=CtrlX) or (C=CtrlU) then begin
BackCBuff( CB, 1 );
QuestionMark := False;
end else
begin { normal character }
QuestionMark := False;
if (C>=' ') and (C<DEL) then begin
IntoCBuff( CB, C );
end;
end;
end { while };
dispose( HFBuff );
end; { ParseCommand }
{===========================================================================}
function GetMenuAnswer( MPtr:pNameDesc; NPix:integer ):integer;
{ Returns 0 for press outside menu }
var ResPtr : ResRes;
Handler OutSide;
begin
ResPtr:=NIL;
exit(Menu);
end; { OutSide }
begin { GetMenuAnswer }
Menu( MPtr,
NotList,
1,
MPtr^.NumCommands,
UseCursorPos,
UseCursorPos,
NPix, {Number of pixels (height)}
ResPtr);
if ResPtr <> NIL then begin
GetMenuAnswer := ResPtr^.Indices[1];
DestroyRes( ResPtr );
end
else
GetMenuAnswer := 0;
end; { GetMenuAnswer }
{=============================================================================}
procedure DestroyPList( var PListPtr : pPListEntry );
var Trail : pPListEntry;
begin
while PListPtr<>NIL do begin
Trail := PListPtr;
case Trail^.Node of
EndNode:
begin
PListPtr := NIL;
dispose( Trail, EndNode );
end;
ParmNode:
begin
PListPtr := NIl;
dispose( Trail, ParmNode );
end;
MenuNode:
begin
PListPtr := Trail^.NextPList;
Trail^.NextPList := NIL;
dispose( Trail, MenuNode );
end;
end;
end;
end;
{=============================================================================}
procedure GetPList( Root : pMenuEntry;
var PListPtr : pPListEntry );
begin
SCurOn;
PListPtr := NIL;
ParseCommand( Root, PListPtr, false, true );
SCurOff;
end;
{=============================================================================}
function GetMenu( MenuFName, HelpFName : String ) : pMenuEntry;
VAR MenuFile : Text;
Blk, Bits : Integer;
SegSize : Integer;
MenuF : FileID;
Root : pMenuEntry;
MMP : MMPointer;
HelpFile : pInt;
MenuSeg, OldSeg : SegmentNumber;
exception BadMenuSeg;
handler BadMenuSeg;
begin
GetMenu := NIL;
exit( GetMenu );
end;
procedure FixPointer( var ME : pMenuEntry );
var MME : record case boolean of
true: ( MM : MMPointer);
false: ( E : pMenuEntry);
end;
begin
with MME do begin
E := ME;
with MM do begin
if (Segmen<>OldSeg) or (Offset>SegSize) then
raise BadMenuSeg;
Segmen := MenuSeg;
end;
ME := E;
end;
end;
procedure ValidatePtrs( ME : pMenuEntry );
var i : integer;
TME : pMenuEntry;
begin
with ME^ do begin
case Node of
MenuNode:
begin
TME := recast( MPtr, pMenuEntry );
FixPointer( TME );
MPtr := recast( TME, pNameDesc );
for i := 2 to MPtr^.NumCommands do begin
{$range-}
FixPointer( NextLevel[i] );
ValidatePtrs( NextLevel[i] );
{$range=}
end;
end;
EndNode, ParmNode:
;
end;
end;
end;
begin
MenuF := FSLookUp( MenuFName, Blk, Bits );
if MenuF=0 then
raise NoMenuFile( MenuFName )
else begin
CreateSegment( MenuSeg, Blk, 1, Blk );
SegSize := (Blk-1)*256 + (Bits div 16);
Root := MakePtr( MenuSeg, WordSize( integer ), pMenuEntry );
MultiRead( MenuF, MakePtr( MenuSeg, 0, pDirBlk ), 0, Blk );
MMP := recast( Root^.MPtr, MMPointer );
OldSeg := MMP.Segmen;
ValidatePtrs( Root );
HelpFile := MakePtr( MenuSeg, 0, pInt );
HelpFile^ := FSLookUp( HelpFName, Blk, Bits );
end;
GetMenu := Root;
end;
{=============================================================================}
procedure InitMenues;
begin
{$Range-}
AllocNameDesc( 1, DefSeg, NullMenu );
with NullMenu^ do begin
Header := 'Confirm:';
Commands[1] := '?';
end;
AllocNameDesc( 2, DefSeg, EndMenu );
with EndMenu^ do begin
Header := 'Confirm selection:';
Commands[1] := '?';
Commands[2] := 'Perform command';
end;
AllocNameDesc( 3, DefSeg, ParmMenu );
with ParmMenu^ do begin
Header := 'Command arguments:';
Commands[1] := '?';
Commands[2] := 'Enter arguments';
Commands[3] := 'No arguments';
end;
{$Range=}
InitPopUp;
IOCursorMode(TrackCursor);
CmdLevel := 0;
PromptChar := KeyChar;
end;
{=============================================================================}
procedure DestroyMenues;
var CI : integer;
begin
DestroyNameDescr( NullMenu );
end.