

DIRECTORY
MailAnswer,
MailBasics USING [RName],
MailParse,
IO,
Rope;

MailParseAndAnswerImpl: CEDAR MONITOR
IMPORTS IO, Rope
EXPORTS MailAnswer, MailParse
= BEGIN OPEN MailParse, IO;


openComment: CHAR = '(;
closeComment: CHAR = ');
quoteNext: CHAR = '\\;
quotes: CHAR = '";
comma: CHAR = ',;
colon: CHAR = ':;
semiColon: CHAR = ';;
openRoute: CHAR = '<;
closeRoute: CHAR = '>;
openSquareBracket: CHAR = '[;
closeSquareBracket: CHAR = '];
dot: CHAR = '.;
atSign: CHAR = '@;

TokenType: TYPE =
{atom, dot, atSign, comma, colon, semiColon, openRoute, closeRoute, domainLiteral,
endOfLine, endOfList, endOfInput};

ParseInfo: PUBLIC TYPE = RECORD
[ strm, tokenStrm, tempName: STREAM,
giveACR: BOOL м FALSE,
peekChar: CHAR м NUL];

ParseHandle: TYPE = REF ParseInfo;

ParseError: PUBLIC ERROR [code: ParseErrorCode] = CODE;
SyntaxError: ERROR = CODE;

AnswerProc: TYPE = MailAnswer.AnswerProc;


InitializeParse: PUBLIC PROC RETURNS [ph: ParseHandle] =
{ ph м NEW[ParseInfoм [strm: ROS[], tokenStrm: ROS[], tempName: ROS[]]] };  -- of InitializeParse


FinalizeParse: PUBLIC PROC [ph: ParseHandle] = {

ph.strm.Close[];
ph.tokenStrm.Close[];
ph.tempName.Close[];
};  -- of FinalizeParse --


GetFieldName: PUBLIC PROC [ph: ParseHandle, next: PROC RETURNS [CHAR]]RETURNS [fieldName: ROPE] = {

char: CHAR;
blanks: BOOL м FALSE;
ph.strm.Reset[];
DO
SELECT char м Get[ph, next] FROM
CR, LF, endOfInput =>
{ fieldName м RopeFromROS[ph.strm, FALSE];
IF fieldName.Length[] = 0 THEN RETURN[NIL]
ELSE ParseError[badFieldName];
};
': => RETURN[RopeFromROS[ph.strm, FALSE]];
SP, TAB => blanks м TRUE;
endOfList, < 40C => ERROR ParseError[badFieldName];
ENDCASE =>
SELECT TRUE FROM
blanks => ERROR ParseError[badFieldName];
ENDCASE => ph.strm.PutChar[char];
ENDLOOP;
};  -- of GetFieldName --


GetFieldBody: PUBLIC PROC
[ph: ParseHandle, next: PROC RETURNS [CHAR],
suppressBody: BOOL м FALSE, suppressWhiteSpace: BOOL м FALSE]
RETURNS [fieldBody: ROPE] = {

char: CHAR;
spaceSeen: BOOL м TRUE; -- TRUE means ignore leading spaces

RemoveTrailingSpace: PROC = INLINE
BEGIN
len: INTм fieldBody.Length[];
WHILE len > 0 AND fieldBody.Fetch[len-1] = SP DO
len м len - 1;
ENDLOOP;
fieldBody м fieldBody.Substr[0, len];
END;  -- of RemoveTrailingSpace --

IF ~suppressBody THEN ph.strm.Reset[];
DO
SELECT char м Get[ph, next] FROM
SP, TAB =>
BEGIN
IF spaceSeen THEN LOOP;
IF suppressWhiteSpace THEN {char м SP; spaceSeen м TRUE};
END;
endOfInput => GO TO Trouble;
endOfList, CR, LF => EXIT;
ENDCASE => spaceSeen м FALSE;
IF ~suppressBody THEN ph.strm.PutChar[char];
ENDLOOP;
IF ~suppressBody THEN
{ fieldBodyм RopeFromROS[ph.strm, FALSE]; RemoveTrailingSpace[]};

EXITS
Trouble => ERROR ParseError[badFieldBody];
};  -- of GetFieldBody --


NameList: PUBLIC PROC[ph: ParseHandle, transport: ATOM, next: PROC RETURNS[CHAR],proc: PROC[rName: RName] RETURNS[nameToWrite: ROPE],write: PROC [ROPE] м NIL ] = {
error: ParseErrorCode м none;
eol: BOOL м FALSE;
recognized: BOOL м FALSE;
rName: MailBasics.RName;
nameToWrite: ROPE;
outputStrm: STREAM м IF write = NIL THEN NIL ELSE ph.strm;
tokenStrm: STREAM м ph.tokenStrm;
tempName: STREAM м ph.tempName;

IF outputStrm # NIL THEN outputStrm.Reset[];
UNTIL eol DO
char: CHAR;
tempName.Reset[];
DO
SELECT (char м Get[ph, next] ) FROM	-- consume leading white space
SP, TAB => LOOP;
ENDCASE => EXIT;
ENDLOOP;
DO
SELECT char FROM
comma => EXIT;
endOfInput => ERROR ParseError[truncated];
endOfList, CR, LF => { eol м TRUE; EXIT };
ENDCASE => tempName.PutChar[char];
char м Get[ph, next];
ENDLOOP;
[recognized, rName] мCheckForRecognizedName[RopeFromROS[ph.tempName, FALSE], transport];
IF NOT recognized THEN ParseError[badFieldBody];
nameToWrite м proc[rName];
IF ( write # NIL ) AND ( nameToWrite # NIL ) THEN write[nameToWrite];
ENDLOOP;
};  -- of NameList --

Get: PROC [ph: ParseHandle, next: PROC RETURNS[CHAR]] RETURNS [char: CHAR] = {
IF ph.giveACR THEN { ph.giveACR м FALSE; RETURN[CR] };
IF ph.peekChar = NUL THEN
BEGIN
char м next[];
IF (char = CR ) OR (char = LF)  THEN
BEGIN
ph.peekChar м next[];
SELECT ph.peekChar FROM
SP, TAB => { ph.peekChar м NUL; RETURN[SP] };
ENDCASE;
END;
END
ELSE { char м ph.peekChar; ph.peekChar м NUL };
};  -- of Get --

CheckForRecognizedName: PROC[temp: ROPE, transport: ATOM]RETURNS[recognized: BOOL м FALSE, rName: RName] = {
FOR pL: LIST OF ParseNameProcRec м GetNameProcs[], pL.rest UNTIL pL=NIL DO
SELECT TRUE FROM
( transport = NIL ), ( transport = $any ) => [recognized, rName] м pL.first.proc[temp];
( transport = pL.first.which) => { [recognized, rName] м pL.first.proc[temp]; RETURN} ;
ENDCASE => NULL;
IF recognized THEN RETURN;
ENDLOOP;
};

MakeHeader: PUBLIC PROC[which: ATOM, getChar: PROC [INT] RETURNS [CHAR],inputLength: INT, userRName: RName, cForCopies: BOOL м FALSE ]
RETURNS [answerError: BOOL м TRUE, answer: ROPE, errorIndex: INT м 0] = {
FOR aL: LIST OF AnswerProcRec м GetAnswerProcs[], aL.rest UNTIL aL = NIL DO
IF ( which = $any ) OR (which = aL.first.which ) THEN {
[answerError, answer, errorIndex] м aL.first.proc[getChar, inputLength, userRName, cForCopies];
RETURN
};
ENDLOOP;
};

GetNameProcs: ENTRY PROC RETURNS[LIST OF ParseNameProcRec] = INLINE 
{ RETURN[nameProcList] };

ParseNameProcRec: TYPE = RECORD[which: ATOM, proc: ParseNameProc];
nameProcList: LIST OF ParseNameProcRec м NIL;

RegisterNameProc: PUBLIC ENTRY PROC[which: ATOM, nameProc: ParseNameProc] = {
ENABLE UNWIND => NULL;
nameProcList м CONS[[which, nameProc], nameProcList];
};

convertNameProcList: LIST OF ConvertNameProc м NIL;

RegisterConvertNameProc: PUBLIC ENTRY PROC[convertProc: ConvertNameProc] = {
ENABLE UNWIND => NULL;
convertNameProcList м CONS[convertProc, convertNameProcList];
};

AnswerProcRec: TYPE = RECORD[which: ATOM, proc: AnswerProc];
answerProcList: LIST OF AnswerProcRec м NIL;

GetAnswerProcs: ENTRY PROC RETURNS[LIST OF AnswerProcRec] = INLINE 
{ RETURN[answerProcList] };

RegisterAnswerProc: PUBLIC ENTRY PROC[which: ATOM, proc: AnswerProc] = {
ENABLE UNWIND => NULL;
answerProcList м CONS[[which, proc], answerProcList];
};

END.
     MailParseAndAnswerImpl.mesa
Copyright ╙ 1985, 1989, 1991 by Xerox Corporation.  All rights reserved.
Based on ArpaMailParser.mesa by Brotz, March 6, 1983  3:29 PM
Willie-sue, November 16, 1989 12:08:13 pm PST
Doug Terry, October 21, 1988 3:36:04 pm PDT
Doug Wyatt, March 7, 1985 11:07:34 am PST
Types
Some special characters specified by RFC 822
Initializes the header parser, and returns a ParseHandle which is to be passed to all other
procedures of this interface.  Subsequent invocations of GetFieldName, GetFieldBody,
and ParseNameList will obtain their input using "next".  If "notifyTruncation" is TRUE,
GetFieldName and GetFieldBody will raise ParseError[truncated] if the string they are
collecting overflows the string provided.  (The signal is not raised until the entire field
name or body has been scanned.)  If "notifyTruncation" is FALSE, this signal is
suppressed.
Finalizes the parser instance specified by "pH".  This procedure must be called when the
client has finished parsing, either because of normal completion or because some error
has occurred.  After calling this procedure, "pH" is no longer meaningful and must not
be reused.  Note: FinalizeParse may not be called while a call to ParseNameList is
pending (for the same ParseHandle).
GetFieldName presumes that "next" (see InitializeParse) is positioned to read the first
character of a field name and returns the field name, without the terminating colon,
as "fieldName".  GetFieldName leaves "next" ready to return the first character
following the colon (or, if the end of the message header has been reached, the
character (if any) after the two CRs that normally terminate the header).  
Upon return, fieldName is NIL if no field names remain in the header.
If the header field ends prematurely or illegal header characters are encountered,
ParseError[badFieldName] is raised.
The (remainder of the) current field body is read using "next" (see InitializeParse)
and is returned as "fieldBody".  If the field body terminates before a CR is seen,
ParseError[badFieldBody] is raised.  Upon return, "fieldBody" has no initial or
terminal white space (blanks and tabs) and, if "suppressWhiteSpace" is TRUE,
each internal run of white space has been replaced by a single blank.
ArpaNet folding conventions are also observed.
IF suppressBody is TRUE, then no fieldBody is generated
ParseNameList expects to read characters using "next" (see InitializeParse) for a structured field body consisting of a list of recipient names.  ParseNameList eliminate leading white space, then scans for a comma that does not appear inside quote marks, and calls the registered NameProcs until one claims to recognize the name; if none do, then ParseError[badFieldBody] is raised.
If proc returns nameToWrite # NIL and write # NIL, then nameToWrite gets written.
It is legitimate for the "proc" routine to raise a signal that causes ParseNameList to be unwound.
Body of ParseNameList
Obtains next input character and smoothes over a few lexical quirks.  This procedure
deals with Arpa-standard line-folding.
 Э╩O  Ц(cedarcode) styleХNewlineDelimiter
Ш codeЪЬЩKЪЬ
╧eЬ=ЩHKЪЬ=Щ=KЪЬ-Щ-KЩ+KЩ)ЧKШ Ъ╧k	Ш	KШKЪЬЮЬ	ШKЪЬ
Ш
KЪЮЬШKШЧKШ Ъ╤blnЬЮЬЮШ%KЪЮЬЮЬШKЪЮЬШKЪЬЮЬЮЬЮЬШЧKШ KЪЬЩШ KЪЬ,Щ,KШ KЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKЪЬЮЬШKШ ЪЬЮЬШKШRKШ"ЧKШ ЪЬЮЬЮЬЮШЪЬЮЬШ$KЪЬ	ЮЬЮЬШKЪЬ
ЮЬЮЬШЧЧKШ KЪЬЮЬЮЬШ"KШ KЪЬЮЬЮЬЮЬШ7KЪЬЮЬЮЬШKШ KЪЬЮЬШ)ЧKШ KШ Ъ╧nЬЮЬЮЬЮЬШ8KЪЬ[Щ[KЪЬTЩTKЪЬWЩWKЪЬUЩUKЪЬ[Щ[KЪЬOЩOЪЬЩKЪ
ЬЮЬЮЬЮЬЮЬ	╧cШaЧЧKШ KШ ЪаЬЮЬЮЬШ0KЪЬXЩXKЪЬVЩVKЪЬVЩVKЪЬRЩRЪЬ#Щ#KШ KШKШKЪЬШKЪЬбШЧЧKШ KШ ЪаЬЮЬЮЬЮЬЮЬЮЬЮЬЮЬШdKЪЬWЩWKЪЬTЩTKЪЬOЩOKЪЬOЩOKЪЬKЩKKЪЬEЩEKЪЬRЩRЪЬ#Щ#KШ KЪЬЮЬШKЪЬЮЬЮЬШKШЪЮШЪЮЬЮШ ЪЮЬЮЬШЪЬ#ЮЬШ*ЪЮЬЮЬЮЬЮЬШ*KЪЮЬШЧKШЧЧKЪЬЮЬЮЬШ*KЪЮЬЮЬЮЬШKЪЬЮЬШ3ЧЪЮЬШ
ЪЮЬЮЬЮШЪЬ
ЮЬШ)KЪЮЬШ!ЧЧЧKЪЮЬШЧKЪЬбШЧЧKШ KШ ЪаЬЮЬЮШЪЬЮЬЮЬЮЬШ,Ъ	ЬЮЬЮЬЮЬЮЬШ=KЪЮЬЮЬШЧЧKЪЬTЩTKЪЬRЩRKЪЬOЩOKЪЬLЩLKЪЬEЩEKЪЬ.Щ.ЪЬ7Щ7KШ KЪЬЮЬШKЪЬЮЬЮЬб#Ш;KШ ЪаЬЮЬЮШ"ЪЮШKЪЬЮЬШЪЮЬ	ЮЬЮЬЮШ0KШЧKЪЮЬШKШ%ЧKЪЮЬбШ"ЧKШ KЪЮЬЮЬШ&ЪЮШЪЮЬЮШ ЪЮЬЮЬШ
KЪЮШKЪЮЬЮЬЮЬШKЪЮЬЮЬ	ЮЬЮЬШ9KЪЮЬШЧKЪЬЮЬЮЬ	ШKЪЬЮЬЮЬЮЬШKЪЮЬЮЬШKЪЮЬЮЬШ,ЧKЪЮЬШЧЪЮЬЮШKЪЬ"ЮЬШAKШ ЧЪЮШKЪЬЮЬШ*ЧKЪЬбШЧЧKШ KШ ЪаЬЮЬЮЬЮЬЮЬЮЬЮЬ	ЮЬЮЬЮЬ
ЮЬЮЬЮЬШеKЪЬ■Щ■KЪЬQЩQЪЬbЩbKШKЪЬЮЬЮЬШKЪЬЮЬЮЬШKШKЪЬЮЬШKЪЬЮЬЮЬ	ЮЬЮЬЮЬЮЬ	Ш:KЪЬЮЬШ!KЪЬ
ЮЬШKШ KЪЬЩKЪЮЬЮЬЮЬШ,ЪЮЬЮШKЪЬЮЬШKЪЬШЪЮШЪЮЬЮЬбШBKЪЮЬЮЬЮЬШKЪЮЬЮЬШЧKЪЮЬШЧЪЮШЪЮЬЮШKЪЬ	ЮЬШKЪЬЮЬШ*KЪ	ЬЮЬЮЬЮЬЮЬШ*KЪЮЬШ"ЧKШKЪЮЬШЧKЪЬFЮЬШYKЪЮЬЮЬЮЬШ0KШKЪ
ЮЬЮЬЮЬЮЬЮЬШEKЪЮЬШЧKЪЬбШKШ ЧЪаЬЮЬЮЬЮЬЮЬЮЬЮЬШNKЪЬTЩTKЪЬ&Щ&KЪ
ЮЬЮЬЮЬЮЬЮЬШ6ЪЮЬЮЬЮШKЪЮШKШЪ	ЮЬ	ЮЬЮЬ	ЮЬЮШ$KЪЮШKШЪЮЬЮШKЪ
ЮЬЮЬЮЬЮЬЮЬШ-KЪЮЬШЧKЪЮЬШЧKЪЮШЧKЪЮЬ%ЮЬШ/KЪЬбШKШ ЧЪаЬЮЬЮЬЮЬЮЬЮЬЮЬШmЪЮЬЮЬЮЬ,ЮЬЮЬЮШJЪЮЬЮЬЮШKЪЬЮЬFШWKЪЬNЮЬШWKЪЮЬЮЬШЧKЪЮЬЮЬЮЬШKЪЮЬШЧKШKШ ЧЪа
ЬЮЬЮЬЮЬЮЬЮЬЮЬЮЬЮЬ ЮЬЮЬШЗKЪ
ЮЬЮЬЮЬ
ЮЬЮЬ	ШIЪЮЬЮЬЮЬ+ЮЬЮЬЮШKЪЮЬЮЬЮЬШ7KШ_KЪЮШKШЧKЪЮЬШЧKШKШ ЧЪаЬЮЬЮЬЮЬЮЬЮЬЮЬШDKЪЬЮЬШKШ ЧKЪЬЮЬЮЬЮЬШBЪЬЮЬЮЬЮЬШ-KШ ЧЪ
аЬЮЬЮЬЮЬЮЬШMKЪЮЬЮЬЮЬШKЪЬЮЬ"Ш5KШKШ ЧЪЬЮЬЮЬЮЬШ3KШ ЧЪаЬЮЬЮЬЮЬ"ШLKЪЮЬЮЬЮЬШKЪЬЮЬ#Ш=KШKШ ЧKЪЬЮЬЮЬЮЬШ<ЪЬЮЬЮЬЮЬШ,KШ ЧЪаЬЮЬЮЬЮЬЮЬЮЬЮЬШCKЪЬЮЬШKШ ЧЪ
аЬЮЬЮЬЮЬЮЬШHKЪЮЬЮЬЮЬШKЪЬЮЬ Ш5KШЧЧKШ KЪЮЬШЧ ЕЧ    Ш  .ы  