home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
ti990.zip
/
ti990.src
< prev
next >
Wrap
Text File
|
1988-08-16
|
110KB
|
2,748 lines
PROGRAM kermit; {$NO GLOBALS}
{
Copyright (C) 1986, Trustees of Columbia University in the City of New
York. Permission is granted to any individual or institution to copy
or use this program except for explicitly commercial purposes, provided
this copyright notice is retained.
The Kermit file transfer protocol was developed at Columbia University.
It is named after Kermit the Frog, star of the television series THE
MUPPET SHOW; the name is used by permission of Henson Associates, Inc.
"Kermit" is also Celtic for "free". KERMIT is available for many
systems for only a nominal fee from Columbia and from various user
group organizations, such as DECUS and SHARE.
Author: Paul W. Madaus
Johnson Controls, Inc.
507 E. Michigan St.
Milwaukee, WI 53201
(414) 274-4528
THIS VERSION OF KERMIT SOURCE WAS ORIGINALLY DESIGNED TO RUN ON THE
SPERRY(UNIVAC) 1100. I HAVE CHOSEN TO CONVERT AND IMPLEMENT THIS
VERSION OF KERMIT ONTO THE TI-990 DX10 SYSTEMS. THE CONVERSION OF
SYSTEM SPECIFIC PROCEDURES WAS STRAIGHTFORWARD, THE BASIC PROTOCOL
OF THE UNIVAC VERSION WAS WRITTEN IN STANDARD PASCAL, AND OF ALL THE
VERSIONS TESTED FOR CONVERSION, THE UNIVAC VERSION PRODUCED AN
ACCEPTABLE AMOUNT OF ERRORS UPON INITIAL DX10 COMPILATION(not a
deciding factor - but very influential). BEFORE CONTINUING FURTHER,
I WISH TO CREDIT THE ORIGINAL UNIVAC VERSION(2.0) OF THIS PROGRAM TO:
Edgar Butt (last known address)
Computer Science Center
University of Maryland
College Park, Maryland 20742
Phone (301) 454-2946
MY METHOD OF RE-DESIGN WILL CONSIST OF REMOVAL OR CONVERSION OF
ALL UNIVAC SYSTEM DEPENDENT SOFTWARE, ADDITION OF A COMMAND
PARSING MECHANISM, ADDITION OF INTERACTIVE COMMAND CONTROL,
ADDITION OF SEVERAL NEW KERMIT COMMANDS, ADDITION OF SIMPLE TTY TYPE
TERMINAL EMULATION VIA CONNECT CMD, ADDITION OF REMOTE AS WELL AS
LOCAL KERMIT EXECUTION, AND ADDITION OF A PASCAL XOR FUNTION FOR
7th AND 8th BIT SETTING AND RESETTING. THIS PROGRAM MAKES USE OF
TI PASCAL EXTENSIONS BUT DOES NOT INCLUDE ANY NON-TI PASCAL
STRUCTURES. PROGRAM WAS COMPILED AND LINKED AT DX10 REL. 3.7.0 AND
DX10 PASCAL REL. 1.8.0. THE TI PASCAL CONFIGURATION PROCESS WAS
NOT USED ONLY FOR GREATER SIMPLICITY AND EASIER PORTABILITY.
< more comments to follow in documentation... >
}
CONST
{ NEXT TWO CONSTANTS USED IN CONNECT FOR XOFF TUNING }
xoff_threshold=800; { NO. OF CHARS TO RECEIVE BEFORE SENDING XOFF }
buf_threshold=1000; { GUARD TO AVOID OVERFILLING CHAR BUFFER }
maxtry = 5;
maxbuf = 200;
maxflen=50; { MAXIMUM FILE NAME LENGTH }
maxwrt = 132;
ascnul = 0;
ascsoh = 1;
ascbs = 8;
asclf = 10;
asccr = 13;
ascsp = 32; { }
ascns = 35; {#}
ascamp = 38; {&}
ascast = 42; {*}
ascper = 46; {.}
ascb = 66; {B}
ascc = 67; {C}
ascd = 68; {D}
asce = 69; {E}
ascf = 70; {F}
ascg = 71; {G}
asch = 72; {H}
asci = 73; {I}
ascl = 76; {L}
ascn = 78; {N}
asco = 79; {O}
ascr = 82; {R}
ascs = 83; {S}
asct = 84; {T}
ascx = 88; {X}
ascy = 89; {Y}
ascz = 90; {Z}
asctil = 126; {~}
ascdel = 127; {rubout}
mark = ascsoh;
crlf='#0D#0A';
{ DX10 SVC I/O SUBOPCODES }
asslun = #91; { ASSIGN LUNO SVC I/O SUBOPCODE }
opnrwd = #03; { OPEN REWIND SVC I/O SUBOPCODE }
readas = #09; { READ ASCII SVC I/O SUBOPCODE }
writas = #0B; { WRITE ASCII SVC I/O SUBOPCODE }
moddev= #15; { MODIFY DEVICE CHARACTERISTICS }
rfc=#05; { READ FILE CHARACTERISTICS }
genluno=#04; { GENERATE LUNO FLAG SET }
lunass=#80; { LUNO ASSIGNED BIT FOR PDT STATUS WORD }
ret_sys_info=#3F; { RETURN SYSTEM INFO SVC }
pdt_memory=1; { RETURN PDT STRUCTURES }
TYPE
ascval = 0..255; { A BYTE }
{ WE'LL NEED STATIC LENGTH STRING BUFFERS ON DX10 }
char2=PACKED ARRAY[1..2]OF char;
char4=PACKED ARRAY[1..4]OF char;
char12=PACKED ARRAY[1..12]OF char;
char40=PACKED ARRAY[1..40]OF char;
char80=PACKED ARRAY[1..80]OF char;
flen=PACKED ARRAY[1..maxflen]OF char;
scistring=PACKED ARRAY[0..10]OF char;
byte6=PACKED ARRAY[1..6]OF ascval; { FILLERS AND OFFSETS }
byte12=PACKED ARRAY[1..12]OF ascval;
byte16=PACKED ARRAY[1..16]OF ascval;
byte18=PACKED ARRAY[1..18]OF ascval;
byte28=PACKED ARRAY[1..28]OF ascval;
byte60=PACKED ARRAY[1..60]OF ascval;
kermitstates = (kcommand,
fininit,
byeinit,
getinit,
wexit,
kexit,
cexit, { EXIT TO CMD MODE }
sinitiate,
sheader,
sdata,
sbreak,
rcv,
rinitiate,
rheader,
rdata);
filestatus = (closed, open, endfile);
ablk=PACKED RECORD { ABORT I/O CALLBLK }
op,lun:ascval
END;
wblk=PACKED RECORD { WAIT I/O SVC }
op,err:ascval;
addr:integer
END;
w1blk=PACKED RECORD { WAIT ANY I/O COMPLETION SVC }
op:ascval;
fil1,fil2,fil3:ascval { ZERO FILLERS }
END;
eflags = SET OF { EDIT FLAGS }
(pass,etx,esc,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13,r14,r15);
pblk=PACKED RECORD { PASSTHRU CALLBLK }
resv1:integer;
eflg:eflags;
resv2:integer
END;
rfcblk=PACKED RECORD { FOR READ FILE CHARACTERISTICS }
fil1,fil2,fil3:integer;
filesize:longint
END;
ascbuf = RECORD
ln: integer;
ch: PACKED ARRAY[1..maxbuf] OF
ascval
END;
sbits = SET of 0..35;
btype=ARRAY[1..16] OF integer; { FOR DISPLAY-ACCEPT }
suflags= SET OF { SVC FLAGS }
(bsy,err,eofil,evnt,f1,f2,f3,f4,qret,rep,f5,f6,f7,opn,ext,blnk);
exflags=SET OF { EXTENDED CALL BLOCK FLAGS }
(fstrt,inten,blink,graph,asci8,tedit,beep,right,curpos,filchr,
noinit,trmchr,noecho,chrval,flderr,wbeep);
svcblk = PACKED RECORD { SVC CALLBLOCK }
svc, { SVC OPCODE }
stat, { STATUS CODE }
subop, { SVC I/O SUBOPCODE }
lun:ascval; { LUNO }
flags:suflags; { SYSTEM AND USER FLAGS }
buf:integer; { DATA BUFFER ADDRESS }
lrl:integer; { LOGICAL RECORD LENGTH }
cc:integer; { CHARACTER COUNT }
fil1:integer; { NOT USED }
{ EXTENDED CALL BLOCK BEGINS HERE - RESERVED FOR FUTURE USE }
xblk:exflags; { NOT USED }
filorflg:ascval; { FILL CHAR OR ASSIGN LUNO FLAG }
event:ascval; { EVENT BYTE }
crow:ascval; { CURSOR POSITION - ROW }
ccol:ascval; { CURSOR POSITION - COL }
frow:ascval; { FIELD START - ROW }
fcol:ascval; { FIELD START - COL }
devaddr:integer; { DEVICE POINTER FOR ASSIGN LUNO }
fil2,fil3:integer { NOT USED }
END;
svcptr=@svcblk; { SVC POINTER TYPE FOR SCB$A }
waitblk = PACKED RECORD { WAIT FOR I/O SVC CALLBLOCK }
opcode:ascval; { SVC OPCODE }
stat:ascval; { ERROR }
svcaddr:integer { ACTUAL SVC I/O ADDRESS (+2) }
END;
bytebits=SET OF { 16 BITS TO A WORD - FOR XORING }
(b15,b14,b13,b12,b11,b10,b9,b8,b7,b6,b5,b4,b3,b2,b1,b0);
svccbt = PACKED RECORD { SVC BLOCK FOR RETURN SYSTEM INFORMATION }
opcode, { OPCODE }
error, { STATUS }
data_type, { TYPE OF STRUCTURE TO RETRIEVE }
flags:ascval; { FLAGS }
index, { STRUCTURE NUMBER }
read_addr, { OFFSET INTO STRUCTURE }
buff_len, { READ BUFFER SIZE }
ret_len, { NUMBER OF BYTES RETURNED }
bufaddr, { READ BUFFER ADDRESS }
reserved:integer
END;
{}
pdtrec=PACKED RECORD
{ BASED ON CURRENT PDT STRUCTURE - NOT AT ALL LIKELY TO CHANGE }
addr:integer;
fil0:byte6; { FILLER }
bsy:ascval; { CONTAINS BUSY BITS }
fil1:ascval; { OTHER HALF OF BYTE }
fil2:byte18; { FILLER }
tiline:ascval; { NEED UPPER PORTION OF TILINE ADDRESS }
fil3:ascval; { FILLER }
fil4:byte12; { FILLER }
devnam:char4; { DEVICE NAME }
fil5:byte60; { FILLER }
addr2:integer; { SHOULD BE SAME THIS PDT'S ADDR }
fil6:byte28; { FILLER }
vdtsc1:bytebits; { PORT INITIALIZED WORD }
fil7:byte16; { FILLER }
init:bytebits; { PORT INITIALIZED WORD }
fil8:byte60 { FILLER }
END;
buf=PACKED ARRAY[1..1024]OF char; { ADJUST IF YOU WISH }
VAR
{ I HOPE I USE ALL THESE!! }
iniflg: boolean; {Set true after first initialization}
server: boolean;
state: kermitstates;
filbuf,wrtbuf,redbuf,sndbuf,rcvbuf,cmdbuf: ascbuf;
redix: integer;
rfile,wfile,lfile: text; { DX10 TEXT FILE TYPES}
wbfile:FILE OF char80; { BINARY WRITE FILE }
rbfile:FILE OF char80; { BINARY READ FILE }
bbuf:char80; { BINARY DATA BUFFER }
bptr:integer; { CURRENT BBUF POINTER }
fname,rfname,lname,ioname,namebuf,tname:flen; { DX10 FILE PATHS }
fnlen,rfnlen,iolen,lnlen,tlen:integer;
rstatus, wstatus,lstatus: filestatus;
seq,rcvseq: integer;
rlen: integer;
stype,rcvtyp: ascval;
numtry: integer;
numcserr: integer;
ineoln: boolean;
sndonly: boolean;
sndlog, rcvlog, wrtlog, redlog: boolean;
creol: boolean;
lfeol: boolean;
crlfeol: boolean;
gotcr: boolean;
locbsiz: ascval;
loctout: ascval;
locnpad: ascval;
locpad: ascval;
loceol: ascval;
locquo: ascval;
optqu8: ascval;
locqu8: ascval;
locrep: ascval;
rembsiz: ascval;
remdsiz: ascval;
{Maximum number of data characters to send (remBsiz-3)}
remtout: ascval;
remnpad: ascval;
rempad: ascval;
remeol: ascval;
remquo: ascval;
remqu8: ascval;
remrep: ascval;
oval:boolean; { IOTERM SETTING SAVE }
blk:btype; { FOR DISPLAY-ACCEPT CLEARSCREENS }
lun:integer; { FOR INITSCREENS }
eolflg:boolean; { DX10 RECORDS DO NOT CONTAIN CRs OR LFs }
pcbuf,tcbuf:char2; { CHAR BUFS }
ts:svcblk; { TERMINAL SVC I/O CALLBLOCK }
ps:svcblk; { PORT SVC I/O CALLBLOCK }
sp:svcptr; { SVCBLK POINTER FOR MISC I/O }
s:svcblk;
rs:rfcblk; { READ FILE CHARACTERISTICS BUFFER }
recsred:integer; { NUMBER OF RECORDS READ IN FILE }
percent:real; { PERCENT OF FILE SENT TO REMOTE }
a:ablk; { ABORT I/O CALLBLK }
w:wblk; { WAIT I/O CALLBLK }
w1:w1blk; { WAIT ANY I/O CALLBLK }
p:pblk; { EDIT FLAG BLOCK FOR PASSTHRU }
bsbuf:char40; { BIG USER MESSAGE STRING BUFFER }
ssbuf:char12; { SMALL STRING BUFFER - MAINLY FOR THE PROMPT }
cond:boolean; { CONNECTED BOOLEAN }
pktsnt:integer; { A RUNNING COUNT OF PACKETS SENT }
headok:boolean; { HEADER PACKET SENT FLAG }
sending:boolean; { SENDING A FILE }
receiving:boolean; { RECEIVING A FILE }
local:boolean; { MODE WE ARE OPERATING IN }
syn,val:scistring; { FOR SYNONYM SETTING }
perr:integer; { GET PARM ERR BUF }
isc:boolean; { ISC TYPE TERMINAL - OPTIONAL }
binary:boolean; { BINARY TYPE FILE FLAG }
reof:boolean; { READ FILE EOF ENCOUNTERED FLAG }
{ FORWARD REFERENCE PROCEDURES }
PROCEDURE error(msg:char40);forward; { 40 CHARACTER ERROR MESSAGE }
{ TI PASCAL EXTERNAL PROCEDURES }
{ THESE FIRST TWO PROCEDURES DEPEND ON THE EXISTENCE OF TIFORMS ON }
{ YOUR DX10 SYSTEM AND ARE OPTIONAL SINCE THEY ONLY CLEAR THE }
{ SCREEN UPON KERMIT INITIALIZATION. YOU MAY REMOVE THEM. }
PROCEDURE initscreen(VAR block:btype;
unit : integer );external; { TIFORMS }
PROCEDURE clearscreen( VAR block : btype);external; { TIFORMS }
PROCEDURE delay(l:longint);external; { DELAY L millisecs }
PROCEDURE p$parm(num:integer; { GET PARMS FROM CALLING PROC }
VAR str:PACKED ARRAY[1..?]OF char;VAR err:integer);external;
PROCEDURE store$syn(VAR syn,value:scistring);external;
PROCEDURE set$acnm(locvar,locfil:integer);external;
{ SET PASCAL FILE NAMES }
PROCEDURE setpdt(w1addr,w2addr:integer);external; { NOT TI PROC }
{ ASSEMBLY - SET PORT INIT BITS FOR 2 WORDS IN PDT IF OPEN FAILS }
PROCEDURE svc$(call_blk_addr:integer);external; { PROCESS SVC }
FUNCTION scb$a(fileloc:integer):svcptr;external;
{ GET TI FILE CHARACTERISTICS }
{ ***************************************************************** }
PROCEDURE passt(VAR s:svcblk;onoff:boolean);
{ SET OR RESET THE PASSTHRU MODE - DEVICE MUST ALREADY BE OPEN }
BEGIN { PASST }
{ SET TERMINAL PASSTHRU MODE }
IF onoff THEN
p.eflg:=[pass] { SET PASSTHRU FLAG }
ELSE
p.eflg:=[]; { RESET PASSTHRU FLAG }
p.resv1:=0;
p.resv2:=0;
s.flags:=[]; { WAIT FOR COMPLETION }
s.subop:=moddev; { SET MODIFY DEVICE SUBOPCODE }
s.buf:=location(p);
s.cc:=6;
svc$(location(s)) { SET PASSTHRU MODE }
END; { PASST }
PROCEDURE abort(VAR s:svcblk);
BEGIN
IF bsy IN s.flags THEN
BEGIN
a.op:=15; { SET ONCE ABORT I/O OPCODE }
a.lun:=s.lun;
svc$(location(a));
w.op:=1; { SET ONCE WAIT I/O OPCODE }
w.err:=0; { NOW WAIT FOR THIS ABORT COMPLETION }
w.addr:=location(s)+2;
svc$(location(w))
END
END;
PROCEDURE chktrm(devname:char4);
VAR
sys_info : svccbt; { USED TO GET PDTs }
pdt_addr :integer; { PDT ADDRESS SAVE }
pdt:pdtrec; { GENERAL PDT STRUCTURE }
vdtaddr,iniaddr:integer; { ADDRESS BUFFERS THE TWO PDT INIT WORDS }
BEGIN { CHKTRM }
vdtaddr:=-1; { NOT A VALID PDT ADDRESS YET }
iniaddr:=-1; { NOT A VALID PDT ADDRESS YET }
IF devname[1]='S' AND devname[2]='T' THEN
WITH sys_info DO { SEARCH FOR DEVICES PDT }
BEGIN
opcode:=ret_sys_info;
error:=0;
data_type:=pdt_memory; { RETRIEVE PDT STRUCTURES }
flags:=0;
index:=0; { START AT BEGINNING OF PDT LIST }
read_addr:=0; { OFFSET INTO PDT }
buff_len:=size(pdt); { SIZE OF READ BUFFER }
ret_len:=0; { ACTUAL NUMBER OF BYTES READ }
bufaddr:=location(pdt);
reserved:=0;
REPEAT
index:=succ(index); { GET NEXT PDT ENTRY }
pdt_addr:=pdt.addr; { POINTER TO NEXT PDT }
svc$(location(sys_info)); { GET NEXT PDT }
IF pdt.devnam=devname AND error=0 THEN
BEGIN { FOUND THE DEVICE }
IF index=1 THEN { IF FIRST PDT ON LIST THEN WE HAVE }
pdt_addr:=pdt.addr2; { TO GET ITS ADDR WITHIN PDT }
IF (pdt.bsy=0 OR pdt.bsy=lunass) AND
{ ONLY ALLOW LUNO ASSISNED BIT SET IN PDT STATUS WORD i.e. not busy }
pdt.tiline>= #F8 AND
{ MAKE SURE STATION COMING OFF CI403 BOARD --> TILINE TYPE ADDR }
NOT (b2 IN pdt.vdtsc1 AND { SEE IF ONE OR BOTH }
b2 IN pdt.init) THEN { WORDS NEEDS MODIFICATION }
{ ALL THE ABOVE CONDITIONS MUST BE SATISFIED FOR THIS FINAL ATTEMPT }
{ TO OPEN A 931 PORT TO EVEN BE ATTEMPTED. ADDRESSES OF WORDS WILL }
{ BE SET THAT NEED BIT MODIFICATION, ELSE ADDRESSES REMAIN AT -1 }
BEGIN
IF NOT b2 IN pdt.vdtsc1 THEN { NEED BIT SET }
vdtaddr:=pdt_addr+location(pdt.vdtsc1)-location(
pdt
); { SO SET ADDRESS OF WORD TO BE MODIFIED }
IF NOT b2 IN pdt.init THEN { SAME FOR THIS WORD }
iniaddr:=pdt_addr+location(pdt.init)-location(pdt
);
setpdt(vdtaddr,iniaddr)
{ SET APPROPRIATE PDT BITS }
END
END
UNTIL pdt.addr=0 OR pdt.devnam=devname OR error<>0
END
END; { CHKTRM }
PROCEDURE initio(dev:integer;VAR s:svcblk);
VAR
devnam:char4; { DEVICE NAME TO OPEN }
BEGIN { INITIO }
IF s.stat=0 THEN { CHECK FOR ANY PREVIOUS ERR }
WITH s DO
BEGIN
svc:=0; { SVC I/O }
subop:=asslun; { ASSIGN LUNO OPERATION }
lun:=0; { SYSTEM WILL PICK THE LUNO }
flags:=[]; { USE EXTENDED CALLBLOCK }
buf:=0; { CLEAR }
lrl:=0; { CLEAR }
cc:=0; { CLEAR }
fil1:=0; { CLEAR }
xblk:=[]; { CLEAR }
filorflg:=genluno; { SYSTEM TO GENERATE LUNO NUMBER }
event :=0; { CLEAR }
crow :=0; { CLEAR }
ccol :=0; { CLEAR }
frow :=0; { CLEAR }
fcol :=0; { CLEAR }
devaddr:=dev; { DEVICE NAME POINTER }
fil2:=0; { CLEAR }
fil3:=0; { CLEAR }
svc$(location(s)); { PERFORM THE SVC }
IF stat=0 THEN { LUNO ASSIGNMENT COMPLETE }
BEGIN { OPEN DEVICE FOR I/O }
filorflg :=0; { CLEAR }
devaddr:=0; { CLEAR }
subop:=opnrwd; { SET OPEN REWIND OPERATION FOR DEVICE }
flags:=[qret]; { QUICK RETURN SO WE CAN CHECK OPEN }
svc$(location(s)); { OPEN THE DEVICE }
delay(500); { ALLOW OPEN OF DEVICE TO PROCEED }
IF bsy IN flags THEN
BEGIN { OPEN NOT COMPLETE YET }
delay(3000); { WAIT SOME MORE }
IF bsy IN flags THEN
BEGIN
abort(s);
{ ABORT AND CHECK PORT'S PDT INIT WORDS }
stat:=0;
IF dev=location(ioname) THEN
BEGIN { PDT MAY NEED INITIALIZATION }
FOR i:=1 TO 4 DO
devnam[i]:=ioname[(i+1)];
chktrm(devnam)
{ CHECK AND POSSIBLY MODIFY PDT PORT INIT BITS }
END;
svc$(location(s)); { TRY ONE MORE ATTEMPT }
delay(2000);
IF bsy IN flags THEN
stat:= #FF { COULDN'T OPEN DEVICE SET ERROR }
END
END;
flags:=[]; { RESET FLAGS }
IF stat=0 AND dev=location(ioname) THEN
passt(s,true); { SET PASSTHRU MODE ON REMOTE PORT }
lrl:=1 { FOR MOST READS }
END
END
END; { INITIO }
{ IN SOME PROCEDURES I CALL SVC$ DIRECTLY FOR QUICKER I/O }
PROCEDURE readdev(VAR rs:svcblk;wait:boolean;bufloc:integer);
BEGIN
rs.subop:=readas;
rs.buf:=bufloc;
IF wait THEN { WAIT I/O COMPLETION }
rs.flags:=rs.flags-[qret]
ELSE
rs.flags:=rs.flags+[qret];
svc$(location(rs)) { DO THE READ }
END;
PROCEDURE writdev(VAR rs:svcblk;wait:boolean;
numchars:integer;bufloc:integer);
BEGIN
rs.subop:=writas;
rs.buf:=bufloc;
rs.cc:=numchars;
IF wait THEN { WAIT I/O COMPLETION }
rs.flags:=rs.flags-[qret]
ELSE
rs.flags:=rs.flags+[qret];
svc$(location(rs)) { DO THE WRITE }
END;
FUNCTION devbsy(ds:svcblk):boolean;
BEGIN
devbsy:=bsy IN ds.flags { DEVICE DOING I/O ? }
END;
{$NO WARNINGS}
FUNCTION bxor(i:integer;b:ascval):ascval; { XOR 128/64 }
VAR
a:bytebits; { BIT MANIPULATION NEEDED }
BEGIN { BXOR }
a:= b::bytebits; { TYPE CONVERT FOR BIT MANIPULATION }
IF i = 64 THEN
BEGIN { XOR 64 }
IF ( b6 IN a ) THEN
a:=a - [b6] { RESET BIT 6 }
ELSE
a:=a+ [b6] { SET BIT 6 }
END; { XOR 64 }
IF i = 128 THEN
BEGIN { XOR 128 }
IF ( b7 IN a ) THEN
a:=a- [b7] { RESET BIT 7 }
ELSE
a:=a+[b7] { SET BIT 7 }
END; { XOR 128 }
{ NO OTHER XORS DONE IN THIS PROTOCOL }
b:=a::ascval; { TYPE CONVERT FOR COMPATABILITY }
bxor:=b { RETURN FUNCTION VALUE }
END; { BXOR }
{$WARNINGS}
FUNCTION makechar (i: integer): ascval;
BEGIN
makechar:=ascsp+i
END;
FUNCTION unchar (a: ascval): integer;
BEGIN
unchar:=a-ascsp
END;
FUNCTION tog64(a: ascval): ascval;
BEGIN
tog64:=bxor(64,a) {System dependent}
END;
FUNCTION tog128(a: ascval): ascval;
BEGIN
tog128:=bxor(128,a) {System dependent}
END;
FUNCTION checksum (sum: integer): ascval;
BEGIN { SINGLE CHARACTER ARITHMETIC CHECKSUM }
checksum := (((sum MOD 256) DIV 64) + sum) MOD 64
END;
PROCEDURE logopn; { OPEN LOG FILE - IF DEMANDED }
BEGIN
set$acnm(location(lfile),location(lname));
{ SET PASCAL FILE NAME }
rewrite(lfile); { OPEN LOG FILE FOR WRITING }
lstatus:=open; { ASSUME SUCCESS }
write(lfile,'DX10 KERMIT-990 --- LOGFILE');
writeln(lfile);
bsbuf:='LOGGING REQUESTED TO: ';
writdev(ts,true,22,location(bsbuf));
FOR i:=1 TO ord(lname[1]) DO
BEGIN
tcbuf[1]:=lname[(i+1)];
writdev(ts,true,1,location(tcbuf))
END;
tcbuf:='#0D#0A';
writdev(ts,true,2,location(tcbuf))
END;
PROCEDURE logcls;
BEGIN
IF lstatus=open THEN
close(lfile) { CLOSE THE LOG FILE }
END;
{ Buffer routines - FOLLOW }
PROCEDURE bufinit(VAR buf:ascbuf);
BEGIN
buf.ln:=0
END;
PROCEDURE putbuf(VAR buf: ascbuf; a:ascval);
BEGIN
IF NOT (buf.ln<maxbuf) THEN
{ I THINK THE CAUSE OF THIS ERROR NEEDS FIXING }
BEGIN { THIS CONDITION SHOULD BE AVOIDED - FIX LATER }
error('SIZE OF ASCII BUFFER EXCEEDED ')
END
ELSE
BEGIN
buf.ln:=buf.ln+1;
buf.ch[buf.ln]:=a
END
END;
PROCEDURE lintobuf(l: flen; len: integer; VAR buf: ascbuf);
BEGIN
bufinit(buf);
FOR i:=2 TO (len+1) DO
putbuf(buf,ord(l[i]))
END;
PROCEDURE buftolin(buf: ascbuf; VAR l:flen; VAR len: integer);
VAR a:ascval;
BEGIN
len:=buf.ln;
IF len>maxflen THEN len:=maxflen;
FOR i:=1 TO len DO
BEGIN
a:=buf.ch[i];
IF a>127 THEN a:=a-127;
l[(i+1)]:=chr(a)
END;
l[1]:=chr(len) { NEED FILE LENGTH }
END;
{ Process parameters to and from remote Kermit }
PROCEDURE putpar;
VAR temp: ascval;
BEGIN
bufinit(filbuf);
putbuf(filbuf,makechar(locbsiz));
putbuf(filbuf,makechar(loctout));
putbuf(filbuf,makechar(locnpad));
putbuf(filbuf,tog64(locpad));
putbuf(filbuf,makechar(loceol));
putbuf(filbuf,locquo);
temp:=ascsp; { SO FAR NO EIGHT BIT QUOTING }
IF locqu8<>0 THEN temp:=locqu8;
putbuf(filbuf,temp);
putbuf(filbuf,ascsp); {Only know how do to 1 character checksum}
temp:=ascsp;
IF locrep<>0 THEN temp:=locrep;
putbuf(filbuf,temp)
END;
PROCEDURE getpar;
BEGIN
IF rcvbuf.ln > 0 THEN rembsiz:=unchar(rcvbuf.ch[1]);
IF rcvbuf.ln > 1 THEN remtout:=unchar(rcvbuf.ch[2]);
IF rcvbuf.ln > 2 THEN remnpad:=unchar(rcvbuf.ch[3]);
IF rcvbuf.ln > 3 THEN rempad:=tog64(rcvbuf.ch[4]);
IF rcvbuf.ln > 4 THEN remeol:=unchar(rcvbuf.ch[5]);
IF rcvbuf.ln > 5 THEN remquo:=rcvbuf.ch[6];
IF rcvbuf.ln > 6 THEN remqu8:=rcvbuf.ch[7];
{ DONT GET CHCKSUM - WE ARE ONLY SET UP FOR SINGLE CHAR CHCKSUM }
IF rcvbuf.ln > 8 THEN remrep:=rcvbuf.ch[9];
" remdsiz:=rembsiz-3;
remdsiz:=rembsiz-6; { SEND LESS DATA - EXCEEDING REMOTE BUFS }
IF state=rinitiate THEN {Our parameters have not been sent}
BEGIN
IF locqu8=0 THEN remqu8:=0; { WE DONT WANT 8-BIT QUOTING }
IF ((32<remqu8) AND (remqu8<63)) OR ((95<remqu8) AND (remqu8<
127))
AND (remqu8<>remquo) THEN
BEGIN
locqu8:=ascy
{Remote Kermit specified 8-bit quote character}
END
ELSE
IF remqu8=ascy THEN
BEGIN
locqu8:=ascamp;
IF (locqu8=remquo) OR (locqu8=remrep) THEN locqu8:=asctil;
IF (locqu8=remquo) OR (locqu8=remrep) THEN locqu8:=ascns;
remqu8:=locqu8
END
ELSE
BEGIN
locqu8:=0; {Don't do 8-bit quoting}
remqu8:=0
END;
IF ((32<remrep) AND (remrep<63)) OR ((95<remrep) AND (remrep<
127))
AND (remrep<>remquo) AND (remrep<>remqu8) AND (locrep<>0)
THEN
BEGIN
locrep:=remrep {Agree to do repeat counts}
END
ELSE
BEGIN
remrep:=0;
locrep:=0
END
END
ELSE {Our parameters have already been sent}
BEGIN
IF (remqu8<>ascy) AND (remqu8<>locqu8) THEN
BEGIN
locqu8:=0 {Don't do 8-bit quoting}
END;
IF remrep<>locrep THEN
locrep:=0 {Don't do repeat counts}
END
END;
PROCEDURE rcvpkt;
{ rcvtyp = 0 - no soh encountered
1 - soh encountered, but packet incomplete
2 - Checksum error
Other - ASCII value of packet type from good packet
rcvseq = -1 - Not a valid packet
0...63 - Sequence number from valid packet
rcvbuf.ln - number of ascii values input since last SOH
rcvbuf.ch - array of ascii values input }
VAR
c:PACKED ARRAY[1..2]OF char;
av,rt: ascval;
rst,rsq,cs:integer;
cct:integer;
dlay:integer; { A DELAY COUNTER }
dtim:longint; { VARIABLE DELAY TIMES }
BEGIN
cct:=0;
IF rcvlog THEN write(lfile,'RCV <');
rcvtyp:=0;
rcvseq:=-1; { NO VALID PACKET YET }
rst:=0;
ineoln:=false;
bufinit(rcvbuf);
{ FOR OPTIMAL SPEED WE WILL AVOID THE PROCEDURE CALL TO READ A CHAR }
ps.subop:=readas;
ps.buf:=location(c);
ps.flags:=ps.flags+[qret];
svc$(location(ps)); { QUEUE THE READ }
WHILE NOT ineoln AND cct<230 DO
{ UNTIL END OF PACKET OR UNTIL NO SOH LIMIT REACHED }
BEGIN
dlay:=0; { CLEAR DELAY COUNTER }
dtim:=0; { NO INITIAL DELAY }
{ THIS WHILE LOOP MAY BE FINE TUNED IF NECESSARY }
WHILE (bsy IN ps.flags) AND dtim<=200 DO
BEGIN
delay(dtim); { VARIABLE DELAY BEGINS WITH ZERO }
dlay:=succ(dlay); { INCREMENT TIME COUNTER }
{ THIS DELAY MECHANISM MAY NEED FINE(or GROSS) TUNING }
IF( (dlay MOD 10) = 0) THEN
dtim:=dtim+50 { WAIT LONGER NEXT TIME }
END;
IF bsy IN ps.flags THEN
{ READ CHARACTER COULD NOT COMPLETE IN ABOUT FIVE SECONDS }
ineoln:=true { SO LEAVE --> RESEND LAST PACKET }
ELSE { WE READ A CHAR }
BEGIN
IF rcvlog THEN
BEGIN
IF ps.stat<>0 THEN
write(lfile,'^^ERR IN PORT READ: ',ps.stat hex,' ^^')
ELSE
write(lfile,c[1])
END;
cct:=succ(cct);
av:=ord(c[1]);
{ WE HAVE THE CHAR - SO REQUEUE THE NEXT READ }
svc$(location(ps));
{ QUEUE NEXT READ WHILE PROCESSING LAST CHAR }
IF av=mark THEN rst:=1;
CASE rst OF
0: {Mark character never encountered.}
BEGIN
putbuf(rcvbuf,av);
END;
1: {Mark character.}
BEGIN
rcvtyp:=1;
rcvseq:=-1;
cct:=0; { CLEAR PACKET OK }
bufinit(rcvbuf);
rst:=2
END;
2: {Length of the packet.}
BEGIN
cs:=av; {Initialize checksum}
rlen:=unchar(av)-3;
rst:=3
END;
3: {Packet number.}
BEGIN
cs:=cs+av;
rsq:=unchar(av);
rst:=4
END;
4: {Packet type.}
BEGIN
cs:=cs+av;
rt:=av; {remember the packet type}
rst:=5;
IF rlen=0 THEN
rst:=6
END;
5: {Data portion.}
BEGIN
cs:=cs+av;
putbuf(rcvbuf,av);
IF rcvbuf.ln = rlen THEN
rst:=6
END;
6: {Checksum.}
BEGIN
IF checksum(cs)=unchar(av) THEN
BEGIN
rcvtyp:=rt;
rcvseq:=rsq;
ineoln:=true {Ignore the rest of the line}
{ CARRIAGE CONTROL CHAR WILL BE READ FROM NEXT QUEUED READ }
END
ELSE
BEGIN
numcserr:=numcserr+1;
rst:=0; {Look for another mark}
rcvtyp:=2; {Indicate checksum error}
ineoln:=true { RETURN ERR NOW }
END
END
END { CASE }
END { ELSE - NOT BSY --> CHAR READ }
END;
IF rcvlog THEN
writeln(lfile,'>');
IF cct>=230 THEN
{ AFTER RECEIVING 230 UNSUCCESSFUL CHARACTERS - IT'S TIME TO RESET }
error('#0D#0A230 CHARS AND STILL NO VALID PACKET.#0D#0A');
IF bsy IN ps.flags THEN
abort(ps) { CLEAN UP BEFORE WE LEAVE }
END; { RCVPKT }
{ Build and send packets PROCEDURES }
PROCEDURE makepacket(ptype: ascval; seq, len: integer);
VAR c: ascval;
cs: integer;
BEGIN
bufinit(sndbuf);
FOR i:=1 TO remnpad DO { ADD PAD CHARS IF ANY TO BE ADDED }
putbuf(sndbuf,rempad);
putbuf(sndbuf,mark); { SOH MARKER }
c:=makechar(len+3);
cs:=c; {Initialize checksum}
putbuf(sndbuf,c); { LENGTH OF PACKET }
c:=makechar(seq);
cs:=cs+c;
putbuf(sndbuf,c); { PACKET SEQ NUMBER }
c:=ptype;
cs:=cs+c;
putbuf(sndbuf,c); { PACKET TYPE }
FOR i:=1 TO len DO
BEGIN
c:=filbuf.ch[i];
cs:=cs+c;
putbuf(sndbuf,c) { ADD PACKET DATA }
END;
c:=makechar(checksum(cs));
putbuf(sndbuf,c); { ADD CHECKSUM TO PACKET }
IF (remeol<>asccr) AND (remeol<>asclf) THEN
putbuf(sndbuf,remeol) { EOL MARKER AT END OF PACKET }
END;
PROCEDURE sndpkt;
VAR { NEED CONTIGUOUS PACKED DATA FOR SVC }
tbuf:PACKED ARRAY[1..maxbuf]OF ascval;
ens:integer; { ENCODE PROCEDURE ERROR BUFFER }
BEGIN
IF sndlog THEN write(lfile,'SND <');
FOR i:=1 TO sndbuf.ln DO
BEGIN
tbuf[i]:=sndbuf.ch[i]; { PACK DATA FOR SVC }
IF sndlog THEN { LOG IT }
write(lfile,chr(sndbuf.ch[i]))
END;
tbuf[sndbuf.ln+1]:= #0D; { SEND EOL CHAR }
IF sndlog THEN
write(lfile,'#0D'); { LOG IT }
writdev(ps,true,(sndbuf.ln+1),location(tbuf)); {WRITE(send) PACKET}
IF ps.stat<>0 AND sndlog THEN
write(lfile,' ERR IN SNDPKT: ',ps.stat hex,' ');
IF local THEN
BEGIN { DISPLAY SEND OR RECEIVE STATS }
IF sending THEN
BEGIN
{$NO WARNINGS}
percent:=recsred/rs.filesize*100;
{ PERCENT OF FILE SENT SO FAR }
{$WARNINGS}
ssbuf:=' % #0D'; { DISPLAY % TEMPLATE }
IF state=sbreak THEN { DONE SENDING THIS FILE }
BEGIN
sending :=false; { BREAK OUT OF HERE }
ssbuf:='100.0% OK#0D#0A'
END
ELSE
encode(ssbuf,1,ens,percent:5:1);
{ PLACE PERCENT IN STRING }
writdev(ts,true,12,location(ssbuf))
{ DISPLAY PERCENT COMPLETE }
END
ELSE
IF receiving THEN
BEGIN
pktsnt:=succ(pktsnt);
ssbuf:='<=#0D#0A ';
IF rcvtyp=ascb THEN { DONE RECEIVING THIS FILE }
BEGIN
receiving:=false;
ssbuf:=' COMPLETE#0D#0A';
writdev(ts,true,12,location(ssbuf))
END
ELSE
BEGIN
IF pktsnt>=36 THEN { NEW LINE FOR NEAT FORMAT }
BEGIN
writdev(ts,true,4,location(ssbuf));
pktsnt:=0
END
ELSE
writdev(ts,true,2,location(ssbuf))
END
END
END;
IF sndlog THEN
writeln(lfile,'>')
END;
{ File output PROCEDURES }
PROCEDURE wrtrec;
VAR
c:char;
BEGIN
IF wrtlog THEN write(lfile,'WRT [');
FOR i:=1 TO wrtbuf.ln DO
BEGIN
c:=chr(wrtbuf.ch[i]); { ASCII VALUE MAY BE >127 }
IF NOT binary THEN
write(wfile,c) { TEXT CHARACTER }
ELSE
BEGIN
bptr:=succ(bptr); { ADVANCE BINARY CHAR BUF PTR }
IF bptr>size(bbuf) THEN { BUF FULL -> WRITE IT }
BEGIN
write(wbfile,bbuf); { WRITE BUF INCLUDING TRAIL BLNKS }
bptr:=1 { RESET BUF PTR }
END;
bbuf[bptr]:=c { STORE OUR CHAR }
END;
IF wrtlog THEN
write(lfile,c)
END;
IF NOT binary THEN
writeln(wfile);
IF wrtlog THEN writeln(lfile,']');
bufinit(wrtbuf)
END;
PROCEDURE wrtcls; {System dependent}
BEGIN
IF wstatus=open THEN
BEGIN
IF wrtbuf.ln>0 THEN wrtrec;
IF binary THEN { TAKE CARE OF REMAINING BINARY CHARS }
BEGIN
FOR i:=(bptr+1) TO (size(bbuf)) DO
bbuf[i]:=' '; { BLANK FILL REST OF RECORD }
write(wbfile,bbuf); { WRITE LAST BINARY RECORD }
close(wbfile)
END
ELSE
close(wfile) { CLOSE THE FILE BEING WRITTEN }
END;
wstatus:=closed
END;
PROCEDURE wrtopn;
VAR
wstat: boolean;
BEGIN
wrtcls;
IF binary THEN
BEGIN { OPEN SPECIAL FILE FOR BINARY CHARS }
{ ACTUALLY WE USE FILE OF CHAR80 TO AVOID TRAIL BLNK TRUNCATION }
set$acnm(location(wbfile),location(fname));
{ SET PASCAL NAME }
ioterm(wbfile,oval,false); { TURN OFF I/O TERM ON ERR }
rewrite(wbfile); { I HOPE THEY WANT A CLEAR FILE }
wstat:= status(wbfile)=0; { CHECK FOR OPEN ERROR }
ioterm(wbfile,oval,true) { TURN BACK ON I/O TERM ON ERR }
END
ELSE
BEGIN { OPEN NORMAL TEXT FILE FOR NON-BINARY DATA }
set$acnm(location(wfile),location(fname));
{ SET PASCAL NAME }
ioterm(wfile,oval,false); { TURN OFF I/O TERM ON ERR }
rewrite(wfile); { I HOPE THEY WANT A CLEAR FILE }
wstat:= status(wfile)=0; { CHECK FOR OPEN ERROR }
ioterm(wfile,oval,true) { TURN BACK ON I/O TERM ON ERR }
END;
IF wstat THEN wstatus:=open;
bufinit(wrtbuf)
END;
PROCEDURE wrtasc(a:ascval);
BEGIN
IF wrtbuf.ln >=maxwrt THEN wrtrec;
putbuf(wrtbuf,a)
END;
PROCEDURE putrec(buf: ascbuf);
{ Process data portion of data packet }
VAR
i,repcnt:integer;
a:ascval;
qflag: boolean;
BEGIN
i:=1;
WHILE i<= buf.ln DO
BEGIN
a:=buf.ch[i];
i:=succ(i);
repcnt:=1;
IF a=remrep THEN
BEGIN { REPEAT CHAR SYMBOL FOUND }
repcnt:=unchar(buf.ch[i]); { GET REPEAT COUNT }
i:=succ(i);
a:=buf.ch[i]; { CHAR TO REPEAT }
i:=succ(i)
END;
qflag:= a=remqu8; { 8th BIT SET }
IF qflag THEN
BEGIN { THEN HANDLE IT }
a:=buf.ch[i];
i:=succ(i)
END;
IF a=remquo THEN
BEGIN { 7th BIT SET }
a:=buf.ch[i];
i:=succ(i);
IF (a<>remquo) AND (a<>remqu8) AND (a<>remrep) THEN
a:=tog64(a)
END;
IF qflag THEN
a:=tog128(a);
FOR j:=1 TO repcnt DO
BEGIN { WRITE DATA TO FILE }
IF a=asclf THEN
BEGIN
IF lfeol OR gotcr THEN
BEGIN
wrtrec;
gotcr:=false
END
ELSE
BEGIN
wrtasc(a)
END
END
ELSE
BEGIN
IF gotcr THEN
BEGIN
wrtasc(asccr);
gotcr:=false
END;
IF a=asccr THEN
BEGIN
IF creol THEN
BEGIN
wrtrec
END
ELSE
IF crlfeol THEN
BEGIN
gotcr:=true
END
ELSE
BEGIN
wrtasc(a)
END
END
ELSE
BEGIN
wrtasc(a)
END
END
END
END
END;
PROCEDURE redrec; { File input }
VAR c: char;
a: ascval;
BEGIN
bufinit(redbuf);
IF redix >= 0 AND NOT binary THEN
readln(rfile); { GET TEXT RECORD TO TASK }
IF binary THEN
BEGIN
IF eof(rbfile) THEN
reof:=true
ELSE
read(rbfile,bbuf) { READ 80 CHAR RECORD }
END;
redix:=0;
IF NOT binary THEN
reof:= eof(rfile);
IF NOT reof THEN { NOT EOF ON FILETYPE IN USE }
BEGIN { BINARY TYPE OR TEXT TYPE NOT EOF YET }
IF redlog THEN write(lfile,'RED [');
IF NOT binary THEN
WHILE NOT eoln(rfile) DO
BEGIN { PROCESS TEXT RECORD }
read(rfile,c);
IF redlog THEN write(lfile,c);
a:=ord(c);
putbuf(redbuf,a)
END
ELSE
FOR i:=1 TO size(bbuf) DO
BEGIN
IF redlog THEN write(lfile,bbuf[i]);
a:=ord(bbuf[i]);
putbuf(redbuf,a)
END;
recsred:=succ(recsred); { NUMBER OF RECORDS READ }
IF redlog THEN writeln(lfile,']');
IF creol OR crlfeol THEN putbuf(redbuf,asccr);
IF lfeol OR crlfeol THEN
putbuf(redbuf,asclf)
END
END;
PROCEDURE redopn; {System dependent}
VAR
rstat: boolean;
BEGIN
rstatus:=closed;
IF NOT binary THEN
BEGIN
set$acnm(location(rfile),location(fname)); { SET PASCAL NAME }
ioterm(rfile,oval,false); { TURN OFF I/O TERM ON ERR }
reset(rfile); { OPEN FILE FOR READING }
rstat:= status(rfile)=0; { CHECK FOR OPEN ERROR }
ioterm(rfile,oval,true) { TURN BACK ON I/O TERM ON ERR }
END
ELSE { BINARY FILE TYPE }
BEGIN
set$acnm(location(rbfile),location(fname)); { SET PASCAL NAME }
ioterm(rbfile,oval,false); { TURN OFF I/O TERM ON ERR }
reset(rbfile); { OPEN FILE FOR READING }
rstat:= status(rbfile)=0; { CHECK FOR OPEN ERROR }
ioterm(rbfile,oval,true) { TURN BACK ON I/O TERM ON ERR }
END;
IF rstat THEN
BEGIN
rstatus:=open;
IF NOT binary THEN
sp:=scb$a(location(rfile)) { GET CALLBLOCK OF FILE OPENED }
ELSE { BINARY }
sp:=scb$a(location(rbfile)); { GET CALLBLOCK OF FILE OPENED }
s.svc:=0; { SET UP READ FILE CHARACTERISTICS }
s.subop:=rfc; { SUBOPCODE }
s.buf:=location(rs); { CHARACTERISTICS BUFFER }
s.lrl:=size(rs);
s.lun:=sp@.lun; { LUNO NUMBER }
svc$(location(s)); { PERFORM THE SVC }
IF lstatus = open THEN
BEGIN { RECORD SVC STATUS AND FILE SIZE }
writeln(lfile,'THE SVC RFC STATUS: ',s.stat hex);
writeln(lfile,'FILE SIZE IS: ',rs.filesize);
END;
{ RS.FILESIZE IS THE NO. OF RECORDS IN FILE USED FOR DISPLAYING % }
IF rs.filesize=0 THEN rs.filesize:=100;
recsred:=0
END;
reof:=false; { NO EOF ENCOUNTERED YET }
redix:= -1;
redbuf.ln:= -1
END;
PROCEDURE redcls;
BEGIN
IF rstatus=open THEN { SEE IF FILE IS OPEN }
BEGIN
IF NOT binary THEN
close(rfile) { CLOSE THE FILE }
ELSE
close(rbfile)
END;
rstatus:=closed
END;
PROCEDURE getrec; { Build data portion of data packet }
VAR a: ascval;
exit: boolean;
prevln,previx,tix: integer;
BEGIN
bufinit(filbuf);
{ WE MUST IMPLEMENT SPECIAL EOF HANDLING FOR FILE OF CHAR80 }
IF (NOT binary AND eof(rfile)) OR (binary AND reof) THEN
BEGIN
rstatus:=endfile
END
ELSE
BEGIN
exit:=false;
REPEAT
IF redix >= redbuf.ln THEN
BEGIN
redrec;
IF (NOT binary AND eof(rfile)) OR (binary AND reof) THEN
BEGIN
exit:=true;
IF filbuf.ln=0 THEN
rstatus:=endfile
END
END;
IF redix < redbuf.ln THEN
BEGIN
prevln:=filbuf.ln;
previx:=redix;
redix:=redix+1;
a:=redbuf.ch[redix];
IF locrep<>0 THEN
BEGIN
tix:=redix+1;
WHILE (a=redbuf.ch[tix]) AND (tix<=redbuf.ln) DO
tix:=tix+1;
tix:=tix-redix; {tix is now the repeat count}
IF tix>3 THEN
BEGIN
IF tix>94 THEN tix:=94;
putbuf(filbuf,locrep);
putbuf(filbuf,makechar(tix));
redix:=redix-1+tix
END
END;
IF (a>127) THEN
BEGIN
IF locqu8<>0 THEN putbuf(filbuf,locqu8);
a:=tog128(a)
END;
IF (a<32) OR (a=ascdel) THEN
BEGIN
putbuf(filbuf,locquo);
a:=tog64(a)
END;
IF (a=locquo) OR (a=locqu8) OR (a=locrep) THEN
BEGIN
putbuf(filbuf,locquo)
END;
putbuf(filbuf,a);
IF filbuf.ln >= remdsiz THEN
BEGIN
exit:=true;
IF filbuf.ln>remdsiz THEN
BEGIN
{Character expansion caused buffer length to be
exceeded. Back up.}
filbuf.ln:=prevln;
redix:=previx
END
END
END
UNTIL exit
END
END;
PROCEDURE gencmd(r:ascbuf);
BEGIN { GENCMD }
IF r.ch[1]=ascl THEN { EXIT KERMIT AND LOGOFF }
BEGIN
sndpkt; { SEND ACK }
ssbuf:='$QUIT '; { SCI SYNONYM FOR LOGOFF UPON EXIT }
FOR i:=1 TO 5 DO
syn[i]:=ssbuf[i];
syn[0]:='#05'; { SET SYN LENGTH }
ssbuf:='YES '; { VALUE OF SYNONYM }
FOR i:=1 TO 3 DO
val[i]:=ssbuf[i]; { MOVE IT }
val[0]:='#03'; { LENGTH }
store$syn(syn,val); { SET $QUIT SYN IN CALLING PROC }
server:=false; { EXIT SERVER }
state:=kexit { EXIT KERMIT }
END
ELSE
IF r.ch[1]=ascf THEN { JUST EXIT KERMIT }
BEGIN
sndpkt; { SEND ACK }
server:=false; { EXIT SERVER }
state:=kexit { EXIT KERMIT }
END
ELSE
error('UNSUPPORTED GENERIC COMMAND. ')
END; { GENCMD }
PROCEDURE sendinitiate; { Send states }
BEGIN
IF fnlen>0 THEN
BEGIN
redopn;
IF rstatus=open THEN
BEGIN
putpar; {Put parameters into buffer}
makepacket(ascs,seq,filbuf.ln);
{Make packet with our parameters}
numtry:=0;
state:=sheader
END
ELSE
error('ERROR OPENING READ FILE ')
END
ELSE
error('NO READ FILE SPECIFIED ')
END;
PROCEDURE sendheader;
VAR
wrkbuf:flen; { WORKING BUFFER FOR FILENAME EXTRACTION }
cptr:integer; { A TEMP CHAR POINTER }
BEGIN
IF rcvtyp=ascy THEN
BEGIN
headok:=true;
IF NOT sndonly THEN getpar;
{Get parameters from ACK of 'S' packet}
IF rfnlen>0 THEN
BEGIN { USER SPECIFIED REMOTE FILENAME - USE AS IS }
lintobuf(rfname,rfnlen,filbuf) {Send remote file name.}
END
ELSE
BEGIN { USE LOCAL FILE NAME FOR REMOTE }
{ WE MUST STRIP ANY UNUSUAL CHARS AND/OR DIRECTORY NAMES FROM LOCAL
PATH TO BUILD A REMOTE FILENAME. KERMIT DOES ALLOW THE USE OF A
DOT WITHIN A FILENAME, BUT SINCE DX10 DOESN'T AND DX10 IS THE
ORIGINATING SYSTEM, WE WILL ONLY ALLOW UPPERCASE CHARS AND DIGITS
WITHIN A FILENAME. IF THE USER WANTS ANYTHING ELSE - THEN USE THE
REMOTE FILE OPTION ON SEND COMMAND - THAT'S WHAT IT'S THERE FOR. }
FOR k:=1 TO maxflen DO
wrkbuf[k]:=' '; { CLEAR FILE NAME WORKING BUFFER }
cptr:=fnlen+1; { POINT TO END OF FILENAME }
WHILE cptr>2 AND fname[cptr]<>'.' DO
BEGIN { EXTRACT LOCAL FILE NAME FOR REMOTE }
IF fname[cptr]<>'$' AND fname[cptr]<>'_' THEN
wrkbuf[cptr]:=fname[cptr]
ELSE { WE'LL REPLACE ANY ILLEGAL CHARS WITH 0 - SORRY }
wrkbuf[cptr]:='0';
cptr:=pred(cptr)
END; { GOT A FILE NAME - NOW PUT IN RIGHT PLACE }
rfnlen:=2; { NOW KEEP TRACK OF LENGTH ALSO }
FOR k:=1 TO maxflen DO
IF wrkbuf[k]<>' ' THEN
BEGIN { EXTRACT GOOD NAME FROM WORKING BUFFER }
rfname[rfnlen]:=wrkbuf[k]; { GRAB A GOOD CHAR }
rfnlen:=succ(rfnlen)
END;
rfnlen:=rfnlen-2; { ADJUST FOR TRUE NAME LENGTH }
rfname[1]:=chr(rfnlen);
lintobuf(rfname,rfnlen,filbuf) { SEND ADJUSTED FILE NAME }
END;
numtry:=0;
seq:=(seq+1) MOD 64;
makepacket(ascf,seq,filbuf.ln);
state:=sdata
END
END;
PROCEDURE senddata;
BEGIN
IF rcvtyp=ascy THEN
BEGIN
IF headok THEN { LAST PACKET - FILE HEADER WAS ACKed }
BEGIN
sending:=true; { START SENDING FILE }
headok:=false; { RESET HEADER FLAG }
bsbuf:= 'SENDING FILE: ';
writdev(ts,true,15,location(bsbuf));
FOR k:=1 TO fnlen DO
bsbuf[k]:=fname[k+1];
writdev(ts,true,fnlen,location(bsbuf));
ssbuf:=' ==> ';
writdev(ts,true,5,location(ssbuf));
FOR k:=1 TO rfnlen DO
bsbuf[k]:=rfname[k+1];
writdev(ts,true,rfnlen,location(bsbuf));
tcbuf:=crlf;
writdev(ts,true,2,location(tcbuf))
END;
getrec;
numtry:=0;
seq:=(seq+1) MOD 64;
IF rstatus = open THEN
makepacket(ascd,seq,filbuf.ln)
ELSE
BEGIN
makepacket(ascz,seq,0);
state:=sbreak;
fnlen:=0
END
END
END;
PROCEDURE sendbreak;
BEGIN
IF rcvtyp=ascy THEN
BEGIN
numtry:=0;
seq:=(seq+1) MOD 64;
makepacket(ascb,seq,0)
END;
state:=wexit
END;
{ Receive states PROCEDURES }
PROCEDURE rcvinitiate;
BEGIN
IF rcvtyp=ascs THEN
BEGIN
getpar; {Get parameters from packet}
putpar; {Put parameters into buffer}
makepacket(ascy,seq,filbuf.ln);
{Make ACK packet with our parameters}
seq:=rcvseq;
numtry:=0;
seq:=(seq+1) MOD 64;
state:=rheader
END
END;
PROCEDURE rcvheader;
BEGIN
IF rcvtyp=ascf THEN
BEGIN
IF fnlen=0 THEN
BEGIN { USE REMOTE FILE NAME }
buftolin(rcvbuf,fname,fnlen);
END;
IF fnlen>0 THEN
BEGIN { GOT A FILE TO RECEIVE TO - OPEN IT }
wrtopn;
IF wstatus=open THEN
BEGIN
makepacket(ascy,seq,0);
numtry:=0;
seq:=(seq+1) MOD 64;
headok:=true;
state:=rdata
END
ELSE
error('ERROR OPENING WRITE FILE ')
END
ELSE
error('NO OUTPUT FILE SPECIFIED ')
END
ELSE
IF rcvtyp=ascb THEN
BEGIN
makepacket(ascy,seq,0);
sndpkt;
state:=cexit
END
ELSE
IF rcvtyp=ascg THEN
BEGIN
makepacket(ascy,seq,0); { ACKNOWLEDGE }
numtry:=0;
gencmd(rcvbuf) { PROCESS GENERIC KERMIT CMD }
END
ELSE
error('WRONG PACKET RECEIVING FILE HEADER ')
END;
PROCEDURE receivedata;
BEGIN
IF rcvtyp=ascd THEN
BEGIN
IF headok THEN { LAST PACKET - FILE HEADER WAS ACKed }
BEGIN
receiving:=true; { START RECEIVING FILE }
headok:=false; { RESET HEADER FLAG }
bsbuf:= 'RECEIVING FILE: ';
writdev(ts,true,17,location(bsbuf));
FOR k:=1 TO rfnlen DO
bsbuf[k]:=rfname[k+1];
writdev(ts,true,rfnlen,location(bsbuf));
ssbuf:=' ==> ';
writdev(ts,true,5,location(ssbuf));
FOR k:=1 TO fnlen DO
bsbuf[k]:=fname[k+1];
writdev(ts,true,fnlen,location(bsbuf));
tcbuf:=crlf;
writdev(ts,true,2,location(tcbuf))
END;
putrec(rcvbuf);
makepacket(ascy,seq,0);
numtry:=0;
seq:=(seq+1) MOD 64
END
ELSE
IF rcvtyp=ascz THEN { RECEIVED EOF INDICATOR PACKET }
BEGIN
wrtcls;
fnlen:=0;
makepacket(ascy,seq,0);
numtry:=0;
seq:=(seq+1) MOD 64;
state:=rheader
END
ELSE
error('UNEXPECTED PACKET RECEIVING DATA ')
END;
PROCEDURE get; { PREPARE AN R PACKET }
BEGIN
IF rcvtyp=ascy THEN
BEGIN { I PACKET ACKed - CONTINUE NEXT STATE }
lintobuf(rfname,rfnlen,filbuf); { SEND FILE NAME TO GET }
numtry:=0;
makepacket(ascr,seq,filbuf.ln);
state:=rinitiate
END
END;
PROCEDURE iinitiate;
BEGIN
putpar; {Put parameters into buffer}
makepacket(asci,seq,filbuf.ln); { MAKE I PARAMETER PACKET }
numtry:=0
END;
PROCEDURE finish; { SHUT DOWN REMOTE SERVER AND KERMIT }
BEGIN
bufinit(filbuf);
putbuf(filbuf,ascf);
makepacket(ascg,seq,filbuf.ln); {Make packet with our parameters}
numtry:=0;
state:=wexit
END;
PROCEDURE bye; { SHUT DOWN REMOTE SERVER, KERMIT & LOGOFF }
BEGIN
bufinit(filbuf);
putbuf(filbuf,ascl);
makepacket(ascg,seq,filbuf.ln); {Make packet with our parameters}
numtry:=0;
state:=wexit
END;
PROCEDURE connect; { CONNECT TO REMOTE }
{ THE PROCEDURE CONNECT IS A SIMPLE TTY TYPE EMULATOR USED TO }
{ CONNECT REMOTE SYSTEMS OR MODEMS. FULL DUPLEX I/O IS EMULATED. }
{ I/O IS ACCOMPLISHED VIA SVC CALLS. CALLS TO PROCEDURES TO PER- }
{ FORM READS AND WRITES HAVE BEEN REMOVED FOR GREATER SPEED - }
{ ESPECIALLY NEEDED FOR CHARACTER INPUT. A WAIT ON ANY I/O }
{ CALL IS MADE WHEN NOTHING IS GOING ON - TO AVOID SPINNING. }
{ IF WE GET AN INPUT BUFFER OVERFLOW(I.E. THE CHARACTERS ARE COM- }
{ ING IN FASTER THAN WE CAN HANDLE THEM),THEN WE WILL DYNAMICALLY }
{ ADJUST OUR XOFF THRESHOLD(I.E. NUMBER OF CHARACTERS TO RECEIVE }
{ AT ONE TIME BEFORE SENDING AN XOFF) TO ADAPT TO THE SYSTEM. }
VAR
escseq:boolean; { ESCAPE FROM REMOTE HOST }
xbuf:char2; { XON - XOFF CHAR BUFFER }
fq,bq:integer; { CHAR POINTERS }
xoff:boolean; { XOFF-XON IN PROGRESS }
wrt:boolean; { WRITE TO TERMINAL IS TAKING PLACE }
b:boolean; { DOUBLE BUFFER POINTER }
bufp:ARRAY[boolean]OF buf; { REMOTE CONNECT DOUBLE BUFFERS }
justread:char; { FOR ECHO CHAR CONTROL }
ti:integer; { GET CHAR LOOP CONTROLLER }
dummy:char2; { JUNK TO SATISFY A WRITE NEED }
adjustxoff:integer; { CURRENT NO. OF CHARS TO RECEIVE BEFORE XOFF }
inesc:integer; { CHEAP EMULATOR FLAG }
seqnum:integer; { HOW MANY ESQ SEQ. CHARS TO THROW AWAY FOR ISC }
twochar:boolean; { DOUBLE CHAR FLAG }
BEGIN
seqnum:=0;
inesc:=0; { NO VALID CHARACTER TO OUTPUT }
twochar:=false; { NO 2 CHAR SEQUENCE TO SEND YET }
adjustxoff:=xoff_threshold; { SET INITIAL VALUE }
bq:=0;
fq:=0;
w1.op:= #36; { SET WAIT ON ANY I/O COMPLETION SVC OPCODE }
w1.fil1:=0; { CLEAR REST OF CALLBLOCK }
w1.fil2:=0;
w1.fil3:=0;
dummy:='#08#08';
xbuf:='#13#11'; { XOFF AND XON FOR I/O CONTROL }
xoff:=false;
wrt:=false;
b:=true;
escseq:=false;
ti:=0;
ps.subop:=readas; { READ ASCII SUBOPCODE }
ps.flags:=[qret]; { QUICK RETURN I/O }
ps.buf:=location(pcbuf); { SET BUFFER }
ps.lrl:=1; { READ A SINGLE CHARACTER }
svc$(location(ps)); { PERFORM I/O OPERATION }
ts.subop:=readas; { READ ASCII SUBOPCODE }
ts.flags:=[qret]; { QUICK RETURN I/O }
ts.buf:=location(tcbuf); { SET BUFFER }
ts.lrl:=1; { READ A SINGLE CHARACTER }
svc$(location(ts)); { PERFORM I/O OPERATION }
{ UNTIL ESCAPE SEQ IS TYPED }
WHILE NOT escseq AND ts.stat=0 AND
(ps.stat=0 OR (ps.stat>=#50 AND ps.stat<=#52)) DO
BEGIN { PARITY,FRAME,OVERFLOW - NON-FATAL }
IF ps.stat>=#50 AND ps.stat<=#52 THEN
BEGIN { NOT FATAL - i.e. HOPEFULLY THINGS WILL GET BETTER }
IF ps.stat=#52 THEN
BEGIN { OVERFLOW ERROR }
IF lstatus=open THEN
BEGIN
writeln(lfile,'PORT FULL BUFFER ERROR');
writeln(lfile,'CHARS BUFFED SO FAR: ',fq)
END;
{ ATTEMPT TO ADJUST XOFF THRESHOLD FOR CURRENT SYSTEM CONDITIONS }
{ BUT KEEP ABOVE MINIMUM TO AVOID XOFFING EVERY LINE OR TWO. }
{ ADJUSTING XOFF THRESHOLD IS EXPERIMENTAL AND MAY BE REMOVED }
IF fq>200 AND fq<adjustxoff THEN
adjustxoff:=fq
END
ELSE
IF ps.stat=#51 THEN
BEGIN
IF lstatus=open THEN
writeln(lfile,'PORT FRAMING ERROR')
END
ELSE { JUST A PARITY ERROR }
BEGIN
IF lstatus=open THEN
writeln(lfile,'PARITY ERROR ON PORT.')
END;
ps.stat:=0; { CLEAR THE ERR }
svc$(location(ps)) { REQUEUE READ }
END;
IF NOT bsy IN ps.flags AND ps.stat=0 THEN
BEGIN { GOT A CHAR FROM REMOTE SYSTEM/MODEM }
ti:=0; { RESET GET CHAR LOOP CONTROLLER }
WHILE ti<800 AND ps.stat=0 DO
{ HOW LONG YOU WANT TO STAY IN HERE DEPENDS ON AVOVE CONSTANT }
BEGIN
{ STAY HERE FOR AWHILE IN CASE MORE CHARS ARE COMING IN }
IF NOT bsy IN ps.flags THEN
BEGIN { READ FINISHED }
fq:=succ(fq); { NUMBER OF CHARS READ IN SO FAR }
(******************************************************************)
IF isc THEN { A VERY QUICK 931 TO TTY EMULATOR }
{ THE OBJECTIVE HERE IS TO ATTEMPT TO INHIBIT THE ESCAPE SEQUENCES }
{ THAT GET SENT TO A TI VDT931 TERMINAL, THUS EMULATING A TTY MODE. }
{ IF AN ESCAPE SEQUENCE ARRIVES, THEN THE ESCAPE SEQUENCE WILL BE }
{ THROWN AWAY. THE NUMBER OF CHARACTERS TOSSED WILL DEPEND ON THE }
{ TYPE OF SEQUENCE. MOST ARE SINGLE CHARACTER SEQUENCES. }
CASE inesc OF { OUR PRESENT STATE }
0:
IF pcbuf[1] <> '#1B' THEN
bufp[b,fq]:=pcbuf[1]
ELSE
BEGIN
inesc:=1;
fq:=pred(fq) { THROW AWAY ESCAPE CHAR }
END;
1:
BEGIN
inesc:=2; { ASSUME >2 SEQ LENGTH }
{ DEPENDING ON THE ESQ SEQ IDENTIFIER, NUMBER OF CHARS TO TOSS IS SET }
CASE pcbuf[1] OF
'V': seqnum:=1;
'Y':
BEGIN
{ DO A CRLF ON A CURSOR POSITION SEQUENCE }
seqnum:=2;
bufp[b,fq]:='#0A';
fq:=succ(fq);
bufp[b,fq]:='#0D';
fq:=succ(fq)
END;
'4': seqnum:=1;
'@': seqnum:=2;
'>': seqnum:=2;
'j':seqnum:=2;
'x': seqnum:=4;
'?': seqnum:=3;
'k':
seqnum:=2
OTHERWISE
{ JUST TOSS THIS ONE i.e. 2 CHAR SEQ }
inesc:=0
{ AND RETURN TO NORMAL CHAR STATE }
END;
fq:=pred(fq) { TOSS THE CHAR }
END;
2:
BEGIN
seqnum:=pred(seqnum);
{ SET NUMBER OF CHARS REMAINING TO TOSS }
fq:=pred(fq); { TOSS THIS ONE }
IF seqnum=0 THEN { ALL DONE TOSSING }
inesc:=0 { RETURN TO NORMAL INPUT STATE }
END
END
ELSE
(******************************************************************)
bufp[b,fq]:=pcbuf[1]; { SAVE CHAR - DOUBLE BUF }
IF fq>adjustxoff THEN
BEGIN { READ BUF ALMOST FULL }
ps.subop:=writas; { WRITE ASCII SUBOPCODE }
ps.flags:=[];
ps.buf:=location(xbuf); { POINT TO XOFF }
ps.cc:=1; { CHARACTERS TO WRITE }
svc$(location(ps)); { SEND XOFF }
ps.subop:=readas; { READ ASCII SUBOPCODE }
ps.flags:=[qret]; { QUICK RETURN I/O }
ps.buf:=location(pcbuf); { SET BUFFER }
ps.lrl:=1; { READ A SINGLE CHARACTER }
IF ps.stat=0 THEN
svc$(location(ps)); { NOW EMPTY PDT BUF }
WHILE fq<buf_threshold AND ps.stat=0 AND NOT
xoff DO
BEGIN { EMPTY PDT BUFFER OF ALL CHARS }
IF NOT bsy IN ps.flags THEN
BEGIN
fq:=succ(fq);
bufp[b,fq]:=pcbuf[1];
IF fq<buf_threshold THEN
svc$(location(ps))
ELSE
xoff:=true
{ ONLY IF USER HAS "LARGE" PDT BUFFER }
END
ELSE
BEGIN
delay(100);
xoff:=bsy IN ps.flags { DONE }
END
END;
IF lstatus = open THEN
BEGIN
writeln(lfile,'FQ SURPASSED ADJUST IS:',fq);
IF xoff THEN
writeln(lfile,'XOFF WAS JUST SET')
END
END
ELSE
svc$(location(ps)); { CONTINUE READING }
ti:=0 { RESET ITERATION LOOP CONTROL }
END
ELSE
ti:=succ(ti)
END
END
ELSE { EITHER DEVBSY(PS) OR XOFF }
BEGIN
IF fq>0 AND NOT wrt AND bsy IN ts.flags AND
(bsy IN ps.flags OR xoff) THEN
BEGIN
IF fq>80 THEN
BEGIN { LIMITED TO 80 CHAR WRITE WITH PASSTHRU }
bq:=fq-80;
fq:=80
END;
abort(ts);
ts.subop:=writas; { WRITE ASCII SUBOPCODE }
ts.flags:=[qret]; { QUICK RETURN I/O }
ts.cc:=fq; { CHARACTERS TO WRITE }
ts.buf:=location(bufp[b]); { SET WRITE BUFFER }
IF isc THEN { SPECIAL CHARACTER HANDLING }
BEGIN
IF fq=1 AND bufp[b,1]=justread THEN
{ THIS IS WHERE WE CAN SUPPRESS ECHO ON ISC }
ts.buf:=location(dummy) { OR NON-PASSTHRU TERM }
ELSE { ONLY UPPERCASE ON ISC ALLOWED }
FOR i:=1 TO (bq+fq) DO { L.C. --> U.CASE }
IF bufp[b,i]>='a' AND bufp[b,i]<='z' THEN
bufp[b,i]:=chr(ord(bufp[b,i])-32)
END;
svc$(location(ts)); { PERFORM I/O OPERATION }
wrt:=true;
b:=NOT b; { ENABLE DOUBLE BUFFERING }
fq:=0
END
ELSE
IF NOT(wrt OR bsy IN ts.flags OR ts.stat<>0)AND
(bsy IN ps.flags OR xoff) THEN
BEGIN { READ A CHAR FROM THE TERMINAL }
IF ts.cc=1 THEN
BEGIN
justread:=tcbuf[1];
{ SAVE LAST CHAR READ FROM TERM }
IF tcbuf[1]='#40' OR tcbuf[1]='#5E' OR
tcbuf[1]='#25' THEN
BEGIN { SPECIAL CHARACTERS }
tcbuf[2]:=tcbuf[1];
{ SAVE POSSIBLE SPECIAL START CHAR }
svc$(location(ts));
{ TRY FOR SPECIAL SEQUENCE }
delay(200); { ALLOW DELAY FOR REST OF SEQ }
IF NOT bsy IN ts.flags AND ts.stat=0 THEN
BEGIN { GOT ANOTHER CHAR }
IF tcbuf='#40#40' THEN
escseq:=true { GET OUT }
ELSE
{ IF ON ISC(NO-PASSTHRU TERM) THE FOLLOWING KEY SEQUENCES ARE NEEDED }
{ IN ORDER TO SEND SPECIAL CONTROL KEYS TO TI REMOTE 931 PORT }
IF tcbuf='#5E#5E' THEN
BEGIN
twochar:=true; { A TWO CHAR SEND }
tcbuf:='#1B#68' { CMD KEY }
END
ELSE
IF tcbuf='#25#25' THEN
BEGIN
twochar:=true;
{ A TWO CHAR SEND }
tcbuf:='#1B#67' { BLNK ORGE KEY }
END
ELSE
IF tcbuf='#5E#40' THEN
tcbuf[1]:='#1B' { ESQ KEY }
ELSE
IF tcbuf='#25#40' THEN
tcbuf[1]:='#11' { SEND XON }
END
END
END
ELSE
IF isc THEN { ONLY FOR ISC TERMINAL }
BEGIN
tcbuf:=crlf; { HEURISTIC-PROBABLY A CR }
ts.subop:=writas;
ts.flags:=[];
ts.cc:=1;
ts.buf:=location(tcbuf)+1;
svc$(location(ts)) { WRITE LF TO ISC }
END;
IF NOT escseq AND NOT xoff AND ts.stat=0 THEN
BEGIN
abort(ps);
ps.subop:=writas; { WRITE ASCII SUBOPCODE }
ps.flags:=[];
IF isc AND twochar THEN
BEGIN
twochar:=false; { RESET }
ps.cc:=2 { WRITE 2 CHARS }
END
ELSE
ps.cc:=1; { CHARACTERS TO WRITE }
ps.buf:=location(tcbuf); { SET BUFFER }
svc$(location(ps)); { PERFORM I/O OPERATION }
IF ps.stat=0 THEN
BEGIN { CONTINUE - NO ERROR }
ps.subop:=readas; { READ ASCII SUBOPCODE }
ps.flags:=[qret]; { QUICK RETURN I/O }
ps.buf:=location(pcbuf); { SET BUFFER }
ps.lrl:=1; { READ A SINGLE CHARACTER }
svc$(location(ps)); { PERFORM I/O OPERATION }
IF NOT bsy IN ts.flags AND ts.stat=0 THEN
BEGIN
{ READ POSSIBLY QUEUED ALREADY ABOVE }
ts.subop:=readas;
{ READ ASCII SUBOPCODE }
ts.lrl:=1; { READ A SINGLE CHAR }
ts.flags:=[qret]; { QUICK RETURN I/O }
ts.buf:=location(tcbuf); { SET BUFFER }
svc$(location(ts))
{ PERFORM I/O OPERATION }
END
END
END
END
ELSE
IF wrt AND NOT bsy IN ts.flags AND ts.stat=0 AND
(bsy IN ps.flags OR xoff) THEN
BEGIN
IF bq>0 THEN
BEGIN
ts.subop:=writas; { WRITE ASCII SUBOPCODE }
ts.flags:=[qret]; { QUICK RETURN I/O }
ts.buf:=ts.buf+80; { SET BUFFER }
IF bq>80 THEN
BEGIN
ts.cc:=80;
bq:=bq-80
END
ELSE
BEGIN
ts.cc:=bq;
bq:=0
END;
svc$(location(ts))
END
ELSE
BEGIN
wrt:=false;
ts.subop:=readas; { READ ASCII SUBOPCODE }
ts.flags:=[qret]; { QUICK RETURN I/O }
ts.buf:=location(tcbuf); { SET BUFFER }
svc$(location(ts)); { PERFORM I/O OPERATION }
IF xoff THEN
BEGIN
IF lstatus=open THEN
writeln(lfile,'XOFF BEING RESET');
xoff:=false;
pcbuf[1]:=xbuf[2];
IF bsy IN ps.flags THEN
abort(ps);
ps.subop:=writas; { WRITE ASCII SUBOPCODE }
ps.flags:=[];
ps.buf:=location(pcbuf); { SET BUFFER }
ps.cc:=1; { CHARACTERS TO WRITE }
svc$(location(ps));
{ PERFORM I/O OPERATION }
IF ps.stat=0 THEN
ps.subop:=readas;
{ READ ASCII SUBOPCODE }
ps.flags:=[qret]; { QUICK RETURN I/O }
ps.lrl:=1; { READ A SINGLE CHARACTER }
svc$(location(ps))
{ PERFORM I/O OPERATION }
END
END
END
END;
IF bsy IN ps.flags AND bsy IN ts.flags AND
bq=0 AND fq=0 AND NOT wrt AND NOT xoff THEN
{ NOTHING GOING ON }
svc$(location(w1)) { DONT SPIN - WAIT ANY I/O COMPLETION }
END;
IF ts.stat<>0 AND lstatus=open THEN
BEGIN
writeln(lfile,'A TERMINAL SVC ERROR.');
writeln(lfile,'THE SVC ERROR IS: ',ts.stat hex);
writeln(lfile,'BYE')
END;
IF ps.stat<>0 AND lstatus=open THEN
BEGIN
writeln(lfile,'A REMOTE PORT SVC ERROR.');
writeln(lfile,'THE SVC ERROR IS: ',ps.stat hex);
writeln(lfile,'BYE')
END
END; { CONNECT }
PROCEDURE help;
BEGIN { HELP }
tcbuf:=crlf;
writdev(ts,true,2,location(tcbuf));
bsbuf:='THE FOLLOWING COMMANDS ARE SUPPORTED.#0D#0A ';
writdev(ts,true,40,location(bsbuf));
bsbuf:='PLEASE USE UPPERCASE FOR ALL COMMANDS.#0D#0A';
writdev(ts,true,40,location(bsbuf));
writdev(ts,true,2,location(tcbuf));
bsbuf:='LOG <OPTIONAL FILENAME> #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='CONNECT - CONNECT TO REMOTE SYSTEM. #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='SEND <LOCAL FILE> <OPTIONAL REM FILE> #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='RECEIVE <DX10 RECEIVE FILE NAME> #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='FINISH - SHUT DOWN REMOTE KERMIT. #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='BYE - SHUT DOWN AND LOG OFF REMOTE. #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='TEST - SEND ONLY TEST MODE. #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='EXIT - LEAVE KERMIT. #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='SERVER - PLACE KERMIT IN SERVER MODE. #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='BINARY - SEND/RECEIVE BINARY FILE. #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='TEXT - SEND/RECEIVE TEXT FILE(DEFAULT)#0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='GET <REMOTE FILE NAME> <LOCAL FILE> #0D#0A';
writdev(ts,true,40,location(bsbuf));
writdev(ts,true,2,location(tcbuf));
writdev(ts,true,2,location(tcbuf))
END; { HELP }
PROCEDURE error; { Error processing - Process fatal errors }
VAR l:integer;
BEGIN { ERROR }
l:=size(msg);
IF l>maxbuf-6 THEN l:=maxbuf-6;
bufinit(filbuf);
FOR i:=1 TO 3 DO putbuf(filbuf,ascsp);
{Make message readable in packet}
FOR i:=1 TO l DO putbuf(filbuf,ord(msg[i]));
FOR i:=1 TO 3 DO putbuf(filbuf,ascsp);
{Make message readable in packet}
makepacket(asce,seq,filbuf.ln);
sndpkt;
state:=cexit; { THEN EXIT BACK TO COMMAND MODE }
IF local AND NOT server THEN { OUT ERROR TO CONSOLE TOO }
BEGIN
ssbuf:='#0D#0A#0D#0A ';
writdev(ts,true,4,location(ssbuf));
writdev(ts,true,40,location(msg));
writdev(ts,true,4,location(ssbuf))
END
END; { ERROR }
PROCEDURE kermcommand;
BEGIN { KERMCOMMAND }
IF lstatus=open AND server THEN
writeln(lfile,'IN SERVER MODE');
REPEAT
rcvpkt; { GET A PACKET }
IF rcvseq>-1 THEN { LEGAL PACKET RECEIVED }
BEGIN
IF rcvtyp=asci AND server THEN { RECEIVED INIT PARMS PACKET }
BEGIN
getpar; {Get parameters from packet}
putpar; {Put parameters into buffer}
seq:=rcvseq;
makepacket(ascy,seq,filbuf.ln);
{Make ACK packet with our parameters}
sndpkt { AND SEND IT OFF }
END
ELSE
IF rcvtyp=ascs THEN
BEGIN { RECEIVED SEND-INIT PACKET }
state:=rinitiate
END
ELSE
IF rcvtyp=ascr AND server THEN
BEGIN { RECEIVE A FILE REQUEST PACKET }
IF fnlen=0 THEN
BEGIN
buftolin(rcvbuf,fname,fnlen)
END;
state:=sinitiate
END
ELSE
IF rcvtyp=ascg AND server THEN
BEGIN
makepacket(ascy,seq,0); { ACKNOWLEDGE }
numtry:=0;
gencmd(rcvbuf) { PROCESS GENERIC KERMIT COMMAND }
END
ELSE
error('UNEXPECTED PACKET TYPE ')
END
ELSE
IF rcvseq=-1 THEN
BEGIN
makepacket(ascn,seq,0);
sndpkt { SEND PERIODIC NAK }
END
ELSE
IF rcvseq=-2 THEN
BEGIN
state:=cexit;
server:=false
END
UNTIL state<>kcommand
END;
PROCEDURE kerminitialize; { Initialization state }
VAR lstat: boolean;
BEGIN
state:=kcommand;
numtry:=0;
seq:=0;
fnlen:=0; {Indicate no file name yet}
rfnlen:=0; { NO REMOTE FILE NAME YET }
pktsnt:=0; { NUMBER OF PACKETS SENT }
sending:=false;
receiving:=false; { NOT RECEIVING A FILE YET }
locbsiz:=78;
loctout:=12;
locnpad:=0;
locpad:=0;
loceol:=asccr;
locquo:=ascns;
{ locqu8 will be set after options are processed. }
locrep:=asctil; {Initialize to 0 to turn off repeat counts}
rembsiz:=78;
{ remdsiz:=rembsiz-3; }
remdsiz:=rembsiz-6; { MAKE SMALLER - EXCEEDING REMOTE BUFS }
remtout:=12;
remnpad:=0;
rempad:=0;
remeol:=asccr;
remqu8:=0;
remrep:=0;
headok:=false; { NO HEADER PACKET YET }
bptr:=0; { NO DATA IN BINARY DATA BUFFER YET }
bufinit(sndbuf);
{The following should only be done on the first call to initialize}
IF iniflg=false THEN
BEGIN
sndonly:=false;
sndlog:=false;
rcvlog:=false;
wrtlog:=false;
redlog:=false;
lnlen:=0; { LOG FILE LENGTH }
crlfeol:=true;
creol:=false;
lfeol:=false;
rstatus:=closed;
wstatus:=closed;
lstatus:=closed;
eolflg:=false; { NO CR OR LF ENCOUNTERED YET }
server:=false; { SET ONLY IN SERVER MODE }
cond:=false;
optqu8:=0; { ASSUME NO EIGHT-BIT QUOTING }
binary:=false { DEFAUTLT NON-BINARY TYPE DATA }
END;
locqu8:=optqu8; { EIGHT BIT QUOTING DONE ONLY WITH BINARY OPTION }
iniflg:=true
END;
PROCEDURE getstr(VAR wp,strlen:integer;VAR str:flen;cnt:boolean);
(******************************************************************
* ATTEMPT TO GET A THE NEXT STRING WITHIN THIS BUFFER OF STRINGS
*
* WP - CURRENT CHAR POINTER WITHIN THE BUFFER
* STRLEN - LENGTH OF THE STRING RETURNED - 0 IF NONE OR PAST END.
* STR - THE ACTUAL STRING
* CNT - IF TRUE PUT THE COUNT AT FRONT OF STRING - NEEDED FOR
* FILE NAMES.
********************************************************************)
BEGIN { GETSTR }
strlen:=0; { CLEAR --> NO VALID STRING YET }
WHILE cmdbuf.ch[wp]<>ascsp AND wp <=cmdbuf.ln DO
wp:=succ(wp); { SKIP PAST CHARS IF ANY }
WHILE cmdbuf.ch[wp]=ascsp AND wp <=cmdbuf.ln DO
wp:=succ(wp); { SKIP PAST BLANKS BETWEEN STRINGS IF ANY }
WHILE cmdbuf.ch[wp]<>ascsp AND wp<=cmdbuf.ln DO
BEGIN { SAVE THE STRING WE ARE NOW POINTING TO }
strlen:=succ(strlen); { SAVE LENGTH OF STRING }
str[strlen]:=chr(cmdbuf.ch[wp]); { MOVE A CHAR }
wp:=succ(wp) { BUMP BUFFER POINTER }
END;
IF strlen > 0 THEN { STRING IS VALID }
BEGIN
IF cnt THEN { WE NEED STRING COUNT AT FRONT }
BEGIN
FOR i:= (strlen+1) DOWNTO 2 DO
str[i]:=str[(i-1)]; { SHIFT STRING ONE TO RIGHT }
str[1]:=chr(strlen)
{ PUT STRING LENGTH AT FRONT OF STRING }
END
END
END; { GETSTR }
PROCEDURE prscmd(VAR parseok:boolean); { PARSE A KERMIT COMMAND }
VAR
sp:integer; { A STRING(cmdbuf) POINTER }
BEGIN
sp:=1; { POINT TO THE BEGINNING OF THE CMDBUF }
(******************** SEND ********************)
IF (cmdbuf.ch[1]=ascs AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascn)
THEN
BEGIN { THIS IS A SEND COMMAND }
getstr(sp,fnlen,fname,true);
{ GET FILE NAME TO SEND - IF ANY }
IF fnlen = 0 THEN
BEGIN
{ SEND FILE NAME NOT IN CMD BUF - PROMPT USER }
bsbuf:='FILE NAME SPECIFICATIONS WERE NOT ENTERE';
writdev(ts,true,40,location(bsbuf));
bsbuf:='D - TRY AGAIN PLEASE.#0D#0A ';
writdev(ts,true,23,location(bsbuf))
END
ELSE
BEGIN
parseok:=true; { CMD ENTERED SYNTACTICALLY OK }
state:=sinitiate; { SET SEND INIT STATE }
getstr(sp,rfnlen,rfname,true)
{ CHK FOR REMOTE FILENAME IN CMD }
{ A REMOTE FILE NAME IS OPTIONAL }
END
END;
(****************** RECEIVE *******************)
IF (cmdbuf.ch[1]=ascr AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascc)
THEN
BEGIN { THIS IS A RECEIVE COMMAND }
getstr(sp,fnlen,fname,true);
{ GET LOCAL FILENAME TO STORE FILE UNDER }
IF fnlen = 0 THEN
BEGIN
{ REQUIRED RECEIVE FILE NAME NOT IN CMD BUF - PROMPT USER }
bsbuf:='FILE NAME SPECIFICATIONS WERE NOT ENTERE';
writdev(ts,true,40,location(bsbuf));
bsbuf:='D - TRY AGAIN PLEASE.#0D#0A ';
writdev(ts,true,23,location(bsbuf))
END
ELSE
BEGIN
state:=rcv; { SET RCV STATE }
parseok:=true { CMD ENTERED SYNTACTICALLY OK }
END
END;
(******************** GET ********************)
IF (cmdbuf.ch[1]=ascg AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=asct)
THEN { THIS IS A GET COMMAND }
BEGIN { EXTRACT FROM COMMAND LINE REMOTE FILE TO GET }
getstr(sp,rfnlen,rfname,true);
IF rfnlen = 0 THEN
BEGIN
{ REMOTE FILE NAME TO GET NOT IN CMD LINE - PROMPT USER }
bsbuf:='A REMOTE FILE NAME TO GET MUST BE ENTERE';
writdev(ts,true,40,location(bsbuf));
bsbuf:='D - TRY AGAIN PLEASE.#0D#0A ';
writdev(ts,true,23,location(bsbuf))
END
ELSE
BEGIN
getstr(sp,fnlen,fname,true);
{ LOCAL FILE NAME TO WRITE FILE TO }
IF fnlen=0 THEN
BEGIN
{ LOCAL FILE NAME TO WRITE REMOTE FILE TO NOT IN CMD LINE }
bsbuf:='A LOCAL DX10 FILE NAME MUST BE ENTERED -';
writdev(ts,true,40,location(bsbuf));
bsbuf:=
' TRY AGAIN PLEASE.#0D#0A ';
writdev(ts,true,20,location(bsbuf))
END
ELSE
BEGIN
parseok:=true; { CMD ENTERED SYNTACTICALLY OK }
iinitiate; { MAKE INITIAL I PACKET }
state:=getinit { PREPARE R PACKET NEXT }
END
END
END;
(********************* LOG ********************)
IF (cmdbuf.ch[1]=ascl AND cmdbuf.ch[2]=asco AND cmdbuf.ch[3]=ascg)
THEN
BEGIN { SET LOGGING }
IF lstatus <> open THEN { NOT ALREADY OPEN }
BEGIN
getstr(sp,lnlen,lname,true); { GET USER LOG FILE - IF ANY }
IF lnlen = 0 THEN { USE DEFAULT LOG FILE }
p$parm(5,lname,perr); { GET DEFAULT LOG FILE PATHNAME }
sndlog:=true;
rcvlog:=true;
wrtlog:=true;
redlog:=true;
logopn;
parseok:=true { LOG COMMAND ACCEPTED CORRECT }
END
ELSE
BEGIN
bsbuf:='LOG FILE ALREADY OPEN - NO NEED TO SET L';
writdev(ts,true,40,location(bsbuf));
bsbuf:='OGGING AGAIN.#0D#0A ';
writdev(ts,true,15,location(bsbuf))
END
END;
(******************** TEST ********************)
IF (cmdbuf.ch[1]=asct AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascs)
THEN
BEGIN { SEND ONLY FOR TESTING }
sndonly:=true;
parseok:=true; { TEST COMMAND ACCEPTED CORRECT }
bsbuf:='TEST MODE->NO PACKETS WILL BE RECEIVED#0D#0A';
writdev(ts,true,40,location(bsbuf))
END;
(******************** SERVER ********************)
IF (cmdbuf.ch[1]=ascs AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascr)
THEN
BEGIN { SEND ONLY FOR TESTING }
server:=true;
bsbuf:='#0D#0AKERMIT SERVER RUNNING ON DX10 HOST,#0D#0AP';
writdev(ts,true,40,location(bsbuf));
bsbuf:='LEASE TYPE YOUR ESC SEQUENCE TO RETURN#0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='TO YOUR LOCAL MACHINE. SHUT DOWN#0D#0ASERVE';
writdev(ts,true,40,location(bsbuf));
bsbuf:='R BY TYPING THE BYE OR FINISH COMMAND #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='ON YOUR LOCAL MACHINE.... #0D#0A';
writdev(ts,true,40,location(bsbuf));
parseok:=true; { SERVER CMD ACCEPTED }
makepacket(ascn,seq,0); { SEND INITIAL NAK TO LOCAL }
sndpkt { GET THINGS ROLLING }
END;
(******************** CONNECT ********************)
IF (cmdbuf.ch[1]=ascc AND cmdbuf.ch[2]=asco AND cmdbuf.ch[3]=ascn)
THEN
BEGIN { CONNECT COMMAND }
IF local THEN { CONNECT ONLY IN LOCAL MODE - PLEASE }
BEGIN
bsbuf:='#0D#0ACONNECTING THRU ';
writdev(ts,true,18,location(bsbuf));
FOR k:=1 TO ord(ioname[1]) DO
bsbuf[k]:=ioname[k+1];
writdev(ts,true,(ord(ioname[1])),location(bsbuf));
bsbuf:=', SPEED 1200#0D#0ATO ESCAPE AND RETURN TO YO';
writdev(ts,true,40,location(bsbuf));
bsbuf:='UR LOCAL #0D#0ASYSTEM - TYPE TWO "AT SIGN" ';
writdev(ts,true,40,location(bsbuf));
bsbuf:=' @ #0D#0ACHARACTERS IN QUICK SEQUENCE. #0D#0A';
writdev(ts,true,40,location(bsbuf));
IF NOT isc THEN
passt(ts,true)
{ SET PASSTHRU MODE WHILE CONNECTED TO REMOTE }
ELSE { DISPLAY SPECIAL CHAR SEQUENCES FOR ISC }
BEGIN
tcbuf:=crlf;
writdev(ts,true,2,location(tcbuf));
writdev(ts,true,2,location(tcbuf));
bsbuf:='TYPE THE FOLLOWING IN FAST SEQUENCE : #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='^ ^ (TWO UP ARROWS) FOR CMD KEY. #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='% % (TWO PERCENTS) FOR BLNK ORNGE KEY.#0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='@ ^ ( AT SIGN AND UP ARROW) FOR ESQ. #0D#0A';
writdev(ts,true,40,location(bsbuf));
bsbuf:='@ % ( AT SIGN AND PERCENT) FOR DC1. #0D#0A';
writdev(ts,true,40,location(bsbuf));
writdev(ts,true,2,location(tcbuf))
END;
IF ts.stat=0 THEN
connect; { GO ATTEMPT CONNECT TO REMOTE }
bsbuf:='#0A#0DKERMIT IS BACK TO LOCAL SYSTEM. #0D#0A';
writdev(ts,true,40,location(bsbuf));
IF ts.stat<>0 THEN
BEGIN { CONSOLE TERMINAL I/O ERR DURING CONNECT }
bsbuf:='CONSOLE TERMINAL ERROR DURING CONNECT.#0D#0A';
writdev(ts,true,40,location(bsbuf))
END;
IF ps.stat<>0 THEN
BEGIN { REMOTE PORT I/O ERROR DURING CONNECT }
bsbuf:='REMOTE PORT I/O ERROR DURING CONNECT. #0D#0A';
writdev(ts,true,40,location(bsbuf))
END;
IF NOT isc THEN { TURN OFF PASSTHRU }
BEGIN { SO WE CAN DO CMD CONTROL AGAIN }
IF bsy IN ts.flags THEN { ABORT ANY I/O FIRST }
abort(ts); { OR PASSTHRU WON'T BE AFFECTED }
passt(ts,false) { THEN TURN IT OFF }
END;
parseok:=true { ONLY ERR ON THIS COMMAND IS MISSPELLING }
END
ELSE
BEGIN
bsbuf:='#0D#0AYOU HAVE ALREADY CONNECTED TO A REMOTE';
writdev(ts,true,40,location(bsbuf));
bsbuf:='#0D#0ASYSTEM. USE YOUR ESCAPE SEQUENCE IF Y';
writdev(ts,true,40,location(bsbuf));
bsbuf:='OU #0D#0AWISH TO RETURN TO YOUR LOCAL SYSTEM';
writdev(ts,true,40,location(bsbuf));
bsbuf:='.#0D#0A ';
writdev(ts,true,3,location(bsbuf))
END
END;
(******************** FINISH ********************)
IF (cmdbuf.ch[1]=ascf AND cmdbuf.ch[2]=asci AND cmdbuf.ch[3]=ascn)
THEN
BEGIN { USER TYPED THE FINISH COMMAND }
parseok:=true; { CMD ENTERED SYNTACTICALLY OK }
iinitiate; { MAKE REQUIRED PRECEDING I PACKET }
state:=fininit
END;
(******************** BYE ********************)
IF (cmdbuf.ch[1]=ascb AND cmdbuf.ch[2]=ascy AND cmdbuf.ch[3]=asce)
THEN
BEGIN { USER TYPED THE BYE COMMAND }
parseok:=true; { CMD ENTERED SYNTACTICALLY OK }
iinitiate; { MAKE REQUIRED PRECEDING I PACKET }
state:=byeinit
END;
(******************** SET-RESERVED FOR FUTURE*)
IF (cmdbuf.ch[1]=ascs AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=asct)
THEN
BEGIN { SET A KERMIT PARAMETER }
sp:=4; { WE GOT PAST SET }
WHILE cmdbuf.ch[sp]=ascsp AND sp<30 DO
sp:=succ(sp); { SKIP SPACES }
parseok:=true;
bsbuf:='SET COMMAND RESERVED FOR FUTURE USE. #0D#0A';
{ YOU COULD PROBABLY IMPLEMENT SET BAUD , SET PARITY, ETC. HERE. }
writdev(ts,true,40,location(bsbuf))
END;
(******************** HELP ********************)
IF (cmdbuf.ch[1]=asch AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascl)
THEN
BEGIN { USER WANTS HELP }
help; { SO HELP USER }
state:=cexit;
parseok:=true { COMMAND PARSED OK }
END;
(******************** BINARY ********************)
IF (cmdbuf.ch[1]=ascb AND cmdbuf.ch[2]=asci AND cmdbuf.ch[3]=ascn)
THEN
BEGIN { SET BINARY FILE TYPE }
optqu8:=ascamp; { EIGHT-BIT QUOTING WILL BE DONE }
crlfeol:=false; { NO CARRIAGE CON. IN BINARY FILES }
binary:=true; { BINARY TYPE FILE TRANSFERS }
bsbuf:='BINARY FILE - 8 BIT QUOTING TURNED ON.#0D#0A';
writdev(ts,true,40,location(bsbuf));
state:=cexit;
parseok:=true { COMMAND PARSED OK }
END;
(********************** TEXT ********************)
IF (cmdbuf.ch[1]=asct AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascx)
THEN
BEGIN { SET TEXT FILE TYPE }
optqu8:=0; { NO EIGHT-BIT QUOTING WILL BE DONE }
crlfeol:=true; { SET CARRIAGE CONTROL ON }
binary:=false; { NO BINARY FILE TYPE }
bsbuf:='TEXT FILE TYPE TRANSFER TURNED ON. #0D#0A';
writdev(ts,true,40,location(bsbuf));
state:=cexit;
parseok:=true { COMMAND PARSED OK }
END;
(********************* EXIT ********************)
IF (cmdbuf.ch[1]=asce AND cmdbuf.ch[2]=ascx AND cmdbuf.ch[3]=asci)
THEN
BEGIN { SET PROPER EXIT FLAGS }
server:=false;
state:=kexit;
parseok:=true { EXIT COMMAND ACCEPTED CORRECT }
END;
END;
PROCEDURE getcmd; { INTERACTIVELY GET A USER COMMAND }
VAR
validcmd:boolean;
BEGIN { GETCMD }
validcmd:=false;
tcbuf:=crlf;
writdev(ts,true,2,location(tcbuf));
WHILE NOT validcmd DO
BEGIN
ssbuf:='KERMIT-990> '; { USER PROMPT- MODIFIABLE IN FUTURE }
writdev(ts,true,12,location(ssbuf));
bufinit(cmdbuf); { CLEAR THE COMMAND BUFFER }
IF local THEN
BEGIN
ts.lrl:=size(cmdbuf.ch); { SIZE OF BUF FOR READ }
readdev(ts,true,location(cmdbuf.ch));
cmdbuf.ln:=ts.cc; { GET ACTUAL SIZE OF CMD READ }
ssbuf:='#0D#0A '; { JUST CRLF FOR OTHERS }
writdev(ts,true,2,location(ssbuf))
END
ELSE { PORT IS IN PASSTHRU MODE SO READ ONE CHAR AT A TIME }
BEGIN
ineoln:=false; { NOT END OF CMD YET }
WHILE NOT ineoln DO { CMD ENDS WITH RETURN }
BEGIN
readdev(ts,true,location(tcbuf)); { GET A CHAR }
IF tcbuf[1]='#0D' THEN
BEGIN
tcbuf:=crlf; { ECHO PROPER CARRIAGE CONTROL }
writdev(ts,true,2,location(tcbuf));
ineoln:=true { ACCEPT AND PARSE CMD }
END
ELSE
IF tcbuf[1]='#08' THEN
BEGIN
IF cmdbuf.ln>=1 THEN { BS IS LEGAL }
BEGIN
ssbuf:='#08 #08 ';
{ THIS IS A BS? - ALMOST! }
writdev(ts,true,3,location(ssbuf));
cmdbuf.ch[cmdbuf.ln]:=ascsp;
{ BLANK POSITION IN CMD BUF }
cmdbuf.ln:=pred(cmdbuf.ln)
END
END
ELSE
BEGIN
writdev(ts,true,1,location(tcbuf)); { ECHO CHAR }
cmdbuf.ch[(cmdbuf.ln+1)]:=ord(tcbuf[1]);
{ SAVE CHAR }
IF cmdbuf.ch[1] <> ascsp THEN
{ IGNORE LEAD SPACES }
cmdbuf.ln:=succ(cmdbuf.ln) { INC CHAR COUNT }
END
END
END;
IF cmdbuf.ln >1 THEN { WE HAVE ACTUAL CMD TO PARSE }
BEGIN
prscmd(validcmd); { PARSE THE COMMAND }
IF NOT validcmd THEN { PARSE FAILURE --> CMD SYNTAX ERR }
BEGIN
bsbuf:='INCORRECT OR NON-SUPPORTED COMMAND: ';
writdev(ts,true,38,location(bsbuf));
FOR i:=1 TO cmdbuf.ln DO
BEGIN
tcbuf[1]:=chr(cmdbuf.ch[i]);
writdev(ts,true,1,location(tcbuf))
{ DISPLAY BAD CMD }
END;
tcbuf:='#0D#0A';
writdev(ts,true,2,location(tcbuf))
END
END
END
END; { GETCMD }
{ ************************* Main block **************************** }
BEGIN { KERMIT }
{ LET'S TAKE CARE OF SOME STANDARD FILE I/O INITIALIZATION }
p$parm(6,ioname,perr); { GET MY STATUS LOCAL OR REMOTE }
local:=ioname[2]='L';
p$parm(7,ioname,perr); { CHECK FOR SPECIAL ISC TERMINAL }
isc:=ioname[2]='I' AND local;
IF local AND NOT isc THEN { THIS BLOCK IS OPTIONAL }
BEGIN { DONT TRY TO CLEAR SOME REMOTE TERMINAL }
initscreen(blk,lun); { ENABLE DISPLAY-ACCEPT FOR CLEARS }
clearscreen(blk) { CLEAR THE SCREEN }
END;
p$parm(3,ioname,perr); { GET REMOTE PORT NAME }
p$parm(4,tname,perr); { MY TERMINAL NAME }
initio(location(tname),ts); { OPEN CONSOLE TERMINAL }
initio(location(ioname),ps); { OPEN REMOTE PORT AND SET PASSTHRU }
IF ps.stat=0 AND ts.stat=0 THEN { PORTS READY FOR I/O }
BEGIN { NORMAL KERMIT PROCESSING }
ssbuf:='#0D#0A#0D#0A ';
writdev(ts,true,2,location(bsbuf));
bsbuf:='WELCOME TO DX10 KERMIT-990 - RELEASE 1.0';
writdev(ts,true,40,location(bsbuf));
bsbuf:= '#0D#0A ';
writdev(ts,true,2,location(bsbuf));
bsbuf:='TYPE HELP TO VIEW THE KERMIT COMMANDS.#0D#0A';
writdev(ts,true,40,location(bsbuf));
iniflg:=false; { FOR ONCE ONLY VAR INITS }
state:=kcommand;
WHILE server OR state<>kexit DO
BEGIN
kerminitialize;
{ KCOMMAND MAY BE A GOOD CHOICE FOR SERVER MODE }
WHILE NOT server AND state=kcommand DO
getcmd;
IF state=rcv THEN state:=kcommand;
{ FALL BACK TO CMD MODE AFTER RCV }
IF state=kcommand THEN kermcommand;
IF state=sinitiate THEN sendinitiate;
IF state=rinitiate THEN rcvinitiate;
WHILE state<>cexit AND state<>kexit DO
BEGIN { PACKET SENDING STATE }
REPEAT
sndpkt;
numtry:=numtry+1;
IF sndonly THEN
BEGIN
rcvseq:=seq;
rcvtyp:=ascy;
rcvbuf.ln:=0
END
ELSE
BEGIN
rcvpkt
END;
IF rcvtyp=ascn THEN
BEGIN { RECEIVED NAK }
rcvseq:=(rcvseq-1) MOD 64;
rcvtyp:=ascy
END
UNTIL (rcvseq=seq) OR (numtry>=maxtry) OR (state=
kexit) OR (state = cexit);
IF (rcvseq<>seq) AND (state<>kexit) THEN
error('DIDNT RECEIVE EXPECTED PACKET ')
ELSE
IF rcvtyp=asce THEN {Just received error packet}
BEGIN
state:=wexit
END
ELSE
BEGIN
CASE state OF
getinit:get;
sheader :sendheader;
sdata :senddata;
sbreak :sendbreak;
rinitiate:rcvinitiate;
rheader :rcvheader;
rdata :receivedata;
wexit:state:=cexit; { ALLOWS LAST SNDPKT }
fininit:finish; { BUILD FINISH PACKET }
byeinit:bye; { BUILD BYE PACKET }
kexit :;
cexit:
END
END
END;
wrtcls
END;
logcls; { CLOSE LOG FILE IF OPEN }
bsbuf:='KERMIT END.#0D#0AHAVE A HOPPY HAPPY DAY!!!#0D#0A';
writdev(ts,true,40,location(bsbuf))
END
ELSE
IF ts.stat=0 THEN { TERMINAL OK TO OUTPUT PORT ERR TO }
BEGIN
bsbuf:='KERMIT PORT OPEN FAILED - TRY AGAIN.#0D#0A#0D#0A';
writdev(ts,true,40,location(bsbuf))
END
END. { KERMIT }