(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 7-Jun-88 13:08:02" {SAFE}IMAP2.;67 39085 previous date%: "26-May-88 09:29:14" |{MCS:MCS:STANFORD}MM>IMAP2.;17|) (PRETTYCOMPRINT IMAP2COMS) (RPAQQ IMAP2COMS ( (* ;  "Interim Mail Access Protocol II --- Mark Crispin") (* ;  "Mail Access Protocol routines --- interface between IMAP and MM") (FNS MAP.OPEN MAP.CLOSE MAP.SELECT MAP.FETCHFLAGS MAP.FETCHENVELOPE MAP.FETCHMESSAGE MAP.FETCHHEADER MAP.FETCHFROMSTRING MAP.FETCHSUBJECT MAP.SETFLAG MAP.CLEARFLAG MAP.CHECKMAILBOX MAP.EXPUNGEMAILBOX MAP.COPYMESSAGE MAP.MOVEMESSAGE MAP.ELT MAP.LOCKED?) (* ;  "Interim Mail Access Protocol support routines") (FNS IMAP.OPEN IMAP.OPEN.TCP IMAP.LOGIN IMAP.LOGOUT IMAP.NOOP IMAP.SELECT IMAP.SEND IMAP.REPLY IMAP.PARSE.UNSOLICITED IMAP.EXISTS IMAP.RECENT IMAP.EXPUNGED IMAP.SEARCHED IMAP.PARSE.DATA IMAP.READ IMAP.READ.ITEM IMAP.LOCK IMAP.UNLOCK IMAP.LOCKED?) (* ; "IMAP contact ports") (CONSTANTS (IMAP.PORT.TCP 143)) (* ;  "Single line string readtable") [INITVARS (IMAP.CR.RDTBL (COPYREADTABLE 'ORIG] (P (for I from 0 to 127 do (SETSYNTAX I 'OTHER IMAP.CR.RDTBL)) (SETSYNTAX (CHARCODE CR) 'BREAKCHAR IMAP.CR.RDTBL)) (* ;  "Commonly used strings and bittables") [INITVARS [MAP.CRLF (CONCAT (CHARACTER (CHARCODE CR)) (CHARACTER (CHARCODE LF] (MAP.LOOKAHEAD 20) [IMAP.SPACEBITTABLE (MAKEBITTABLE (LIST (CHARCODE SPACE] (IMAP.ARGBITTABLE (MAKEBITTABLE (LIST (CHARCODE CR) (CHARCODE "%"") (CHARCODE {] (* ;  "IMAP user-settable parameters") (INITVARS (IMAP.PROTOCOL 'TCP) (IMAP.DEBUG NIL) (IMAP.GAG T) (IMAP.LOCKDEBUG NIL)) (* ; "Declare all globals") (GLOBALVARS MAP.CRLF MAP.LOOKAHEAD IMAP.SPACEBITTABLE IMAP.ARGBITTABLE IMAP.CR.RDTBL IMAP.PORT.TCP IMAP.PROTOCOL IMAP.DEBUG IMAP.GAG IMAP.LOCKDEBUG PROMPTWINDOW) (* ; "IMAP reply record") (RECORDS IMAP.PARSEDREPLY))) (* ; "Interim Mail Access Protocol II --- Mark Crispin") (* ; "Mail Access Protocol routines --- interface between IMAP and MM") (DEFINEQ (MAP.OPEN [LAMBDA (NAME OLDSTREAM) (* ; "Edited 29-Apr-88 19:18 by MRC") (* ; "Mail Access Protocol open") (PROG ((HOST (FILENAMEFIELD NAME 'HOST)) (WINDOW PROMPTWINDOW) STREAM OLDHOST NMSGS) (if OLDSTREAM then (SETQ OLDHOST (STREAMPROP OLDSTREAM 'HOST)) [SETQ WINDOW (GETPROMPTWINDOW (STREAMPROP OLDSTREAM 'TWINDOW] (if (AND (EQ (U-CASE HOST) (U-CASE OLDHOST)) (SETQ STREAM (IMAP.NOOP OLDSTREAM))) then (printout WINDOW T "Reusing connection to " HOST) else (printout WINDOW T "Closing connection to " OLDHOST) (IMAP.LOGOUT OLDSTREAM))) (if (AND (OR STREAM (AND (SETQ STREAM (IMAP.OPEN HOST)) (EQ 'OK (fetch (IMAP.PARSEDREPLY KEY) of (IMAP.REPLY STREAM))) (IMAP.LOGIN STREAM HOST))) (IMAP.SELECT STREAM (PACKFILENAME 'HOST NIL 'BODY NAME)) (SETQ NMSGS (STREAMPROP STREAM 'NMSGS)) (GEQ NMSGS 1)) then (STREAMPROP STREAM 'HOST HOST) (RETURN STREAM) else (if (ZEROP NMSGS) then (printout WINDOW T "Mailbox is empty")) (IMAP.LOGOUT STREAM]) (MAP.CLOSE [LAMBDA (STREAM) (* ; "Edited 6-Jul-87 16:12 by MRC") (* ;  "Here to break any protocol connections") (if (OPENP STREAM) then (IMAP.LOGOUT STREAM]) (MAP.SELECT [LAMBDA (STREAM CRITERIA) (* ; "Edited 26-Oct-87 18:24 by MRC") (* ;  "Do a search with the given criteria") (IMAP.SEND STREAM 'SEARCH CRITERIA]) (MAP.FETCHFLAGS [LAMBDA (STREAM FIRST LAST) (* ; "Edited 25-Feb-88 18:25 by MRC") (* ; "Fetch fast mailbox properties") (IMAP.SEND STREAM 'FETCH `(,(if (EQ FIRST LAST) then FIRST else (CONCAT FIRST ":" LAST)) FAST]) (MAP.FETCHENVELOPE [LAMBDA (STREAM MESSAGEARRAY MSG) (* ; "Edited 27-Apr-88 15:51 by cdl") (* ;  "Fetch envelope for the given message") (OR (fetch (MM.CACHE Envelope) of (MAP.ELT MESSAGEARRAY MSG)) (LET ((NMSGS (GETSTREAMPROP STREAM 'NMSGS)) LAST) (if (AND MAP.LOOKAHEAD (LESSP MSG NMSGS)) then (for old LAST from (ADD1 MSG) to (MIN NMSGS (PLUS MSG MAP.LOOKAHEAD)) until (fetch (MM.CACHE Envelope) of (MAP.ELT MESSAGEARRAY LAST )) do)) (IMAP.SEND STREAM 'FETCH `(,(if LAST then (CONCAT MSG ":" (SUB1 LAST)) else MSG) ALL)) (fetch (MM.CACHE Envelope) of (MAP.ELT MESSAGEARRAY MSG]) (MAP.FETCHMESSAGE [LAMBDA (STREAM MESSAGEARRAY MSG) (* ; "Edited 26-Jan-88 16:48 by MRC") (* ;  "Fetch text for the given message") (IMAP.SEND STREAM 'FETCH `(,MSG RFC822)) (fetch (MM.CACHE RFC822.Stream) of (MAP.ELT MESSAGEARRAY MSG]) (MAP.FETCHHEADER [LAMBDA (STREAM MESSAGEARRAY MSG) (* ; "Edited 26-Jan-88 17:31 by MRC") (* ;  "Fetch RFC822 header for the given message") (IMAP.SEND STREAM 'FETCH `(,MSG RFC822.HEADER)) (fetch RFC822.Header of (MAP.ELT MESSAGEARRAY MSG]) (MAP.FETCHFROMSTRING [LAMBDA (STREAM MESSAGEARRAY MSG MAXFROMLENGTH) (* ; "Edited 30-Mar-88 09:28 by cdl") (* ; "Return human-readable From") (LET (TEXT ENV ADDRESS) (with MM.CACHE (MAP.ELT MESSAGEARRAY MSG) (SETQ FromText (ALLOCSTRING MAXFROMLENGTH (CHARCODE SPACE))) [if [AND (SETQ ENV (OR Envelope (MAP.FETCHENVELOPE STREAM MESSAGEARRAY MSG))) (SETQ ADDRESS (CAR (fetch (MM.MESSAGE From) of ENV] then (with MM.ADDRESS ADDRESS (SETQ TEXT (OR PersonalName (if Mailbox then (if Host then (CONCAT Mailbox "@" Host ) else Mailbox] (if TEXT then (RPLSTRING FromText 1 (if (GREATERP (NCHARS TEXT) MAXFROMLENGTH) then (SUBSTRING TEXT 1 MAXFROMLENGTH) else TEXT)) else FromText]) (MAP.FETCHSUBJECT [LAMBDA (STREAM MESSAGEARRAY MSG MAXSUBJECTLENGTH) (* ; "Edited 15-Dec-87 18:18 by MRC") (* ; "Return Subject") (LET (SUB ENV) (with MM.CACHE (MAP.ELT MESSAGEARRAY MSG) (SETQ SubjectText (if (AND (SETQ ENV (OR Envelope (MAP.FETCHENVELOPE STREAM MESSAGEARRAY MSG))) (SETQ SUB (fetch (MM.MESSAGE Subject) of ENV))) then (if (GREATERP (NCHARS SUB) MAXSUBJECTLENGTH) then (SUBSTRING SUB 1 MAXSUBJECTLENGTH) else SUB) else " "]) (MAP.SETFLAG [LAMBDA (STREAM SEQUENCE FLAG) (* ; "Edited 10-Mar-88 12:14 by MRC") (* ;  "Set a flag in the message's flaglst") (if FLAG then (if (LISTP FLAG) then (SETQ FLAG (CAR FLAG))) (* ; "MM.MENU returns (LIST FLAG)") (LET [(REPLY (IMAP.SEND STREAM 'STORE (LIST SEQUENCE '+Flags FLAG] (with IMAP.PARSEDREPLY REPLY (if (NEQ 'OK KEY) then (printout PROMPTWINDOW T "Set flag rejected: " TEXT]) (MAP.CLEARFLAG [LAMBDA (STREAM SEQUENCE FLAG) (* ; "Edited 10-Mar-88 12:15 by MRC") (* ;  "Clear a flag in the message's flaglst") (if FLAG then (if (LISTP FLAG) then (SETQ FLAG (CAR FLAG))) (* ; "MM.MENU returns (LIST FLAG)") (LET [(REPLY (IMAP.SEND STREAM 'STORE (LIST SEQUENCE '-Flags FLAG] (with IMAP.PARSEDREPLY REPLY (if (NEQ 'OK KEY) then (printout PROMPTWINDOW T "Clear flag rejected: " TEXT]) (MAP.CHECKMAILBOX [LAMBDA (STREAM) (* ; "Edited 20-May-88 12:16 by MRC") (* ; "Check for new messages") (PROG ([WINDOW (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW] REPLY) (PRINTOUT WINDOW T) (with IMAP.PARSEDREPLY (SETQ REPLY (IMAP.SEND STREAM 'CHECK)) (if (EQ 'OK KEY) then (printout WINDOW T "Check completed") (RETURN REPLY) else (printout WINDOW T "Check rejected: " TEXT]) (MAP.EXPUNGEMAILBOX [LAMBDA (STREAM) (* ; "Edited 20-May-88 12:16 by MRC") (* ; "Expunges the mailbox") (PROG ([WINDOW (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW] REPLY) (PRINTOUT WINDOW T) (with IMAP.PARSEDREPLY (SETQ REPLY (IMAP.SEND STREAM 'EXPUNGE)) (if (EQ 'OK KEY) then (if [AND TEXT (NOT (EQUAL TEXT (CONSTANT null] then (* ;  "Message from IMAP server is more interesting") (printout WINDOW T TEXT) else (printout WINDOW T "Expunge Completed")) (RETURN REPLY) else (printout WINDOW T "Expunge rejected: " TEXT]) (MAP.COPYMESSAGE [LAMBDA (STREAM MSGNO DESTMAILBOX) (* ; "Edited 25-Apr-88 15:21 by cdl") (* ; "Copy mailbox to destination") (PROG ([WINDOW (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW] REPLY) (PRINTOUT WINDOW T) (if DESTMAILBOX then (with IMAP.PARSEDREPLY (SETQ REPLY (IMAP.SEND STREAM 'COPY (LIST MSGNO DESTMAILBOX))) (if (EQ 'OK KEY) then (MAP.SETFLAG STREAM MSGNO '\Seen) (RETURN DESTMAILBOX) else (printout WINDOW "Copy rejected: " TEXT))) else (printout WINDOW "Copy aborted.") NIL]) (MAP.MOVEMESSAGE [LAMBDA (STREAM MSGNO DESTMAILBOX) (* ; "Edited 3-Mar-88 17:40 by MRC") (* ; "Copy mailbox to destination") (if (AND (MAP.COPYMESSAGE STREAM MSGNO DESTMAILBOX) (MAP.SETFLAG STREAM MSGNO '\Deleted)) then DESTMAILBOX]) (MAP.ELT [LAMBDA (MESSAGEARRAY MSGNO) (* ; "Edited 26-Jan-88 17:34 by MRC") (* ;  "Returns extant message record from mailbox or creates one") (LET* ((MSG (SUB1 MSGNO)) (MESSAGERECORD (CL:AREF MESSAGEARRAY MSG))) (if (NULL MESSAGERECORD) then (replace (MM.CACHE Msg#) of (SETQ MESSAGERECORD (CL:SETF (CL:AREF MESSAGEARRAY MSG) (create MM.CACHE))) with MSGNO)) MESSAGERECORD]) (MAP.LOCKED? [LAMBDA (STREAM) (* ; "Edited 29-Apr-88 15:26 by MRC") (* ; "Returns T if stream locked") (IMAP.LOCKED? STREAM]) ) (* ; "Interim Mail Access Protocol support routines") (DEFINEQ (IMAP.OPEN [LAMBDA (HOST) (* ; "Edited 29-Apr-88 19:17 by MRC") (* ; "Opens an IMAP connection") (SELECTQ IMAP.PROTOCOL (TCP (IMAP.OPEN.TCP HOST)) (ERROR "Unknown IMAP protocol" IMAP.PROTOCOL]) (IMAP.OPEN.TCP [LAMBDA (HOST) (* ; "Edited 28-Jan-88 18:02 by MRC") (* ;  "Open IMAP connection using TCP/IP") (PROG ((HOSTADDR (DODIP.HOSTP HOST)) STREAM) (if HOSTADDR then (if (SETQ STREAM (TCP.OPEN HOSTADDR IMAP.PORT.TCP NIL 'ACTIVE 'INPUT T)) then (PUTSTREAMPROP STREAM 'OUTSTREAM (TCP.OTHER.STREAM STREAM)) (RETURN STREAM) else (printout PROMPTWINDOW T "Can't connect to " HOST " server")) else (printout PROMPTWINDOW T "No such host as " HOST]) (IMAP.LOGIN [LAMBDA (STREAM HOST) (* ; "Edited 28-Jan-88 15:32 by MRC") (* ; "Logs user in to IMAP server") (PROG ((LOGINTRYCOUNT -4) USRPSW LOGINSUCCESSFLG REPLY) [until (OR LOGINSUCCESSFLG (ZEROP (add LOGINTRYCOUNT 1))) do (if REPLY then (printout PROMPTWINDOW T "Login failed: " (fetch ( IMAP.PARSEDREPLY TEXT) of REPLY))) (SETQ USRPSW (\INTERNAL/GETPASSWORD HOST REPLY)) [SETQ REPLY (IMAP.SEND STREAM 'LOGIN (LIST (CAR USRPSW) (\ENCRYPT.PWD (CONCAT (CDR USRPSW] (SETQ LOGINSUCCESSFLG (EQ 'OK (fetch (IMAP.PARSEDREPLY KEY) of REPLY] (if LOGINSUCCESSFLG then (RETURN REPLY) else (printout PROMPTWINDOW T "Too many login failures") (IMAP.LOGOUT STREAM]) (IMAP.LOGOUT [LAMBDA (STREAM) (* ; "Edited 29-Apr-88 18:55 by MRC") (* ; "Logs out IMAP session") (if STREAM then (PROG1 (IMAP.SEND STREAM 'LOGOUT) (CLOSEF? STREAM]) (IMAP.NOOP [LAMBDA (STREAM) (* ; "Edited 7-Apr-88 15:55 by MRC") (* ;  "Send a no-op to the stream; this is to see if the stream is still alive.") (if STREAM then (PROG [(REPLY (IMAP.SEND STREAM 'NOOP] (with IMAP.PARSEDREPLY REPLY (if (EQ 'OK KEY) then (RETURN STREAM) else (* ; "We can't no-op. The stream may be still alive, but with a buggy server that doesn't like no-ops. In any case, punt it.") (IMAP.LOGOUT STREAM]) (IMAP.SELECT [LAMBDA (STREAM MAILBOX) (* ; "Edited 29-Apr-88 17:08 by MRC") (* ; "Select desired mailbox") (STREAMPROP STREAM 'NMSGS NIL) (* ;  "Clear stuff from previous select") (STREAMPROP STREAM 'RECENT NIL) (PROG ((REPLY (IMAP.SEND STREAM 'SELECT MAILBOX))) (with IMAP.PARSEDREPLY REPLY (if (EQ 'OK KEY) then (RETURN REPLY) else (printout PROMPTWINDOW T "Can't select mailbox: " TEXT) (IMAP.LOGOUT STREAM]) (IMAP.SEND [LAMBDA (STREAM COMMAND ARGS) (* ; "Edited 6-May-88 16:26 by MRC") (* ;  "Sends an IMAP command to the server") (* ;; "Note that the strange usage of PRIN3 and MAP.CRLF is to prevent any sort of line folding from being done.") (if (AND (OPENP STREAM) (NOT (EOFP STREAM))) then (IMAP.LOCK STREAM) (LET ((TAG (GENSYM)) (OSTREAM (GETSTREAMPROP STREAM 'OUTSTREAM)) REPLY RTAG LARG) (PRIN3 TAG OSTREAM) (PRIN3 " " OSTREAM) (PRIN3 COMMAND OSTREAM) (if IMAP.DEBUG then (printout PROMPTWINDOW T TAG %, COMMAND) elseif (NOT IMAP.GAG) then (printout PROMPTWINDOW '+)) [if ARGS then (RESETFORM (RADIX 10) (for ARG inside ARGS do (if (STRPOSL IMAP.ARGBITTABLE ARG) then (PRIN3 " {" OSTREAM) (PRIN3 (SETQ LARG (NCHARS ARG)) OSTREAM) (PRIN3 "}" OSTREAM) (if IMAP.DEBUG then (printout PROMPTWINDOW " {" LARG "}")) (PRIN3 MAP.CRLF OSTREAM) (FORCEOUTPUT OSTREAM T) (SETQ REPLY (IMAP.REPLY STREAM TAG)) (if (EQ (CAR REPLY) '+) then (PRIN3 ARG OSTREAM) (SETQ REPLY NIL) else (RETURN)) else (PRIN3 " " OSTREAM) (if (STRPOSL IMAP.SPACEBITTABLE ARG) then (PRIN4 ARG OSTREAM) else (PRIN3 ARG OSTREAM)) (if IMAP.DEBUG then (printout PROMPTWINDOW %, ARG] (if (NULL REPLY) then (PRIN3 MAP.CRLF OSTREAM) (FORCEOUTPUT OSTREAM T) (SETQ REPLY (IMAP.REPLY STREAM TAG))) (while (NEQ TAG (SETQ RTAG (CAR REPLY))) do (SELECTQ RTAG (* (IMAP.PARSE.UNSOLICITED STREAM REPLY)) (printout PROMPTWINDOW T "Unexpected tagged response: " REPLY)) (SETQ REPLY (IMAP.REPLY STREAM TAG))) (with IMAP.PARSEDREPLY REPLY (if (EQ 'BAD KEY) then (printout PROMPTWINDOW T "IMAP II protocol error: " TEXT))) (IMAP.UNLOCK STREAM) REPLY) else (create IMAP.PARSEDREPLY TAG _ '* KEY _ 'BYE TEXT _ "IMAP connection went away!"]) (IMAP.REPLY [LAMBDA (STREAM CTAG) (* ; "Edited 20-May-88 12:15 by MRC") (* ;  "Reads a reply string from the server") (if (AND (OPENP STREAM) (NOT (EOFP STREAM))) then (LET ((REPLY (RSTRING STREAM IMAP.CR.RDTBL)) TAG KEY TAGPOS KEYPOS) (while (ZEROP (NCHARS REPLY)) do (if IMAP.DEBUG then (printout PROMPTWINDOW T "IMAP server sent a blank line" )) (to (CONSTANT (NCHARS MAP.CRLF)) do (BIN STREAM)) (SETQ REPLY (RSTRING STREAM IMAP.CR.RDTBL))) (if IMAP.DEBUG then (printout PROMPTWINDOW T REPLY) elseif (NOT IMAP.GAG) then (printout PROMPTWINDOW '!)) (to (CONSTANT (NCHARS MAP.CRLF)) do (BIN STREAM)) (* ; "Slurp TCP/IP newline") (if [AND (SETQ TAGPOS (STRPOSL IMAP.SPACEBITTABLE REPLY)) [SETQ TAG (U-CASE (SUBATOM REPLY 1 (SUB1 TAGPOS] (SETQ KEY (U-CASE (SUBATOM REPLY (ADD1 TAGPOS) (SUB1 (SETQ KEYPOS (OR (STRPOSL IMAP.SPACEBITTABLE REPLY (ADD1 TAGPOS)) (ADD1 (NCHARS REPLY] then (create IMAP.PARSEDREPLY TAG _ TAG KEY _ KEY TEXT _ (SUBSTRING REPLY (ADD1 KEYPOS))) else (printout PROMPTWINDOW T "Bogus IMAP response: " REPLY) (create IMAP.PARSEDREPLY TAG _ '* KEY _ 'BAD TEXT _ REPLY))) else (create IMAP.PARSEDREPLY TAG _ (OR CTAG '*) KEY _ 'BYE TEXT _ "IMAP connection went away!"]) (IMAP.PARSE.UNSOLICITED [LAMBDA (STREAM REPLY) (* ; "Edited 25-Apr-88 08:52 by cdl") (* ; "Parse an unsolicited IMAP reply") (LET (TEMP OP) (with IMAP.PARSEDREPLY REPLY (if (NUMBERP KEY) then (if (SETQ TEMP (STRPOSL IMAP.SPACEBITTABLE TEXT)) then [SETQ OP (U-CASE (SUBATOM TEXT 1 (SUB1 TEMP] (SETQ TEXT (SUBSTRING TEXT (ADD1 TEMP))) else (SETQ OP (U-CASE (MKATOM TEXT))) (SETQ TEXT NIL)) (SELECTQ OP (EXISTS (IMAP.EXISTS STREAM KEY)) (RECENT (IMAP.RECENT STREAM KEY)) (EXPUNGE (IMAP.EXPUNGED STREAM KEY)) ((STORE FETCH) (if (GETSTREAMPROP STREAM 'MESSAGEARRAY) then (IMAP.PARSE.DATA STREAM KEY TEXT) else (printout PROMPTWINDOW T "Unexpected message data: " REPLY))) (COPY (printout (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW)) T "Message(s) copied")) (printout PROMPTWINDOW T "Unknown message data: " OP %, REPLY)) else (SELECTQ KEY (FLAGS (PUTSTREAMPROP STREAM 'FLAGLST (CL:READ-FROM-STRING TEXT))) (SEARCH (IMAP.SEARCHED STREAM TEXT)) (BYE (printout PROMPTWINDOW T TEXT)) (OK NIL) (NO (printout PROMPTWINDOW T "Error from IMAP II server: " TEXT)) (BAD (printout PROMPTWINDOW T "IMAP II protocol error: " TEXT)) (printout PROMPTWINDOW T "Unexpected unsolicited message: " REPLY]) (IMAP.EXISTS [LAMBDA (STREAM NMSGS) (* ; "Edited 28-Mar-88 09:29 by cdl") (* ;  "Server has notified us of a new message size") (MM.EXISTS NMSGS STREAM) (PUTSTREAMPROP STREAM 'NMSGS NMSGS]) (IMAP.RECENT [LAMBDA (STREAM NMSGS) (* ; "Edited 25-Feb-88 17:57 by MRC") (* ;  "Server has notified us of recent messages") (PUTSTREAMPROP STREAM 'RECENT NMSGS]) (IMAP.EXPUNGED [LAMBDA (STREAM MSG) (* ; "Edited 5-Aug-87 16:33 by MRC") (* ;  "Server has notified us of an expunged message") (MM.EXPUNGED (GETSTREAMPROP STREAM 'TWINDOW) MSG) (PUTSTREAMPROP STREAM 'NMSGS (SUB1 (GETSTREAMPROP STREAM 'NMSGS]) (IMAP.SEARCHED [LAMBDA (STREAM TEXT) (* ; "Edited 28-Mar-88 09:45 by cdl") (* ;  "Here when server gives us a search string") (LET ((SELECTED 0)) [if TEXT then (bind (STR _ (OPENSTRINGSTREAM TEXT)) (WINDOW _ (GETSTREAMPROP STREAM 'TWINDOW)) until (EOFP STR) as old SELECTED from 0 do (MM.SEARCHED WINDOW (READ STR] (printout (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW)) T (if (ZEROP SELECTED) then "No" else SELECTED) " message" (if (EQ SELECTED 1) then " " else "s ") "selected") SELECTED]) (IMAP.PARSE.DATA [LAMBDA (STREAM MSG TEXT) (* ; "Edited 28-Jan-88 16:10 by MRC") (* ; "Parse message data from server") (LET ((DATA (IMAP.READ TEXT STREAM)) VALUE KEY) (with MM.CACHE (MAP.ELT (GETSTREAMPROP STREAM 'MESSAGEARRAY) MSG) (for PAIR on DATA by (CDDR PAIR) do (SETQ VALUE (CADR PAIR)) (SELECTQ (U-CASE (SETQ KEY (CAR PAIR))) (ENVELOPE (SETQ Envelope VALUE)) (FLAGS (SETQ Flags VALUE)) (INTERNALDATE (SETQ InternalDate VALUE)) (RFC822 (SETQ RFC822.Stream VALUE)) (RFC822.HEADER (SETQ RFC822.Header VALUE)) (RFC822.SIZE (SETQ RFC822.Size VALUE)) (RFC822.TEXT (SETQ RFC822.Stream VALUE)) (printout PROMPTWINDOW T "Unknown message property: " KEY " value: " VALUE]) (IMAP.READ [LAMBDA (TEXT STREAM) (* ; "Edited 25-Mar-88 08:00 by cdl") (* ;  "Read IMAP-format S-expression including curly-brace quoting") (if (NEQ (NTHCHARCODE TEXT 1) (CHARCODE %()) then (ERROR "Bogus IMAP II data:" TEXT)) (if (EQ (NTHCHARCODE TEXT -1) (CHARCODE %))) then (CL:READ-FROM-STRING TEXT) else (LET ((RSTREAM (OPENSTRINGSTREAM TEXT)) PROP) (BIN RSTREAM) (* ;  "move the stream pointer past the initial parenthesis") (PUTSTREAMPROP STREAM 'RSTREAM RSTREAM) (while [SETQ PROP (U-CASE (READ (SETQ RSTREAM (GETSTREAMPROP STREAM 'RSTREAM] join (LIST PROP (IMAP.READ.ITEM PROP STREAM)) finally (if (EQ RSTREAM STREAM) then (to (CONSTANT (NCHARS MAP.CRLF)) do (BIN STREAM))) (PUTSTREAMPROP STREAM 'RSTREAM NIL]) (IMAP.READ.ITEM [LAMBDA (PROP STREAM) (* ; "Edited 28-Mar-88 18:23 by cdl") (* ;  "Read an item (atom or list) from STREAM, switching to RSTREAM if necessary") (LET ((RSTREAM (GETSTREAMPROP STREAM 'RSTREAM)) LEN VALUE) (while (EQ (CHARCODE SPACE) (\PEEKBIN RSTREAM)) do (BIN RSTREAM)) (if (EQ (CHARCODE %() (\PEEKBIN RSTREAM)) then (BIN RSTREAM) [while [NOT (EQ (CHARCODE %)) (\PEEKBIN (GETSTREAMPROP STREAM 'RSTREAM] collect (IMAP.READ.ITEM PROP STREAM) finally (BIN (GETSTREAMPROP STREAM 'RSTREAM] else (SETQ VALUE (READ RSTREAM)) (if (AND (EQ (NTHCHARCODE VALUE 1) (CHARCODE {)) (EQ (NTHCHARCODE VALUE -1) (CHARCODE }))) then (if (NEQ STREAM RSTREAM) then (SETQ RSTREAM STREAM) (PUTSTREAMPROP STREAM 'RSTREAM STREAM) else (to (CONSTANT (NCHARS MAP.CRLF)) do (BIN STREAM))) (SETQ LEN (SUBATOM VALUE 2 -2)) (if (FMEMB PROP '(RFC822 RFC822.TEXT)) then [SETQ VALUE (OPENSTREAM '{NODIRCORE} 'BOTH NIL '((EOL CRLF] (COPYBYTES RSTREAM VALUE LEN) (SETFILEPTR VALUE 0) else (SETQ VALUE (ALLOCSTRING LEN)) (COPYBYTES RSTREAM (OPENSTRINGSTREAM VALUE 'OUTPUT) LEN))) VALUE]) (IMAP.LOCK [LAMBDA (STREAM) (* ; "Edited 7-Apr-88 16:43 by MRC") (* ; "Locks the IMAP stream") (while (STREAMPROP STREAM 'IMAPLOCK T) do (if IMAP.LOCKDEBUG then (printout PROMPTWINDOW T "Waiting for IMAP lock...") ) (DISMISS 100)) (if IMAP.LOCKDEBUG then (printout PROMPTWINDOW T '<]) (IMAP.UNLOCK [LAMBDA (STREAM) (* ; "Edited 7-Apr-88 16:40 by MRC") (* ; "Unlocks the IMAP stream") (if (STREAMPROP STREAM 'IMAPLOCK NIL) then (if IMAP.LOCKDEBUG then (printout PROMPTWINDOW '>)) else (ERROR "IMAP unlock when already unlocked"]) (IMAP.LOCKED? [LAMBDA (STREAM) (* ; "Edited 29-Apr-88 15:26 by MRC") (* ; "Returns T if stream locked") (STREAMPROP STREAM 'IMAPLOCK]) ) (* ; "IMAP contact ports") (DECLARE%: EVAL@COMPILE (RPAQQ IMAP.PORT.TCP 143) (CONSTANTS (IMAP.PORT.TCP 143)) ) (* ; "Single line string readtable") (RPAQ? IMAP.CR.RDTBL (COPYREADTABLE 'ORIG)) (for I from 0 to 127 do (SETSYNTAX I 'OTHER IMAP.CR.RDTBL)) (SETSYNTAX (CHARCODE CR) 'BREAKCHAR IMAP.CR.RDTBL) (* ; "Commonly used strings and bittables") (RPAQ? MAP.CRLF (CONCAT (CHARACTER (CHARCODE CR)) (CHARACTER (CHARCODE LF)))) (RPAQ? MAP.LOOKAHEAD 20) (RPAQ? IMAP.SPACEBITTABLE (MAKEBITTABLE (LIST (CHARCODE SPACE)))) (RPAQ? IMAP.ARGBITTABLE (MAKEBITTABLE (LIST (CHARCODE CR) (CHARCODE "%"") (CHARCODE {)))) (* ; "IMAP user-settable parameters") (RPAQ? IMAP.PROTOCOL 'TCP) (RPAQ? IMAP.DEBUG NIL) (RPAQ? IMAP.GAG T) (RPAQ? IMAP.LOCKDEBUG NIL) (* ; "Declare all globals") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MAP.CRLF MAP.LOOKAHEAD IMAP.SPACEBITTABLE IMAP.ARGBITTABLE IMAP.CR.RDTBL IMAP.PORT.TCP IMAP.PROTOCOL IMAP.DEBUG IMAP.GAG IMAP.LOCKDEBUG PROMPTWINDOW) ) (* ; "IMAP reply record") (DECLARE%: EVAL@COMPILE (RECORD IMAP.PARSEDREPLY (TAG KEY TEXT)) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3176 16250 (MAP.OPEN 3186 . 4877) (MAP.CLOSE 4879 . 5242) ( MAP.SELECT 5244 . 5580) (MAP.FETCHFLAGS 5582 . 6036) (MAP.FETCHENVELOPE 6038 . 7316) (MAP.FETCHMESSAGE 7318 . 7740) (MAP.FETCHHEADER 7742 . 8165) ( MAP.FETCHFROMSTRING 8167 . 9684) (MAP.FETCHSUBJECT 9686 . 10733) (MAP.SETFLAG 10735 . 11534) (MAP.CLEARFLAG 11536 . 12341) (MAP.CHECKMAILBOX 12343 . 12977) ( MAP.EXPUNGEMAILBOX 12979 . 13953) (MAP.COPYMESSAGE 13955 . 14864) ( MAP.MOVEMESSAGE 14866 . 15244) (MAP.ELT 15246 . 15996) (MAP.LOCKED? 15998 . 16248)) (16313 37731 (IMAP.OPEN 16323 . 16659) (IMAP.OPEN.TCP 16661 . 17453) ( IMAP.LOGIN 17455 . 18766) (IMAP.LOGOUT 18768 . 19098) (IMAP.NOOP 19100 . 19986) (IMAP.SELECT 19988 . 20852) (IMAP.SEND 20854 . 24708) (IMAP.REPLY 24710 . 27347) (IMAP.PARSE.UNSOLICITED 27349 . 29542) (IMAP.EXISTS 29544 . 29909) (IMAP.RECENT 29911 . 30248) (IMAP.EXPUNGED 30250 . 30682) (IMAP.SEARCHED 30684 . 31659) ( IMAP.PARSE.DATA 31661 . 32855) (IMAP.READ 32857 . 34247) (IMAP.READ.ITEM 34249 . 36359) (IMAP.LOCK 36361 . 37050) (IMAP.UNLOCK 37052 . 37472) (IMAP.LOCKED? 37474 . 37729))))) STOP