home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
pub
/
vmspascal
/
vxkerm.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2020-01-01
|
69KB
|
3,178 lines
{
Program : KERMIT.PAS - Main program
PARSER.PAS - Kermit Command Parser
PGLOBAL.PAS - Parser Global Definitions
VERSION.PAS - Version header & prompts
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.
19-NOV-83 BWP Placed kludge in SLEEPVMS to avoid the problem
with chr function in PASCAL 2.2.
28-NOV-83 BWP Fixed the parsing of the receiveinit packet
so that the quote character was interpretted
correctly.
20-DEC-83 BWP Provided eight-bit quoting facility for the
program.
(Version 1.1)
22-MAY-84 PTM Add error messages for file opens and add
flush of TypeAhead in SendInit.
Add message for non-ascii send in Text file.
(Version 1.1A)
23-JUL-84 PTM On unsucessful receive delete file.
Modify ErrorPack
(Version 1.1B)
26-JUL-84 PTM Increase line length for Text file to 255
on write.
Fix DataToFile for <CR><CR><LF> sequence.
(Version 1.1C)
10-AUG-84 PTM GetData does not quote properly !!
(Version 1.1D)
22-AUG-84 PTM Fix GetData for DEL.
Modify ErrorPack.
(Version 1.1E)
}
{ TOP OF PROGRAM }
[inherit('SYS$LIBRARY:STARLET')]
program Kermit(input,output,file3,file4,binfile,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 }
{ eight bit stuff }
SBIT = 7;
EBIT = 8;
BLKSIZE = 512;
{ universal manifest constants }
NULL = 0;
ENDSTR = -255; { null-terminated strings }
ENDFILE = -256;
ENDOFQIO = -257;
MAXSTR = 100; { longest possible string }
CONLENGTH = 20; { length of constant string }
MAXCHARPERLINE = 255; { Maximum number of characters for file line }
STDCHARPERLINE = 133; { Standard number of characters for file line }
{ ascii character set in decimal }
BACKSPACE = 8;
TAB = 9;
NEWLINE = 10;
BLANK = 32;
EXMARK = 33;
SHARP = 35;
AMPERSAND = 38;
PERIOD = 46;
RABRACK = 62;
QUESTION = 63;
GRAVE = 96;
TILDE = 126;
LETA = 65;
LETZ = 90;
LETsa = 97;
LETsz = 122;
LET0 = 48;
LET9 = 57;
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 = 7; { number of parameters in init packet }
DEFQUOTE = SHARP; { default quote character }
DEFEBQUOTE = AMPERSAND;
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;
{ Command parser constants }
SMALLSIZE = 13;
LARGESIZE = 80;
MINPACKETSIZE = 10;
MAXPACKETSIZE = 94;
%include 'kermdir:pglobal.pas'
type
character = ENDOFQIO..127; { byte-sized. ascii + other stuff }
schar = -128..127;
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 : -IOWRITE..IOWRITE;
ftype : SBIT..EBIT;
end;
{ Eight bit file stuff }
block = packed array[1..BLKSIZE] of char;
binfiletype = file of block;
EBQtype = (Ascii, Binary);
{ 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,Invalid,Connect);
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, 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;
Debug : boolean;
{ Check for received file - was it OK ? }
TransferOK : 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. }
vmsReadModifer : integer;
vmsReadBuff, vmsWriteBuff : packed array[1..VMSBUFSIZE] of schar;
vmsChRead, curBuffPoint, vmsWritePnt, vmsFilePnt, stat : integer;
ctrlOff : integer;
fileExists, lastFile, vmsWriteFlg : boolean;
{ VMS routine exit handler vars. }
exitStatus : integer;
{ Eight Bit Quoting Info }
sentEBQuote, recvdEBQuote, needEBQuote : boolean; { Used for determining 8 bit state }
EBQState : EBQtype; { ... }
EBQchar : character; { Quote character for 8 bit trans }
binfile : binfiletype; { Binary file }
ishigh : integer; { Shift to put high bit on }
binascflg : -1..1; { State of file open binary/ascii }
binbuffer : block; { Buffer for binary data }
binptr : integer; { Binary buffer pointer }
{ Parser defined variables }
commandLine, fileSpec : string80;
exitProgram : boolean;
localEcho, sFileSpec, rFileSpec, lSpeed, transtype : 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;
procedure Greeting; {Kermit Version Message}
const
%include 'kermdir:version.pas'
begin
writeln(VERSION);
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);
file3cnt := 0;
{ initialise all files to seven bit as default }
for i := STDIN to MAXOPEN do
openlist[i].ftype := SBIT;
{ 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 binf : binfiletype;
var linelen : integer);
begin
linelen := 0;
case openlist[i].mode of
IOERROR,
IOAVAIL : { Do Nothing; this should actually not happen };
IOREAD :
begin
open(FILE_VARIABLE := f,
FILE_NAME := intname,
RECORD_LENGTH := 255,
HISTORY := OLD,
ERROR := CONTINUE);
if (status(f) <> NULL) then
begin
openlist[i].mode := IOAVAIL;
i := IOERROR;
fileExists := false
end
else
begin
reset(f, ERROR := CONTINUE);
openlist[i].ftype := SBIT;
end;
end;
-IOREAD :
begin
open(FILE_VARIABLE := binf,
FILE_NAME := intname,
RECORD_TYPE := FIXED,
CARRIAGE_CONTROL := NONE,
RECORD_LENGTH := 512,
HISTORY := OLD,
ERROR := CONTINUE);
if (status(binf) <> NULL) then
begin
openlist[i].mode := IOAVAIL;
i := IOERROR;
fileExists := false
end
else
begin
reset(binf, ERROR := CONTINUE);
openlist[i].ftype := EBIT;
binbuffer := binf^;
binptr := 1;
end;
end;
IOWRITE :
begin
open(FILE_VARIABLE := f,
FILE_NAME := intname,
RECORD_LENGTH := 255,
HISTORY := NEW,
ERROR := CONTINUE);
if (status(f) <> 0) then
begin
openlist[i].mode := IOAVAIL;
i := IOERROR;
end
else
begin
rewrite(f, ERROR := CONTINUE);
openlist[i].ftype := SBIT;
end;
end;
-IOWRITE:
begin
open(FILE_VARIABLE := binf,
FILE_NAME := intname,
RECORD_TYPE := FIXED,
CARRIAGE_CONTROL := NONE,
RECORD_LENGTH := 512,
HISTORY := NEW,
ERROR := CONTINUE);
if (status(binf) <> 0) then
begin
openlist[i].mode := IOAVAIL;
i := IOERROR;
end
else
begin
rewrite(binf, ERROR := CONTINUE);
openlist[i].ftype := EBIT;
end;
binptr := 1;
end;
end;
end;
begin
i := 1;
DebugMessage ('Sopen... ');
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, binfile, file4cnt);
end;
Sopen := i;
found := true
end;
i := i + 1
end
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;
procedure GetBinary(var c : character);
var
x : packed record
case boolean of
true : (c : char);
false: (i : -128..127);
end;
i : integer;
begin
if binptr > BLKSIZE then
begin
get(binfile, ERROR := CONTINUE);
if eof(binfile) then
c := ENDFILE
else
begin
binptr := 1;
binbuffer := binfile^;
GetBinary(c);
end;
end
else
begin
x.c := binbuffer[binptr];
c := x.i;
binptr := binptr + 1;
end;
end;
begin
case fd of
STDIN :
Getcf := getc(c);
STDERR :
Getcfx(file3);
4 :
case openlist[fd].ftype of
SBIT : Getcfx(file4);
EBIT : GetBinary(c);
end;
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 + vmsReadModifer;
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 FlushTypeAhead(mode : boolean);
{ Flush TypeAhead buffer for input line }
begin
if mode then
vmsReadModifer := IO$M_TIMED + IO$M_PURGE
else
vmsReadModifer := IO$M_TIMED;
end;
procedure PutBinary(c : character);
var
i : integer;
begin
if (c = ENDFILE) then
begin { Flush the Buffer }
while (binptr <= BLKSIZE) do
begin
binbuffer[binptr] := chr(NULL);
binptr := binptr + 1;
end;
c := NULL;
end;
if (binptr > BLKSIZE) then
begin
binfile^ := binbuffer;
put(binfile);
binptr := 1;
PutBinary(c);
end
else
begin
binbuffer[binptr] := chr(c);
binptr := binptr + 1;
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;
maxforline :integer);
begin
linelen := linelen + 1;
IF (c = NEWLINE) then
begin
linelen := 0;
writeln(f);
end
else
if (linelen > maxforline) 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 : 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, STDCHARPERLINE);
4 :
case openlist[fd].ftype of
SBIT : Putcfx(file4, file4cnt, MAXCHARPERLINE);
EBIT : PutBinary(c);
end;
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 }
var
DeleteOnClose : boolean;
begin
if (fd > STDERR) and (fd <= MAXOPEN) then
begin
{ Check if file received was OK }
DeleteOnClose := ( abs(openlist[fd].mode) = IOWRITE) and
(not TransferOK);
case fd of
1: { nothing };
2: { nothing };
3:
close(file3, ERROR := CONTINUE);
4:
case openlist[fd].ftype of
SBIT :
if DeleteOnClose then
close(file4, DISPOSITION := DELETE,
ERROR := CONTINUE)
else
close(file4, ERROR := CONTINUE);
EBIT :
begin
if (openlist[fd].mode = -IOWRITE) then
PutBinary(ENDFILE);
if DeleteOnClose then
close(binfile, DISPOSITION := DELETE,
ERROR := CONTINUE)
else
close(binfile, ERROR := CONTINUE);
end;
end;
end;
openlist[fd].mode := IOAVAIL;
end;
fd := IOERROR;
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
DebugMessage ('Exists... ');
fileExists := true;
fd := Sopen(s,IOREAD*binascflg);
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 DebugMessNumb(s : cstring; val : integer);
{ Print message and a number }
begin
if debug then
begin
Putcln(s, STDERR);
PutNum(val, STDERR);
end;
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;
kludgechar : char;
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
begin
kludgechar := chr(timConvert[i]);
sleepLength := sleepLength+kludgechar;
end;
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 <> NULL) 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
if (c >= NULL) then
IsControl := (c = DEL ) or (c < BLANK )
else
IsControl := IsControl(c + 128);
end;
function Ctl( c:character): character;
{ c XOR 100 }
begin
if (c >= NULL) then
if (c < 64) then
c := c + 64
else
c := c-64
else
c := Ctl(c + 128) - 128;
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 SetEBQuoteState;
begin
if (EBQState = Binary) then
begin
transType := oBINARY;
binascflg := oBINSTATE;
end
else
begin
transType := oASCII;
binascflg := oASCSTATE;
end;
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 }
{ Handle eight bit quoting parm }
case RunType of
Transmit :
if EBQState = Binary then
begin
if EBQChar <> DEFEBQUOTE then
begin
data[7] := EBQChar;
sentEBQuote := true;
end
else
data[7] := TYPEY;
end
else
data[7] := TYPEN;
Receive :
if EBQState = Binary then
begin
if recvdEBQuote then
data[7] := TYPEY
else if needEBQuote then
data[7] := EBQChar
else
begin
EBQState := Ascii;
data[7] := TYPEN;
end;
end
else
data[7] := TYPEN;
end;
SetEBQuoteState;
end;
function CheckEBQuote( inchr : character;
var outchr : character) : EBQtype;
begin
if (inchr in [EXMARK..RABRACK, GRAVE..TILDE]) then
begin
outchr := inchr;
CheckEBQuote := Binary
end
else
CheckEBQuote := Ascii;
end;
procedure DeCodeParm( var data:string); { decode parameters }
var
InEBQChar : character;
i,l : integer;
begin
DebugMessage('DeCodeParm... ');
{ Pad with blanks }
l := lengthSTIP(data);
IF l < NUMPARAM
THEN
FOR i := l + 1 TO NUMPARAM DO
data[i] := BLANK;
data[NUMPARAM+1] := ENDSTR;
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 }
{ Handle eight bit quoting parm }
InEBQchar := data[7];
case RunType of
Transmit :
if EBQState = Binary then
begin
if sentEBQuote then
begin
if InEBQchar <> TYPEY then
EBQState := Ascii;
end
else if InEBQchar = TYPEN then
EBQState := Ascii
else
EBQState := CheckEBQuote(InEBQchar, EBQchar);
end;
Receive :
if EBQState = Binary then
begin
if InEBQchar = TYPEY then
needEBQuote := true
else if InEBQchar = TYPEN then
EBQState := Ascii
else
begin
EBQState := CheckEBQuote(InEBQchar, EBQchar);
if EBQState = Binary then
recvdEBQuote := true;
end;
end;
end;
SetEBQuoteState;
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;
FlushTypeAhead(false);
State := Init; { send initiate is the start state }
NumTry := 0; { say no tries yet }
end;
procedure OpenPortVMS;
var
status : integer;
begin
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
VirtualTerminal(remoteChannel, remReadFunc, remWriteFunc,
localChannel, locReadFunc, locWriteFunc,
invalidConnection);
end;
procedure ResetKermitPacketNumber;
begin
n := 0;
end;
procedure KermitInit; { initialize various parameters & defaults }
begin
DebugMessage('KermitInit... ');
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;
EBQChar := DEFEBQUOTE;
MaxTry := DEFITRY;
localEcho := oOFF;
parity := oNONE;
lSpeed := o4800BAUD;
fileEol := oCLF;
transtype := oASCII;
binascflg := oASCSTATE;
lastFile := false;
Local := false; { default to remote }
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
if (data[i] >= 0) then
chksum := chksum + data[i] { loop for data }
else
chksum := chksum + data[i] + 256;
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 remote or print message if local }
var
i : integer;
begin
DebugMessage('ErrorPack... ');
with ThisPacket^ do
begin
seq := n;
ptype := TYPEE;
if local then
CtoS('Kermit: ',data)
else
CtoS('Remote Kermit: ',data);
for i := 1 to CONLENGTH do
data[CONLENGTH + i] := ord(c[i]);
data[CONLENGTH + CONLENGTH + 1] := ENDSTR;
count := LengthSTIP(data);
if local then
begin
putstr(data,STDERR);
putcf(NEWLINE,STDERR);
end
else
SendPacket;
end;
end;
procedure PutErr( c:cstring);
{ Print error_messages }
begin
DebugMessage('PutErr... ');
if Local then
Putcln(c,STDERR);
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 ProcessQuoted; { for data }
begin
with NextPacket^ do
begin
if (t = MyQuote) or ((t = EBQchar) and (EBQState = Binary)) then
begin
if control then
begin
data[dataptr] := t + ishigh;
dataptr := dataptr + 1;
control := false;
ishigh := 0;
end
else if (t = MyQuote) then { Set Control on }
control := true;
end
else if control then
begin
data[dataptr] := ctl(t) + ishigh;
dataptr := dataptr + 1;
control := false;
ishigh := 0;
end
else
begin
data[dataptr] := t + ishigh;
dataptr := dataptr + 1;
ishigh := 0;
end;
end;
end;
procedure Field4; { Data }
begin
PacketPtr := PacketPtr+1;
InputPacket^.data[PacketPtr] := t;
with NextPacket^ do
begin
if ((pType = TYPES) or (pType = TYPEY)) then
begin
data[dataptr] := t;
dataptr := dataptr+1;
end
else
begin
if (EBQstate = Binary) then
begin { Has it been quoted }
if (not(control) and (t = EBQchar)) then
ishigh := 128
else
ProcessQuoted;
end
else
ProcessQuoted;
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
DebugMessNumb('Bad CheckSum= ', check);
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
with NextPacket^ do
begin
if restart then
begin
{ read until get SOH marker }
if (t = SOH) then
begin
finished := false; { set varibles }
control := false;
ishigh := 0; { no shift }
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) 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) then
fld := 5
else
fld := 4;
4:
if (PacketPtr>=count-3) then
fld := 5;
end { case };
if (fld<>5) then
{ add into checksum }
check := check+t;
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(true);
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) then
begin
ReceivePacket := false;
if (timeOutStatus) then
begin
CurrentPacket^.ptype := TYPET;
restart := true;
if (local) then
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... ');
Ok := ReceivePacket;
with CurrentPacket^ do
begin
if (ptype=TYPEY) then
NumACKrecv := NumACKrecv+1
else if (ptype=TYPEN) then
NumNAKrecv := NumNAKrecv+1
else
NumBadrecv := NumBadrecv +1;
{ got right one ? }
ReceiveACK := ( Ok and (ptype=TYPEY) and (n=seq))
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
begin
if (x > DEL) then
begin
ErrorPack('Non-ASCII text char ');
FinishUp(true);
ProgramHalt;
end;
if (x < NULL) then
case EBQstate of
ascii :
begin
ErrorPack('No Binary Support ');
FinishUp(true);
ProgramHalt;
end;
binary :
begin
data[i] := EBQchar;
i := i + 1;
x := x + 128;
end;
end;
if (IsControl(x)) or (x=SendQuote) or
((x = EBQchar) and (EBQState = Binary)) then
begin { control char -- quote }
if ((x=NEWLINE) and
(EBQState <> Binary)) then
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;
{ V1.1D next line should be 'and' }
if (x<>SendQuote) and (x <> EBQchar) then
data[i] := Ctl(x)
else
data[i] := x;
end
else { regular char }
data[i] := x;
end;
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, j, 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;
for j:=(length(vmsFileRes) + 1) to CONLENGTH do
tempFile[j] := ' ';
CtoS(tempFile, newFileName);
newFilename[i] := ENDSTR; { Shorten to correct file length }
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 }
DiskFile := Sopen(data,IOREAD*binascflg);
if DiskFile = IOERROR then
begin
ErrorPack('Cannot open file ');
FinishUp(true);
ProgramHalt;
end;
count := LengthSTIP(data);
AddTo(ChInFileSend , count);
seq := n;
ptype := TYPEF;
result := false;
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)) 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
State := Complete;
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 (NumTry = 1) then { Flush to prevent pile up of NAK's }
FlushTypeAhead(true);
if ReceiveACK then
begin
with CurrentPacket^ do
begin
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;
FlushTypeAhead(false);
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 ');
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;
EXTLEN = 3;
var
p, strend, i, j, periodCnt : integer;
temp : string;
begin
DebugMessage ('GetFile... ');
with CurrentPacket^ do
begin
if DiskFile = IOERROR then
begin
i := 1;
j := 1;
periodCnt := 0;
repeat
if (data[i] in [LETA..LETZ, LETsa..LETsz,
LET0..LET9, PERIOD]) then
begin
temp[j] := data[i];
if data[i] = PERIOD then
begin
p := j;
periodCnt := periodCnt + 1;
end
end
else
begin
temp[j] := j + LET0;
if not (temp[j] in [LET0..LET9]) then
temp[j] := LET0;
end;
i := i + 1;
j := j + 1;
until (data[i] = ENDSTR);
temp[j] := ENDSTR;
j := j - 1;
{ check position of '.' -- truncate if bad }
if periodCnt = 2 then
begin
temp[p] := ENDSTR;
p := IndexSTIP(temp,PERIOD);
end;
if (p > FLEN1 ) then
begin
temp[FLEN1] := PERIOD;
temp[p] := (p mod 10) + LET0;
p := FLEN1;
end;
{ check Max length }
if j > FLEN2 then
begin
temp[FLEN2 +1] := ENDSTR;
j := FLEN2;
end;
if (j >= FLEN1) then
begin
if ((j-p) > EXTLEN) then
if (p <> NULL) then
begin
temp[p +EXTLEN+1] := PERIOD;
temp[p +EXTLEN+2] := ENDSTR;
end
else
temp[j - EXTLEN] := PERIOD;
end
else
begin
temp[j +1] := PERIOD;
temp[j +2] := ENDSTR;
end;
if Exists(temp) then
if (local) or (debug) then
PutCS('File already exists ',temp,
STDERR);
if (local) or (debug) then
PutCS('Creating... ',temp,STDERR);
DiskFile := Sopen(temp,IOWRITE*binascflg);
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
n := CurrentPacket^.seq;
DeCodeParm(InputPacket^.data);
{ 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);
if (EBQState <> Binary) then
case EOLFORFILE of
LineFeed:
PutStr(data,DiskFile);
CrLf:
begin { output CR only if next is not LF }
for i:=1 to len do
if data[i] = CR then
begin
if data[i+1] <> NEWLINE then
Putcf(data[i],DiskFile);
end
else
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
else
PutStr(data, DiskFile);
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 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) then
{ packet number }
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 then { packet number ? }
SendNAK(n) { NAK }
else
begin { send ACK }
TransferOK := true; { Set true before calling Sclose }
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 then { check number of tries }
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 then { check type }
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 then { packet number ? }
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 then { packet number ? }
SendNAK(n) { NAK }
else
begin { send ACK }
AddTo(ChInFileRecv, LengthSTIP(data));
GetFile(data); { get file name }
TransferOK := false;
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 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) then
{ packet number }
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> DEFITRY then
begin
State := Abort;
PutErr('Old init - Too many ');
end
else
begin
OldTry := OldTry+1;
if CurrentPacket^.seq = ((n + 63) MOD 64) then
{ packet number }
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 then { check number of tries }
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*binascflg);
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 };
end; { case }
FinishUp(errorOccurred); { end of program }
end { main };
{ Include the parser into kermit. }
%include 'kermdir:parser.pas/list'
begin
ctrlOff := LIB$M_CLI_CTRLY;
stat := $Disable_ctrl(ctrlOff);
SetUpExitHandlerVMS(1, 6); { VMS dependent routine }
Greeting;
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.