// IfsMailUndeliv.bcpl -- "Return to sender: undeliverable"
// Copyright Xerox Corporation 1980, 1981
// Last modified September 18, 1983  1:44 PM by Taft

get "Ifs.decl"
get "IfsSystemInfo.decl"
get "IfsMail.decl"

external
[
// outgoing procedure
StartUndelivMsg; FinishUndelivMsg

// incoming procedures from other mail modules
StartMsg; WriteMNB; FinishMsg
MailStat; EnumerateMB; ReadMB; AppendRegistry

// incoming procedures - misc
LockCell; UnlockCell; VFileReadPage
StringCompare; ExtractSubstring; CopyString
PutTemplate; Wss; WRITEUDT; PrintIFSVersion
ReadBlock; SetFilePos; DiskToDisk
SysFree; FreePointer; MoveBlock
IFSError

// incoming statics
infoVMD
]

//----------------------------------------------------------------------------
let StartUndelivMsg(msg) be
//----------------------------------------------------------------------------
// Starts an undeliverable message msg to the sender of msg.
[
let uMsg = StartMsg(); if uMsg eq 0 return

// Sender of uMsg is Mailer.registry.
let sender = AppendRegistry("Mailer")
WriteMNB(uMsg, mbTypeSndr, sender)

// Recipient of uMsg is sender of msg.
SetFilePos(msg>>Msg.stream, lv msg>>Msg.posSndr)
let recip = ReadMB(msg); CopyString(recip, lv recip>>MNB.name)
if StringCompare(recip, sender) eq 0 then  //Mailer sent msg.
   [
   let ms = VFileReadPage(infoVMD, msPage)
   LockCell(lv ms)
   let deadLtr, dot = lv ms>>MS.deadLtr, 0
   test deadLtr>>String.length eq 0
      ifso deadLtr = 0
      ifnot
         [
         // Make sure deadLtr contains a registry.
         for i = deadLtr>>String.length to 1 by -1 do
            if deadLtr>>String.char↑i eq $. then [ dot = i; break ]
         deadLtr = dot? ExtractSubstring(deadLtr), AppendRegistry(deadLtr)
         ]
   UnlockCell(lv ms)
   // Mailer sent msg so recipient should be deadLtr.
   SysFree(recip); recip = deadLtr
   EnumerateMB(msg, UndelivUndeliv, lv deadLtr)
   if deadLtr eq 0 then  //msg is undeliverable to deadLtr.
      [  // Abondon uMsg, thereby discarding msg.
      MailStat(msTypeDiscard)
      FreePointer(lv recip, lv sender)
      FinishMsg(uMsg, false)
      return
      ]
   ]
WriteMNB(uMsg, mbTypeMlbx, recip)

// Generate the covering letter's header text.
let uStream = uMsg>>Msg.stream
PutTemplate(uStream, "To: $S", recip)
PutTemplate(uStream, "*NFrom: $S ($P mail job)",
 sender, PrintIFSVersion, 0)
FreePointer(lv recip, lv sender)
Wss(uStream, "*NDate: "); WRITEUDT(uStream, 0, true)
Wss(uStream, "*NSubject: Undeliverable mail*N")

// Ready to generate the list of undeliverable recipients.
Wss(uStream, "*NUndeliverable to:")
msg>>Msg.uMsg = uMsg
]

//----------------------------------------------------------------------------
and UndelivUndeliv(mb, msg, lvDeadLtr) = valof
//----------------------------------------------------------------------------
// Called by EnumerateMB on behalf of StartUndelivMsg.
// Scans msg's recipients (which are by now exception blocks),
//  looking for a recipient = deadLtr.
// If it finds one, then msg is undeliverable to deadLtr and
//  a uMsg should not be created.
[
if mb>>MB.type ne mbTypeExcp % @lvDeadLtr eq 0 resultis false
if StringCompare(lv mb>>MNB.name, @lvDeadLtr) eq 0 then
   [
   mb>>MB.type = mbTypeFree
   @lvDeadLtr = 0  //signal StartUndelivMsg to abandon uMsg
   ]
resultis mb>>MB.type eq mbTypeFree
]

//----------------------------------------------------------------------------
and FinishUndelivMsg(msg) be
//----------------------------------------------------------------------------
[
// copy the original message
SetFilePos(msg>>Msg.stream, lv msg>>Msg.posTxt)
let bytes = vec 1; MoveBlock(bytes, lv msg>>Msg.lenTxt, 2)
Wss(msg>>Msg.uMsg>>Msg.stream, "*N---------------------------*N")
DiskToDisk(msg>>Msg.uMsg>>Msg.stream, msg>>Msg.stream, bytes)
msg>>Msg.uMsg = FinishMsg(msg>>Msg.uMsg, true)
]