home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
norskdata.tar.gz
/
norskdata.tar
/
ndkcom.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-06-24
|
29KB
|
769 lines
(* tab p; *)
(*
* Command-handling
*
* for
*
* ND-KERMIT
*
*)
(*
UTILITY ROUTINES:
*)
function AtoI ( IntString : NameType; VAR Int : integer ): boolean;
(*
* Abstract : Converts the string in IntString to an integer.
* Returns false if IntString does
* not contain a valid integer.
*)
var i : integer;
ch : char;
OkSoFar : boolean;
begin (* AtoI *)
OkSoFar := IntString.Valid <= 4;(* Allow only up to 4 digits *)
Int := 0; (* in order to prevent overflow... *)
for i := MinWord to IntString.Valid do
begin
ch := IntString.String(.i.);
OkSoFar := OkSoFar and ( ( ch >= '0' ) and
( ch <= '9' ) );
if OkSoFar then
Int := Int * 10 + ord(ch) - ord('0');
end;
AtoI := OkSoFar;
end; (* AtoI *)
function OkFileSyntax( FileName : NameType ): boolean;
begin (* OkFileSyntax *)
(* This one could be complicated - leave it out so long. *)
OkFileSyntax := true;
end; (* OkFileSyntax *)
(*
* END of Utility routines.
*)
procedure Bell;
begin
write( ctl('G') );
end;
procedure EditLine ( VAR Line : CmdLinType; RePrint : boolean );
(*
* Abstract : Returns with a command line in Line. The "Valid" field
* may be non-zero in order to continue editing of a line already
* containing parts of a complete command.
* Repeats until a non-empty command line has been input and terminated.
* Terminating characters may be <ESC>, "?" or <CR>.
* Editing characters recognized by this routine:
* ^H - deletes last character and does BsSpBs.
* <DEL> - same
* ^A - same (ND style).
* ^Q - deletes hole line by doing BsSpBs several times.
* (also ND style). (Unless Xon/Xoff is enabled).
* ^X - same (CP/M style).
* ^U - same (DEC style)
* ^W - deletes last word (also ND style).
*)
type CharTypes = ( CtlQ, CtlW, CtlA, CtlH, chQMark, chCR,
chESC, CtlX, CtlU, Del, OtherCtl, PrintAble );
var ch : char;
Ech : CharTypes;
i : integer;
PrevSpace,fin,DoTest,Done : boolean;
Returning : boolean;
procedure BsSpBs;
begin
write( ctl('H') , ' ' , ctl('H') );
end;
function GetChar : char;
(*
* Abstract : Read a character from the user's terminal.
* Hangs until a character has been typed, and returns this
* character as the function result.
*)
begin (* GetChar *)
GetChar := inbt ( idev );
end; (* GetChar *)
begin (* EditLine *)
with Line do
repeat
Returning := false;
if Valid >= MinName then
PrevSpace := String(.Valid.) = ' '
else
PrevSpace := true; (* previous character was <space> *)
Cursor := MinName;
if RePrint then begin
write( Prompt );
for i := 1 to Valid do
write( String(.i.) );
end;
RePrint := true;
repeat
(* perform editing of Line.String *)
fin := false;
ch := GetChar;
if ( ch = ctl('A') )
or( ch = ctl('H') )
or( ch = ctl('?') ) (* DEL *)
then
begin
if Valid >= 1 then begin
BsSpBs;
Valid := Valid - 1;
end else
Bell;
if Valid >= MinName then
PrevSpace := String(.Valid.) = ' '
else
PrevSpace := true;
end else
if ( ch = ctl('Q') )
or( ch = ctl('X') )
or( ch = ctl('U') )
then
begin
for i := 1 to Valid do
BsSpBs;
Valid := 0;
PrevSpace := true;
end else
if ch = ctl('W') then
begin
if Valid <> 0 then
begin
(* back-space over blanks: *)
repeat
Done := false;
if ( Valid >= 1 ) then
if ( String(.Valid.) = ' ' ) then
begin
BsSpBs;
Valid := Valid - 1;
end else
Done := true
else Done := true;
until Done;
DoTest := Valid >= MinName;
if DoTest then
begin
(* back-space over word *)
while DoTest do
begin
if String(.Valid.) <> ' ' then
begin
BsSpBs;
Valid := Valid - 1;
end
else
DoTest := false;
DoTest := DoTest and (Valid >= MinName)
end;
PrevSpace := true;
end;
end else
Bell;
end else
if ch = ctl('M') (* CR *) then
begin
fin := true;
Returning := Valid > 0;
if not Returning then
writeln;
Terminator := CR;
end else
if ch = '?' then
begin
write('?');
fin := true;
Returning := true;
Terminator := QMark;
end else
if ch = ctl('[') then
begin
fin := (Valid > 0) and (not PrevSpace);
if not fin then
Bell;
Returning := fin;
Terminator := ESC;
end else
if ( ch >= ctl('@') )
and( ch < ' ') (* other control characters *)
then
begin
if ch = ctl('T') then
begin
(* output debug info *)
writeln;
writeln('Valid =',Valid:2,' Cursor =',Cursor:2);
write('EndW =',EndWord:2,' String :');
for i := MinName to Valid do
write(String(.i.));
writeln;
fin := true;
end else
Bell;
end
else
(* ch is printable character *)
begin
if Valid < MaxName then begin
Valid := Valid + 1;
String(.Valid.) := ch;
write( ch );
end else
Bell;
PrevSpace := ch = ' ';
end;
until fin;
until Returning;
end; (* EditLine *)
function AtEnd ( VAR Buffer : CmdLinType ) : boolean;
begin (* AtEnd *)
AtEnd := Buffer.Cursor = Buffer.Valid + 1;
end; (* AtEnd *)
procedure GetWord ( VAR Buffer : CmdLinType;
VAR Word : WordType );
(*
* Abstract : Get the next word from "Buffer" - Buffer.Cursor points
* to next character to be read. Leading blanks are stripped off.
* Only blanks are recognized as word separators.
* Buffer.Cursor is advanced to next non-blank or to end of string.
*)
var i,j : integer;
begin (* GetWord *)
with Buffer do
begin
i := Cursor; (* Starting pos. *)
PrevCursor := Cursor;
while (Buffer.String(.i.) = ' ')
and ( i <= Valid ) (* Space over leading blanks *)
do
i := i + 1;
j := MinWord;
while ( i <= Valid ) and
( String(.i.) <> ' ' ) and
( j <= MaxWord ) do
begin
(* Copy word from buffer to Word. *)
Word.String(.j.) := String(.i.);
i := i + 1; (* and increment pointers *)
j := j + 1;
end;
Word.Valid := j - 1;
EndWord := i - 1;
while ( String(.i.) <> ' ' )(* Advance cursor to next blank *)
and ( i <= Valid ) (* or to end *)
do
i := i + 1;
if i = Valid then
Cursor := i + 1
else
Cursor := i;
end; (* With *)
end; (* GetWord *)
procedure GetName ( VAR Buffer : CmdLinType;
VAR Name : NameType );
(*
* Abstract : Get the next item from "Buffer" - Buffer.Cursor points
* to next character to be read. Leading blanks are stripped off.
* Only blanks are recognized as word separators.
* Buffer.Cursor is advanced to next non-blank or to end of string.
*)
var i,j : integer;
begin (* GetName *)
with Buffer do
begin
i := Cursor; (* Starting pos. *)
PrevCursor := Cursor;
while (Buffer.String(.i.) = ' ')
and ( i <= Valid ) (* Space over leading blanks *)
do
i := i + 1;
j := MinName;
while ( i <= Valid ) and
( String(.i.) <> ' ' ) and
( j <= MaxName ) do
begin
(* Copy word from buffer to Word. *)
Name.String(.j.) := String(.i.);
i := i + 1; (* and increment pointers *)
j := j + 1;
end;
Name.Valid := j - 1;
EndWord := i - 1;
while ( String(.i.) <> ' ' )(* Advance cursor to next blank *)
and ( i <= Valid ) (* or to end *)
do
i := i + 1;
if i = Valid then
Cursor := i + 1
else
Cursor := i;
end; (* With *)
end; (* GetName *)
procedure WordToSymbol ( Word : WordType;
VAR Symbol : VocabType;
VAR Status : MatchType;
VAR Matching : VocabSet;
VAR Expect : VocabSet );
(*
* Abstract : Translates from Word to Symbol. Status is set according
* to the result of the match. The matching words become members
* of the set Matching.
*)
var MatchFound, ThisWordMatch : boolean;
i,j : integer;
Index,RetVal: VocabType;
function WordsMatch ( Abbrev , Reference : WordType ):boolean;
var i : integer;
Match : boolean;
begin (* WordsMatch *)
Match := true;
if ( Abbrev.Valid <= Reference.Valid ) and
( Abbrev.Valid >= MinWord )
then
for i := MinWord to Abbrev.Valid do
Match := Match and
( uc(Abbrev.String(.i.) ) = Reference.String(.i.))
else
Match := False;
WordsMatch := Match;
end; (* WordsMatch *)
begin (* WordToSymbol *)
RetVal := ExitSym; (* in order to avoid ILLEGAL SUBRANGE ASSIGNMENT *)
Matching := (. .);
Status := NoMatch;
for Index := First( VocabType ) to Last( VocabType ) do
begin
if WordsMatch ( Word , VocabTable(.Index.) ) then
begin
if Index in Expect then
begin
Matching := Matching + (. Index .);
if Status = NoMatch then
begin
Status := Exact;
Symbol := Index;
end else
Status := Ambigous;
end;
end;
end;
end; (* WordToSymbol *)
procedure GetCmd ( VAR Verb, Noun, Adj : VocabType;
VAR ParBlock : ParType );
(*
* Abstract : Get a new command from the user's terminal.
* Does appropriate checking so that returned values are consistent.
* Repeats until valid command is given.
* Does the following:
* "?" preceded by at least a space:
* Types out the expected parameters and continues
* editing of same line.
* "?" not preceded by a space:
* Types out the matching parameters.
* If no match is found, works as if the last word
* had not been typed. Continues editing of current
* command.
* <ESC> not preceded by a space:
* Deabbreviates the current word. If no match is
* found, acts as if "?" had been typed instead.
* Continues editing of current command.
* <ESC> preceded by a space is not allowed.
* (Taken care of by EditLine.)
*)
var Expect : VocabSet;
Sym : VocabType;
Word : WordType;
ValidCommand : boolean;
RePrint : boolean;
Buffer : CmdLinType;
procedure BackWord;
begin
if Buffer.PrevCursor = MinName then
Buffer.Valid := MinName - 1
else
Buffer.Valid := Buffer.PrevCursor;
end;
procedure MakeEndBlank( VAR Buffer : CmdLinType );
begin
with Buffer do
if ( Valid >= MinName ) and ( Valid < MaxName ) then
if String(.Valid.) <> ' ' then
begin
String(.Valid + 1.) := ' ';
Valid := Valid + 1;
end;
end;
function ParseWord ( Expect : VocabSet;
VAR Symbol : VocabType ): boolean;
(*
*
*)
var Matching : VocabSet;
Status : MatchType;
RetVal : boolean;
procedure WriteWord( Word : WordStr; Valid : integer );
var i : integer;
begin
for i := MinWord to Valid do
write( Word(.i.) );
end;
procedure OneOf( These : VocabSet );
const LettersPrWord = 8;
WordsPrLine = 6;
InitSpace = 4;
var Index : VocabType;
WordNo: integer;
i : integer;
procedure PrintWord( This : VocabType );
var Need,i : integer;
begin (* PrintWord *)
Need := 1 + ( VocabTable(.This.).Valid + 2 )
div LettersPrWord;
if WordNo + Need > WordsPrLine then
begin
writeln;
write(' ':InitSpace);
WordNo := 0;
end;
WordNo := WordNo + Need;
with VocabTable(.This.) do
begin
WriteWord( String, Valid );
for i := ( ( Valid + 1 ) mod LettersPrWord )
to LettersPrWord
do
write( ' ' );
end;
end; (* PrintWord *)
begin (* OneOf *)
writeln(' Use one of the following:');
WordNo := 0;
write(' ':InitSpace);
for Index := First( VocabType ) to Last( VocabType ) do
if Index in These then
begin
PrintWord( Index );
end;
writeln;
end; (* OneOf *)
procedure Deabbr( Word : WordType;
Symbol : VocabType;
VAR Buffer : CmdLinType );
var i,j : integer;
begin (* Deabbr *)
with Buffer do
begin
j := -1;
for i := Word.Valid + 1 to VocabTable(. Symbol .).Valid do
begin
j := i - Word.Valid - 1;
ch := VocabTable(. Symbol .).String(.i.);
String(. j + Cursor .):= ch;
write(ch);
end;
String(. j + Cursor + 1 .) := ' ';
write(' ');
Valid := j + Cursor + 1;
end;
RePrint := false;
end; (* Deabbr *)
begin (* ParseWord *)
if AtEnd( Buffer ) then
begin
case Buffer.Terminator of
QMark,Cr:
with Buffer do
begin
if Terminator = Cr then
write(' Not confirmed.');
OneOf( Expect );
MakeEndBlank( Buffer );
end;
Esc : ;
end;
RetVal := false;
end else begin
GetWord ( Buffer, Word );
WordToSymbol ( Word, Symbol, Status, Matching, Expect );
case Status of
Exact :
begin
if AtEnd( Buffer ) and ( Buffer.Terminator = Esc )
then
begin
RetVal := false;
Deabbr( Word, Symbol, Buffer );
end else
RetVal := true;
end;
Ambigous:
begin
RetVal := false;
if
not AtEnd( Buffer )
or ( Buffer.Terminator <> QMark )
then
begin
write(' Ambigous word: "');
WriteWord( Word.String, Word.Valid );
write('".');
end;
OneOf( Matching );
Buffer.Valid := Buffer.EndWord;
end;
NoMatch :
begin
RetVal := false;
write(' No match for word: "');
WriteWord( Word.String, Word.Valid );
write('"');
OneOf( Expect );
BackWord;
end;
end;
end;
ParseWord := RetVal;
end; (* ParseWord *)
function TestConfirm: boolean;
begin (* TestConfirm *)
if not AtEnd( Buffer ) then
begin
writeln(' No extra parameters needed.');
Buffer.Valid := Buffer.EndWord;
TestConfirm := false;
end else
if Buffer.Terminator <> Cr then
begin
writeln(' Confirm with CR.');
Buffer.Valid := Buffer.EndWord;
TestConfirm := false;
end
else
TestConfirm := true;
end; (* TestConfirm *)
function GetInt( VAR ParBlock : ParType ): boolean;
begin (* GetInt *)
if not AtEnd( Buffer ) then
begin
GetName( Buffer, ParBlock.Name );
if not AtoI( ParBlock.Name, ParBlock.int ) then
begin
GetInt := False;
writeln(' Illegal number syntax.');
BackWord;
end;
end else
begin
writeln(' Confirm with valid integer.');
GetInt := false;
end;
MakeEndBlank( Buffer );
end; (* GetInt *)
function GetFileName ( VAR FileName : NameType ): boolean;
(*
* Abstract : Get a filename from the input line-buffer.
* Checks for valid syntax of the filename, but does not attempt
* to open the file.
*)
var RetVal : boolean;
i : integer;
begin (* GetFileName *)
if AtEnd ( Buffer ) then begin
writeln(' File name required.');
MakeEndBlank( Buffer );
RetVal := false;
end else begin
GetName ( Buffer, FileName );
(* Convert filename to upper case. *)
for i := MinName to FileName.Valid do
FileName.String(.i.) := uc( FileName.String(.i.) );
RetVal := OkFileSyntax( FileName );
end;
GetFileName := RetVal;
end; (* GetFileName *)
function GetSetParameter ( VAR Noun, Adj : VocabType;
VAR ParBlock : ParType ): boolean;
(*
* Abstract : Get a SET parameter.
* The verb SET has already been fetched from "Buffer".
*)
var Valid : boolean;
function GetDbgParameter ( VAR Adj : VocabType;
VAR ParBlock : ParType ): boolean;
(*
* Abstract : Get a valid parameter for SET DEBUG.
*)
var Valid : boolean;
begin (* GetDbgParameter *)
Expect := (. OnSym, OffSym, LogFileSym, NoLogFileSym .);
Valid := ParseWord ( Expect, Adj );
if Valid then
case Adj of
OnSym : Valid := TestConfirm;
OffSym : Valid := TestConfirm;
LogFileSym :
Valid := GetFileName ( ParBlock.Name );
NoLogFileSym: Valid := TestConfirm;
end;
GetDbgParameter := Valid;
end; (* GetDbgParameter *)
function GetRSParameter ( VAR Adj : VocabType;
VAR ParBlock : ParType ): boolean;
(*
* Abstract : Get a valid SET SEND or SET RECEIVE parameter.
* Returns true if syntactically correct
* command has been entered.
*)
var Valid : boolean;
begin (* GetRSParameter *)
Expect := (. TimeOutSym .);
Valid := ParseWord ( Expect , Adj );
if Valid then
case Adj of
TimeOutSym :
Valid := GetInt ( ParBlock );
end;
GetRSParameter := Valid;
end; (* GetRSParameter *)
function GetUse8( VAR Adj : VocabType ): boolean;
var Valid : boolean;
Expect: VocabSet;
begin(* GetUse8 *)
Expect := (. AutoSym, OffSym .);
Valid := ParseWord( Expect, Adj );
if Valid then
Valid := TestConfirm;
GetUse8 := Valid;
end; (* GetUse8 *)
function GetFWarn( VAR Adj : VocabType ): boolean;
var Expect : VocabSet;
Valid : boolean;
begin(* GetFWarn *)
Expect := (. OnSym, OffSym .);
Valid := ParseWord( Expect, Adj );
if Valid then
Valid := TestConfirm;
GetFWarn := Valid;
end; (* GetFWarn *)
begin (* GetSetParameter *)
Expect := (. DbgSym, DelaySym, (* LogFileSym, *)
FWarnSym, RcvSym, SendSym, Use8Sym .);
Valid := ParseWord ( Expect, Noun );
if Valid then
case Noun of
DbgSym :
Valid := GetDbgParameter( Adj, ParBlock );
DelaySym:
Valid := GetInt ( ParBlock );
LogFileSym: ; (* Only to be used if this is a LOCAL Kermit *)
(* -- which this one can't be. *)
RcvSym, SendSym :
Valid := GetRSParameter( Adj, ParBlock );
Use8Sym :
Valid := GetUse8( Adj );
FWarnSym:
Valid := GetFWarn( Adj );
end;
GetSetParameter := Valid;
end; (* GetSetParameter *)
begin (* GetCmd *)
Descf;
Buffer.Valid := 0;
RePrint := true;
ValidCommand := false;
repeat
EditLine ( Buffer, RePrint );
RePrint := true;
Expect := (. ExitSym, HelpSym, QuitSym, RcvSym,
SendSym, SetSym, StatisticsSym .);
ValidCommand := ParseWord ( Expect, Verb );
if ValidCommand then begin
case Verb of
ExitSym, QuitSym : ValidCommand := TestConfirm;
HelpSym : ValidCommand := TestConfirm;
RcvSym : ValidCommand := TestConfirm;
SendSym :
ValidCommand := GetFileName( ParBlock.Name );
SetSym :
ValidCommand := GetSetParameter( Noun, Adj, ParBlock );
StatisticsSym :
ValidCommand := TestConfirm;
end;
end;
until ValidCommand;
Eescf;
end; (* GetCmd *)
procedure InitVocab;
(*
* Abstract : Initializes the vocabulary and stores it in
* the global variable VocabTable.
*)
var Index : VocabType;
begin (* InitVocab *)
VocabTable (. ExitSym .).String := 'EXIT$';
VocabTable (. QuitSym .).String := 'QUIT$';
VocabTable (. RcvSym .).String := 'RECEIVE$';
VocabTable (. SendSym .).String := 'SEND$';
VocabTable (. SetSym .).String := 'SET$';
VocabTable (. DbgSym .).String := 'DEBUG$';
VocabTable (. OnSym .).String := 'ON$';
VocabTable (. OffSym .).String := 'OFF$';
VocabTable (. LogFileSym .).String := 'LOG-FILE$';
VocabTable (. DelaySym .).String := 'DELAY$';
VocabTable (. TimeOutSym .).String := 'TIMEOUT$';
VocabTable (. StatisticsSym .).String := 'STATISTICS$';
VocabTable (. HelpSym .).String := 'HELP$';
VocabTable (. LogFileSym .).String := 'LOG-FILE$';
VocabTable (. NoLogFileSym .).String := 'NO-LOG-FILE$';
VocabTable (. AutoSym .).String := 'AUTO$';
VocabTable (. Use8Sym .).String := 'USE-8-BIT-QUOTE$';
VocabTable (. FWarnSym .).String := 'FILE-WARNING$';
for Index := First( VocabType ) to Last( VocabType ) do
with VocabTable(.Index.) do
begin
Valid := MinWord;
while String(.Valid.) <> '$' do
Valid := Valid + 1;
Valid := Valid - 1;
end;
end; (* InitVocab *)