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
DIRECTORY
MailAnswer,
MailBasics USING [RName],
MailParse,
IO,
Rope;
MailParseAndAnswerImpl: CEDAR MONITOR
IMPORTS IO, Rope
EXPORTS MailAnswer, MailParse
= BEGIN OPEN MailParse, IO;
Types
Some special characters specified by RFC 822
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] =
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.
{ ph ¬ NEW[ParseInfo¬ [strm: ROS[], tokenStrm: ROS[], tempName: ROS[]]] }; -- of InitializeParse
FinalizeParse: PUBLIC PROC [ph: ParseHandle] = {
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).
ph.strm.Close[];
ph.tokenStrm.Close[];
ph.tempName.Close[];
}; -- of FinalizeParse --
GetFieldName: PUBLIC PROC [ph: ParseHandle, next: PROC RETURNS [CHAR]]
RETURNS
[fieldName: ROPE] = {
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.
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] = {
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
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 ] = {
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.
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;
Body of ParseNameList
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] = {
Obtains next input character and smoothes over a few lexical quirks. This procedure
deals with Arpa-standard line-folding.
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.