// DLSDialInServer.bcpl -- Control program for Alto DLS
// Last modified July 11, 1983 12:02 PM by Taft
// Last modified January 15, 1985 10:56 AM by Diebert
get "DLSDriver.decl"
get "Pup.decl"
get "DLSControl.decl"
get "AltoDefs.d"
external
[
// outgoing procedures
DLSCommand; Connect; OpenPortForCtx; TalkToRemote; TerminalToNet; NetToTerminal
NetError; Disconnect; CheckConnection; MakeBSP
// Procedures defined in other parts of the DLS control program
DLSCommandError; OtherPupProc; SendTelnetProtocol
LeaveRemoteMode; DLSReturnFrom; DLSRemoteError; Grapevine
// Procedures defined in DLSUtil
GetString; Echo; Confirm; Error; Ws; Wss; Wns; TimeCallStop; Set7BitProcs
GetNumber; WizardMode; OnListCheck
// Procedures defined in DLS driver
DLSResetOutput; DLSOutputEmpty; DLSInputIdle; ControlOut; ControlIn;
DetermineDLSLineSpeed; UpdateCarrierOn; WaitForBitTimes
DLSInput; DLSInput7; DLSOutput; DLSOutput7; DLSOutputTI
// Procedures defined in other packages
OpenLevel1Socket; CloseLevel1Socket; ReleasePBI; OpenRTPSocket; CloseRTPSocket;
CreateBSPStream; CloseBSPSocket; BSPForceOutput; GetPBI;AppendStringToPup;
BSPGetMark; BSPPutMark; BSPPutInterrupt; GetPartner; ExchangePorts; CompletePup
InitializeContext; CallContextList; Block; Enqueue; Dequeue; Unqueue;
SetTimer; TimerHasExpired; Dismiss; PutTemplate; PutNum; WriteRingBuffer
// Procedures defined in operating system
Gets; Puts; Endofs; Resets; Allocate; Free; AddToZone; Zero;
CallSwat; MyFrame; GotoFrame; ReturnFrom; Noop; DefaultArgs; MoveBlock
// incoming statics
mainCtx; ctxTable; versionText; crlf; dlsWizardList
dlsName
@lbTable // DLS line block table
CtxRunning; sysZone; lenPBI; pbiFreeQ; ndbQ; keyDsp; postedNotice; socketSequence
loginServerCB;
]
// ---------------------------------------------------------------------------
let DLSCommand(ctx) be
// ---------------------------------------------------------------------------
// Does local command decoding. Returns when user hangs up.
[
let type = nil
let length = nil
let width = nil
let dlb = ctx>>CTX.dlb
let soc = lv ctx>>CTX.socket
dlb>>DLB.error = DLSCommandError
ctx>>CTX.lineState = lineStateActive // Flag not in remote mode
dlb>>DLB.timeout = 100 // 1-second timeout for DLS Gets
Puts(dlb, $>) // Prompt
// Dispatch on command character
let char = Gets(dlb)
switchon char into
[
case $8:
Wss(dlb, "Set line to 8 bit no parity ")
if Confirm(dlb) then [ dlb>>DLB.eightBit = 1; dlb>>DLB.flowControl = 0 ]
endcase
case $7:
Wss(dlb, "Set line to 7 bit even parity ")
if Confirm(dlb) then [ dlb>>DLB.eightBit = 0; dlb>>DLB.flowControl = 1 ]
endcase
case 3: // Control-C means connect to default host
if Connect(ctx, ctx>>CTX.host) then TalkToRemote(ctx)
endcase
case $B: case $b:
Wss(dlb, "Bye [Confirm] ")
if Confirm(dlb) then
[
Disconnect(ctx)
PutTemplate(dlb, "#$O off*n*l", dlb>>DLB.line)
return
]
endcase
case $C: case $c:
if Connect(ctx, 0) then TalkToRemote(ctx)
endcase
case $D: case $d:
Wss(dlb, "Disconnect ")
if Confirm(dlb) then Disconnect(ctx, 3000)
endcase
case $E: case $e:
Wss(dlb, "Escape character currently = ")
Echo(dlb, ctx>>CTX.escapeChar)
Wss(dlb, " Change to ")
char = Gets(dlb)
if char eq $*n % char eq $*l % char eq 177B then
[
Error(dlb, " Illegal escape character*n*l") // Don't allow cr, lf, delete
endcase
]
Echo(dlb, char); Puts(dlb, $*s)
if Confirm(dlb) then ctx>>CTX.escapeChar = char
endcase
case $F: case $f:
Wss(dlb, "Flush typein stream ")
unless ctx>>CTX.socketOpen do
[ Error(dlb, "? No connection open*n*l"); endcase ]
if Confirm(dlb) then
if BSPPutInterrupt(soc, 0, "Sync") then BSPPutMark(soc, 1)
endcase
case $G: case $g:
Wss(dlb, "Grapevine...")
if Grapevine(ctx) then TalkToRemote(ctx)
endcase
case $I: case $i:
Wss(dlb, "Ignore escape character ")
if Confirm(dlb) then [ Wss(dlb, "Number of seconds to ignore for? ")
ctx>>CTX.escapeTime = GetNumber(dlb)
if ctx>>CTX.escapeTime le 0 then [ ctx>>CTX.escapeTime = 0; endcase ]
ctx>>CTX.escapeDisabled = 1
SetTimer(lv ctx>>CTX.escapeCharTimer, 100) ]
endcase
case $L: case $l:
PutTemplate(dlb, "Local echoing $S ", (ctx>>CTX.localEcho? "off", "on"))
if Confirm(dlb) then ctx>>CTX.localEcho = not ctx>>CTX.localEcho
endcase
case $P: case $p:
PutTemplate(dlb, "Pad $S ", (dlb>>DLB.noPad? "on", "off"))
if Confirm(dlb) then [ dlb>>DLB.noPad = not dlb>>DLB.noPad; Set7BitProcs(dlb) ]
endcase
case $R: case $r:
Wss(dlb, "Resume connection ")
unless ctx>>CTX.socketOpen do
[ Error(dlb, "? No connection open*n*l"); endcase ]
if Confirm(dlb) then TalkToRemote(ctx)
endcase
case $T: case $t:
Wss(dlb, "Set terminal parameters*n*lType? ")
type = GetNumber(dlb)
if type ls 0 then endcase
if type gr 10 % (type gr 3 & type ls 7) do
[ Wss(dlb, "Bad terminal type*n*l"); endcase ]
ctx>>CTX.terminalType = type
Wss(dlb, "Width? ")
width = GetNumber(dlb)
if width ls 0 then endcase
ctx>>CTX.terminalWidth = width
Wss(dlb, "Length? ")
length = GetNumber(dlb)
if length ls 0 then endcase
ctx>>CTX.terminalLength = length
endcase
case $V: case $v:
PutTemplate(dlb, "Version: $S running on Alto $O#$O#*n*l",
versionText, (ndbQ!0)>>NDB.localNet, (ndbQ!0)>>NDB.localHost)
endcase
case $W: case $w:
if ctx>>CTX.name eq 0 do
[
Wss(dlb, "Wizard mode*n*lLogin required. *n*l")
endcase
]
if dlb>>DLB.lineType ne ltHardwired do
unless dlb>>DLB.carrierOff then
[
Wss(dlb, "Wizard mode*n*lYou must break connection first!!!*n*l")
endcase
]
Wss(dlb, "Wizard mode [Confirm] ")
if Confirm(dlb) then
if OnListCheck(ctx, dlb, dlsWizardList) then
WizardMode(ctx, dlb)
endcase
case $X: case $x:
PutTemplate(dlb, "Xon/Xoff (Flow Control) $S ", (dlb>>DLB.flowControl? "off", "on"))
if Confirm(dlb) then dlb>>DLB.flowControl = not dlb>>DLB.flowControl
endcase
case $?:
Wss(dlb, "? Commands are: Bye, Connect, Disconnect, Escape, Flush, Grapevine*n*l")
Wss(dlb, " Ignore escape char, Local, Pad, Resume, Terminal, Version,*n*l")
Wss(dlb, " Xon/Xoff, 7 bit, 8 bit.*n*l")
if ctx>>CTX.host ne 0 then
PutTemplate(dlb, " Control-C = connect to $S*n*l", ctx>>CTX.host)
endcase
case 177B: // delete
Wss(dlb, " XXX")
case $*n: case $*l: case $*s:
Wss(dlb, crlf)
endcase
default:
Error(dlb, " ?*n*l", char)
]
] repeat
// ---------------------------------------------------------------------------
and Connect(ctx, hostName) = valof
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
Wss(dlb, "Connect to: ")
if ctx>>CTX.socketOpen then
[ Error(dlb, "? Connection already open*n*l"); resultis false ]
let frnPort = vec lenPort
let string = vec 20
test hostName eq 0
ifso
[
unless GetString(dlb, string, 40) resultis false
hostName = string
]
ifnot
PutTemplate(dlb, "$S*n*l", hostName)
unless GetPartner(hostName, dlb, frnPort, 0, 1) do
[ Error(dlb, crlf); resultis false ]
if frnPort>>Port.host eq 0 then
[
Error(dlb, "Inadequate foreign port specification*n*l")
resultis false
]
resultis MakeBSP(frnPort, ctx)
]
// ---------------------------------------------------------------------------
and Disconnect(ctx, timeout) be
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
Set7BitProcs(dlb)
if ctx>>CTX.socketOpen then
[
if ctx>>CTX.auxCtx ne 0 then
[
Unqueue(mainCtx, ctx>>CTX.auxCtx)
ctx>>CTX.auxCtx = 0
]
CloseBSPSocket(lv ctx>>CTX.socket, timeout)
ctx>>CTX.socketOpen = false
]
]
// ---------------------------------------------------------------------------
and CheckConnection(ctx) = valof
// ---------------------------------------------------------------------------
// Returns true if the connection was open and became closed.
[
if ctx>>CTX.socketOpen then
test ctx>>CTX.socket.state eq stateOpen
ifso if ctx>>CTX.timeout then
[
Disconnect(ctx, 0) // Abort connection
Wss(ctx>>CTX.dlb, " [Connection timed out]*n*l>")
resultis true
]
ifnot
[
Disconnect(ctx, 3000)
Wss(ctx>>CTX.dlb, " [Connection closed remotely]*n*l>")
resultis true
]
resultis false
]
// ---------------------------------------------------------------------------
and OpenPortForCtx(ctx, frnPort) = valof
// ---------------------------------------------------------------------------
[
let lclPort = vec lenPort; Zero(lclPort, lenPort)
if socketSequence eq 0 % socketSequence eq socTransient then
socketSequence = socketSequence+1
lclPort>>Port.socket↑1 = socketSequence
lclPort>>Port.socket↑2 = ctx>>CTX.dlb>>DLB.line
socketSequence = socketSequence+1
let soc = lv ctx>>CTX.socket
Zero(soc, lenBSPSoc)
OpenLevel1Socket(soc, lclPort, frnPort)
resultis soc
]
// ---------------------------------------------------------------------------
and TalkToRemote(ctx) be
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
test dlb>>DLB.eightBit eq 1
ifso
[
dlb>>DLB.gets = DLSInput
dlb>>DLB.puts = DLSOutput
]
ifnot Set7BitProcs(dlb)
let auxCtx = vec 150
Enqueue(mainCtx, InitializeContext(auxCtx, 150, NetToTerminal, 1))
auxCtx!3 = ctx
ctx>>CTX.auxCtx = auxCtx
ctx>>CTX.lineState = lineStateRemote // Flag that we are in remote mode
ctx>>CTX.timeout = false
ctx>>CTX.returnFrame = MyFrame() // Frame to force return to
dlb>>DLB.error = DLSRemoteError
dlb>>DLB.timeout = -1 // Never time out DLS Gets
TerminalToNet(ctx) // Returns on escape char or error
Unqueue(mainCtx, auxCtx)
ctx>>CTX.auxCtx = 0
dlb>>DLB.error = DLSCommandError
Wss(dlb, crlf)
Set7BitProcs(dlb)
]
// ---------------------------------------------------------------------------
and TerminalToNet(ctx) be
// ---------------------------------------------------------------------------
// This is a procedure called within the line's main context.
// Its task is to copy characters from terminal to net.
// It returns if either the escape character is typed or the
// connection is broken. The NetToTerminal process can force us
// to return by subterfuge involving diddling of stack frames.
[
let dlb = ctx>>CTX.dlb
let soc = lv ctx>>CTX.socket
let bspStr = lv soc>>BSPSoc.bspStr
// Send terminal parameters.
let type, length = ctx>>CTX.terminalType, ctx>>CTX.terminalLength
if type eq 0 & dlb>>DLB.baud ge 1200 do
[
type = 10
if ctx>>CTX.terminalLength eq 0 then length = 24
]
if type ne 0 then SendTelnetProtocol(soc, 4B, type)
if length ne 0 then SendTelnetProtocol(soc, 3B, length)
let width = ctx>>CTX.terminalWidth
if width eq 0 then width = selecton dlb>>DLB.baud into
[ // Select width by assuming terminal type on the basis of baud rate
case 300: 79 // TI 700
case 1200: 80 // Tektronix 4023
default: 72 // All others (including Teletype)
]
SendTelnetProtocol(soc, 2B, width)
// Main loop to send terminal characters to net.
// This code accumulates characters and sends them only when the line goes
// idle or one second elapses from the beginning of a burst, whichever
// occurs first. This attempts to maximize the number of characters per Pup
// during sustained activity without introducing excessive echoing delays.
[ // repeat
let burstStarted = false
let timer = nil
[ // repeat
let char = Gets(dlb)
unless burstStarted do
[ burstStarted = true; SetTimer(lv timer, 100) ]
test ctx>>CTX.escapeDisabled
ifso [
test TimerHasExpired(lv ctx>>CTX.escapeCharTimer)
ifso test ctx>>CTX.escapeTime le 0
ifso [ ctx>>CTX.escapeDisabled = 0 ]
ifnot [ ctx>>CTX.escapeTime = ctx>>CTX.escapeTime - 1;
SetTimer(lv ctx>>CTX.escapeCharTimer, 100) ]
ifnot [ ]
]
ifnot [ if (char & 177b) eq ctx>>CTX.escapeChar do
[ Set7BitProcs(dlb)
return ]
]
Puts(bspStr, char)
if ctx>>CTX.localEcho then
[
Puts(dlb, char)
if char eq $*n then [ Puts(bspStr, $*l); Puts(dlb, $*l) ]
]
if Endofs(dlb) then
[
if TimerHasExpired(lv timer) then break
WaitForBitTimes(dlb, 2) // wait for next char to start if it's going to
if DLSInputIdle(dlb) then break
]
] repeat
// sendNow if forcing due to timeout -- because the next ForceOut
// is also likely to be invoked by a timeout, and one second is more
// than the Pup package's timeout before requesting acknowledgment.
BSPForceOutput(soc, TimerHasExpired(lv timer))
] repeat
]
// ---------------------------------------------------------------------------
and NetToTerminal(ctx) be
// ---------------------------------------------------------------------------
// This is a separate process whose only task is to copy characters
// from net to terminal.
[
ctx = ctx!3 // Get main context for this line
let dlb = ctx>>CTX.dlb
let str = lv ctx>>CTX.socket.bspStr
[
let char = Gets(str)
test ctx>>CTX.syncCount eq 0
ifso Puts(dlb, char)
ifnot DLSResetOutput(dlb)
] repeat
]
// ---------------------------------------------------------------------------
and NetError(str, ec) = valof
// ---------------------------------------------------------------------------
// This is the procedure called via the BSP stream error dispatch
// for any abnormal condition. Note that failures may occur either
// within the line's main context (TerminalToNet) or within
// the auxiliary context (NetToTerminal).
[
let soc = str-offset BSPSoc.bspStr/16
let ctx = soc-offset CTX.socket/16
let dlb = ctx>>CTX.dlb
switchon ec into
[
case ecMarkEncountered:
switchon BSPGetMark(soc) into
[
case 1: // Data Mark
ctx>>CTX.syncCount = ctx>>CTX.syncCount-1
DLSResetOutput(dlb)
while ctx>>CTX.syncCount ls 0 do Block()
endcase
case 5: // Timing Mark
until DLSOutputEmpty(dlb) do Block()
until BSPPutMark(soc, 6) loop // Timing Mark Reply
] // Unknown Mark types are ignored
resultis 0 // Return a null -- the user will never notice!
case ecPutsTimeout:
if soc>>BSPSoc.unAckedPups eq 0 & soc>>BSPSoc.bytesPerPup ne 0 then
[
if ctx eq CtxRunning then //do this only in main ctx
Error(dlb, "*007") //too much typeahead, Warren
resultis false
]
ctx>>CTX.timeout = true //fall thru to other error cases
case ecBadStateForGets:
case ecBadStateForPuts:
LeaveRemoteMode(ctx)
]
]
// ---------------------------------------------------------------------------
and MakeBSP(frnPort, ctx) = valof
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
let soc = OpenPortForCtx(ctx, frnPort)
let login = CheckForLogin(frnPort, ctx>>CTX.name)
OpenRTPSocket(soc, 0, modeInitAndReturn, 0, OtherPupProc)
let timer = nil
SetTimer(lv timer, 3000) // 30 seconds
[
Block()
if soc>>RTPSoc.state eq stateOpen break
if soc>>RTPSoc.state ne stateRFCOut % TimerHasExpired(lv timer) %
dlb>>DLB.carrierOff then
[
CloseRTPSocket(soc, 0)
CloseLevel1Socket(soc)
ctx>>CTX.socketOpen = false
Wss(dlb, "*n*lFailed to connect*n*l")
resultis false
]
] repeat
CreateBSPStream(soc)
ctx>>CTX.socketOpen = true
soc>>BSPSoc.error = NetError // Own stream error procedure
ctx>>CTX.syncCount = 0
if login then
PutTemplate(lv soc>>BSPSoc.bspStr, "Login $S $S 1*n", ctx>>CTX.name, ctx>>CTX.password)
resultis true
]
// ---------------------------------------------------------------------------
and CheckForLogin(frnPort, name) = valof
// ---------------------------------------------------------------------------
[
let sendLogin = false
let soc = vec lenPupSoc
let infoPort = vec lenPort
MoveBlock(infoPort, frnPort, lenPort)
infoPort>>Port.socket↑1 = 0
infoPort>>Port.socket↑2 = miscServicesSocket
OpenLevel1Socket(soc, 0, infoPort)
for i=1 to 5 do //Try five times....
[SendWherePup
let p=GetPBI(soc)
AppendStringToPup(p, 1, name)
p>>PBI.pup.type = typeWhereUserRequest
CompletePup(p)
let wait=nil; SetTimer(lv wait, 200) // 2 sec
Block() repeatuntil TimerHasExpired(lv wait) %
soc>>PupSoc.iQ.head ne 0
p=Dequeue(lv soc>>PupSoc.iQ)
if p eq 0 then loop
let pup=lv p>>PBI.pup
switchon p>>PBI.pup.type into
[
case typeWhereUserReply:
[
sendLogin = true
ReleasePBI(p)
break
]
default:
[ ReleasePBI(p) ]
] //Switchon
]SendWherePup
CloseLevel1Socket(soc)
resultis sendLogin
]