{
	Program :  KERMIT.PAS		- Main program 
		     PARSER.PAS		- Kermit Command Parser 
		     PGLOBAL.PAS	- Parser Global Definitions 
		     VTERM.FOR		- Kermit Virtual Terminal Program 
		     VTGLOBAL.FOR	- Virtual Terminal Global Definitions 

	Author :   Philip Murton - original RT-11 pascal program,
		   Bruce W. Pinn - modified version for VMS 3.x
					added regular command parser,
					virtual terminal support,
					pretty pascal code.

	Date :  April 28, 1983
	Site :  University of Toronto
		Computing Services

	Abstract :
	     This program implements the KERMIT protocol under VAX/VMS.  KERMIT
	is an acronym for the expression "KL-10 Error-Free Reciprocol
	Microcomputer Interchange over TTY-Lines".  For more information on
	Kermit please refer to the documentation included with this distri-
	bution.
	     This version of KERMIT, with its virtual terminal support, may
	be used as a local, or remote kermit.

	Bug Fixes :
		01-JUN-83  BWP	Reset packet pointer to zero after each
				file group send/receive to satisfy UNIX
				kermit.

		01-JUN-83  BWP	Fixed file handling so that if incoming line
				exceeds 133 then it is wrapped to next line.

		08-AUG-83  BWP  Fixed getfile so that routine will open an
				incoming file of xxx to xxx. as opposed to
				xxx.DAT.

		09-AUG-83  BWP  Fixed parsing routine to strip off leading
				blanks from user command.

		09-AUG-83  BWP  Fixed parsing routine to allow `?' to be
				specified after send or receive command.

		10-AUG-83  BWP  Fixed bug so that when remote connection
				generates hangup, the user cannot type conn
				to reconnect.  This also fixes the gobbled
				character problem (actually now only one 
				gobbled character).

		11-AUG-83  BWP  Added dcl call to parser.

                11-AUG-83  BWP  Turned off control-(c/y) checking.

		15-AUG-83  BWP	Adjusted code to check local user for input
				during send.  (Allow abort, and retransmit
				packets.)

		29-SEP-83  BWP  Fixed code so that before each send the
				find_file/next file pointer is reset to zero.

		29-SEP-83  BWP  Turned off sysprv priviledge after allocating
				the remote port.

		01-NOV-83  BWP	Turned on, then off control-y handling when
				execing DCL.

		01-NOV-83  BWP  Fixed bug so that when user performs transfer
				abort the diskfile is appropriately closed.

		01-NOV-83  BWP	Fixed bug so that when user aborts, or error
				occurs during a file open, an error packet is
				sent to the remote kermit.

		
									   }

[inherit('SYS$LIBRARY:STARLET')]
program Kermit(input,output,file3,file4,helpfile);

label 
    9999;               { used only to simulate a "halt"  instruction }

const 

    { standard file descriptors. subscripts in open, etc. }
    STDIN = 1;          { these are not to be changed }
    STDOUT = 2;
    STDERR = 3;
    LOCALCHAN = 5;
    REMOTECHAN = 6;

    { other io-related stuff }
    IOERROR = 0;        { status values for open files  }
    IOAVAIL = 1;
    IOREAD = 2;
    IOWRITE = 3;
    MAXOPEN = 6;        { maximum number of open files  }

    { universal manifest constants  }
    ENDFILE = -1;
    ENDSTR = 0;         { null-terminated strings }
    ENDOFQIO = -128;
    MAXSTR = 100;       { longest possible string }
    CONLENGTH = 20;     { length of constant string }
    MAXCHARPERLINE = 133; { Maximum number of characters for file line }

    { ascii character set in decimal }
    BACKSPACE = 8;
    TAB = 9;
    NEWLINE = 10;
    BLANK = 32;
    SHARP = 35; 
    PERIOD = 46;
    QUESTION = 63;

    SOH = 1;            { ascii SOH character }
    CR = 13;            { CR }
    DEL = 127;          { rubout }

    DEFTRY = 5;         { default for number of retries }
    DEFITRY = 10;       { default for number of retries on init }
    DEFTIMEOUT = 20;    { default time  out }
    MAXPACK = 94;       { max is 94 }
    DEFDELAY = 5;      { delay before  sending first init }
    NUMPARAM = 6;       { number of parameters in init packet }
    DEFQUOTE = SHARP;   { default quote character   }
    DEFPAD = 0;         { default number of padding chars   }
    DEFPADCHAR = 0;     { default padding character  }

    { SYSTEM DEPENDENT }
    DEFEOL = CR;

    { packet TYPES  }

    TYPEB  = 66;    { ord('B') }
    TYPED  = 68;    { ord('D') }
    TYPEE  = 69;    { ord('E') }
    TYPEF  = 70;    { ord('F') }
    TYPEN  = 78;    { ord('N') }
    TYPES  = 83;    { ord('S') }
    TYPET  = 84;    { ord('T') }
    TYPEY  = 89;    { ord('Y') }
    TYPEZ  = 90;    { ord('Z') }

    MAXCMD = 10;

    { Virtual Terminal Support }
    LOCALONLY = 0;
    LOCALREMOTE = 1;

    { VMS qio buffer size }
    VMSBUFSIZE = 512;
    SLEEPEFN = 10;
    READWITHTIMEOUT = %x'80';

    { Command parser constants }
    SMALLSIZE = 13;
    LARGESIZE = 80;
    MINPACKETSIZE = 10;
    MAXPACKETSIZE = 94;

%include   'kermdir:pglobal.pas'

type 
    character = -128..127;          { byte-sized. ascii + other stuff }
    wordInteger = 0..65535;
    string = array [1..MAXSTR] of character;
    vstring = record
		   len : integer;
		   ch  : array [1..MAXSTR] of char;
	      end;
    cstring = PACKED array [1..CONLENGTH] of char;
    filedesc = IOERROR..MAXOPEN;
    ioblock = record                { to keep track of open files }
		   filevar : text;
		   mode : IOERROR..IOWRITE;
	      end;

    { Data  TYPES for Kermit }
    Packet = RECORD
		   mark : character;       { SOH character  }
		   count: character;       { # of bytes following this field }
		   seq  : character;       { sequence number modulo 64  }
		   ptype: character;       { d,y,n,s,b,f,z,e,t  packet type }
		   data : string;          { the actual data }
	     end;
    { chksum is last validchar in data array }
    { eol is added, not considered  part of packet proper }

    timeArray = packed array[1..2] of integer;
    Command = (Transmit,Receive,SetParm,Invalid,Connect,Alldone);
    KermitStates = (FileData,Init,Break,FileHeader,EOFile,Complete,Abort);
    EOLtype = (LineFeed,CrLf,JustCr);

    Words = (Low,High);
    Stats = integer;
    Ppack = ^Packet;

    Intype = (nothing,CRin,abortnow);

    {  Parser defined types }
    vmsString = varying[255] of char;
    $UBYTE = [BYTE] 0..255;
    string13 = packed array [1..SMALLSIZE] of char;
    string80 = packed array [1..LARGESIZE] of char;

var 
    openlist : array [1..MAXOPEN] of ioblock; { open files  }
    cmdargs  : 0..MAXCMD;
    cmdlin   : string;
    cmdidx   : array [1..MAXCMD] of 1..MAXSTR;
    file3,file4,helpfile : text;
    file3cnt, file4cnt : integer;

    { varibles for  Kermit }
    DiskFile : filedesc;     { File being read/written }
    SaveState : kermitstates;
    NextArg  : integer;      { next argument to process }
    local    : boolean;      { local/remote flag }
    MaxTry   : integer;
    n        : integer;      { packet number }
    NumTry   : integer;      { times this packet retried }
    OldTry   : integer;
    Delay    : integer;
    Pad, MyPad : integer;      { number of padding characters I need  }
    PadChar, MyPadChar: character;
    MyTimeOut, TheirTimeOut : integer;
    timeOutStatus, fileWarning, fudge : boolean;
    Runtype, oldRunType  : command;
    State    : kermitstates;

    LineIN, LineOUT, ControlIN,ControlOUT : filedesc; 
    SizeRecv, SizeSend : integer;
    SendEOL, SendQuote : character;
    myEOL,myQuote: character;
    EOLFORFILE : EOLtype;
    NumSendPacks, NumRecvPacks : integer;
    NumACK, NumNAK : integer;
    NumACKrecv, NumNAKrecv, NumBADrecv : integer;
    RunTime : integer;
    startTime, endTime: timeArray;
    ChInFileRecv, ChInPackRecv, ChInFileSend, ChInPackSend : Stats;
    OneWayOnly, Debug : boolean;
    ThisPacket :    Ppack;  { current packet being  sent }
    LastPacket :    Ppack;  { last  packet sent }
    CurrentPacket : Ppack;  { current packet received }
    NextPacket :    Ppack;  { next  packet being received }
    InputPacket : Ppack;    { save  input to do debug }

    { these are used for the Receive Packet procedures }
    FromConsole : Intype;   { input from Console during     receive }
    check: integer;         { Checksum }
    PacketPtr : integer;    { pointer to InputPacket }
    dataptr : integer;      { pointer to data of Packet }
    fld : 0..5;             { current fld number }
    t : character;          { input character }
    finished : boolean;     { finished packet ? }
    restart : boolean;      { restart packet ? }
    control : boolean;      { quoted ? }
    isgood : boolean;       { packet is good  ? }

    {  Virtual Terminal Connect Parameters  }
    localChannel, remoteChannel : integer;
    locWriteFunc, locReadFunc : integer;
    remWriteFunc, remReadFunc : integer;
    vTermSetType : integer;
    invalidConnection : boolean;

    {  VMS qiow read buffer, and pointers. }
    vmsReadBuff, vmsWriteBuff : packed array[1..VMSBUFSIZE] of character;
    vmsChRead, curBuffPoint, vmsWritePnt, vmsFilePnt, stat : integer;
    ctrlOff : integer;
    fileExists, lastFile, vmsWriteFlg : boolean;

    {  VMS routine exit handler vars. }
    exitStatus : integer;

    {  Parser defined variables }
    commandLine, fileSpec : string80;
    exitProgram : boolean;
    localEcho, sFileSpec, rFileSpec, fileWarn, lSpeed : integer;
    escape, debugging, commandLen, fileEol, parity : integer;


procedure SetUpVirtualTerminal(var remChanl : integer;
			       var remRFunc : integer;
			       var remWFunc : integer;
			       var locChanl : integer;
			       var locRFunc, locWFunc,
				   status, setType, locEcho, 
				   parity, speed  : integer) ; fortran;


procedure SetUpExitHandlerVMS(swapm, priority : integer); fortran;

[asynchronous, external (LIB$DISABLE_CTRL)] function $Disable_Ctrl
      ( var mask : integer := %immed 0)
   : integer;
external;

[asynchronous, external (LIB$ENABLE_CTRL)] function $Enable_Ctrl
      ( var mask : integer := %immed 0)
   : integer;
external;

[asynchronous, external (LIB$FIND_FILE)] function $Find_File
      ( var fileName : varying[$l1] of
				char := %immed 0;
	var resultName : varying[$l2] of
				char := %immed 0;
	var context : integer := %immed 0;
	var defaultName : varying[$l3] of
				char := %immed 0;
	var relatedName : varying[$l4] of
				char := %immed 0 )
   : integer;
external;

[asynchronous, external (LIB$SPAWN)] function $Spawn
      ( var shelline : varying[$ll1] of
				char := %immed 0)
   : integer;
external;

[asynchronous, external (LIB$SUBX)] function $Subx
      ( var a : timeArray;
	var b : timeArray;
	var c : timeArray)
   : integer;
external;


[asynchronous, external (LIB$EDIV)] function $Ediv
      ( var divisor   : integer := %immed 0;
	var dividend  : timeArray;
	var quotient  : integer := %immed 0;
	var remainder : integer := %immed 0)
   : integer;
external;


procedure DebugMessage( c:cstring); forward;


procedure PutCln( x:cstring;
		       fd:filedesc); forward;
 

procedure AddTo( var sum : Stats;
		  inc:integer); forward;


procedure PutCN( x:cstring;
		 v : integer;
		 fd:filedesc); forward;


procedure FinishUp(noErrors : boolean); forward;


procedure ErrorPack(c:cstring); forward;


procedure ProgramHalt; { used by external  procedures for halt }
begin
    GOTO 9999
end;


{ initio  -- initialize open file list  }

procedure Initio;

var 
    status : integer;
    i : filedesc;
begin
    controlIN := STDIN;
    controlOUT := STDOUT;

    openlist[STDIN].mode := IOREAD;
    openlist[STDOUT].mode := IOWRITE;
    openlist[STDERR].mode := IOWRITE;

   { connect STDERR to  user's terminal ... }

    open(FILE_VARIABLE := file3,
	 FILE_NAME := 'SYS$ERROR');

    rewrite(file3);

   { initialize rest of files }
    for i := STDERR+1 to MAXOPEN do
	openlist[i].mode := IOAVAIL;

    {  Initialize the local channel }
    vTermSetType := LOCALONLY;
    invalidConnection := false;
    SetUpVirtualTerminal(remoteChannel, remReadFunc, remWriteFunc,
			 localChannel, locReadFunc, locWriteFunc,
			 status, vTermSetType, localEcho, parity, lSpeed);
    if (status <> ss$_normal) then
	invalidConnection := true;

    openlist[LOCALCHAN].mode := IOREAD;

end;


function Sopen (name : string; mode : integer) : filedesc;
{ Sopen  -- open a file for reading or  writing }
var 
	i : integer;
	intname : PACKED array [1..MAXSTR] of char;
	found : boolean;

procedure Iopen(var f:text;
		var linelen : integer);
begin
    linelen := 0;
    if openlist[i].mode = IOREAD
	then
	    begin
		open(FILE_VARIABLE := f,
		     FILE_NAME := intname,
		     RECORD_LENGTH := 255,
		     HISTORY := OLD,
		     ERROR := CONTINUE);
		if (status(f) <> 0)
		    then
		       fileExists := false;
		reset(f, ERROR := CONTINUE);
	    end
	else
	    begin
		open(FILE_VARIABLE := f,
		     FILE_NAME := intname,
		     HISTORY := NEW,
		     ERROR := CONTINUE);
		if (status(f) <> 0) then
		    begin
			openlist[i].mode := IOAVAIL;
			i := IOERROR;
		    end
		else
		    rewrite(f, ERROR := CONTINUE);
	    end;

end;

begin
	i := 1;
	while (name[i] <> ENDSTR) and (name[i] <> NEWLINE) do
	    begin
		intname[i] := chr(name[i]);
		i := i + 1
	    end;
	for i := i to MAXSTR do
		intname[i] := ' ';      { pad name with blanks  }
	{ find  a free slot in openlist }
	Sopen := IOERROR;
	found := false;
	i := 1;
	while (i <= MAXOPEN) and (not found) do
	    begin
		if (openlist[i].mode = IOAVAIL)
		    then
			begin
			    openlist[i].mode := mode;
			    case i of
				1:      { nothing };
				2:      { nothing };
				3:      { nothing };
				4:      Iopen(file4, file4cnt);
				end;
			    Sopen := i;
			    found := true
			end;
		i := i + 1
	    end
end;


function Create (name : string; mode : integer) : filedesc;
{ create (UCB)  -- create a file }
begin
    create := Sopen(name,IOWRITE);
end;


function getc (var c : character) : character;
{ getc  (UCB) -- get one character from standard input }
var 
	ch : char;
begin
	if eof
	    then
		c := ENDFILE
	    else
		if eoln
		    then
			begin
			    readln;
			    c := NEWLINE
			end
		    else
			begin
			    read(ch);
			    c := ord(ch)
			end;
	getc := c
end;


function Getcf (var c: character; fd : filedesc) : character;
{ getcf  -- get one character from file }
var 
	ch : char;

procedure Getcfx(VAR f:text);
begin
    if eof(f)
	then
	    c := ENDFILE
	else
	    if eoln(f)
		then
		    begin
			readln(f);
			c := NEWLINE
		    end
		else
		    begin
			read(f, ch);
			c := ord(ch)
		    end;
end;

begin
    if (openlist[fd].mode <> IOREAD)
	then
	    begin
		PutCln('Getcf:  mode=IOREAD ', STDERR);
		ProgramHalt;
	    end;
	case fd of
	    STDIN:          Getcf := getc(c); 
	    STDERR:         Getcfx(file3);
	    4:              Getcfx(file4);
	    LOCALCHAN:      PutCln('Read of local chan. ', STDERR);
	    REMOTECHAN:     PutCln('Read of remote Chan.', STDERR);
		end;
	Getcf := c
end;


function GetVmsPacket (fd : filedesc) : integer;
{  Function to get a block of text from the incomming channel. }

function GetBlockVMS(channel, channelReadFunc : integer) : integer;

var 
    status : integer;
    info, addrCh, addrIosb : integer;
    ch : char;
    channelTerminator : packed array[1..2] of integer;
    channelIosb : packed array[1..4] of wordInteger;
begin

    DebugMessage('GetBlockVMS...      ');
    curBuffPoint := 0;
    timeOutStatus := false;
    channelTerminator[1] := 0;
    channelTerminator[2] := 2**myEol;
    channelReadFunc := channelReadFunc + READWITHTIMEOUT;

    status := $QIOW(,%immed (channel),
		     %immed (channelReadFunc),
		     channelIosb,,,
		     vmsReadBuff,
		     %immed (VMSBUFSIZE),
		     %immed (TheirTimeOut),
		     %ref (channelTerminator),,);

    if ( not(odd(status)) or  not(odd(channelIosb[1])))
	then
	    timeOutStatus := true;
    
    GetBlockVms := channelIosb[2] + channelIosb[4];
end;

begin
    if (openlist[fd].mode <> IOREAD)
	then
	    begin
		PutCln('Getcf:  mode=IOREAD ', STDERR);
		ProgramHalt;
	    end;
	case fd of
	    LOCALCHAN:      GetVmsPacket := GetBlockVms(localChannel, 
							locReadFunc);
	    REMOTECHAN:     GetVmsPacket := GetBlockVms(remoteChannel, 
							remReadFunc);
	end;
end;


procedure Putc (c : character);
{ putc  (UCB) -- put one character on standard output }
begin
	if c = NEWLINE
	    then
		writeln
	    else
		write(chr(c));
end;


procedure Putcf (c : character; fd : filedesc);
{ putcf  -- put a single character on file fd }

procedure Putcfx(var f:text;
		 var linelen : integer);
begin
    linelen := linelen + 1;
    IF (c = NEWLINE)
	then
	    begin
		linelen := 0;
		writeln(f);
	    end
	else
	    if (linelen = MAXCHARPERLINE) then
		begin
		    linelen := 1;
		    writeln(f);
		    write(f, chr(c))
		end
	    else
		write(f, chr(c));
end;

procedure PutCVMS(    channel, channelWriteFunc : integer;
                  var totalChars : integer);

var 
	status, info : integer;
	channelIosb : packed array[1..2] of integer;
begin
    status := $QIOW(,%immed (channel),
  		     %immed (channelWriteFunc),
		     channelIosb,,,
		     %ref (vmsWriteBuff),
		     %immed (totalChars),,,,);

    {  Reset put buffer pointer }
    vmsWritePnt := 0;

    if (not(odd(status)))
        then
   	    PutCN('PutCVMS : bad qiow  ', status, STDERR);

end;


procedure BufferPutVMS(var  currentPntr : integer;
			    c : character);
{  Buffer the character to be written. }
begin
    vmsWritePnt := vmsWritePnt + 1;

    if (vmsWritePnt > VMSBUFSIZE) then
	begin
	    FinishUp(true);
	    ProgramHalt;
	end;

    if (c <> Pad) and (c <> sendEOL) then
        AddTo(ChInPackSend, 1);

    vmsWriteBuff[vmsWritePnt] := c;
end;


begin
    case fd of
	STDOUT:       Putc(c); 
	STDERR:       Putcfx(file3, file3cnt);
	4:            Putcfx(file4, file4cnt);
	LOCALCHAN:    
		      if (vmsWriteFlg) then
			  PutcVMS(localChannel, locWriteFunc, vmsWritePnt)
                      else
                          BufferPutVMS(vmsWritePnt, c);
	REMOTECHAN:   
		      if (vmsWriteFlg) then
			  PutcVMS(remoteChannel, remWriteFunc, vmsWritePnt)
                      else
                          BufferPutVMS(vmsWritePnt, c);
	end;
end;


procedure FlushPutBufferVMS;
{  Flush the put buffer by writing it out to the remote channel. }
var
    c : character;
begin
    vmsWriteFlg := true;
    PutCf(c, LineOut);
    vmsWriteFlg := false;
end;


procedure PutStr (var s : string; f : filedesc);
{ putstr (UCB)  -- put out string on file }
var 
	i : integer;
begin
	i := 1;
	while (s[i] <> ENDSTR) do
	    begin
		Putcf(s[i], f);
		i := i + 1
	    end
end;


procedure Sclose (var fd : filedesc);
{  Close a File descriptor }
begin
    if (fd > STDERR) and (fd <= MAXOPEN)
	then
	    begin
		openlist[fd].mode := IOAVAIL;
		case fd of
		    1:      { nothing };
		    2:      { nothing };
		    3:      close(file3, ERROR := CONTINUE);
		    4:      begin
				fd := IOERROR;
				close(file4, ERROR := CONTINUE);
			    end;
		end;
	    end;
end;



function ItoC (n : integer; var s : string; i : integer)
		: integer;      { returns end of s }
{ ItoC  - convert integer n to char string in s[i]... }
begin
	if (n < 0)
	    then
		begin
		    s[i] := ord('-');
		    ItoC := ItoC(-n, s, i+1)
		end
	    else
		begin
		    if (n >= 10)
			then
			    i := ItoC(n div 10, s, i);
		    s[i] := n mod 10 + ord('0');
		    s[i+1] := ENDSTR;
		    ItoC := i + 1
		end
end;


function LengthSTIP (var s : string) : integer;
{ lengthSTIP -- compute length of string }
var 
	n : integer;
begin
	n := 1;
	while (s[n] <> ENDSTR) do
		n := n + 1;
	LengthSTIP := n - 1
end;


procedure Scopy (var src : string; i : integer;
		 var dest : string; j : integer);
{ scopy -- copy string  at src[i] to dest[j] }
begin
	while (src[i] <> ENDSTR) do
	    begin
		dest[j] := src[i];
		i := i + 1;
		j := j + 1
	    end;
	dest[j] := ENDSTR
end;


function IsUpper (c : character) : boolean;
{ isupper -- true if c  is upper case letter }
begin
	isupper := (c >= ord('A')) and (c <= ord('Z'))
end;


function IndexSTIP (var s : string; c : character) : integer;
{ IndexSTIP -- find position of character c in string s }
var 
	i : integer;
begin
	i := 1;
	while (s[i] <> c) and (s[i] <> ENDSTR) do
		i := i + 1;
	if (s[i] = ENDSTR)
	    then
		IndexSTIP := 0
	    else
		IndexSTIP := i
end;


procedure CtoS( x:cstring;  var s:string);
{ convert constant to STIP string }
var 
    i : integer;
begin
    for i:=1 to CONLENGTH do
	s[i] := ord(x[i]);
    s[CONLENGTH+1] := ENDSTR;
end;


function Exists( s:string):  boolean;
{ returns true  if file exists }
var 
    fd:  filedesc;
    result: boolean;
    temp : character;
    dummy: boolean;
begin
    fileExists := true;
    fd   := Sopen(s,IOREAD);
    Sclose(fd);
    Exists := fileExists;
end;


procedure PutCon( x:cstring;
	           fd:filedesc);
{ output literal }
var 
    s: string;
begin
    CtoS(x,s);
    PutStr(s,fd);
end;


procedure PutCln;
{ output literal followed by NEWLINE }
begin
    PutCon(x,fd);
    Putcf(NEWLINE,fd);
end;


procedure PutNum( n:integer;
		  fd:filedesc);
{ Ouput number  }
var 
    s: string;
    dummy: integer;
begin
    s[1] := BLANK;
    dummy := ItoC(n,s,2);
    PutStr(s,fd);
end;


procedure PutCS( x:cstring;
		 s : string;
		 fd:filedesc);
{ output literal & string }
begin
    PutCon(x,fd);
    PutStr(s,fd);
    Putcf(NEWLINE,fd);
end;


procedure PutCN;
{ output literal & number }
begin
    PutCon(x,fd);
    PutNum(v,fd);
    Putcf(NEWLINE,fd);
end;


procedure AddTo;
begin
    sum := sum + inc;
end;


procedure OverHd( p,f: Stats;
		  var o:integer);
{ Calculate OverHead as % }
{ 0verHead := (p-f)*100/f }
begin
    if (f <> 0) then
	o := ((p - f)*100) div f
    else
	o := 100;
end;


procedure CalRat( f:   Stats;
		  t:integer;
		  var r:integer);
{ Calculate Effective Baud Rate }
{ Rate  = f*10/t }
begin
    if (t <> 0) then
	r := (f * 10) div t
    else
	r := 0;
end;


procedure BadVTerminalConnect;
{ Inform user that connection was not valid. }
begin
    PutCon(' ? VTerm Connection ',ControlOUT);
    PutCln('not established     ',ControlOUT);
end;


procedure DebugMessage;
{ Print writeln if debug }
begin
    if debug
	then
	    Putcln(c,STDERR);
end;


procedure CopyStringVMS(var fileSpec : string80;
			var newFile : string);
{  System dependent procedure to copy a VMS string to a STIP string }
var
    tempFile : cstring;
    i : integer;
begin
    tempFile := '                    ';
    for i:=1 to CONLENGTH do
	tempFile[i] := fileSpec[i];
    CtoS(tempFile, newFile);
end;


procedure CheckTypeAhead(var consoleChar : InType);

const
    ABORTCONs = 'a';
    ABORTCONL = 'A';
    
type

    $UBYTE = [byte] 0..255;
    $WORD =  [word] -32768..32767;
    blotto = [unsafe] array[1..500] of $UBYTE;
    typeAhead = packed record
			   case boolean of
		   		true : ( a : blotto);
		   		false: ( b : [unsafe] array[1..250] of $WORD);
			   end;

var
    infoTypeAhead : typeAhead;
    blottoreal : blotto;
    statqiow, sensemode, i, typeAheadCnt : integer;
    tempChar : character;

begin

    consoleChar := nothing;

    sensemode := io$_sensemode + io$m_typeahdcnt;
    statqiow := $qiow(,
		       localChannel,
		       sensemode,,,,
		       blottoreal,,,,,);

    for i:=1 to 8 do
	infoTypeAhead.a[i] := blottoreal[i];

    typeAheadCnt := infoTypeAhead.b[1];

    if (typeAheadCnt > 0) then
	begin
	    statqiow := $qiow(,
				localChannel,
				locReadFunc,,,,
				blottoreal,
				typeAheadCnt,,,,);
	    tempChar := blottoreal[1];
	    if ((tempChar = ord(ABORTCONs)) or (tempChar = ord(ABORTCONL))) then
		begin
		    consoleChar := abortnow;
		    if (local) then
			PutCln('Aborting Transfer   ', STDERR)
		end
	    else if (tempChar = CR) then
		begin
		    consoleChar := CRin;
		    if (local) then
			PutCln('Resending Packet    ', STDERR)
		end;
	end;

end;


procedure ClockVMS(var timeState : timeArray);
{  System dependent routine to obtain clock time from VMS. }
var
    status : integer;
begin
    status := $gettim(timeState);
    if (status <> ss$_normal) then
	PutCN('Bad sys$gettim      ',status, STDERR);

end;


function TotalRunTimeVMS(startTime, endTime : timeArray) : integer;
{  Calculate the total runtime for the transfer }
var
    tempTime3 : timeArray;
    status, i, quotient, remainder, million : integer;
begin

    status := $Subx(endTime, startTime, tempTime3);
    if (status <> ss$_normal) then
	PutCN('Bad multi-add $addx ',status, STDERR);

    million := 10000000;
    status := $ediv(million, tempTime3, quotient, remainder);
    if (status <> ss$_normal) then
	PutCN('Bad multi-div $ediv ', status, STDERR);

    TotalRunTimeVMS := quotient;
end; 


procedure SleepVMS( t:integer);   { pause for t seconds }
{  System Dependent routine for VMS }
type
    { Data TYPES for VMS dependent code }
    $quad = [quad,unsafe] record
			      l0 : unsigned;
			      l1 : integer;
			  end;
var 
    sleepLength : vmsString;
    timConvert : string;
    endPos, status, i : integer;
    binaryTime : $quad;

begin
    DebugMessage('Sleep...            ');
    sleepLength := '0 00:0';
    if ( (t mod 60) = 1)
	then
	    begin
		sleepLength := sleepLength+'1:';
		t := t rem 60;
	    end
	else
	    sleepLength := sleepLength+'0:';

    endPos := ItoC(t, timConvert, 1);

    if (endPos = 2)
	then
	    sleepLength := sleepLength+'0';

    for i:=1 to (endPos-1) do
	   sleepLength := sleepLength+chr(ord(timConvert[i]));

    status := $BINTIM((sleepLength), binaryTime);
    if (not(odd(status)) and (local))
	then
	    PutCln('Sleep: Illegal time ', STDERR);

    status := $SETIMR(SleepEFN, binaryTime);
    if (not(odd(status)) and (local))
	then
	    PutCln('Sleep: Bad set time ', STDERR);

    status := $WAITFR(SleepEFN);
    if (not(odd(status)) and (local))
	then
	    PutCln('Sleep : Hibernation ', STDERR);

end;


procedure PutPacket( p : Ppack); { Output Packet }
var 
    i : integer;
begin
    DebugMessage('PutPacket...        ');
    if (Pad >0)
	then
	    for i := 1 to Pad do
		Putcf(PadChar,LineOut);
     with p^ do
	 begin
	     Putcf(mark,LineOut);
	     Putcf(count,LineOut);
	     Putcf(seq,LineOut);
	     Putcf(ptype,LineOut);
	     PutStr(data,LineOut);
	 end;

     FlushPutBufferVMS;
end;


function GetIn  : character;  { get character    }
{ Should return NULL ( ENDSTR ) if  no characters }
var
	c : character;
begin
    curBuffPoint := curBuffPoint + 1;

    if (curBuffPoint <= vmsChRead) then
	c := vmsReadBuff[curBuffPoint]
    else
	c := ENDOFQIO;

    GetIn := c;
    if (c <> ENDSTR) then
	AddTo(ChInPackRecv,1)
end;


function MakeChar(   c:character):  character;
{ convert integer to printable }
begin
    MakeChar := c+BLANK;
end;


function UnChar( c:character):  character;
{ reverse of makechar }
begin
    UnChar := c-BLANK
end;


function IsControl( c:character):  boolean;
{ true if control }
begin
    IsControl := (c=DEL ) or (c < BLANK );
end;


function Ctl( c:character):  character;
{ c XOR 100 }
begin
    if IsControl(c)
	then
	    c := c+64
	else
	    c := c-64;
    Ctl := c;
end;


function Checkfunction( c:integer):  character;
{ calculate checksum }
var 
    x: integer;
begin
    DebugMessage('Checkfunction...    ');
    {    Checkfunction := (c + ( c and 300 ) /100 ) and 77; }
    x := (c MOD 256 ) DIV 64;
    x := x+c;
    Checkfunction := x MOD 64;
end;


procedure EnCodeParm( var data:string);    { encode parameters }
var 
    i: integer;
begin
    DebugMessage('EnCodeParm...       ');
    for i:=1 to NUMPARAM do
	data[i] := BLANK;
    data[NUMPARAM+1] := ENDSTR;
    data[1] := MakeChar(SizeRecv);     { my  biggest packet }
    data[2] := MakeChar(MyTimeOut);         { when I want timeout}
    data[3] := MakeChar(MyPad);             { how much padding }
    data[4] := Ctl(MyPadChar);              { my padding character }
    data[5] := MakeChar(myEOL);             { my EOL }
    data[6] := MyQuote;                     { my quote char  }
end;


procedure DeCodeParm( var data:string); {   decode parameters }
begin
    DebugMessage('DeCodeParm...       ');
    SizeSend := UnChar(data[1]);
    TheirTimeOut := UnChar(data[2]);   { when I should time  out }
    Pad := UnChar(data[3]);            { padding characters  to send  }
    PadChar := Ctl(data[4]);           { padding character }
    SendEOL := UnChar(data[5]);        { EOL to send }
    SendQuote := data[6];              { quote to send }
end;


procedure StartRun; { initialization as necessary }
begin
    DebugMessage('StartRun...         ');
    ClockVMS(startTime);

    NumSendPacks := 0;
    NumRecvPacks := 0;
    NumACK := 0;
    NumNAK := 0;
    NumACKrecv := 0;
    NumNAKrecv := 0;
    NumBADrecv := 0;

    ChInFileRecv := 0;
    ChInFileSend := 0;
    ChInPackRecv := 0;
    ChInPackSend := 0;

    RunTime := 0;

    vmsWritePnt := 0;
    vmsWriteFlg := false;

    State := Init;              { send  initiate is the start state }
    NumTry := 0;                { say no tries  yet }
end;


procedure OpenPortVMS;
var 
    status : integer;
begin
    DebugMessage('OpenPort...         ');
    vTermSetType := LOCALREMOTE;

    LineIN := REMOTECHAN;
    LineOUT := REMOTECHAN;
    openlist[LINEIN].mode := IOREAD;
    openList[LINEOUT].mode := IOREAD;

    status := ss$_normal;
    SetUpVirtualTerminal(remoteChannel, remReadFunc, remWriteFunc,
			 localChannel, locReadFunc, locWriteFunc,
			 status, vTermSetType, localEcho, parity, lSpeed);
    if (status <> ss$_normal) then
	invalidConnection := true;
end;


procedure VirtualTerminal(var remChanl : integer;
			  var remRFunc : integer;
			  var remWFunc : integer;
			  var locChanl : integer;
			  var locRFunc : integer;
			  var locWFunc : integer;
			  var conStatus : boolean ) ;
fortran;


procedure ConnectVMS;
{ System Dependent connect to remote }
begin
    DebugMessage('Connect...          ');

    VirtualTerminal(remoteChannel, remReadFunc, remWriteFunc,
		    localChannel, locReadFunc, locWriteFunc,
		    invalidConnection);

end;


procedure ResetKermitPacketNumber;
begin
    n := 0;
end;


procedure KermitInit;  { initialize various parameters  & defaults }
begin
    Pad := DEFPAD;               { set defaults }
    MyPad := DEFPAD;
    PadChar := DEFPADCHAR;
    MyPadChar := DEFPADCHAR;
    TheirTimeOut := DEFTIMEOUT;
    MyTimeOut := DEFTIMEOUT;
    Delay := DEFDELAY;
    SizeRecv := MAXPACK;
    SizeSend := MAXPACK;
    SendEOL := DEFEOL;
    MyEOL := DEFEOL;
    SendQuote := DEFQUOTE;
    MyQuote := DEFQUOTE;
    MaxTry := DEFITRY;

    DebugMessage('KermitInit...       ');
    localEcho := oOFF;
    parity := oNONE;
    lSpeed := o4800BAUD;
    fileWarn := oON;
    fileEol := oCLF;
    lastFile := false;
    Local := false;      { default to remote }

    OneWayOnly := false;
    Debug := false;
    debugging := oOFF;
    Runtype := invalid;

    DiskFile := IOERROR;      { to indicate  not open yet }
    LineIN := LOCALCHAN;
    LineOUT := LOCALCHAN;
    ControlIN := STDIN;
    ControlOUT := STDOUT;

    new(ThisPacket);
    new(LastPacket);
    new(CurrentPacket);
    new(NextPacket);
    new(InputPacket);
end;


procedure FinishUp;
{ do any  end of transmission clean up }
begin
    DebugMessage('FinishUp...         ');

    Sclose(DiskFile);

    ClockVMS(endTime);
    if not(noErrors) then
        RunTime := TotalRunTimeVMS(startTime, endTime)
    else
	begin
	    ErrorPack('Aborting Transfer   ');
	    RunTime := 0;
	end;

    oldRunType := RunType;
    lastFile := false;
    PutCf(NEWLINE, ControlOUT);

end;


procedure DebugPacket(    mes : cstring;
		        var p : Ppack);
{ Print Debugging Info }
begin
    DebugMessage('DebugPacket...      ');
    PutCon(mes,STDERR);
    with p^ do
	begin
	    PutNum(Unchar(count),STDERR);
	    PutNum(Unchar(seq),STDERR);
	    Putcf(BLANK,STDERR);
	    Putcf(ptype,STDERR);
	    Putcf(NEWLINE,STDERR);
	    PutStr(data,STDERR);
	    Putcf(NEWLINE,STDERR);
	end;
end;


procedure ReSendPacket;
{ re -sends previous packet }
begin
    DebugMessage('ReSendPacket...     ');
    NumSendPacks := NumSendPacks+1;
    if Debug
	then
	    DebugPacket('Re-Sending ...      ',LastPacket);
    PutPacket(LastPacket);
end;


procedure SendPacket;
{ expects count as  length of data portion }
{ and seq as number of packet }
{ builds &  sends packet }
var 
    i,len,chksum : integer;
    temp : Ppack;
begin
    DebugMessage('Sending Packet      ');
    if (NumTry <> 1) and (Runtype = Transmit )
	then
	    ReSendPacket
	else
	    begin
		with ThisPacket^ do
		    begin
			mark := SOH;               { mark }
			len := count;             {  save length }
			count := MakeChar(len+3); {  count = 3+length of data }
			seq := MakeChar(seq);     {  seq number }
			chksum := count + seq + ptype;
			if ( len > 0)
			    then      { is there data ? }
				for i:= 1 to len do
				    chksum := chksum + data[i];       { loop for data }
			chksum := Checkfunction(chksum);  {  calculate  checksum }
			data[len+1] := MakeChar(chksum);  {  make printable & output }
			data[len+2] := SendEOL;                    { EOL }
			data[len+3] := ENDSTR;
		    end;

		NumSendPacks := NumSendPacks+1;
		if Debug
		    then
			DebugPacket('Sending ...         ',ThisPacket);
		PutPacket(ThisPacket);

		if Runtype = Transmit
		    then
			begin
			    temp := LastPacket;
			    LastPacket := ThisPacket;
			    ThisPacket := temp;
			end;
	    end;
end;


procedure SendACK(   n:integer); { send ACK  packet }
begin
    DebugMessage('SendAck...          ');
    with ThisPacket^ do
	begin
	    count := 0;
	    seq := n;
	    ptype := TYPEY;
	end;
    SendPacket;
    NumACK := NumACK+1;
end;

procedure SendNAK(   n:integer); { send NAK  packet }
begin
    DebugMessage('SendNAK...          ');
    with ThisPacket^ do
	begin
	    count := 0;
	    seq := n;
	    ptype := TYPEN;
	end;
    SendPacket;
    NumNAK := NumNAK+1;
end;


procedure ErrorPack;
{ output Error packet if necessary  -- then exit }
begin
    DebugMessage('ErrorPack...        ');
    with ThisPacket^ do
        begin
	    seq := n;
	    ptype := TYPEE;
	    CtoS(c,data);
	    count := LengthSTIP(data);
	end;
    SendPacket;
end;


procedure PutErr( c:cstring);
{ Print error_messages }
begin
    DebugMessage('PutErr...           ');
    if Local then
	begin
	    Putcln(c,STDERR);
	end;
end;


procedure Field1; { Count }
var 
    test: boolean;
begin
    DebugMessage('Field1...           ');
    with NextPacket^ do
	begin
	    InputPacket^.count := t;
	    count := UnChar(t);
	    test := (count >= 3) or (count <= SizeRecv-2);
	    if not test
		then
		    DebugMessage('Bad count           ');
	    isgood := isgood and test;
	end;
end;


procedure Field2; { Packet Number }
var 
    test : boolean;
begin
    DebugMessage('Field2...           ');
    with NextPacket^ do
	begin
	    InputPacket^.seq := t;
	    seq := UnChar(t);
	    test := (seq >= 0) or (seq <= 63);
	    if not test
		then
		    DebugMessage('Bad seq number      ');
	    isgood := isgood and test;
	end;
end;


procedure Field3; { Packet type }
var 
    test : boolean;
begin
    DebugMessage('Field3...           ');
    with NextPacket^ do
	begin
	    ptype := t;
	    InputPacket^.ptype := t;

	    test := (t =TYPEB) or (t=TYPED) or (t=TYPEE) or (t=TYPEF)
		    or (t=TYPEN) or (t=TYPES) or (t=TYPEY) or (t=TYPEZ);
	    if not test
		then
		    DebugMessage('Bad Packet type     ');
	    isgood := isgood and test;
	end;
end;


procedure Field4; { Data }
begin
    DebugMessage('Field4...           ');
    PacketPtr := PacketPtr+1;
    InputPacket^.data[PacketPtr] := t;
    with NextPacket^ do
	begin
	    if t=MyQuote
		then    { character  is quote }
		    begin
			if control
			    then        { quote ,quote  }
				begin
				    data[dataptr] := MyQuote;
				    dataptr := dataptr+1;
				    control := false;
				end
			    else      { set  control on }
				control := true
		    end
		else                 { not quote }
		    if control
			then      {  convert to control }
			    begin
				data[dataptr] := ctl(t);
				dataptr := dataptr+1;
				control := false
			    end
			else      {  regular data }
			    begin
				data[dataptr] := t;
				dataptr := dataptr+1;
			    end;
	end;
end;


procedure Field5; { Check Sum }
var 
    test : boolean;
begin
    DebugMessage('Field5...           ');
    with InputPacket^ do
	begin
	    PacketPtr := PacketPtr +1;
	    data[PacketPtr] := t;
	    PacketPtr := PacketPtr +1;
	    data[PacketPtr] := ENDSTR;
	end;
    {  end of input string }
    check := Checkfunction(check);
    check := MakeChar(check);
    test := (t=check);
    if not test
	then
	    DebugMessage('Bad CheckSum        ');
    isgood := isgood and test;
    NextPacket^.data[dataptr] := ENDSTR;
    {  end of data string }
    finished := true;  { set finished }
end;


procedure BuildPacket;
{ receive packet &  validate checksum }
var 
    temp : Ppack;
begin
    DebugMessage('BuildPacket...      ');
    with NextPacket^ do
	begin
	    if restart
		then
		    begin
			{ read until get SOH marker }
			if  (t = SOH)
			    then
				begin
				    finished := false;    {  set varibles }
				    control := false;
				    isgood := true;
				    seq := -1;       { set return values to  bad packet }
				    ptype := QUESTION;
				    data[1] := ENDSTR;
				    data[MAXSTR] := ENDSTR;
				    restart := false;
				    fld := 0;
				    dataptr := 1;
				    PacketPtr := 0;
				    check := 0;
				end;
		    end
		else                          { have started packet  }
		    begin
			if (t=SOH)          { check  for restart or EOL }
			    then
				restart := true
			    else
				if (t=myEOL)
				    then
					begin
					    finished := true;
					    isgood := false;
					end
				    else
					begin
					    case fld of
						{ increment  field number }
						0:   fld := 1;
						1:   fld := 2;
						2:   fld := 3;
						3: 
						     if (count=3)  { no data }
							 then
							     fld := 5
							 else
							     fld := 4;
						4: 
						     if (PacketPtr>=count-3) { end of  data }
							 then
							     fld := 5;
					    end { case };

					    if (fld<>5)
						then
						    check := check+t; { add  into checksum }

					    case fld of
						1:      Field1;
						2:      Field2;
						3:      Field3;
						4:      Field4;
						5:      Field5;
					    end; { case }
					end;
		    end;

	    if finished
		then
		    begin
			if (ptype=TYPEE)  and isgood
			    then   { error_packets }
				begin
				    if Local
					then
					    PutStr(data,STDERR);
				    Putcf(NEWLINE,STDERR);
				    FinishUp(false);
				    ProgramHalt;
				end;
			NumRecvPacks := NumRecvPacks+1;
			if Debug
			    then
				begin
				    DebugPacket('Received ...        ',InputPacket);
				    if isgood
					then
					    PutCln('Is Good             ',STDERR);
				end;
			temp := CurrentPacket;
			CurrentPacket := NextPacket;
			NextPacket := temp;
		    end;
	end;
end;


function ReceivePacket: boolean;
begin
    DebugMessage('ReceivePacket...    ');
    finished := false;
    restart := true;
    FromConsole := nothing;  { No Interupt }

    {  Obtain packet from VMS incoming channel }
    vmsChRead := GetVMSPacket(LineIn);

    {  Check local terminal for abort, resend character }
    if local then
	begin
	     CheckTypeAhead(FromConsole);
	     case FromConsole of
		 abortnow: 
			   begin
			       FinishUp(true);
			       ProgramHalt;
			   end;
		 nothing:        { nothing };
		 CRin: 
			   begin
			       t := MyEOL;
			       FromConsole := nothing;
			   end;
	      end;
	end;

    if (vmsChRead = 0)   { Determine if any characters were read }
	then
	    begin
		ReceivePacket := false;
		if (timeOutStatus)
		    then
			begin
			    CurrentPacket^.ptype := TYPET;
			    restart := true;
			    PutCln('Timed Out           ', STDERR)
			end;
	    end
	else begin
		 repeat
		     t := GetIn;
 	 
		     if (t<>ENDOFQIO)
			 then
			     BuildPacket
		     else
			begin
		 	    finished := true;
			    isgood := false;
			end;
		 until finished;

		 ReceivePacket := isgood;
	     end;
end;


function ReceiveACK :    boolean;
{ receive ACK with  correct number }
var 
    Ok: boolean;
begin
    DebugMessage('ReceiveACK...       ');
    if (not OneWayOnly )
	then
	    Ok := ReceivePacket;
    with CurrentPacket^ do
	begin
	    if (ptype=TYPEY)
		then
		    NumACKrecv := NumACKrecv+1
		else
		    if (ptype=TYPEN)
			then
			    NumNAKrecv := NumNAKrecv+1
			else
			    if not OneWayOnly
				then
				    NumBadrecv := NumBadrecv +1;
	    { got right  one ? }
	    ReceiveACK := ( Ok and (ptype=TYPEY) and (n=seq))
			  or  ( OneWayOnly)
	end;
end;


procedure GetData(   var newstate:KermitStates);
{ get data from file into ThisPacket }
var 
    { and return next state - data &  EOF }
    x,c : character;
    i: integer;
begin
    DebugMessage('GetData...          ');
    if (NumTry=1)
	then
	    begin
		i := 1;
		x := ENDSTR;
		with ThisPacket^ do
		    begin
			while (i< SizeSend - 8 ) and (x <> ENDFILE) do
			    { leave room for quote  & NEWLINE }
			    begin
				x := Getcf(c,DiskFile);
				if (x<>ENDFILE)
				    then
					if (IsControl(x)) or (x=SendQuote)
					    then
						begin           { control char -- quote }
						    if x=NEWLINE
							then      {  use proper EOL }
							    case EOLFORFILE of
								LineFeed:   { ok as  is };
								CrLf: 
								      begin
									  data[i] := SendQuote;
									  i := i+1;
									  data[i] := Ctl(CR);
									  i := i+1;
									  { LF  will sent below }
								      end;
								JustCR:     x := CR;
							    end { case };
						    data[i] := SendQuote;
						    i := i+1;
						    if (x<>SendQuote)
							then
							    data[i] := Ctl(x)
							else
							    data[i] := SendQuote;
						end
					    else               { regular char }
						data[i] := x;

				if (x<>ENDFILE)
				    then
					begin
					    i := i+1;    { increase  count for next char }
					    AddTo(ChInFileSend,1);
					end;
			    end;

			data[i] := ENDSTR;   { to terminate  string }

			count := i -1;       { length }
			seq := n;
			ptype := TYPED;

			if (x=ENDFILE)
			    then
				begin
				    newstate := EOFile;
				    Sclose(DiskFile);
				end
			    else
				newstate := FileData;
			SaveState := newstate;        { save state }
		    end
	    end
	else
	    newstate := SaveState;        {  get old state }
end;


function GetFileVMS(    fileName : string80;
		    var newFileName : string;
		    var nextFilePnt : integer;
		    var lastFile : boolean) : boolean;
{  Routine to get a new file from VMS }
var
    vmsFileIn, vmsFileRes : varying[80] of char;
    stat, i, lenStr, tempPnt : integer;
    tempFile : cstring;

begin
    vmsFileIn := fileName;
    tempPnt := nextFilePnt;
    stat := $Find_File(fileName := vmsFileIn,
		       resultName := vmsFileRes,
		       context := tempPnt);
    nextFilePnt := tempPnt;
    if ((stat <> rms$_normal) or (lastFile)) then
	begin
	    if (stat = rms$_fnf) and (RunType <> Receive) then
		    PutErr('VMS - File Not Found')
	    else if (stat = rms$_typ) then
		    PutErr('VMS - File Type Err ')
	    else if (stat <> rms$_normal) and (stat <> rms$_nmf) and
		    (RunType <> Receive) then
		    PutErr('VMS - RMS file Error');
	    GetFileVMS := false;
	    lastFile := true;
	end
    else
	begin
	    i := index(vmsFileRes,']');
	    lenStr := length(vmsFileRes) - i;
	    vmsFileRes := substr(vmsFileRes, i+1, lenStr);
	    i := index(vmsFileRes, ';');
	    vmsFileRes := substr(vmsFileRes, 1, i-1);
	    tempFile := vmsFileRes;
	    CtoS(tempFile, newFileName);
	    GetFileVMS := true;
	end;
end;
    

function GetNextFile:    boolean;
{ get next  file to send in ThisPacket }
{ returns true if no more }
var 
    result: boolean;
begin
    DebugMessage('GetNextFile...      ');
    result := true;
    if (NumTry=1)
	then
	    with ThisPacket^ do
		begin
		    if GetFileVMS(fileSpec, data, vmsFilePnt, lastFile)
			then
			    begin            { open file  }
				if Exists(data)
				    then
					begin
					    DiskFile := Sopen(data,IOREAD);
					    count := LengthSTIP(data);
					    AddTo(ChInFileSend , count);
					    seq := n;
					    ptype := TYPEF;
					    if DiskFile <= IOERROR
						then
						    begin
							FinishUp(true);
							ProgramHalt;
						    end;
					    result := false;
					end;
			    end;
		end
	    else
		result := false; { for saved packet  }
    GetNextFile := result;
end;


procedure SendFile; { send file name  packet }
begin
    DebugMessage('SendFile...         ');
    if NumTry > MaxTry
	then
	    begin
		PutErr ('Send file - Too Many');
		State := Abort;      { too many tries, abort }
	    end
	else
	    begin
		NumTry := NumTry+1;
		if GetNextFile
		    then
			begin
			    State := Break;
			    NumTry := 0;
			end
		    else
			begin
                            if ((NumTry = 1) and (local) and (fileWarning))
				then
				    PutCs('Sending File...     ',
					    ThisPacket^.data, controlOUT);
			    if debug
				then
				    begin
					if (NumTry = 1)
					    then
						PutStr(ThisPacket^.data,STDERR)
					    else
						PutStr(LastPacket^.data,STDERR);
					Putcf(NEWLINE,STDERR);
				    end;
			    SendPacket;     { send this packet }
			    if ReceiveACK
				then
				    begin
					State := FileData;
					NumTry := 0;
					n := (n+1) MOD 64;
				    end
			end;
	    end;
end;


procedure SendData;  { send file data packets }
var 
    newstate: KermitStates;
begin
    DebugMessage('SendData...         ');
    if debug
	then
	    PutCN ( 'Sending data        ',n,STDERR);
    if NumTry > MaxTry
	then
	    begin
		State := Abort;       { too  many tries, abort }
		PutErr ('Send data - Too many');
	    end
	else
	    begin
		NumTry := NumTry+1;
		GetData(newstate);
		SendPacket;
		if ReceiveACK
		    then
			begin
			    State := newstate;
			    NumTry := 0;
			    n := (n+1) MOD 64;
			end
	    end;
end;


procedure SendEOF;    { send  EOF  packet }
begin
    DebugMessage('SendEOF...          ');
    if NumTry > MaxTry
	then
	    begin
		State := Abort;       { too  many tries, abort }
		PutErr('Send EOF - Too Many ');
	    end
	else
	    begin
		NumTry := NumTry+1;
		if (NumTry = 1)
		    then
			begin
			    with ThisPacket^ do
				begin
				    ptype := TYPEZ;
				    seq := n;
				    count := 0;
				end;
			    Sclose(DiskFile);
			end;
		SendPacket;
		if ReceiveACK
		    then
			begin
			    State := FileHeader;
			    NumTry := 0;
			    n := (n+1) MOD 64;
			end
	    end;
end;


procedure SendBreak; { send break packet }
begin
    DebugMessage ('Sending break       ');
    if NumTry > MaxTry
	then
	    begin
		State := Abort;       { too  many tries, abort }
		PutErr('Send break -Too Many');
	    end
	else
	    begin
		NumTry := NumTry+1;
		{ make up packet  }
		if NumTry = 1
		    then
			begin
			    with ThisPacket^ do
				begin
				    ptype := TYPEB;
				    seq := n;
				    count := 0;
				end
			end;
		SendPacket; { send this packet }
		if ReceiveACK
		    then
			begin
			    State := Complete;
			end
	    end;
end;


procedure SendInit;  { send init packet }
begin
    DebugMessage ('Sending init        ');
    if NumTry > MaxTry
	then
	    begin
		State := Abort;      { too many tries, abort }
		PutErr('Cannot Initialize   ');
	    end
	else
	    begin
		NumTry := NumTry+1;
		if (NumTry = 1)
		    then
			begin
			    with ThisPacket^ do
				begin
				    EnCodeParm(data);
				    count := NUMPARAM;
				    seq := n;
				    ptype := TYPES;
				end
			end;

		 SendPacket; { send this packet }
		 if ReceiveACK
		     then
			 begin
			     with CurrentPacket^ do
				 begin
				     if OneWayOnly
					 then  { use  same data if test mode }
					     data := LastPacket^.data;
				     SizeSend := UnChar(data[1]);
				     TheirTimeOut := UnChar(data[2]);
				     Pad := UnChar(data[3]);
				     PadChar := Ctl(data[4]);
				     SendEOL := CR;  { default to CR  }
				     if (LengthSTIP(data) >= 5)
					 then
					     if (data[5] <> 0)
						 then
						     SendEOL := UnChar(data[5]);
				     SendQuote := SHARP;  { default # }
				     if (LengthSTIP(data) >= 6)
					 then
					     if (data[6] <> 0)
						 then
						     SendQuote := data[6];
				 end;

			     State := FileHeader;
			     NumTry := 0;
			     MaxTry := DEFTRY;  { use regular default now  }
			     n := (n+1) MOD 64;
			 end;
	    end;
end;


procedure SendSwitch;
{ Send-switch is the state  table switcher for sending files.
* It loops until either it is finished or a fault is encountered.
* Routines called by sendswitch are responsible for changing the state. }

begin
    DebugMessage ('Send Switch         ');
    if (not OneWayOnly )
	then
	    SleepVMS(Delay);
    StartRun;
    repeat
	case State of
	    FileData:     SendData;         { data-send state }
	    FileHeader:   SENDFILE;         { send file name }
	    EOFile:       SendEOF;          { send end-of-file }
	    Init:         SendInit;         { send initialize }
	    Break:        SendBreak;        { send break }
	    Complete:     {  nothing };
	    Abort:        {  nothing };
	end { case };
    until ( (State = Abort) or (State=Complete) );
end;


procedure GetFile(   data:string);
{ create file from  fileheader packet }

const 
    { used  for GetFile }
      FLEN1 = 10;
      FLEN2 = 13;
      TEMPFILE = 'KERMTEMP.K          ';

var 
    p, strend, i : integer;
    temp : string;
begin
    DebugMessage ('Get File            ');
    with CurrentPacket^ do
	begin
	    if DiskFile = IOERROR      { check if we already have a  file }
		then
		    begin
			{  check position of '.' -- truncate if bad }
			p := IndexSTIP(data,PERIOD);
			if (p > FLEN1 )
			    then
				begin
				    data[FLEN1] := PERIOD;
				    Scopy(data,p+1,temp,1);
				    Scopy(temp,1,data,FLEN1+1);
				end;
			{  check Max length }
			p := LengthSTIP(data);
			if p > FLEN2
			    then
				data[FLEN2 +1] := ENDSTR
			else
			    begin
				data[p +1] := PERIOD;
				data[p +2] := ENDSTR;
			    end;
			
			if Exists(data)
			    then
				begin
				    if ((local) and (fileWarning))
					then
					    PutCS('File already exists ',data,
						ControlOUT)
				    else if (debug)
					then
					    PutCS('File already exists ',data,
						STDERR);
				    CtoS(TEMPFILE,data);
				    strend := 0;
				    repeat
					strend := strend +1;
				    until (data[strend] = BLANK);
				    strend := ItoC(n,data,strend);
				end;
			if ((local) and (fileWarning))
 			    then
  				PutCS('Receiving File...   ',data, ControlOUT)
			else if (debug)
 			    then
  				PutCS('Creating  ...       ',data,STDERR);
			DiskFile := Sopen(data,IOWRITE);
		    end;
	    if (Diskfile <= IOERROR)
		then
		    begin
			FinishUp(true);
			ProgramHalt;
		    end;
	end;
end;


procedure ReceiveInit;
{ receive init packet }
{ respond with ACK  and  our parameters }
var
	receiveStat : boolean;
begin
    DebugMessage ('ReceiveInit...      ');
    if NumTry > MaxTry
	then
	    begin
		State := Abort;
		PutErr('Cannot receive init ');
	    end
	else
	    begin
		NumTry := NumTry+1;
		receiveStat := ReceivePacket;
		if (ReceiveStat and (CurrentPacket^.ptype = TYPES))
		    then
			begin
			    with CurrentPacket^ do
				begin
				    n := seq;
				    DeCodeParm(data);
				end;

			    {  now send mine }
			    with ThisPacket^ do
				begin
				    count := NUMPARAM;
				    seq := n;
				    Ptype := TYPEY;
				    EnCodeParm(data);
				end;

			    SendPacket;

			    NumACK := NumACK+1;
			    State := FileHeader;
			    OldTry := NumTry;
			    NumTry := 0;
			    MaxTry := DEFTRY; { use  regular default now }
			    n := (n+1) MOD 64
			end
		    else
			begin
			    if Debug
				then
				    PutCln('Received Bad init   ',STDERR);
			    SendNAK(n);
			end;
	    end;
end;


procedure DataToFile; { output to file }

var 
    len,i : integer;
    temp : string;
begin
    DebugMessage ('DataToFile...       ');
    with CurrentPacket^ do
	begin
	    len := LengthSTIP(data);
	    AddTo(ChInFileRecv ,len);
	    case EOLFORFILE of
		LineFeed:     PutStr(data,DiskFile);
		CrLf: 
		      begin  { don't output   CR }
			  for i:=1 to len do
			      if data[i] <> CR
				  then
				      Putcf(data[i],DiskFile);
		      end;
		JustCR: 
			begin   { change CR  to NEWLINE }
			    for i:=1 to len do
				if data[i]=CR
				    then
					data[i] := NEWLINE;
			    PutStr(data,DiskFile);
			end;
	    end; { case  }
	end;
end;


procedure dodata;  {  Process Data packet }
begin
    DebugMessage ('DoData...           ');
    with CurrentPacket^ do
	begin
	    if  seq = ((n + 63) MOD 64)
		then
		    begin                { data last one }
			if OldTry>MaxTry {  number of tries? }
			    then
				begin
				    State := Abort;
				    PutErr('Old data - Too many ');
				end
			    else
				 begin
				     SendACK(seq);
				     NumTry := 0;
				 end;
		     end
		 else
		     begin            { data  - this one }
			 if (n<>seq)
			     then
				 SendNAK(n)
			     else
				 begin
				     DataToFile;
				     SendACK(n); { ACK }
				     OldTry := NumTry;
				     NumTry := 0;
				     n := (n+1) MOD 64;
				 end;
		     end;
	 end;
end;

procedure doFileLast;   { Process File Packet }
begin          { File header - last  one  }
    DebugMessage ('DoFileLast...       ');
    if OldTry > MaxTry { tries ? }
	then
	    begin
		State := Abort;
		PutErr('Old file - Too many ');
	    end
	else
	    begin
		OldTry := OldTry+1;
		with CurrentPacket^ do
		    begin
			if seq = ((n + 63) MOD 64)
			    {  packet number }
			    then
				begin  { send ACK }
				    SendACK(seq);
				    NumTry := 0
				end
			    else
				begin
				    SendNAK(n);   {  NAK }
				end;
		    end;
	    end;
end;


procedure DoEOF;  { Process EOF packet }
begin                 { EOF  - this one }
    DebugMessage ('DoEOF...            ');
    if CurrentPacket^.seq<>n    { packet number ? }
	then
	    SendNAK(n) { NAK }
	else
	    begin               { send ACK }
		Sclose(DiskFile);  { close file }
		SendACK(n);
		OldTry := NumTry;
		NumTry := 0;
		n := (n+1) MOD 64; { next packet  }
		State := FileHeader;   { change state }
	    end;
end;


procedure ReceiveData;  { Receive data packets }

var 
    strend: integer;
    good : boolean;

begin
    DebugMessage ('ReceiveData...      ');
    if NumTry > MaxTry          { check number of tries }
	then
	    begin
		State := Abort;
		if local
		    then
			PutCN('Recv data -Too many ',n,STDERR);
	    end
	else
	    begin
		NumTry := NumTry+1;                { increase number of tries }
		good := ReceivePacket;        { get  packet }
		with CurrentPacket^ do
		    begin
			if debug
			    then
				PutCN('Receiving (Data)    ',CurrentPacket^.seq,STDERR);
			if ((ptype = TYPED) or (ptype=TYPEZ)
			   or (ptype=TYPEF)) and good           { check type }
			    then
				case ptype of
				    TYPED:  doData;
				    TYPEF:  doFileLast;
				    TYPEZ:  doEOF;
				end { case }
			    else
				begin
				    if Debug
					then
					    PutCln('Expected data pack  ',STDERR);
				    SendNAK(n);
				end;
		    end;
	    end;
end;


procedure doBreak; {  Process Break packet }
begin                    { Break transmission }
    DebugMessage ('DoBreak...          ');
    if CurrentPacket^.seq<>n    { packet number ? }
	then
	    SendNAK(n) { NAK }
	else
	    begin            { send   ACK }
		SendACK(n) ;
		State := Complete  { change  state }
	    end;
end;


procedure DoFile; { Process file packet }
begin                 { File Header  }
    DebugMessage ('DoFile...           ');
    with CurrentPacket^ do
	begin
	    if seq<>n           { packet number ? }
		then
		    SendNAK(n)  { NAK }
		else
		    begin               { send ACK }
			AddTo(ChInFileRecv, LengthSTIP(data));
			GetFile(data);   { get file  name }
			SendACK(n);
			OldTry := NumTry;
			NumTry := 0;
			n := (n+1) MOD 64; { next packet  }
			State := FileData;   { change state  }
		    end;
	end;
end;


procedure DoEOFLast; { Process EOF Packet }
begin               { end of File Last One}
    DebugMessage ('DoEOFLast...        ');
    if OldTry > MaxTry { tries ? }
	then
	    begin
		State := Abort;
		PutErr('Old EOF - Too many  ');
	    end
	else
	    begin
		OldTry := OldTry+1;
		with CurrentPacket^ do
		    begin
			if seq =((n + 63 ) MOD 64)
			    {  packet number }
			    then
				begin  { send ACK }
				    SendACK(seq);
				    Numtry := 0
				end
			    else
				begin
				    SendNAK(n);  { NAK }
				end
		    end;
	    end;
end;


procedure DoInitLast;
begin                { Init  Packet - last one }
    DebugMessage ('DoInitLast...       ');
    if OldTry>MaxTry   { number of tries? }
	then
	    begin
		State := Abort;
		PutErr('Old init - Too many ');
	    end
	else
	    begin
		OldTry := OldTry+1;
		if CurrentPacket^.seq = ((n + 63) MOD  64)
		    { packet number }
		    then
			begin   { send ACK }
			    with ThisPacket^ do
				begin
				    count := NUMPARAM;
				    seq := CurrentPacket^.seq;
				    ptype := TYPEY;
				    EnCodeParm(data);
				end;
			    SendPacket;
			    NumACK := NumACK+1;
			    NumTry := 0;
			end
		    else
			begin
			    SendNAK(n);  { NAK }
			end;
	    end;
 end;


procedure ReceiveFile; { receive file packet  }

var 
    good: boolean;

begin
    DebugMessage ('ReceiveFile...      ');
    if NumTry > MaxTry          { check number of tries }
	then
	    begin
		State := Abort;
		PutErr('Recv file - Too many');
	    end
	else
	    begin
		NumTry := NumTry+1;                { increase number of tries }
		good := ReceivePacket;             { get packet }
		with CurrentPacket^ do
		    begin
			if debug
			    then
				PutCN('Receiving (File)    ',seq,STDERR);
			if ((ptype = TYPES) or (ptype=TYPEZ)
			   or (ptype=TYPEF) or (ptype=TYPEB)) { check type }
			   and good
			    then
				case ptype of
				    TYPES:  doInitLast;
				    TYPEZ:  doEOFLast;
				    TYPEF:  doFile;
				    TYPEB:  doBreak;
				end { case }
			    else
				begin
				    if Debug
					then
					    PutCln('Expected File Pack  ',STDERR);
				    SendNAK(n);
				end;
		    end;
	    end;
end;


procedure RecvSwitch; { this procedure  is the main receive routine }
begin
    DebugMessage ('RecvSwitch...       ');
    StartRun;
    repeat
	case State of
	    FileData:       ReceiveData;
	    Init:           ReceiveInit;
	    Break:          {  nothing };
	    FileHeader:     ReceiveFile;
	    EOFile:         {  nothing };
	    Complete:       {  nothing };
	    Abort:          {  nothing };
	end;
    {  case }
    until (State = Abort ) or ( State = Complete );
end;


procedure KermitMain; { Main  procedure }

var 
    aline : string;
    j : integer;
    errorOccurred : boolean;
begin

    DebugMessage ('KermitMain...       ');

    errorOccurred := false;
    case Runtype of
	Receive: 
		 begin { filename is optional here }
		     if (rFileSpec = oON) then
			 begin
			     CopyStringVMS(fileSpec, aline);
			     if ((Exists(aline)) and (local)) then
				 PutCS('Overwriting         ',aline,STDERR);
			     DiskFile := Sopen(aline, IOWRITE);
			     if (DiskFile <= IOERROR) then
			 	 begin
			     	     PutErr('Cannot Open File    ');
			     	     errorOccurred := true;
			 	 end
			     else
				 if (local) then
  				     PutCS('Receiving File...   ',
						aline, ControlOUT);
			     rFileSpec := oOFF;
			 end;

		     if not(errorOccurred) then
		         RecvSwitch;
		 end;
	Transmit:  
		 SendSwitch;

	 Invalid:        { nothing };
	SetParm:        { nothing };
	Alldone:               { nothing };
    end; {  case }

    FinishUp(errorOccurred); { end  of program }

end { main   };

{  Include the parser into kermit. }
%include   'kermdir:parser.pas'

begin

    ctrlOff := LIB$M_CLI_CTRLY;
    stat := $Disable_ctrl(ctrlOff);

    SetUpExitHandlerVMS(1, 6);   { VMS dependent routine }

    KermitInit;       { initialize }

    initio;

9999: { Goto for an error packet }
    RunType := Invalid;

    while not(exitProgram) do
	begin

	    PromptAndParseUser(exitProgram, RunType);

	    if not(exitProgram) then
		begin
		    ResetKermitPacketNumber;
		    case RunType of
			Receive,
			 Transmit : 
                            if not(invalidConnection) then
 				KermitMain
			    else
				BadVTerminalConnect;
			Connect :
			    begin
				local := true;
				OpenPortVMS;
				if not(invalidConnection) then
 				    ConnectVMS
				else
				    BadVTerminalConnect; 
			    end;
		    end;
		end;
	    RunType := Invalid;
	end;

        SetUpExitHandlerVMS(0, 4);   { VMS dependent routine }

        stat := $Enable_Ctrl(ctrlOff);

end.
