// IfsMailStore.bcpl -- IFS Mail Server Store command // Copyright Xerox Corporation 1979, 1980, 1981 // Last modified November 17, 1981 9:05 PM by Taft get "IfsDirs.decl" get "IfsFtpProt.decl" get "IfsMail.decl" get "IfsSystemInfo.decl" external [ // outgoing procedures MtpSStore; MtpSStoreMail; MtpSStoreCleanup // incoming procedures from other FTP and Mail modules FtpSSendMark; NetToDisk; FlipCursor; FTPM StartMsg; WriteMNB; FinishMsg; CheckName; EnumerateMB // incoming procedures from IFS Dirs modules DestroyFD // incoming procedures - miscellaneous SysFree; Zero; MultEq; Dequeue; FilePos LookupErrorCode // incoming statics CtxRunning ] //---------------------------------------------------------------------------- let MtpSStore(pl) = valof //---------------------------------------------------------------------------- // This procedure is called once for each property list (i.e. each recipient), // and then once more (when the [EOC] arrives) with pl = zero. // The recipients are validated as they arrive; rejected ones are so marked. // On the last call (when pl = zero), run down the list generating // exceptions and checking for a sender and at least one recipient. [ if CtxRunning>>FtpCtx.msg eq 0 then //first pl [ let ec = nil CtxRunning>>FtpCtx.msg = StartMsg(0, 0, lv ec) if CtxRunning>>FtpCtx.msg eq 0 then resultis FtpSSendMark(markNo, ec) ] let msg = CtxRunning>>FtpCtx.msg if pl eq 0 then //no more pls [ // generate mailbox exceptions // we are counting on the way the compiler allocates local variables. let sawMlbx, mlbxIndex, sndrEc = false, 1, ecSndrRequired EnumerateMB(msg, StoreRecipients, lv sawMlbx) while msg>>Msg.hostQ.head ne 0 do SysFree(Dequeue(lv msg>>Msg.hostQ)) // there must be at least one valid MLBX property unless sawMlbx resultis FtpSSendMark(markNo, ecNoValidMlbx) // check sender property if sndrEc eq 0 resultis true let errRec = LookupErrorCode(sndrEc) FTPM(markNo, 42b, lv errRec>>ErrRec.errorString) SysFree(errRec) resultis false ] // is there a valid MailBox property? // Note: must check this first so that MSG.hostQ will be empty // on first call with lookupMailbox=true if pl>>PL.MLBX ne 0 then [ let mlbx, ec = pl>>PL.MLBX, 0 let fd = CheckName(mlbx, msg, lv ec, true) if fd ne 0 & fd ne -1 then DestroyFD(fd) WriteMNB(msg, (ec eq 0? mbTypeMlbx, mbTypeExcp), mlbx, ec) ] // is there a valid Sender property? if pl>>PL.SNDR ne 0 & MultEq(lv msg>>Msg.posSndr, table [ 0; 0 ]) then [ let sndr, ec = pl>>PL.SNDR, 0 CheckName(sndr, msg, lv ec, false) WriteMNB(msg, mbTypeSndr, sndr, ec) ] resultis true ] //---------------------------------------------------------------------------- and MtpSStoreMail() = valof //---------------------------------------------------------------------------- [ let msg = CtxRunning>>FtpCtx.msg let ec = NetToDisk(msg>>Msg.stream, CtxRunning>>FtpCtx.bspStream) if ec eq 0 then [ // disallow zero length messages let pos = vec 1; FilePos(msg>>Msg.stream, pos) if MultEq(lv msg>>Msg.posTxt, pos) then ec = ecZeroLengthMsg ] resultis ec? FtpSSendMark(markNo, ec), true ] //---------------------------------------------------------------------------- and MtpSStoreCleanup(ok) be //---------------------------------------------------------------------------- if CtxRunning>>FtpCtx.msg then CtxRunning>>FtpCtx.msg = FinishMsg(CtxRunning>>FtpCtx.msg, ok) //---------------------------------------------------------------------------- and StoreRecipients(mb, msg, args) = valof //---------------------------------------------------------------------------- // Called from EnumerateMB in MtpSStore, this procedure generates mailbox // exceptions for those recipients which can be verified on the fly. // It also sets flags to record seeing at least one recipient. // args!0 is sawMlbx, args!1 is mlbxIndex, args!2 is sndrEc [ let rewrite = false switchon mb>>MB.type into [ case mbTypeMlbx: [ args!0 = true //sawMlbx args!1 = args!1 +1 //mlbxIndex endcase ] case mbTypeExcp: [ let errRec = LookupErrorCode(mb>>MNB.ec) FTPM(markMailboxException, errRec>>ErrRec.ftpEc, "$D $S", false, args!1, lv errRec>>ErrRec.errorString) SysFree(errRec) mb>>MNB.type = mbTypeFree rewrite = true args!1 = args!1 +1 //mlbxIndex endcase ] case mbTypeSndr: [ args!2 = mb>>MNB.ec // sndrEc endcase ] ] resultis rewrite ]