// 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<>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<>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 ]