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.