conststring (13) vsn = "ftps....2a "
#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
! 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)))
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
#if k
include "tsbsp_tscodes"
#else
include "b_ygatecalls"
#fi
#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 ! k
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'
!********************* 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 connect 1 = 5; ! lev3 connected, waiting for
! 2900 connect&enable
constinteger connected = 6; ! in file
constinteger enabld = 7; ! 2900 has started file
constinteger close ready = 8; ! fep is ready to accept a close
constinteger closing = 9; ! 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
#if k
constinteger send push = 34
#fi
#fi
!**************************************************************
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 = 16; ! 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 (63) 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
#if k
owninteger mon = 0; ! monitoring flag off
#else
owninteger mon = 1; ! monitoring flag (set to 'P')
#fi
owninteger data len = 120; ! cut down length for pss
owninteger spec mon = 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, qual
ownstring (1) disqual
! l o g g i n g o n
integer i
conststring (7) array ostates(-1:closing) = "not all",
"waiting", "ready", "asking", "timing", "abortng",
"chcking", "conning", "going", "clserdy", "close"
ownstring (15) ad1, ad2, ad3
!**********************************************
!* 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)
redo enable:
#if ~x
to gate(enable facility, null, 16)
#else
p_ser = gate ser; p_reply = own id
p_fn = enable facility; p_a2 = 0; p_facility = "FTP"
pon(p)
#fi
alarm(500); ! set clock for 10 secs
!**********************************************
!* main loop *
!**********************************************
cycle
p_ser = 0; poff(p)
if int = 'K' start
data len = 100; ! so safefor gateway
int = 0
finish
if 'M' <= int <= 'P' start
mon = int-'O'; int = 0
printstring("ok
")
finish
if int = '?' start
cycle i = 2, 1, con lim
d == con desa(i)
if d_o state # not alloc start
printstring("ftp:")
who and state
printstring("p ="); write(d_port, 1)
printstring(", oc ="); write(d_nc, 1)
printstring(", istate ="); write(d_istate, 1)
printstring(", omode ="); write(d_mode, 1)
printstring(", ifirst ="); write(d_first, 1)
printstring(", operm ="); 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
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
if int='R' then int = 0 and ->redo enable; ! horrible
cycle i = con lim, -1, 0
d == con desa(i)
if d_o state = timing then do connect
repeat
alarm(1000); ! 20 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
wait
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
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)
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 then p_c1 = 0 else p_c1 = 1
#else
if reason = get op block then p_c1 = 0 else p_c1 = 1
#fi
! ****** watch the above line ********
#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
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
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
write(d_index, 2); space
if d_direction = 0 then printstring("ftp-Q") else c
printstring("ftp-P")
#if ~x
write(d_term, 1)
#else
space; printstring(adda(d_index))
#fi
space
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 ! k
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
integer node
#if ~x
switch fns(incoming call:message reply)
#else
switch fns(connect:datagram)
#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
->fns(fn)
#if ~x
fns(incoming call):
#else
fns(Connect):
strm = p_gate port; ! remember gate port no
#fi
flag = 0; ! reject if all else fails
!! There are two possible conditions,
!! 1) The specific device has already send in a file.
!! 2) the 2900 has to be asked to validate the device
#if x
disqual = ""
mes == p_mes
#fi
if host state = down start
plant fail('d', p_mes)
-> 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
#else
calling = unpack(mes, 2)
qual = unpack(mes, 3)
#fi
d == get free des
if d == null then plant fail('f', p_mes) and -> reply
! No free descriptors
#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
adda(d_index) = calling
#fi
d_o state = connect 1; ! wait for confirmation
d_nc = 0
if mon < 0 start
#if ~x
tell; printstring("asking
")
#else
write(d_index, 2); printstring("Call from:"); printstring(calling)
printstring(", Called ="); printstring(unpack(mes, 1))
printstring(", qual:"); printstring(qual); newline
#fi
finish
#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
d_holdi == mes
#fi
do repm(flag)
return
#if ~x
fns(input recd):
#else
fns(Input Here):
#fi
ftpi = ftpi+1
mes == p_mes
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):
d_permit = d_permit+1
if d_permit = 1 and d_o state = enabld then c
get buffer(get op block)
#else
fns(Enable Output):
d_permit = d_permit + p_a2
if d_permit = p_a2 and d_o state = enabld thenc
get buffer(get op block)
#fi
return
#if ~x
fns(call closed):
fns(call aborted): ! all is lost
#else
fns(Disconnect):
unless p_mes == null then free buffer(p_mes)
#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 d_o state = trying start
d_nc = d_nc+1; d_port = flag; ! remember reason
d_o state = timing; ! try again soon
return
finish
#fi
who and state
printstring("network abort
")
#if x
to gate(Disconnect, null, 1); !ack to gate
#fi
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
#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 start
tell; printstring("Invalid call reply !
")
return
finish
return if d == d4; ! not assigned
#if x
free buffer(p_mes) unless p_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 ~k
if mon # 0 start
tell; printstring("connected
")
finish
#else
tell; printstring("connected to"); write(p_a2,2); newline
#fi
get buffer(connecting reply); ! get buffer to reply to spoolr
get buffer(connecting reply 2); ! and for other stream
d_permit = initial permit; ! nsi change
d_o state = connected
d_nc = 0
#if ~x
finish
#fi
return
#if ~x
fns(message r): ! incoming login or enquiry
fns(message reply): ! reply to sendmessage
#else
fns(reset):
tell; printstring("Reset !
")
to gate(Disconnect, null, 1)
d_o state = idle
get buffer(send abort); ! and tell 2900 call gone
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):
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
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):
-> 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):
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
#if k
tell; printstring("connect accepted
")
#fi
#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 aborted # d_o state # idle and ioflag # 0 start
! this must only be done on one stream !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
d_o state = closing
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
if mon # 0 and ioflag # 0 start
who and state; printstring("Disconnect ignored
")
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
-> junk m
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
")
-> junk m
com stateb(aborting):
com stateb(suspending):
com stateb(disconnecting):
d_o state = idle
host state = down
clear all streams
junk m: tidy buffers
-> 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
#if ~k
printstring("Connect called !
")
#fi
get buffer(get connect buffer)
end
routine do actual connect(record (mef) name mes)
record (pe) p
ownstring (11) ef = "EMAS - ftp"
#if k
called=adda(d_index)
calling=snil
#else
qual = adda(d_index)
called = string(addr(qual)+1)
calling = string(addr(qual)+length(called)+2)
#fi
if mon # 0 start
printstring("Connect to:"); printstring(called)
printstring(", from:"); printstring(calling)
newline
finish
mes_len = 0
pack(mes, called)
pack(mes, calling)
pack(mes, snil)
pack(mes, ef)
d_port = 0; ! ensure it goes out on port 0
to Gate(Connect, mes, 0)
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
len = d_n
if d_mode=x'50' and d_n = d_cpos+1 then len = len-1
! 1 dummy length byte present
#if k & x
if len<=0 then len=0;
#else
if len <= 0 then free buffer(mes) else start
#fi
#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
#if k & x
to gate(put output, mes, 0)
#else
to gate(put output, mes, 0)
#fi
#if ~( k & x)
finish
#fi
#if k & x
else
! get buffer(send push); !send push (null data)
#fi
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
#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
d_hold == p_mes; d_n = 0
get buffer(low level op transfer)
return
finish
if reason = do input connect start
log == p_mes
#if x
log_type = 4; ! new type for packed strings
#else
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
called = unpack(d_holdi, 1)
calling = unpack(d_holdi, 2)
lc1 = length(called); lc2 = length(calling)
! temp frig as butler is letting '.' thru on end of string
if charno(calling, lc2) = '.' then lc2=lc2-1
! end
if lc1+lc2 > 59 start
printstring("Incoming length too long - truncated !
")
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 m
printstring("Incoming call from:"); printstring(log_address)
newline
#fi
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
#if k
if reason = send push start
p_mes_len=0
d_permit = d_permit - 1
to gate(put output, p_mes, 0); !push null data
return
finish
#fi
#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 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 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
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 = unpack(mes,3)
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
#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):
#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 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 mon = -1 start
select output(1); printstring("in data: n, cpos:")
write(n, 1); write(cpos, 1); newline
select output(0)
finish
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 n < 3 and d_outlen < 10 start
printstring("ftps: output inconsistency! Outlen =")
write(d_outlen, 1); printstring("Block =")
mon mes(mes)
finish
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)
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)
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: 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
-> 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
-> send it
data state(13): ! 3rd and last byte of tcc
-> kick; ! tell 2900
send it:
l_txd = sym
repeat
repeat
am1 rep:
p_c1 = am1 reply
to 2900(return control, null)
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
if d_count # d_nc start ; ! Another message waiting
get buffer(get op block)
finish
type = m_type; ! max = 256
unless 1 <= type <= 5 then ->badm
-> hlm(type)
hlm(2): ! Allocate stream - reply
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(1): ! allocate new (output) pair
hlm(4): ! new packed string number
! set d_direction = 1 %if an outgoing connection to be made ??
d == get free des
if d == null start ; ! failed
! flag it ????
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
if length(m_address) > 63 start
printstring("FTP: Outgoing address overflow, address TRUNCATED:")
printstring(m_address); newline
length(m_address) = 63
finish
#if k
!special kent code to use addresses of the form N0Txx the F number if present
!is converted to the full facility code (F*256 + 16)
if m_address -> ad1.(".F").ad2 start
n=stoi(ad2) << 8 + 16
m_address=ad1
else
n=16
finish
adda(d_index) = m_address.".F".itos(n, -1)
#else
adda(d_index) = m_address
#fi
#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
-> swd(d_o state)
swd(not alloc):
crunch
swd(idle): ! ok, so do it
retrieve(d)
-> move it
swd(op ready):
swd(timing): ! its trying to connect
get buffer(connecting reply failed)
get buffer(connecting reply 2 failed)
! retrieve the descriptor AFTER the connect reply sent
-> move it
swd(trying): ! connect outstanding
d_o state = aborted
d_nc = 99
-> 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
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)
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