%conststring (13) vsn = "ftps....3m "
#datestring
#timestring
!********************************
!* emas-2900 fep ftp server *
!* file: fpt3s/fpt3y *
!* *
!********************************
#options
! prep versions are:-
!
! k = kent (no uflag)
! e = ERCC
! r = ring
! n = nsi
! x = Transport Service
! m = Full Monitoring
! c = Clock monitoring (needs a real time clock)
! i = new imp compiler
!
#if ~(k!e) ! ~(r!n!x) ! (r&n) ! (k&e) ! (k&n)
#if "incompatible prep options"
#fi
#fi
#if i
%control x'4001'
#else
%control 1
#fi
#if i
%include "b_deimosspecs"
#else
%include "deimosperm"
#fi
%begin
%externalstring (255) %fnspec itos(%integer n,j)
%recordformat am1f(%integer rxs, rxd, txs, txd)
%ownrecord (am1f) %name l == 1; ! supplied by am1 handler
#if n
%recordformat lev3f(%byteinteger fn, sufl, st, ss, %c
(%byte sn, dn, dt, ds, lfl, luflag, %bytearray aa(0:241) %or
%byte sfl, suflag, %c
(%byteintegerarray a(0:241) %or %c
%integer x1, x2, x3, x4, users, state, cpu, pkts, sbr, byt, ftpo, ftpi)))
#fi
#if r
#if k
%recordformat lev3f(%integer st,ds,rc,tc, %c
(%byteintegerarray a(0:241) %or %c
%integer x1, x2, x3, x4, users, state, cpu, pkts, sbr, byt, ftpo, ftpi))
#else
%recordformat lev3f(%integer st,ds,rc,tc,uflag, %c
(%byteintegerarray a(0:241) %or %c
%integer x1, x2, x3, x4, users, state, cpu, pkts, sbr, byt, ftpo, ftpi))
#fi
#fi
#if x
%recordformat lev3f(%bytearray reserved(0:7), %bytearray a(0:241))
#fi
#if r
#if e
%recordformat ssmessagef(%integer sou,prt,c,prt r,ds,st,sn, %c
%byteintegerarray a(0:237)); !$e
#else
%recordformat ssmessagef(%integer sou,prt,c,prt r,ds, %c
%byteintegerarray a(0:239))
#fi
#fi
%recordformat mef(%record (mef) %name link, %c
%byteinteger len, type, (%record (lev3f)lev3 %or %c
%bytearray params(0:231) %or %string (231) str))
%recordformat m2900f(%record (mef) %name l, %byteinteger len, type, %c
%integer stream, sub ident, %c
(%integer p2a, p2b, p3a, p3b,p4a, p4b, p5a, p5b, p6a, p6b %or%c
%bytearray b(0:19)))
%recordformat maf(%record (mef)%name l, %byteinteger mlen, %c
mtype, (%byte len, type, %c
(%bytearray m(0:242) %or %c
%integer ref, in ident, out ident, %string (63) address) %or %c
%bytearray a(0:240)))
#if ~x
%recordformat pe(%byteinteger ser, reply, %c
fn, gate port, %record (mef) %name mes, (%byte c1, s1 %or %c
%integer c))
#else
%recordformat pe(%byteinteger ser, reply, %c
(%integer a, b, (%integer c %or %byte c1, c2) %or %byte fn, a2, %c
(%record(mef)%name mes, %byte gate port, task port %or %c
%string (3) facility)))
#fi
%recordformat qf(%record (mef) %name e)
!********************************************************
!* formats of tables, ie stream descriptors, tcps etc *
!********************************************************
%recordformat con desf(%record (mef) %name hold, %c
%integer index, stream, permit, node, term, first, istate, %c
o state, port, mode, kill, direction, in, n, icount, ref, outlen, %c
cpos, count, nc, secadd, %c
%record (mef) %name holdi, %record (qf) inp q)
!************************************************************
!* upper level (itp&ftp) handler messages to gate
!************************************************************
#if ~x
%constinteger enable facility = 1; ! enable the facility
! %constinteger disable facility = 2; ! the reverse
%constinteger call reply = 3; ! reply to a 'call connect'
%constinteger enable input = 4; ! allow a block to be read
%constinteger put output = 5; ! send a block of output
%constinteger close call = 6; ! terminate a call
%constinteger abort call = 7; ! abort the call
%constinteger open call = 8; ! open up a call
%constinteger open message = 9; ! send a message
!**********************************************************
!* messages from gate to upper level protocols
!**********************************************************
%constinteger incoming call = 2
%constinteger input recd = 3; ! block arrived from node
%constinteger output transmitted = 4; ! prepared to accept more
%constinteger call closed = 5; ! either end has closed down
%constinteger call aborted = 6; ! other end has aborted
%constinteger open call a = 7
%constinteger open call b = 8; ! reply from remote
%constinteger message r = 9; ! message rec'd
%constinteger message reply = 10; ! message reply from gate
#else
%include "b_ygatecalls"
#fi
!**************************************************************
!* buffer manager calls (from and to) *
!**************************************************************
! %constinteger buffer here = 0
!********** to buffer manager ***********
%constinteger request buffer = 0
%constinteger release buffer = 1
!**************************************************************
!* calls to 2900 link handler *
!**************************************************************
%constinteger send data = 0
%constinteger low level control = 1
%constinteger here i am = 2
%constinteger return control = 3
!**************************************************************
!* replies from 2900 link handler *
!****************************************************************
%constinteger interf addr = 0
%constinteger do input = 1
%constinteger do output = 2
%constinteger message = 3
%constinteger mainframe up = 4
%constinteger mainframe down = 5
!****************************************************************
!********** various service numbers *************
#if ~x
%constinteger gate ser = 16
#else
%constinteger gate ser = 24
#fi
%constinteger buffer manager = 17
%constinteger link handler = 18
%constinteger t3 ser = 21
%constinteger comm bit = k'1'
%constinteger accept char = k'002'
%constinteger acfy = k'010'; ! peter calls it rxfy
%constinteger xopl = k'020'; ! x operable - latched
! %constinteger xop = k'040'; ! x operable
%constinteger ready = k'200'
%constinteger ts accept = 17
!********************* FTP Transfer Control Commands *************
%constinteger ss = x'40'; ! Start of Data
%constinteger cs = x'42'; ! Code Select
%constinteger es = x'43'; ! End of Data
%constinteger qr = x'46'; ! Quit
%constinteger er = x'47'; ! End Acknowledge
!******************* FTP Initialisation and Termination ***************
%constinteger p stop = X'00'; ! Request Termination (from p)
%constinteger q Stopack = X'05'; ! Acknowledge Termination (from q)
!***********************************************************
!* 2900 states *
!***********************************************************
%own %integer host state = 0; ! holds 2900 state
%constinteger down = 0
%constinteger up = 1
!****************** comms control states ********************
%constinteger unused = 0
%constinteger disconnecting = 1
%constinteger connecting = 2
%constinteger suspending = 4; ! end of section or file
%constinteger aborting = 5
%constinteger enabling = 7
%constinteger enabled = 8
!* s t a t e s
%constinteger not alloc = -1
%constinteger idle = 0
%constinteger op ready = 1; ! applies to the connection
%constinteger input ready = 1; ! input streams only
%constinteger trying = 2; ! awaiting network reply
%constinteger timing = 3; ! connection refused, waiting for clock
%constinteger aborted = 4; ! 2900 has gone down
%constinteger wait ts = 5; ! fix Xgate YB problems
%constinteger connect 1 = 6; ! lev3 connected, waiting for
! 2900 connect&enable
%constinteger connected = 7; ! in file
%constinteger enabld = 8; ! 2900 has started file
%constinteger close ready = 9; ! fep is ready to accept a close
%constinteger closing = 10; ! close has been sent to network
!******************************************
!* reasons for waiting for a buffer *
!******************************************
%constinteger low level ip transfer = 22
%constinteger low level op transfer = 23
%constinteger get op block = 24
%constinteger send abort = 25; ! ask emas to abort stream
%constinteger do input connect = 27
%constinteger connecting reply = 29; ! keep this odd (see from buffer manager)
%constinteger connecting reply 2 = 30
%constinteger connecting reply failed = 31
%constinteger connecting reply 2 failed = 32
#if x
%constinteger get connect buffer = 33
#fi
!**************************************************************
%routinespec do enable facility(%string (11) address)
%routinespec to gate(%integer fn, %record (mef) %name mes, %c
%integer flag)
%routinespec to 2900(%integer fn, %record (m2900f) %name m2900)
%routinespec get buffer(%integer reason)
%routinespec free buffer(%record (mef) %name mes)
%routinespec who and state
%routinespec tell
%routinespec from gate
%routinespec from 2900
%routinespec do connect
%record (con desf) %mapspec get free des
%routinespec flush file
%routinespec from buffer manager(%record (pe) %name p)
%integerfnspec allocate stream(%record (con desf) %name d)
%routinespec tidy buffers
%routinespec retrieve(%record (con desf) %name d)
%routinespec do repm(%integer flag)
%routinespec clear all streams
%routinespec read from am1
%routinespec write to am1
%routinespec read message from am1
%routinespec write message to am1
%routinespec mon mes(%record (mef) %name mes)
!******************************************************
%record (pe) p
%owninteger con sub id reply = 1; ! picks up from actual mess
%ownrecord (con desf) %name d
%ownrecord (con desf) %name d4, d5
%constinteger con lim = 26; ! number of active terminals (see fixed top)
%ownrecord (con desf) %array con desa(0:con lim)
%ownrecord (qf) %name free des; ! pts to list of free con desa
%record (qf) %name q frig
#if x
%ownstring (73) %array adda(0:conlim)
#fi
#if ~x
%constinteger max ports = 50
%ownbyteintegerarray porta(0:max ports)
! cross index from port to tcp
#fi
%constinteger fixed = 350; ! 1st available stream
%constinteger fixed top = 400; ! number of 2900 streams in eam5
! was 281 !
%ownbyteintegerarray am1a(fixed:fixed top) = k'377'(*)
%ownbyteintegerarray alloc(fixed:fixed top) = 0(*)
!* * * * * * * * * * * * * * * * * *
%ownrecord (qf) %name buffer pool; ! =k'142472'
%owninteger no of buff = 0, bh = 0
%owninteger mon = 0; ! monitoring flag (set to 'O')
%owninteger data len = 120; ! cut down length for pss
%owninteger spec mon = 0
%owninteger out pos = 0
%owninteger ftpi = 0; ! no of ftp packets
%owninteger ftpo = 0
#if r
%constinteger initial permit = 2
#if k
%constinteger header len = 0, header m len = 0
#else
%constinteger header len = 2, header m len = 2
#fi
#else
#if x
%constinteger initial permit = 2
%constinteger header len = 0
#else
%constinteger initial permit = 1; ! = 2 for ring
%constinteger header len = 6, header m len = 10
#fi
#fi
%ownstring(1) snil = ""
%ownstring (63) called, calling
%ownstring (73) qual; ! nb: emas address moved through it
%ownstring (1) disqual
%ownstring (5) window = ""
! l o g g i n g o n
%integer i
%conststring (7) %array ostates(-1:closing) = "not all",
"waiting", "ready", "asking", "timing", "abortng", "Wait Ts",
"chcking", "conning", "going", "clserdy", "close"
%ownstring (15) ad1, ad2, ad3
#if c
%routinespec mark(%integer type)
%constintegername clock st == k'12540'; ! in seg 0
%constintegername clock cnt == k'12544'
%constinteger clock start = k'31'; ! 100khz, up, multiple, no ints
%owninteger tpt
%ownbytearray typen(0:511)
%ownintegerarray timer(0:511)
#fi
!**********************************************
!* initialisation *
!**********************************************
#if i
use tt(t3 ser)
#else
change out zero = t3 ser
#fi
%cycle i = con lim, -1, 2
con desa(i)_index = i; con desa(i)_o state = not alloc
qfrig == con desa(i)
qfrig_e == free des
free des == qfrig
%repeat
con desa(1)_index = 1
condesa(0)_stream = 6
con desa(1)_stream = 7
printstring(vsn)
#if e
printstring(" ERCC")
#else
printstring(" kent")
#fi
#if r
printstring(" ring ")
#else
#if x
printstring(" ts")
#else
printstring(" nsi")
#fi
#fi
printstring(datestring)
newline
map hwr(0); ! map am1 to segment 3
i = map virt(buffer manager, 5, 4); ! map buff man stack to seg 4
i = map virt(buffer manager, 6, 5)
d == con desa(0)
d4 == d
d5 == con desa(1)
p_c = 6; ! param for 'here i am'
to 2900(here i am, null)
p_c = 7
to 2900(here i am, null)
#if ~x
to gate(enable facility, null, 16)
#else
do enable facility("FTP")
do enable facility("MAIL")
do enable facility("X"); ! NB: very special for GEAC
#fi
#if c
clock st = clock start
#fi
alarm(500); ! set clock for 10 secs
!**********************************************
!* main loop *
!**********************************************
%cycle
p_ser = 0; poff(p)
%if int # 0 %start
%if 'M' <= int <= 'P' %start
mon = int-'O'; int = 0
printstring("ok
")
%finish
#if c
%if int = 'T' %start
select output(1)
i = tpt
%cycle
write(typen(i), 2); write(timer(i), 4)
write(timer(i)-timer(i-1), 4); newline
i = (i+1)&511
%exit %if i = tpt
%repeat
select output(0)
mark(99)
int = 0
%finish
#fi
%if '1' <= int <= '7' %start
window = "W=2/2"
charno(window,3) = int; charno(window,5) = int
int = 0
%finish
%if int = '?' %start
printstring("Buff ="); write(bh, 1)
printstring(", Pool ="); write(no of buff, 1); newline
%cycle i = 2, 1, con lim
d == con desa(i)
%if d_o state # not alloc %start
printstring("ftp:")
who and state
newline %if out pos > 30
printstring("p ="); write(d_port, 1)
printstring(", oc ="); write(d_nc, 1)
printstring(", istate ="); write(d_istate, 1)
printstring(", icnt ="); write(d_icount, 1)
printstring(", omde ="); write(d_mode, 1)
printstring(", ifrst ="); write(d_first, 1)
printstring(", oprm ="); write(d_permit, 1)
newline
%finish
%repeat
int = 0
newline
%finish
%if int = 'C' %start; ! close output
select output(1); ! select it
close output
printstring("done
")
int = 0
%finish
%finish
%if p_reply = link handler %start
from 2900
%finish %else %if p_reply = gate ser %start
from gate
%finish %else %if p_reply = buffer manager %start
from buffer manager(p)
%finish %else %if p_reply = 0 %start; ! clock tick
%cycle i = con lim, -1, 0
d == con desa(i)
%if d_o state = timing %start
d_count = d_count-1
%if d_count <= 0 %then do connect
%finish
%repeat
alarm(100); ! 2 secs
%finish
%repeat
!*************************************************
!* routines to do the work *
!*************************************************
%routine crunch
%integer i
who and state; newline
%cycle i = 1, 1, 10
printstring("**** ftps failed - dump it ***
")
%repeat
*=k'104001'; ! emt wait
%end
#if c
%routine mark(%integer type)
typen(tpt) = type
timer(tpt) = clock cnt
tpt = (tpt+1)&511
%end
#fi
%routine do enable facility(%string (11) address)
%if length(address) <= 3 %start
p_ser = gate ser; p_reply = own id
p_fn = enable facility; p_a2 = 0
p_facility = address
pon(p)
%else
p_ser = buffer manager; p_reply = id
p_fn = request buffer
ponoff(p)
p_ser = gate ser; p_reply = own id
p_fn = enable facility; p_a2 = 1
string(addr(p_mes_params)) = address
pon(p)
%finish
%end
%routine to gate(%integer fn, %record (mef) %name mes, %c
%integer flag)
%if mon < 0 %start
select output(1); printstring("To gate:"); write(fn, 1)
printstring(" on task port "); write(d_index, 1)
printstring(", Gate Port"); write(d_port, 1)
printstring(", Flag"); write(flag, 1); newline
select output(0)
%finish
%if fn = put output %start; ! queue these as necessary
%if mon = -1 %or spec mon # 0 %start
spec mon = 0
select output(1)
printstring("io "); mon mes(mes)
%finish
ftpo = ftpo+1
%if addr(mes)&k'140000'=k'140000' %or addr(mes)&k'77'#0 %then crunch
%finish
p_ser = gate ser; p_reply = own id
#if ~x
p_fn = fn; p_gate port = d_port; p_mes == mes; p_s1 = flag
#else
p_fn = fn; p_gate port = d_port; p_task port = d_index
p_mes == mes; p_a2 = flag
#fi
%unless p_mes == null %then bh = bh-1
pon(p)
%end
%routine to 2900(%integer fn, %record (m2900f) %name m2900)
p_ser = link handler; p_reply = own id
p_fn = fn; p_mes == m2900
pon(p)
bh = bh-1 %unless m2900 == null
%end
%routine get buffer(%integer reason)
%record (pe) p
!*******************************************************
!* hold a pool, so can call buffer here immedialtely*
!* otherwise hold the activity until it arrives*
!*******************************************************
#if ~x
%if reason = get op block %c
%then p_c1 = 0 %else p_c1 = 1
#else
%if reason = get op block %or reason = get connect buffer %c
%then p_c1 = 0 %else p_c1 = 1
#fi
! ****** watch the above line ******** (big or small buffer)
#if ~x
p_s1 = reason; p_gate port = d_index
%if buffer pool == null %or p_c1 # 0 %start; ! have to ask for it
#else
p_c2 = reason; p_a2 = d_index
%if buffer pool == null %or p_c1 # 0 %start; ! have to ask for it
#fi
p_ser = buffer manager; p_reply = own id
p_fn = request buffer
pon(p)
%else
p_mes == buffer pool; buffer pool == p_mes_link
p_mes_link == null
bh = bh-1; ! from buff adds one back on
no of buff = noof buff-1; from buffer manager(p)
%finish
%end
%routine free buffer(%record (mef) %name mes)
%record (pe) p
%if addr(mes)&k'140000'=k'140000' %or addr(mes)&k'77'#0 %then crunch
%if mes_type # 0 %or no of buff > 3 %start
p_ser = buffer manager; p_reply = own id
!! queue it if it is a long buffer
p_fn = release buffer; p_mes == mes
bh = bh-1
pon(p)
%else
!! long buffer, so queue it
mes_link == buffer pool; buffer pool == mes
no of buff = no of buff+1
%finish
%end
!!
%routine tell
%string (*) %name s
write(d_index, 2); space
%if d_direction = 0 %start
printstring("ftp-Q ")
#if x
s == adda(d_index)
printstring(s)
#fi
%else
printstring("ftp-P ")
#if x
s == string(addr(adda(d_index))+1)
printstring(s)
#fi
%finish
#if ~x
write(d_term, 1)
#else
#fi
space
out pos = length(s)
%end
%routine who and state
tell
printsymbol('(')
printstring(ostates(d_o state))
printstring(") ")
%end
%routine plant fail(%integer type, %record (mef) %name mes)
#if ~x
#if n
%record (lev3f) %name ssmessage
ssmessage == mes_lev3
ssmessage_aa(0) = 1; ssmessage_aa(1) = type
mes_len = header m len + 2
#else
%record (SSMESSAGEF) %name ssmessage
ssmessage == mes_lev3
ssmessage_a(0) = 1; ssmessage_a(1) = type
mes_len = header m len+2-1; !$e
#fi
#else
disqual = to string(type)
#fi
%end
#if ~x
%integer %fn stoi(%string (*)%name s)
%integer x,y,sum
sum = 0
%result = 0 %if s = ""
%cycle x = 1, 1, length(s)
sum = sum*10+(charno(s, x)-'0')
%repeat
%result = sum
%end
#fi
#if x
%string (127) %fn unpack(%record (mef) %name mes, %integer no)
%integer i, l
%unless mes == null %or mes_len<=0 %or no<=0 %start
l = 0
%while no>1 %cycle
l=l+mes_params(l)+1
no = no-1
%repeat
%result = string(addr(mes_params(l)))
%finish %else %result = ""
%end
%routine pack(%record(mef) %name mes, %string (*) %name s)
string(addr(mes_params(mes_len))) = s
mes_len = mes_len+length(s)+1
%end
#fi
! r o u t i n e f r o m g a t e
%routine from gate
%record (mef) %name mes
#if n!x
%record (lev3f) %name ssmessage
#else
%record (ssmessagef) %name ssmessage
#fi
%recordformat p3f(%byteinteger ser,reply,fn,port,a,b,c,d)
%record (p3f) %name p3
%integer fn, flag, strm, i, trm, fac, d1, d2
%integer node
#if ~x
%switch fns(incoming call:control data)
#else
%switch fns(connect:control data)
#fi
#if x
%routine discres
printstring(", reason ="); write(p_a2, 1)
write(d1, 1); write(d2, 1); newline
%end
#fi
fn = p_fn
#if ~x
strm = p_gate port
d == con desa(porta(strm))
#else
strm = p_task port
d == con desa(strm)
#fi
#if m
%if mon < 0 %start
select output(1)
printstring("From Gate, fn="); write(fn, 1)
printstring(", G Port ="); write(p_gate port, 1)
printstring(", T Port ="); write(p_task port, 1)
printstring(", Flag ="); write(p_a2, 1)
newline
select output(0)
%finish
#fi
mes == p_mes
%unless mes == null %then bh = bh+1
->fns(fn)
#if ~x
fns(incoming call):
#else
fns(Connect):
mes == p_mes
strm = p_gate port; ! remember gate port no
#fi
flag = 0; ! reject if all else fails
#if x
disqual = ""
#fi
#if c
mark(30)
#fi
%if host state = down %start
#if ~x
plant fail('d', p_mes)
#else
flag = x'fd'
#fi
-> reply
%finish
#if ~x
ssmessage == p_mes_lev3
#if e
#if r
node = ssmessage_sn; trm = ssmessage_st; ! nsi mod
%if node=0 %then trm = p_c1; ! source is on ring
#else; ! nsi
node = p_mes_lev3_sn; trm = p_mes_lev3_st
#fi
#else
node = 0; trm = p_c1;
#fi
#fi
d == get free des
%if d == null %then flag = x'fe' %and -> reply
#if n
d_permit = p_c1; ! remember the for/rev buff lim (nsi mod)
#fi
#if n
i = p_mes_lev3_luflag; ! pickup 'f' number
d_secadd = i&x'7f'; ! nb: in the network, x'80' is not present
#else
#if ~x
d_secadd = ssmessage_ds>>8; ! Fn portion of address is here
#fi
#fi
!! construct a message to the 2900 *******
i = allocate stream(d); ! both streams
d_direction = 0; ! 0 = incoming, 1 = outgoing
#if ~x
d_node = node; d_term = trm
#else
d_holdi == mes; ! retain the message
#fi
d_o state = connect 1; ! wait for confirmation
d_nc = 0
#if m
%if mon < 0 %start
#if ~x
tell; printstring("asking
")
#else
write(d_index, 2); printstring("Incoming Call
")
#fi
%finish
#fi
#if ~x
d_port = p_gate port; ! remember gate port no
porta(p_gate port) = d_index; ! backward mapping
#else
d_port = strm; ! remember gate port no
#fi
get buffer(do input connect)
%return; ! Asking the 2900, so wait
reply:
#if x
! no descriptor, so reply now
p_ser = gate ser; p_reply = own id
p_mes == null
p_fn = Disconnect; p_a2 = flag
pon(p)
free buffer(mes); ! and free the buffer
bh = bh-1
#else
do repm(flag)
#fi
%return
#if ~x
fns(input recd):
#else
fns(Input Here):
#fi
ftpi = ftpi+1
#if c
mark(1)
#fi
%if d_o state = not alloc %start; ! X-over (tighten up check ????)
free buffer(mes)
printstring("Ftps: Invalid Buffer from Gate, stream =")
write(d_index, 1); newline
%finish
%if d_inp q_e == null %and d_holdi == null %start
!! stream is waiting for a network buffer
get buffer(low level ip transfer) %if d_o state = enabld
d_in = 0; ! into buffer pointer, and kick 2900
! if the stream is able to go
%finish
%if mon = -1 %start
select output(1)
printstring("In "); mon mes(mes)
select output(0)
%finish
push(d_inp q, mes); ! q buffer anyway
d_nc = d_nc+1; ! count it
%return
#if ~x
fns(output transmitted):
#if c
mark(10)
#fi
i = d_permit
d_permit = d_permit+1
#else
fns(Enable Output):
#if c
mark(10)
#fi
i = d_permit
d_permit = d_permit+p_a2
#fi
%if i = 0 %and d_o state = enabld %then %c
get buffer(get op block)
%return
#if ~x
fns(call closed):
fns(call aborted): ! all is lost
#else
fns(Disconnect):
%unless mes == null %start
d1 = mes_lev3_reserved(2); d2 = mes_lev3_reserved(3)
free buffer(mes)
%finish
%if strm = 0 %start; ! disconnect before Accept !
%cycle i = 2, 1, con lim
d == con desa(i)
%if p_task port = d_port %then -> got
%repeat
printstring("Disc on unknown strm ="); write(strm, 1)
discres; newline
%return
got:
%finish
#fi
%if d_o state = closing %start
%if mon < 0 %start
tell; printstring("close ack
")
%finish
%if host state = down %then retrieve(d) %and %return
to 2900(low level control, d_hold)
d_o state = idle; d_hold == null
%else
#if x
#if x
! hold disconnect params for spoolr
d_term = d2<<8!d1; ! effectively swabbed for spoolr
%if p_a2 # 139 %then d_term = 0; ! if not 'call closed' - no info
#fi
%if d_o state = trying %or d_o state = wait ts %start
%if d_o state = wait ts %then to gate(Disconnect, null, 1)
d_nc = d_nc+1; d_port = flag; ! remember reason
d_o state = timing; ! try again soon
d_count = 15; ! after 30 secs
%if mon < 0 %start
tell; printstring("ConRej"); discres
%finish
%return
%finish
#fi
%if mon # 0 %or d1 > 1 %start
who and state
printstring("network abort")
#if x
discres
#else
newline
#fi
%finish
%if d_o state = not alloc %then %return; ! very nasty ***************
%if d_o state >= connected %or d_o state = input ready %c
%start
get buffer(send abort); ! get 2900 to abort stream
#if ~x
to gate(abort call, null, 0); ! reply to gate to clear port
#else
to gate(Disconnect, null, 255); ! reply to gate to clear port
#fi
%finish
%if d_o state = aborted %or host state = down %then %c
retrieve(d) %else d_o state = idle
%finish
%return
#if ~x
fns(open call a): ! allocated port no
d == con desa(p_gate port)
!! p_gate port < 0 (ie failed!)
#if n
d_port = p_s1; ! note: nsi difference (and 2 lines below)
#else
p3 == p
d_port = p3_a
#fi
%if d_port = 0 %then p_s1 = 125 %else %start
porta(d_port) = p_gate port
%return
%finish
!* d_port = 0 => no gate ports, so treat as a open call b
!* with error flag = 125
fns(open call b): ! reply from remote device
flag = p_s1; ! success/fail flag
#else
fns(Accept Call):
#fi
%if d_o state # trying %and d_o state # aborted %start
tell; printstring("Invalid call reply !
")
%return
%finish
%return %if d == d4; ! not assigned
#if x
free buffer(mes) %unless mes == null
d_port = p_Gate Port
#fi
%if d_o state = aborted %or host state = down %start
!! connection established !
#if ~x
%if flag#0 %then retrieve(d) %else %start
to gate(abort call, null, 0)
d_nc = 98
%finish
#else
to gate(Disconnect, null, 1)
d_nc = 98
#fi
%return
%finish
#if ~x
%if flag # 0 %start
d_nc = d_nc+1; d_port = flag; ! remember reason
d_o state = timing
%else
#fi
%if mon < 0 %start
tell; printstring("connected
")
%finish
d_permit = initial permit; ! nsi change
d_o state = wait ts; ! must wait for YB accept (Xgate problems)
d_nc = 0
d_count = 0
#if ~x
%finish
#fi
%return
#if ~x
fns(message r): ! incoming login or enquiry
fns(message reply): ! reply to sendmessage
#else
fns(reset):
free buffer(mes) %unless mes == null
%if mon # 0 %start
tell; printstring("Reset !
")
%finish
chop connection:
to gate(Disconnect, null, 1)
%unless d_o state = wait ts %start
d_o state = idle
get buffer(send abort); ! and tell 2900 call gone
%else
d_o state = trying
%finish
%return
fns(Expedited):
tell; printstring("Expedited !
")
-> chop connection
fns(control data):
%if d_o state = wait ts %start
%if mes_lev3_a(0) # ts accept %start
printstring("ts accept? "); write(mes_lev3_a(0), 1); newline
%else
d_o state = connected
get buffer(connecting reply); ! tell EMAS to go
get buffer(connecting reply 2); ! and second stream
%finish
%finish
to gate(Enable input, null, 1)
free buffer(mes)
%return
fns(*):
#fi
crunch
%end
!! r o u t i n e from 2900
!! all messages from the 2900 come to this routine
%routine from 2900
%record (m2900f) %name m2900
%record (m2900f) %name m2900b
%integer stream, sub ident, state, mode, am1c, type, nsta
%integer p2a, p2b, ioflag
%switch link fns(interf addr:mainframe down)
%switch com state(disconnecting:enabled)
%switch com state b(disconnecting:enabled)
m2900 == p_mes; m2900b == m2900
%if p_fn = message %start
stream = m2900_stream; ! get first stream no
%finish %else stream = p_c
am1c = am1a(stream)
%if am1c = k'377' %then d == null %else %c
d == con desa(am1c)
-> link fns(p_fn)
link fns(interf addr): ! interface addr from eam5
l == record(addr(p_mes)&k'17777'); ! force to seg 0
%return
link fns(do output): ! -> 11/34
%if stream = 7 %then read message from am1 %else %c
read from am1
%return
link fns(do input): ! -> 2900
%if stream = 6 %then write message to am1 %else %c
write to am1
%return
link fns(mainframe down):
link fns(mainframe up):
host state = down
clear all streams
%return
link fns(message):
bh = bh+1
sub ident = m2900_sub ident
state = m2900b_b(1); mode = m2900b_b(0)&x'f0'
! mode = 0 - seq, 1 - circ, 2 - seq cont
! = x'10' - iso, x'20' - ebc, x'30' - bin
! = x'40' - normal FTP (data phase)
! = x'50' - default emas to emas FTP (data)
! = x'60' - Negitiation Phase FTP
p2a = m2900_p2a; p2b = m2900_p2b
m2900_p2a = 0; m2900_p2b = 0
%if sub ident # 0 %start; ! low level
!******************************************
!* l o w l e v e l control message
!******************************************
ioflag = stream&1; ! ioflag = 1 => 2900 o/p
%if mon < 0 %start
select output(1)
printstring("from 2900 "); who and state %unless d == null
write(stream, 2)
write(sub ident, 2); write(state, 2); write(mode, 2)
newline
select output(0)
%finish
%if stream <= 7 %start
%if stream = 6 %then d ==d4 %else d == d5
->com state b(state)
%finish
%if d == null %start
printstring("ftps: stream?
")
-> control reply
%finish
-> com state(state)
com state(enabling):
#if c
mark(21)
#fi
-> control reply %if d_o state = idle
d_o state = enabld
%if mon < 0 %start
tell; printstring(" enab")
write(mode, 2)
%finish
%if ioflag # 0 %start
%if mon < 0 %then write(p2b, 1) %and printstring(" o
")
d_mode = mode; ! remember type (output only, istate on input)
d_outlen = p2b; ! length of output trans (for monit)
%if d_permit > 0 %start
%if d_hold == null %start
get buffer(get op block)
%else
type = low level op transfer
do trans and reply: to 2900(low level control, m2900)
get buffer(type)
%return
%finish
%finish
%else
%if mode = x'40' %then nsta = 10; ! normal Ftp data
%if mode = x'50' %then nsta = 5; ! Default Emas-Emas
%if mode = x'60' %then nsta = 0; ! Neg phase
%if d_icount = 0 %start
d_istate = nsta; ! accept new state
%if mon < 0 %then newline
%else
%if mon < 0 %then printstring(" (nsc)
")
%finish
d_first = x'ff'
%unless d_holdi == null %and d_inp q_e == null %c
%then type = low level ip transfer %and -> do trans and reply
%finish
-> control reply
com state(connecting):
#if c
mark(20)
#fi
con sub id reply = m2900_sub ident; ! retain for reply
%if ioflag # 0 %start; ! output
d_nc = 0
%if d_direction # 0 %start
%if mon < 0 %then tell %and printstring("out conn
")
do connect
%finish %else -> control reply
%else; ! input
d_icount = 0; ! always allow state change after conn
%if d_o state = connect 1 %start
p_gate port = d_port; ! for repm
#if n
do repm(d_permit); !ok - nsi mod
#else
do repm(1); ! ok
#fi
d_o state = connected
d_permit = initial permit
->control reply
%finish
%finish
free buffer(m2900); ! reply is made up later
%return
com state(disconnecting):
#if c
mark(22)
#fi
%if aborted # d_o state # idle %and ioflag # 0 %start
! this must only be done on one stream !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
d_o state = closing
%unless d_hold == null %then free buffer(d_hold)
! note: It can easily do one more
! 'request' for o/p than needed
d_hold == m2900
%if mon < 0 %then tell %and printstring("Disconnecting call
")
#if ~x
to gate(abort call, null, 0); ! issue to gate
#else
to gate(Disconnect, null, 0)
#fi
%return; ! hold reply till later
%finish
-> control reply
com state(aborting):
%if mon < 0 %start
tell; printstring("aborting
")
%finish
->suspd
com state(suspending):
flush file %if ioflag # 0
suspd: d_o state = connected %if d_o state # idle %and ioflag = 0
! susp on output does not stop input
d_kill = state %unless d_kill = aborting; !remember type of call
! stop transfers unless its idle anyway
control reply:
to 2900(low level control, m2900)
%return
!! ***********************************************
!! the following are all stream 6 & 7 manipulations
!! ************************************************
com state b(enabling):
d_o state = enabling
d_mode = p2b; ! bUFFER SIZE
host state = up
-> control reply
com state b(connecting):
d_o state = connected
d_n = 0; d_nc = 0; d_count = 0; d_mode = 0; d_cpos = 0
printstring("ftp: logon stream"); write(stream, 1)
printstring(" connected
")
string(addr(m2900_p3a)) = "X25"; ! flag x25 fep to spoolr
%if stream = 6 %then -> clear out
com stateb(aborting):
com stateb(suspending):
com stateb(disconnecting):
d_o state = idle
host state = down
clear out: tidy buffers
clear all streams
-> control reply
%finish
!! high level control message
d == d5
free buffer(m2900)
get buffer(get op block) %if d_nc = d_count; ! dont do twice
d_nc = p2b; ! update pointer
%end
#if x
%routine do connect
get buffer(get connect buffer)
%end
%routine do actual connect(%record (mef) %name mes)
%record (pe) p
%ownstring (11) ef = "EMAS - ftp"
qual = adda(d_index)
called = string(addr(qual)+1)
calling = string(addr(qual)+length(called)+2)
%if mon # 0 %and d_nc = 0 %start
printstring("Connect to:"); printstring(called)
printstring(", from:"); printstring(calling)
newline
%finish
mes_len = 0
pack(mes, called)
pack(mes, calling)
pack(mes, window)
pack(mes, ef)
d_port = 0; ! ensure it goes out on port 0
to Gate(Connect, mes, 2)
d_o state = trying
%end
#else
%routine do connect
#if n
%recordformat p3f(%byteinteger ser, reply, %c
fn, port, (%byteinteger facility, flag %or %c
%record (mef) %name mes), %byteinteger node, term)
#else
%recordformat p3f(%byteinteger ser, reply, %c
fn, port, (%byteinteger node, flag %or %c
%record (mef) %name mes), %byteinteger term, facility)
#fi
%record (p3f) p3
! note on se of 'flag'
! flag < 128 - standard NSI use - not used on ring
! flag > 128 - 128+F number - put in 'user flags' used as
! address extension for psse
p3_ser = gate ser; p3_reply = own id
#if ~x
p3_fn = open call; p3_port = d_index
p3_term = d_term
p3_facility = 16
p3_node = d_node; !overwritten by k&r option below
#fi
#if r
#if e
%if d_secadd # 0 %then p3_flag = x'80'!d_secadd
#else
p3_facility=255; !16 bit facility number
p3_flag=d_secadd; p3_node=16; !big facility no.
#fi
#else
p3_flag = x'80'!d_secadd
#fi
d_o state = trying
pon(p3)
%end
#fi
%record (con des f) %map get free des
qfrig == free des
%if qfrig == null %start
printstring("ftps: out of descriptors! ****
")
%result == null
%finish
free des == qfrig_e
qfrig_e == null
%result == qfrig
%end
%routine flush file
%integer len
%record (mef) %name mes
! This pushes out the last block when 2900 sends suspend
mes == d_hold
%unless mes == null %start
d_hold == null
%if d_o state # enabld %then free buffer(mes) %and %return
! transfer has been aborted while transfer was in progress
len = d_n
%if d_mode=x'50' %and d_n = d_cpos+1 %then len = len-1
! 1 dummy length byte present
%if len <= 0 %then free buffer(mes) %else %start
#if n
mes_lev3_suflag = 1
#else
#if e&(~x)
mes_lev3_uflag = x'0100'
#fi
#fi
mes_len = len+header len; d_n = 0
d_permit = d_permit-1; ! for mode changing
to gate(put output, mes, 0)
%finish
%finish
%end
%routine kick 2900 message(%record (maf) %name log)
!! this routine sends 'log' to the 2900 by inserting
!! it in the input q for stream 4, and kicking it if
!! necessary
d == d4
%if (d_hold == null %and d_inp q_e == null) %or d_cpos>5 %then %c
get buffer(do output)
push(d_inp q, log)
d_cpos = d_cpos+1
%end
!! r o u t i n e from buffer manager
!! all requests for buffers come back through here
%routine from buffer manager(%record (pe) %name p)
%integer reason, type, strm
%record (m2900f) %name m2900
%record (maf) %name log
%integer lc1, lc2
%string (3) td
bh = bh+1
#if ~x
reason = p_s1; ! get reason for calling
strm = p_gate port
#else
reason = p_c2; ! get reason for calling
strm = p_a2
#fi
d == con desa(strm); ! and map to descriptor
%if mon < 0 %start
select output(1)
printstring("from bm: reason, index")
write(reason, 2); write(strm, 2); newline
select output(0)
%finish
%if reason = get op block %start
#if c
mark(2)
#fi
free buffer(d_hold) %unless d_hold == null; ! safety check
d_hold == p_mes; d_n = 0
get buffer(low level op transfer)
%return
%finish
#if x
! Connect from Network, going to Spoolr
! The incoming buffer is used to hold the 'qual of service'
! the only required part of params (in a SHORT buffer)
! The incoming call buffer (LONG) is used to pass the params
! to Spoolr.
!
#fi
%if reason = do input connect %start
#if c
mark(31)
#fi
#if x
called = unpack(d_holdi, 1)
calling = unpack(d_holdi, 2)
%if charno(calling, 2) = '.' %then %c
calling -> td.(".").calling
qual = unpack(d_holdi, 3)
log == d_holdi; d_holdi == p_mes; ! swap the buffers
p_mes_str = qual; ! save the qual of service
log_type = 4; ! new type for packed strings
#else
log == p_mes
log_type = 1
#fi
log_in ident = swab(d_stream)
log_out ident = swab(d_stream+1)
log_ref = 0
#if ~x
log_address = "N"
log_address = log_address.itos(d_node, -1)
log_address = log_address."T"
log_address = log_address.itos(d_term, -1)
%if d_secadd # 0 %start
log_address = log_address.".F"
log_address = log_address.itos(d_secadd, -1)
%finish
#else
adda(d_index) = calling
lc1 = length(called); lc2 = length(calling)
%if lc1+lc2 > 256-12-3 %start
printstring("In Len?
")
printstring(calling); newline
length(calling) = 0
%finish
string(addr(log_address)+1) = called
string(addr(log_address)+lc1+2) = calling
length(log_address) = lc1+lc2+2
#fi
%if mon # 0 %start
printstring("Incoming call from:"); printstring(calling)
printstring(" To "); printstring(called)
newline
%finish
log_len = 5+2+1+length(log_address)
kick 2900 message(log)
%return
%finish
#if x
%if reason = get connect buffer %start
do actual connect(p_mes)
%return
%finish
#fi
!! message to 2900 reason
!! note: streams 6&7 also use this mechanism
m2900 == p_mes
m2900_stream = d_stream
m2900_sub ident = 10; m2900_p2a = 0; m2900_p2b = 0
type = low level control
#if c
mark(3)
#fi
%if reason = low level op transfer %and d_stream > 7 %then %c
m2900_stream = m2900_stream+1
%if reason = send abort %start
m2900_sub ident = 0
m2900_p3a = 0
m2900_p3b = 1
type = send data
%finish
%if connecting reply <= reason <= connecting reply 2 failed %start
m2900_sub ident = con sub id reply
%if reason >= connecting reply failed %then %c
m2900_p2b = x'0a00'; ! = swab(10)
%if reason&1 = 0 %then m2900_stream = m2900_stream+1
%if reason = connecting reply 2 failed %and %c
d_nc # 99 %then retrieve(d)
%finish
%if mon < 0 %start
select output(1)
printstring("to 2900, str, subid, p2b:")
write(m2900_stream, 1); write(m2900_sub ident, 1)
write(m2900_p2b, 1); newline
select output(0)
%finish
to 2900(type, m2900)
%end
%integerfn allocate stream(%record (con desf) %name d)
!! nb: allocates two streams, one odd and the other even
%integer i
%cycle i = fixed, 2, fixed top-2
%if alloc(i) = 0 %start
alloc(i) = d_index
d_stream = i
p_c = i; ! claim the stream
to 2900(here i am, null)
am1a(i) = d_index
p_c = i+1
to 2900(here i am, null)
am1a(i+1) = d_index
%result = i
%finish
%repeat
%result = 0
%end
%routine tidy buffers
free buffer(pop(d_inp q)) %while %not d_inp q_e == null
free buffer(d_hold) %unless d_hold == null
d_hold == null
free buffer(d_holdi) %unless d_holdi == null
d_holdi == null
%end
%routine retrieve(%record (con desf) %name d)
!! sever link between 2900 and descriptor and
!! free the descriptor
%if d_stream <= 7 %start; ! illegae
crunch
%finish
am1a(d_stream) = k'377'; ! mark unused
am1a(d_stream+1) = k'377'
tidy buffers
d_o state = not alloc; d_term = -1
d_port = 0; d_node = 0; ! in x25 is disconnect reason
alloc(d_stream) = 0; alloc(d_stream+1) = 0
qfrig == d
qfrig_e == free des
free des == qfrig
%end
%routine do repm(%integer flag)
!! sends a 'call reply' to gate, nb: assumes p_gate port = port number
#if x
%record (mef) %name mes
%integer fn
#fi
p_ser = gate ser; p_reply = own id
#if ~x
p_fn = call reply; p_s1 = flag
#else
%if flag = 0 %then fn = Disconnect %else fn = Accept Call
p_fn = fn; p_a2 = 0
p_task port = d_index
mes == d_holdi; d_holdi == null
qual = mes_str
%if qual -> called.("P=256/256").calling %then %c
qual = called."P=128/128".calling
mes_len = 0
pack(mes, snil)
pack(mes, qual)
pack(mes, snil)
p_mes == mes
#if m
%if mon < 0 %start
select output(1)
printstring("Call reply:"); %if flag = 0 %then printstring %c
("Failed") %else printstring("Ok")
write(p_task port, 1); write(p_gate port, 1); newline
select output(0)
%finish
bh = bh-1
#fi
#fi
pon(p)
%end
%routine clear all streams
!! used when emas goes down
%integer i
%switch sts(not alloc:closing)
%cycle i = 2, 1, con lim
d == con desa(i)
%if mon < 0 %and d_o state # not alloc %start
who and state; newline
%finish
->sts(d_o state)
sts(close ready):
sts(connect 1):
p_gate port = d_port
do repm(0); ! reply 'reject' to connect
sts(idle):
sts(op ready):
sts(timing):
retrieve(d)
%continue
sts(connected):
sts(enabld):
sts(Wait Ts):
#if ~x
to gate(abort call, null, 0)
#else
to gate(Disconnect, null, 1)
#fi
d_o state = aborted
%continue
sts(trying):
d_o state = aborted
%continue
sts(aborted):
sts(closing): ! must wait for network
sts(not alloc):
%repeat
host state = down
%end
%routine read from am1
%record (am1f) %name l2
%integer max ad, adr, adr2
%record (mef) %name mes
%record (lev3f) %name lev3
#if i
%label cyc, parity, commbt, xopdwn, exit2, y1, y3
%constinteger r0=0,r1=1,r2=2,r3=3, xopl = k'20', acfy = k'10'
#fi
%integer n, cpos, t, max2
#if c
mark(11)
#fi
%if d == null %then mes == null %else %c
mes == d_hold
%if mes == null %start
printstring("ftp: seq1!
")
t = 0!128; -> skip2
%finish
lev3 == mes_lev3
!! (cater for partial block rec'd)
%if d_n # 0 %start
n = d_n; cpos = d_cpos
%else
n = 0
n = n+1 %if d_mode = x'50'; ! default mode
cpos = 0
%finish
%if mon = -1 %start
select output(1)
printstring("read from, n cpos:"); write(n, 1); write(cpos, 1)
newline; select output(0)
%finish
!! next section is in assembler in a file 'ercc14.ftpassm'
! acfy =10
! xopl =20
l2 == l
adr2 = addr(lev3_a(0)); !$e lev3_a(0)
max ad = adr2+data len; max2 = max ad
rep cycle: adr = adr2+n; ! lev3_a(n)
%if d_mode = x'50' %then max ad = adr2+n+63
%if max ad > max2 %then max ad = max2; ! mode 50 really
!
#if i
*mov_adr,r1
*mov_l2,r3
cyc: *mov_@r3,r2; ! r2 = status
*bit_#k'220',r2; ! ready or xopl set?
*beq_cyc; ! no, so wait
*bit_#xopl,r2; ! was it xop?
*bne_xopdwn; ! it was set, so get out
*mov_2(r3),r0; ! pick up char
*bit_#acfy,@r3; ! did it fail to read?
*beq_y1; ! no, so carry on
*mov_2(r3),r0; ! read it again
*bit_#acfy,@r3; ! failed again?
*bne_parity; ! hard failure, so get out
y1: *asr_r2; ! get comm bit (9th bit)
*bcs_commbt; ! set, so exit
*movb_r0,(r1)+; ! store char in array
y3: *cmp_r1,maxad; ! at end of array?
*bhis_exit2; ! yes, so get out
*bis_#2,(r3); ! accept the last char
*br_cyc; ! go for the next one
exit2: *mov_r1,adr
-> exit
parity: *mov_r1,adr
t = 3; -> skip
commbt: *mov_r1,adr
t = 2!128; -> skip
xopdwn: *mov_r1,adr
t = 64
#else
*=k'016401';*=k'10'; ! mov 10(r4),r1 ! r1 == nss_a(n)
*=k'016403';*=k'4'; ! mov 4(r4),r3 ! l2 = -4(r5)
*=k'011302' ; ! cycle: mov (r3),r2 ! stat=r2
*=k'032702';*=k'000220'; ! bit #200+xopl,r2
*=k'001774' ; ! beq cycle ! nothing set, so wait
*=k'032702';*=k'000020'; ! bit #xopl,r2 ! xopl set?
*=k'001034' ; ! bne xopdwn ! yes, so fail it
!
*=k'016300';*=k'000002'; ! mov 2(r3),r0 ! sym=r0
*=k'032713';*=k'000010'; ! bit #acfy,@r3 ! failed to read?
*=k'001405' ; ! beq y1 ! no, so carry on
*=k'016300';*=k'000002'; ! mov 2(r3),r0 ! read it again
*=k'032713';*=k'000010'; ! bit #acfy,@r3 ! failed again?
*=k'001014' ; ! bne parity ! yes, so fails
! y1:
*=k'006202' ; ! asr r2 ! get comm bit
*=k'103415' ; ! bcs commbt ! comm bit seen
*=k'110021' ; ! movb r0,(r1)+ ! nss_a(n) = sym! n=n+1
*=k'020164';*=k'6'; ! y3: cmp r1,6(r4) ! end of cuurent record
*=k'103003' ; ! bhis exit ! yes, so exit
*=k'052713';*=k'000002'; ! bis #2,(r3) ! accept char
*=k'000746' ; ! br cycle
!
! exit: ! etc
*=k'010164';*=k'10'; ! mov r1,10(r4) ! restore 'adr'
-> exit
! parity:
s1: *=k'010164';*=k'10'; ! mov r1,10(r4)
l1: ->parity
! commbt:
s2: *=k'010164';*=k'10'; ! mov r1,10(r4)
l3: ->comm bit
! xopdwn:
xopdwn:
t = 64; -> skip; ! send unsuccessfull
parity:
t = 3; -> skip
comm bit:
t = 2!128
#fi
skip:
n = adr-adr2; ! recomput n
%if d_mode=x'50' %start
lev3_a(cpos) = (n-cpos-1)!128
d_cpos = n; ! start new record here
d_n = n+1; ! leave one byte for length of next
%finish %else d_n = n
skip2:
p_c1 = t; ! long block+accept last
to 2900(return control, null)
%return
exit:
n = adr-adr2; ! recompute n
#if m
%if mon = -1 %start
select output(1); printstring("in data: n, cpos:")
write(n, 1); write(cpos, 1); newline
select output(0)
%finish
#fi
%if d_mode = x'50' %start
lev3_a(cpos) = (n-cpos-1)!128
%finish
%if n < data len-5 %start
cpos = n; n = n+1 %if d_mode = x'50'
l_rxs = l_rxs!accept char; ! accept the last char
-> rep cycle
%finish
d_hold == null
p_c1 = 0!128; ! done+accept last
to 2900(return control, null)
d_n = 0
#if n
lev3_suflag = 1; ! allways binary mode - nsi mod
#else
#if e&(~x)
lev3_uflag = x'0100'
#fi
#fi
mes_len = n+header len; !$e
%if d_o state # enabld %start; ! transfer has been aborted
free buffer(mes); ! get rid of the buffer
%else
#if c
mark(12)
#fi
to gate(put output, mes, 0)
d_nc = d_nc+1
d_permit = d_permit-1
%if d_permit > 0 %then get buffer(get op block)
#if c
mark(13)
#fi
%finish
%end
%routine write to am1
%record (mef) %name mes
%record (lev3f) %name lev3
%integer n, end, gate reply, am1 reply, stat, sym
%switch data state(0:13)
#if c
mark(4)
#fi
am1 reply = 0; ! "normal" reply
%while d_o state = enabld %cycle
mes == d_holdi
%if mes == null %then mes == pop(d_inp q)
%if mes == null %then %exit
!! terminate with "normal" (shouldnt happen)
lev3 == mes_lev3
end = mes_len-header len; !$e
gate reply = enable input; ! allow next to gate
n = d_in; ! start of block - d_in = 0
%cycle
%cycle
stat = l_rxs
%if stat&xopl#0 %start
am1 reply = 64
d_holdi == mes; ! retain for retry
d_in = n; ! and the pointer
-> am1 rep
%finish
%if stat&ready # 0 %start
!! l i m i t sent
am1 reply = 2; ! long block
d_in = n
d_holdi == mes; ! retain for later
-> am1 rep
%finish
%if l_txs&ready # 0 %then %exit
%repeat
skip: %if n >= end %start
!! send go ahead
#if ~x
gate rep:
#if c
mark(5)
#fi
to gate(gate reply, null, 0); ! enable input or close call
#else
gate rep: to gate(Gate reply, null, 1); ! one buffer ack
#fi
free buffer(mes)
d_holdi == null; d_in = 0
%if d_inp q_e == null %then ->am1 rep
%exit
%finish
sym = lev3_a(n); n = n+1
%if mon = -1 %start; ! int = 'N'
select output(1)
printstring("di:"); write(d_istate, 1)
write(n, 1)
write(d_icount, 1); write(sym, 3)
space %and printsymbol(sym) %if sym > 32
newline; select output(0)
%finish
->data state(d_istate)
data state(0): ! beginning of record (neg phase)
d_icount = sym&63
%if sym&128 # 0 %then d_istate = 2; ! ie 3 - get 1stchar
d_istate = d_istate+1
%if d_icount = 0 %start
%if d_istate = 3 %then -> kick
d_istate = 0
%finish
-> send it
data state(1): ! 1st char of sub/record (neg phase)
data state(3): ! 1st char of last record/sub record
d_first = sym %if d_first = x'ff'
d_istate = d_istate+1
-> ds4 %if d_istate = 4
data state(2): ! chars in block (neg phase)
d_icount = d_icount-1
%if d_icount = 0 %start
d_istate = 0
%finish
%if d_icount < 0 %start
printstring("ftps: phase error
")
-> had it; ! temp expedient
%finish
-> send it
data state(4): ! chars in block (last block)
ds4:
d_icount = d_icount-1
%if d_icount = 0 %start
kick:
d_o state = connected; ! no more i/p until a new enable
%if mon < 0 %start
select output(1); tell; printstring("kick
")
select output(0)
%finish
d_istate = 0
am1 reply = 4; ! kick 2900
l_txd = sym; ! pass to 2900
%if n >= end %then ->gate rep; ! block fin, reply to gate
d_in = n
d_holdi == mes; ! retain the block & pointer
-> am1 rep; ! tell the 2900
%finish
-> send it
! * * * Now the states for the Defaut Emas-Emas data transfer
data state(5): ! record/sub record count (default phase)
%if sym = 128 %start; ! horrible frig for dec-10 (0 len)
sym = nl; ! implant a nl
-> send it; ! expect a record headernext
%finish
d_icount = sym&63
%if d_icount = 0 %start; ! transfer command
d_istate = 7
%finish %else d_istate = d_istate+1
-> skip; ! record count is not part of the data
data state(6): ! subsequent data chars (default phase)
d_icount = d_icount-1
%if d_icount = 0 %then d_istate = 5
-> send it
data state(7): ! 1st char of transfer comm (default phase)
%if sym = es %or sym = qr %or sym = er %then %c
d_istate = d_istate+2 %and -> send it
%if sym # ss %and sym # cs %start; ! illegal - halt for now
printstring("ftps:illegal tcc =")
write(sym, 1); newline
had it:
printstring("ptr ="); write(n, 1); printstring(" block =
")
mon mes(mes)
-> kick
%finish
d_istate = d_istate+1; ! rubbish - so junk the last byte
-> skip
data state(8): ! skip mode of transfer command
d_istate = 5
-> skip
data state(9): ! end of transfer (default phase)
-> kick; ! nb: state -> 0 as expect disconnect next
! * * * Now the states for the non-default, full Ftp Data transfer * * *
data state(10): ! 1st char - length of record/sub/tcc
%if sym = 0 %start; ! TCC
d_istate = 12; ! get the next 2 chars f tcc
d_icount = 2; ! mainly to stop an 'enabling' changing state
-> send it; ! send the first thru
%finish
d_icount = sym&63; ! pickup record length
%if d_icount # 0 %start; ! zero-length record is valid
%if sym&64 # 0 %start; ! compression
d_icount = 1; ! only one to go
%finish
d_istate = d_istate+1; ! go to 'into block' state
%finish
-> send it
data state(11): ! inside record/sub record
d_icount = d_icount-1; ! count it down
%if d_icount = 0 %then d_istate = 10; ! eor, to length next
%if d_icount < 0 %then printstring("FTPS:Non-default Phase error
") %and -> kick
! on error, give up by kicking 2900
-> send it
data state(12): ! 2nd byte of tcc
d_istate = d_istate+1; ! pickup 3rd byte
d_icount = 1
-> send it
data state(13): ! 3rd and last byte of tcc
d_icount = 0
-> kick; ! tell 2900
send it:
l_txd = sym
%repeat
%repeat
am1 rep:
p_c1 = am1 reply
to 2900(return control, null)
#if c
mark(6)
#fi
%end
!! r e a d m e s s a g e f r o m a m 1
%routine read message from am1
%record (maf) %name m
%integer n, sym, t, stat, x
%integer type, strm
%switch swd(not alloc:closing)
%switch hlm(1:5)
d == d5; ! messages on stream 7
m == d_hold
%if m == null %start
printstring("ftp: seq2!
")
stat = l_rxs
t = 0!128; -> reply
%finish
!! (cater for partial block rec'd)
n = d_n
%if n = 0 %then d_cpos = 0
%cycle
%cycle
stat = l_rxs
%exit %if stat&(ready!xopl) # 0
%repeat
%if stat&xopl # 0 %start; ! xop gone down
t = 64; ! send unsuccessfull
printstring("ftps: xop d
")
-> skip
%finish
sym = l_rxd; ! read the char
%if l_rxs&acfy # 0 %start; ! failed to read
sym = l_rxd; ! read it again
%if l_rxs&acfy # 0 %start; ! hard failure - parity
t = 3
printstring("ftps: parity
")
-> skip
%finish
%finish
%if stat&comm bit # 0 %start
t = 2!128
skip:
d_n = n
reply:
p_c1 = t; ! long block+accept last
to 2900(return control, null)
%return
%finish
%if d_count = d_mode %then d_count = -1
%if d_count = d_nc %then -> badm
d_count = d_count+1
m_a(n) = sym; n = n+1
%if n = 1 %start; ! Got the total length
d_cpos = m_a(0)+1; ! max = 256 - length is like string
%unless 5 < d_cpos <= 256-18 %start
badm: printstring("***ftps: message fails -")
write(d_cpos, 1); write(d_count, 1); write(d_mode, 1)
write(d_nc, 1); write(type, 1)
printstring(" all ftp messages lost
")
-> reply
%finish
%else
%if n = d_cpos %then -> exit3; ! Got the whole message
%finish
l_rxs = l_rxs!accept char; ! accept the last char
%repeat
exit3:
d_hold == null
t = 0!128; ! normal+accept last
type = m_type; ! max = 256
%unless 1 <= type <= 4 %then ->badm
%if d_count # d_nc %start; ! Another message waiting
get buffer(get op block)
%finish
-> hlm(type)
hlm(2): ! Allocate stream - reply
#if c
mark(34)
#fi
n = swab(m_in ident); ! this is known to ftp allready
d == con desa(alloc(n))
-> free it %if d == d4; ! null !
%if m_ref = 0 %start
%if mon < 0 %then %c
tell %and printstring("refused
")
p_gate port = d_port; do repm(0)
retrieve(d)
%else
d_ref = m_ref; ! remember spoolers ref no
%finish
free it:
free buffer(m); -> reply
hlm(4): ! new packed string number
! set d_direction = 1 %if an outgoing connection to be made ??
%if length(m_address) > 73 %or charno(m_address, 1)>63 %start
! overall length, or length of 1st packed
! string inside
%if mon # 0 %then printstring("Length Too Long
")
-> failed
%finish
d == get free des
%if d == null %start; ! failed
hlm(1): ! allocate new (output) pair
failed:
! flag it
m_in ident = 0
m_out ident = 0
%else
i = allocate stream(d); ! get both streams
d_o state = idle
#if ~x
%if m_address -> ("N").ad1 %and ad1 -> ad1.("T").ad2 %start
%if ad2 -> ad2.(".F").ad3 %then d_secadd = stoi(ad3) %c
%else d_secadd = 0
d_node = stoi(ad1); d_term = stoi(ad2)
%if mon # 0 %start
printstring("ftps:address N"); write(d_node, 1)
printstring(" T"); write(d_term, 1)
%if d_secadd # 0 %start
printstring(" F"); write(d_secadd, 1)
%finish
newline
%finish
%else
printstring("ftps:address ? "); printstring(m_address)
newline
%finish
#else
adda(d_index) = m_address
#fi
m_in ident = swab(d_stream)
m_out ident = swab(d_stream+1)
d_direction = 1
d_ref = m_ref
%finish
-> move it
hlm(3): ! spoolr requests deallocation
strm = swab(m_in ident)
d == con desa(alloc(strm))
%if d == d4 %start
printstring("ftps:Spoolr deallocate on an idle strm, =")
write(strm, 1); newline
-> move it; ! ignore
%finish
%if mon < 0 %start
who and state
printstring(" deallocated
")
%finish
m_in ident = d_term; ! pass in disconnect reason
-> swd(d_o state)
swd(not alloc):
crunch
swd(idle): ! ok, so do it
retrieve(d)
-> move it
swd(wait ts):
to gate(Disconnect, null, 39); ! then fall thru
swd(op ready):
swd(timing): ! its trying to connect
swd(trying): ! Call outstanding
d_nc = 0; ! ensure sub-state flag is clear
get buffer(connecting reply failed)
get buffer(connecting reply 2 failed)
! retrieve the descriptor AFTER the connect reply sent
%if d_o state = trying %or d_o state = wait ts %start
d_o state = aborted
d_nc = 99
! set 'flag' in _nc, so that connecting reply 2
! does not retrieve the descriptor
%finish %else d_o state = idle
-> move it
swd(aborted):
crunch
swd(connect 1):
p_gate port = d_port
do repm(0)
retrieve(d); ! and get the descriptor back
-> move it
swd(connected):
swd(enabld):
swd(closing):
! send failed ( x over )
who and state; printstring(" Deallocate error 6
")
m_out ident = 999
move it:
kick 2900 message(m)
-> reply
%end
!! w r i t e m e s s a g e t o a m 1
%routine write message to am1
%record (maf) %name m
%integer n, max, am1 reply, stat
d == d4; ! messages on stream 4
am1 reply = 4; ! "condition y"
%cycle
#if c
mark(32)
#fi
m == d_hold
%if m == null %then m == pop(d_inp q) %and d_cpos = d_cpos-1
%if m == null %then %exit
!! terminate with "normal" (shouldnt happen)
n = d_n; ! start of block - d_n = 0
%cycle
%cycle
stat = l_rxs
%if stat&xopl#0 %start
d_hold == m; ! retain buffer for retry
am1 reply = 64; d_kill = n; ->am1 rep
%finish
%if stat&ready # 0 %start
!! l i m i t sent
am1 reply = 2; ! long block
d_n = n; d_count = max
d_hold == m; ! retain for later
-> am1 rep
%finish
%if l_txs&ready # 0 %then %exit
%repeat
%if n > m_a(0) %start
free buffer(m)
d_hold == null; d_n = 0; d_kill = 0
%if d_inp q_e == null %then ->am1 rep
%exit
%finish
l_txd = m_a(n); n=n+1
%repeat
%repeat
am1 rep:
p_c1 = am1 reply
to 2900(return control, null)
#if c
mark(33)
#fi
%end
%routine mon mes(%record (mef) %name mes)
%integer i, j, k, n
%record (lev3f) %name lev3
k = mes_len; lev3 == mes_lev3
write(k, 1); printstring(": ")
j = 0
%cycle i = 0, 1, k-1
write(lev3_a(i), 1)
j = j+1; %if j = 20 %then j = 0 %and newline
%repeat
newline; select output(0)
%end
%endofprogram