// IfsMailForward.bcpl -- Forwards mail to other mail systems
// Copyright Xerox Corporation 1979, 1980, 1981, 1982
// Last modified September 18, 1983 1:41 PM by Taft
get "IfsDirs.decl"
get "IfsFiles.decl"
get "IfsMail.decl"
get "IfsFtpProt.decl"
get lenPort from "Pup0.decl"
get "IfsName.decl"
external
[
// outgoing procedure
ForwardMail
// incoming procedures from Pup package
OpenLevel1Socket; CloseLevel1Socket
OpenRTPSocket; CloseRTPSocket
CreateBSPStream
// incoming procedures from Ftp package
UserOpen; UserClose; UserStoreMail
InitPList; FreePList; FlipCursor; DiskToNet; FtpSSendMark
// incoming procedures from other mail modules
EnumerateMailFile; EnumerateMB; ReadMB; MailStatDelay
StartUndelivMsg; FinishMsg
// incoming procedures from Streams package
FilePos; SetFilePos; WriteBlock
// incoming procedures -- miscellaneous
IFSError; EnumeratePupAddresses; IFSPrintError; StreamsFD
SysAllocate; SysFree; FreePointer; Zero; MoveBlock; Noop
DoubleUsc; DeclarePupSoc
ExtractSubstring; PutTemplate
// incoming statics
CtxRunning; debugFlag
dFTPI; lBSPSoc; mail
]
//----------------------------------------------------------------------------
let ForwardMail(stream) = valof
//----------------------------------------------------------------------------
// stream is open on a file containing messages queued for delivery to a
// remote host. ForwardMail tries to open an MTP connection to the host
// and send the mail. Returns true if the file behind stream can be deleted.
// stream is enumerated even if forwarding is disabled so that
// delivery timeouts can be detected.
[
let soc = 0
if mail>>Mail.forward ne 0 then
[
// extract registry name from file name
let fd = StreamsFD(stream)
let host = ExtractSubstring(lv fd>>FD.dr>>DR.pathName,
fd>>FD.lenSubDirString+1, fd>>FD.lenBodyString-1)
// for registries that map to multiple addresses, try each one in order
// of distance from here.
EnumeratePupAddresses(host, FwdOpenConn)
SysFree(host)
soc = CtxRunning>>FtpCtx.bspSoc
if soc ne 0 then
[
CtxRunning>>FtpCtx.bspStream = CreateBSPStream(soc)
CtxRunning>>FtpCtx.dspStream = dFTPI>>FTPI.dspStream
CtxRunning>>FtpCtx.lst = dFTPI>>FTPI.lst
CtxRunning>>FtpCtx.dls = dFTPI>>FTPI.dls
CtxRunning>>FtpCtx.dbls = CtxRunning>>FtpCtx.bspStream
UserOpen(Noop)
]
]
// do the work
let delete = EnumerateMailFile(stream, Forward)
// Clean up network stuff
if soc ne 0 then
[
if CtxRunning>>FtpCtx.connFlag then UserClose(false)
DeclarePupSoc(0)
SysFree(soc)
]
resultis delete
]
//----------------------------------------------------------------------------
and FwdOpenConn(port, nil) = valof
//----------------------------------------------------------------------------
// Proc passed to EnumeratePupAddresses -- attempts to connect to each
// port until one succeeds.
[
let soc = SysAllocate(lBSPSoc)
OpenLevel1Socket(soc, 0, port)
DeclarePupSoc(soc) // puts soc in CtxRunning>>FtpCtx.bspSoc
if OpenRTPSocket(soc) resultis true // succeeded, stop enumeration
// failed, clean up and continue
CloseLevel1Socket(soc)
DeclarePupSoc(0)
SysFree(soc)
resultis false
]
//----------------------------------------------------------------------------
and Forward(msg) be
//----------------------------------------------------------------------------
// Called from EnumerateMailFile in ForwardMail.
// Calls the MTP module to send messages to remote sites.
[
if CtxRunning>>FtpCtx.connFlag then
[
CtxRunning>>FtpCtx.msg = msg
let mark = UserStoreMail(FwdGen, FwdExcp, FwdXfer)
if mark eq 0 then
[ // MTP catastrophe - undo everything
if CtxRunning>>FtpCtx.connFlag then UserClose(true)
if msg>>Msg.uMsg then
msg>>Msg.uMsg = FinishMsg(msg>>Msg.uMsg, 0)
]
EnumerateMB(msg, FwdFree, mark)
if mark<<Mark.mark eq markYes then
MailStatDelay(msTypeFwd, lv msg>>Msg.date)
]
]
//----------------------------------------------------------------------------
and FwdGen(pl) = valof
//----------------------------------------------------------------------------
// Called from UserStoreMail, generates the next recipient pl.
// The sender is included in the first pl only.
[
let msg = CtxRunning>>FtpCtx.msg
let stream = msg>>Msg.stream
let mb, sndr, mlbx = SysAllocate(maxLenMB), 0, 0
if pl eq 0 then //first time -- generate Sndr property
[
SetFilePos(stream, lv msg>>Msg.posSndr)
ReadMB(msg, mb)
sndr = ExtractSubstring(lv mb>>MNB.name)
SetFilePos(stream, lv msg>>Msg.posBlk)
]
[ //generate next Mlbx
let pos = vec 1; FilePos(stream, pos)
if DoubleUsc(pos, lv msg>>Msg.posTxt) ge 0 break
ReadMB(msg, mb)
if mb>>MB.type ne mbTypeMlbx loop
mlbx = ExtractSubstring(lv mb>>MNB.name)
break
] repeat
SysFree(mb)
pl = FreePList(pl)
test mlbx eq 0
ifso if sndr ne 0 then SysFree(sndr)
ifnot
[
pl = InitPList()
pl>>PL.SNDR = sndr
pl>>PL.MLBX = mlbx
]
resultis pl
]
//----------------------------------------------------------------------------
and FwdExcp(mark, index) be
//----------------------------------------------------------------------------
// Called from UserStoreMail to announce rejection of mailbox 'index'.
// It finds the mailbox block, marks it free, and copies the rejection
// text from the remote server into an undeliverable msg msg.
// If it can't create an undeliverable msg msg, then it changes the
// mailbox block into an exception, in the hope that later on it
// will be able to create one.
[
let msg = CtxRunning>>FtpCtx.msg
let diskStream = msg>>Msg.stream
// if we don't have an undeliverable message set up, do so
if msg>>Msg.uMsg eq 0 then
[
StartUndelivMsg(msg)
CtxRunning>>FtpCtx.index = 77777b
]
// do we have to back up and scan forward?
if CtxRunning>>FtpCtx.index gr index then
[
SetFilePos(diskStream, lv msg>>Msg.posBlk)
CtxRunning>>FtpCtx.index = 0
]
// find the offending mailbox block
let mb, pos = SysAllocate(maxLenMB), vec 1
[
FilePos(diskStream, pos)
if DoubleUsc(pos, lv msg>>Msg.posTxt) ge 0 then
[ //index supplied by remote server is bogus
if debugFlag then IFSError(ecMlbxIndex, index, msg)
CtxRunning>>FtpCtx.index = 77777b //force a backup
SysFree(mb)
return
]
ReadMB(msg, mb)
if mb>>MB.type ne mbTypeMlbx & mb>>MB.type ne mbTypeTempFree &
mb>>MB.type ne mbTypeTempExcp loop
CtxRunning>>FtpCtx.index = CtxRunning>>FtpCtx.index +1
if CtxRunning>>FtpCtx.index eq index break
] repeat
// generate the mailbox name and error text
test msg>>Msg.uMsg ne 0
ifso
[
PutTemplate(msg>>Msg.uMsg>>Msg.stream, "*N$S - $S",
lv mb>>MNB.name, CtxRunning>>FtpCtx.getCmdString)
mb>>MB.type = mbTypeTempFree
]
ifnot
[
mb>>MNB.ec = ecUnspecified
mb>>MB.type = mbTypeTempExcp
]
SetFilePos(diskStream, pos)
WriteBlock(diskStream, mb, mb>>MB.length)
SysFree(mb)
]
//----------------------------------------------------------------------------
and FwdXfer() = valof
//----------------------------------------------------------------------------
// Moves the message text over the connection.
[
let msg = CtxRunning>>FtpCtx.msg
let diskStream = msg>>Msg.stream
let bytes = vec 1; MoveBlock(bytes, lv msg>>Msg.lenTxt, 2)
SetFilePos(diskStream, lv msg>>Msg.posTxt)
let ec = DiskToNet(CtxRunning>>FtpCtx.bspStream, diskStream, bytes)
resultis ec? FtpSSendMark(markNo, ec), true
]
//----------------------------------------------------------------------------
and FwdFree(mb, msg, mark) = valof
//----------------------------------------------------------------------------
// Called from EnumerateMB in ForwardMail.
// Cleans up after attempting to forward a message.
[
let code = mark<<Mark.subCode
mark = mark<<Mark.mark
let type = mb>>MB.type
if type eq mbTypeMlbx & mark eq markNo &
((code ge 40b & code le 43b) % code eq 110b) then
[ // permanent error -- return to sender
if msg>>Msg.uMsg eq 0 then StartUndelivMsg(msg)
test msg>>Msg.uMsg ne 0
ifso
[
PutTemplate(msg>>Msg.uMsg>>Msg.stream, "*N$S - $S",
lv mb>>MNB.name, CtxRunning>>FtpCtx.getCmdString)
mb>>MB.type = mbTypeFree
]
ifnot
[
mb>>MB.type = mbTypeExcp
mb>>MNB.ec = ecUnspecified
]
resultis true
]
if type eq mbTypeMlbx & mark eq markYes then
mb>>MB.type = mbTypeFree
if type eq mbTypeTempFree then
mb>>MB.type = mark eq 0? mbTypeMlbx, mbTypeFree
if type eq mbTypeTempExcp then
mb>>MB.type = mark eq 0? mbTypeMlbx, mbTypeExcp
resultis type ne mb>>MB.type
]