git.fiddlerwoaroof.com
Browse code

Copy imap.cl to imap.lisp

Orivej Desh authored on 10/02/2012 10:13:29
Showing 1 changed files
imap.lisp
History View file @ 36b5903
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,2182 @@
1 
+#+(version= 7 0)
2 
+(sys:defpatch "imap" 1
3 
+  "v1: fetch-letter-sequence support."
4 
+  :type :system
5 
+  :post-loadable t)
6 
+
7 
+#+(version= 8 0)
8 
+(sys:defpatch "imap" 1
9 
+  "v1: fetch-letter-sequence support."
10 
+  :type :system
11 
+  :post-loadable t)
12 
+
13 
+#+(version= 8 1)
14 
+(sys:defpatch "imap" 1
15 
+  "v1: Add ssl/tls support for both imap/pop connections."
16 
+  :type :system
17 
+  :post-loadable t)
18 
+
19 
+;; -*- mode: common-lisp; package: net.post-office -*-
20 
+;;
21 
+;; imap.cl
22 
+;; imap and pop interface
23 
+;;
24 
+;; copyright (c) 1999-2002 Franz Inc, Berkeley, CA - All rights reserved.
25 
+;; copyright (c) 2002-2007 Franz Inc, Oakland, CA - All rights reserved.
26 
+;;
27 
+;; This code is free software; you can redistribute it and/or
28 
+;; modify it under the terms of the version 2.1 of
29 
+;; the GNU Lesser General Public License as published by
30 
+;; the Free Software Foundation, as clarified by the AllegroServe
31 
+;; prequel found in license-allegroserve.txt.
32 
+;;
33 
+;; This code is distributed in the hope that it will be useful,
34 
+;; but without any warranty; without even the implied warranty of
35 
+;; merchantability or fitness for a particular purpose.  See the GNU
36 
+;; Lesser General Public License for more details.
37 
+;;
38 
+;; $Id: imap.cl,v 1.32 2009/03/25 22:46:02 layer Exp $
39 
+
40 
+;; Description:
41 
+;;- This code in this file obeys the Lisp Coding Standard found in
42 
+;;- http://www.franz.com/~jkf/coding_standards.html
43 
+;;-
44 
+
45 
+
46 
+(defpackage :net.post-office
47 
+  (:use :lisp :excl)
48 
+  (:export
49 
+   #:address-name
50 
+   #:address-additional
51 
+   #:address-mailbox
52 
+   #:address-host
53 
+
54 
+   #:alter-flags
55 
+   #:close-connection
56 
+   #:close-mailbox
57 
+   #:copy-to-mailbox
58 
+   #:create-mailbox
59 
+   #:delete-letter
60 
+   #:delete-mailbox
61 
+
62 
+   #:envelope-date
63 
+   #:envelope-subject
64 
+   #:envelope-from
65 
+   #:envelope-sender
66 
+   #:envelope-reply-to
67 
+   #:envelope-to
68 
+   #:envelope-cc
69 
+   #:envelope-bcc
70 
+   #:envelope-in-reply-to
71 
+   #:envelope-message-id
72 
+
73 
+   #:expunge-mailbox
74 
+   #:fetch-field
75 
+   #:fetch-letter
76 
+   #:fetch-letter-sequence
77 
+   #:end-of-letter-p
78 
+   #:with-fetch-letter-sequence
79 
+   #:fetch-parts
80 
+   #:*imap-version-number*
81 
+   #:make-envelope-from-text
82 
+   #:mailbox-flags      ; accessor
83 
+   #:mailbox-permanent-flags ; acc
84 
+   #:mailbox-list
85 
+   #:mailbox-list-flags
86 
+   #:mailbox-list-separator
87 
+   #:mailbox-list-name
88 
+   #:mailbox-message-count ; accessor
89 
+   #:mailbox-recent-messages ; ac
90 
+   #:mailbox-separator  ; accessor
91 
+   #:mailbox-uidvalidity
92 
+   #:mailbox-uidnext
93 
+   #:make-imap-connection
94 
+   #:make-pop-connection
95 
+   #:with-imap-connection
96 
+   #:with-pop-connection
97 
+   #:noop
98 
+   #:parse-mail-header
99 
+   #:top-lines	; pop only
100 
+   #:unique-id  ; pop only
101 
+
102 
+   #:po-condition
103 
+   #:po-condition-identifier
104 
+   #:po-condition-server-string
105 
+   #:po-error
106 
+
107 
+   #:rename-mailbox
108 
+   #:reset-mailbox
109 
+   #:search-mailbox
110 
+   #:select-mailbox
111 
+
112 
+   )
113 
+  )
114 
+
115 
+(in-package :net.post-office)
116 
+
117 
+(provide :imap)
118 
+
119 
+(defparameter *imap-version-number* '(:major 1 :minor 14)) ; major.minor
120 
+
121 
+;; todo
122 
+;;  have the list of tags selected done on a per connection basis to
123 
+;;  eliminate any possible multithreading problems
124 
+;;
125 
+;;
126 
+
127 
+(defvar *debug-imap* nil)
128 
+
129 
+
130 
+
131 
+
132 
+
133 
+(defclass post-office ()
134 
+  ((socket :initarg :socket
135 
+	   :accessor post-office-socket)
136 
+
137 
+   (host :initarg :host
138 
+	 :accessor  post-office-host
139 
+	 :initform nil)
140 
+   (user  :initarg :user
141 
+	  :accessor post-office-user
142 
+	  :initform nil)
143 
+
144 
+   (state :accessor post-office-state
145 
+	  :initarg :state
146 
+	  :initform :unconnected)
147 
+
148 
+   (timeout
149 
+    ;; time to wait for network activity for actions that should
150 
+    ;; happen very quickly when things are operating normally
151 
+    :initarg :timeout
152 
+    :initform 60
153 
+    :accessor timeout)
154 
+  ))
155 
+
156 
+(defclass imap-mailbox (post-office)
157 
+  ((mailbox-name   ; currently selected mailbox
158 
+    :accessor mailbox-name
159 
+    :initform nil)
160 
+
161 
+   (separator
162 
+    ;; string that separates mailbox names in the hierarchy
163 
+    :accessor mailbox-separator
164 
+    :initform "")
165 
+
166 
+   ;;; these slots hold information about the currently selected mailbox:
167 
+
168 
+    (message-count  ; how many in the mailbox
169 
+    :accessor mailbox-message-count
170 
+    :initform 0)
171 
+
172 
+   (recent-messages ; how many messages since we last checked
173 
+    :accessor mailbox-recent-messages
174 
+    :initform 0)
175 
+
176 
+   (uidvalidity  ; used to denote messages uniquely
177 
+    :accessor mailbox-uidvalidity
178 
+    :initform 0)
179 
+
180 
+   (uidnext
181 
+    :accessor mailbox-uidnext ;; predicted next uid
182 
+    :initform 0)
183 
+
184 
+   (flags	; list of flags that can be stored in a message
185 
+    :accessor mailbox-flags
186 
+    :initform nil)
187 
+
188 
+   (permanent-flags  ; list of flags that be stored permanently
189 
+    :accessor mailbox-permanent-flags
190 
+    :initform nil)
191 
+
192 
+   (first-unseen   ; number of the first unseen message
193 
+    :accessor first-unseen
194 
+    :initform 0)
195 
+
196 
+   ;;; end list of values for the currently selected mailbox
197 
+
198 
+   ;;; state information for fetch-letter-sequence
199 
+   (fetch-letter-offset
200 
+    :accessor fetch-letter-offset)
201 
+   (fetch-letter-number
202 
+    :accessor fetch-letter-number)
203 
+   (fetch-letter-uid
204 
+    :accessor fetch-letter-uid)
205 
+   (fetch-letter-finished
206 
+    :accessor fetch-letter-finished)
207 
+   )
208 
+  )
209 
+
210 
+
211 
+(defclass pop-mailbox (post-office)
212 
+  ((message-count  ; how many in the mailbox
213 
+    :accessor mailbox-message-count
214 
+    :initform 0)
215 
+   (fetch-letter-state
216 
+    :accessor state
217 
+    :initform :invalid)))
218 
+
219 
+
220 
+
221 
+
222 
+(defstruct (mailbox-list (:type list))
223 
+  ;; a list of these are returned by mailbox-list
224 
+  flags
225 
+  separator
226 
+  name)
227 
+
228 
+
229 
+
230 
+(defstruct (envelope (:type list))
231 
+  ;; returned by fetch-letter as the value of the envelope property
232 
+  date
233 
+  subject
234 
+  from
235 
+  sender
236 
+  reply-to
237 
+  to
238 
+  cc
239 
+  bcc
240 
+  in-reply-to
241 
+  message-id)
242 
+
243 
+
244 
+(defstruct (address (:type list))
245 
+  name     ;; often the person's full name
246 
+  additional
247 
+  mailbox  ;; the login name
248 
+  host	   ;; the name of the machine
249 
+  )
250 
+
251 
+
252 
+
253 
+;--------------------------------
254 
+; conditions
255 
+;
256 
+; We define a set of conditions that are signalled due to events
257 
+; in the imap interface.
258 
+; Each condition has an indentifier which is a keyword.  That can
259 
+; be used in the handling code to identify the class of error.
260 
+; All our conditions are po-condition or po-error (which is a subclass of
261 
+; po-condition).
262 
+;
263 
+; A condition will have a server-string value if it as initiated by
264 
+; something returned by the server.
265 
+; A condition will have a format-control value if we want to display
266 
+; something we generated in response to
267 
+;
268 
+;
269 
+;
270 
+;; identifiers used in conditions/errors
271 
+
272 
+; :problem  condition
273 
+;	the server responded with 'no' followed by an explanation.
274 
+;	this mean that something unusual happend and doesn't necessarily
275 
+;	mean that the command has completely failed (but it might).
276 
+;
277 
+; :unknown-ok   condition
278 
+;	the server responded with an 'ok' followed by something
279 
+;	we don't recognize.  It's probably safe to ignore this.
280 
+;
281 
+;  :unknown-untagged condition
282 
+;	the server responded with some untagged command we don't
283 
+;	recognize.  it's probaby ok to ignore this.
284 
+;
285 
+;  :error-response  error
286 
+;	the command failed.
287 
+;
288 
+;  :syntax-error   error
289 
+;	the data passed to a function in this interface was malformed
290 
+;
291 
+;  :unexpected    error
292 
+;	the server responded an unexpected way.
293 
+;
294 
+;  :server-shutdown-connection error
295 
+;	the server has shut down the connection, don't attempt to
296 
+;       send any more commands to this connection, or even close it.
297 
+;
298 
+;  :timeout  error
299 
+;	server failed to respond within the timeout period
300 
+;
301 
+;  :response-too-large error
302 
+;	contents of a response is too large to store in a Lisp array.
303 
+
304 
+
305 
+;; conditions
306 
+(define-condition po-condition ()
307 
+  ;; used to notify user of things that shouldn't necessarily stop
308 
+  ;; program flow
309 
+  ((identifier
310 
+    ;; keyword identifying the error (or :unknown)
311 
+    :reader po-condition-identifier
312 
+    :initform :unknown
313 
+    :initarg :identifier
314 
+    )
315 
+   (server-string
316 
+    ;; message from the imap server
317 
+    :reader po-condition-server-string
318 
+    :initform ""
319 
+    :initarg :server-string
320 
+    ))
321 
+  (:report
322 
+   (lambda (con stream)
323 
+     (with-slots (identifier server-string) con
324 
+       ;; a condition either has a server-string or it has a
325 
+       ;; format-control string
326 
+       (format stream "Post Office condition: ~s~%" identifier)
327 
+       (if* (and (slot-boundp con 'excl::format-control)
328 
+		 (excl::simple-condition-format-control con))
329 
+	  then (apply #'format stream
330 
+		      (excl::simple-condition-format-control con)
331 
+		      (excl::simple-condition-format-arguments con)))
332 
+       (if* server-string
333 
+	  then (format stream
334 
+		       "~&Message from server: ~s"
335 
+		       (string-left-trim " " server-string)))))))
336 
+
337 
+
338 
+
339 
+(define-condition po-error (po-condition error)
340 
+  ;; used to denote things that should stop program flow
341 
+  ())
342 
+
343 
+
344 
+
345 
+;; aignalling the conditions
346 
+
347 
+(defun po-condition (identifier &key server-string format-control
348 
+			  format-arguments)
349 
+  (signal (make-instance 'po-condition
350 
+	    :identifier identifier
351 
+	    :server-string server-string
352 
+	    :format-control format-control
353 
+	    :format-arguments format-arguments
354 
+	    )))
355 
+
356 
+(defun po-error (identifier &key server-string
357 
+		      format-control format-arguments)
358 
+  (error (make-instance 'po-error
359 
+	    :identifier identifier
360 
+	    :server-string server-string
361 
+	    :format-control format-control
362 
+	    :format-arguments format-arguments)))
363 
+
364 
+
365 
+
366 
+;----------------------------------------------
367 
+
368 
+
369 
+
370 
+
371 
+
372 
+
373 
+(defparameter *imap-tags* '("t01" "t02" "t03" "t04" "t05" "t06" "t07"))
374 
+(defvar *cur-imap-tags* nil)
375 
+
376 
+(defvar *crlf*
377 
+    (let ((str (make-string 2)))
378 
+      (setf (aref str 0) #\return)
379 
+      (setf (aref str 1) #\linefeed)
380 
+      str))
381 
+
382 
+;; returns values: socket starttls
383 
+;; server is a cons of the form:
384 
+;; (server-name &key (port 25) (ssl nil) (starttls nil) ...ssl-client-keywords...)
385 
+(defun connect-to-imap/pop-server (server-info server-type)
386 
+  (macrolet ((pop-keyword (k l) `(prog1 (getf ,l ,k) (remf ,l ,k)))
387 
+	     (server-port (ssl type) `(cond ((eq ,type :imap) (if ,ssl 993 143))
388 
+					    ((eq ,type :pop) (if ,ssl 995 110)))))
389 
+    (let* ((server (car server-info))
390 
+	   (ssl-args (cdr server-info))
391 
+	   ssl port starttls sock)
392 
+      (setq ssl (pop-keyword :ssl ssl-args))
393 
+      (setq port (or (pop-keyword :port ssl-args) (server-port ssl server-type)))
394 
+      (setq starttls (pop-keyword :starttls ssl-args))
395 
+      (setq sock (socket:make-socket :remote-host server
396 
+				     :remote-port port))
397 
+      (when ssl
398 
+	(setq sock (apply #'socket:make-ssl-client-stream sock ssl-args)))
399 
+
400 
+      (values sock starttls))) )
401 
+
402 
+(defun make-imap-connection (host &key (port 143)
403 
+				       user
404 
+				       password
405 
+				       (timeout 30))
406 
+  (multiple-value-bind (sock starttls)
407 
+      (if (consp host)
408 
+	  (connect-to-imap/pop-server host :imap)
409 
+	(socket:make-socket :remote-host host :remote-port port))
410 
+    (let ((imap (make-instance 'imap-mailbox
411 
+		  :socket sock
412 
+		  :host   host
413 
+		  :timeout timeout
414 
+		  :state :unauthorized)))
415 
+
416 
+    (multiple-value-bind (tag cmd count extra comment)
417 
+	(get-and-parse-from-imap-server imap)
418 
+      (declare (ignorable cmd count extra))
419 
+      (if* (not (eq :untagged tag))
420 
+	 then  (po-error :error-response
421 
+			 :server-string comment)))
422 
+
423 
+    ; check for starttls negotiation
424 
+    (when starttls
425 
+      (let (capabilities)
426 
+	(send-command-get-results
427 
+	 imap "CAPABILITY"
428 
+	 #'(lambda (mb cmd count extra comment)
429 
+	     (declare (ignorable mb cmd count extra))
430 
+	     (setq capabilities comment))
431 
+	 #'(lambda (mb cmd count extra comment)
432 
+	     (check-for-success mb cmd count extra comment
433 
+				"CAPABILITY")))
434 
+	(when (and capabilities (match-re "STARTTLS" capabilities :case-fold t
435 
+					  :return nil))
436 
+	  ;; negotiate starttls
437 
+	  (send-command-get-results imap "STARTTLS"
438 
+				    #'handle-untagged-response
439 
+				    #'(lambda (mb cmd count extra comment)
440 
+					(check-for-success mb cmd count extra comment
441 
+							   "STARTTLS")
442 
+					(setf (post-office-socket mb)
443 
+					  (socket:make-ssl-client-stream
444 
+					   (post-office-socket mb) :method :tlsv1)))))))
445 
+
446 
+    ; now login
447 
+    (send-command-get-results imap
448 
+			      (format nil "login ~a ~a" user password)
449 
+			      #'handle-untagged-response
450 
+			      #'(lambda (mb command count extra comment)
451 
+				  (check-for-success mb command count extra
452 
+						     comment
453 
+						     "login")))
454 
+
455 
+    ; find the separator character
456 
+    (let ((res (mailbox-list imap)))
457 
+      ;;
458 
+      (let ((sep (cadr  (car res))))
459 
+	(if* sep
460 
+	   then (setf (mailbox-separator imap) sep))))
461 
+
462 
+
463 
+
464 
+    imap)))
465 
+
466 
+
467 
+(defmethod close-connection ((mb imap-mailbox))
468 
+
469 
+  (let ((sock (post-office-socket mb)))
470 
+    (if* sock
471 
+       then (ignore-errors
472 
+	     (send-command-get-results
473 
+	      mb
474 
+	      "logout"
475 
+	      ; don't want to get confused by untagged
476 
+	      ; bye command, which is expected here
477 
+	      #'(lambda (mb command count extra)
478 
+		  (declare (ignore mb command count extra))
479 
+		  nil)
480 
+	      #'(lambda (mb command count extra comment)
481 
+		  (check-for-success mb command count extra
482 
+				     comment
483 
+				     "logout")))))
484 
+    (setf (post-office-socket mb) nil)
485 
+    (if* sock then (ignore-errors (close sock)))
486 
+    t))
487 
+
488 
+
489 
+(defmethod close-connection ((pb pop-mailbox))
490 
+  (let ((sock (post-office-socket pb)))
491 
+    (if* sock
492 
+       then (ignore-errors
493 
+	     (send-pop-command-get-results
494 
+	      pb
495 
+	      "QUIT")))
496 
+    (setf (post-office-socket pb) nil)
497 
+    (if* sock then (ignore-errors (close sock)))
498 
+    t))
499 
+
500 
+
501 
+
502 
+(defun make-pop-connection (host &key (port 110)
503 
+				      user
504 
+				      password
505 
+				      (timeout 30))
506 
+  (multiple-value-bind (sock starttls)
507 
+      (if (consp host)
508 
+	  (connect-to-imap/pop-server host :pop)
509 
+	(socket:make-socket :remote-host host :remote-port port))
510 
+    (let ((pop (make-instance 'pop-mailbox
511 
+		:socket sock
512 
+		:host   host
513 
+		:timeout timeout
514 
+		:state :unauthorized)))
515 
+
516 
+    (multiple-value-bind (result)
517 
+	(get-and-parse-from-pop-server pop)
518 
+      (if* (not (eq :ok result))
519 
+	 then  (po-error :error-response
520 
+			 :format-control
521 
+			 "unexpected line from server after connect")))
522 
+
523 
+    ; check for starttls negotiation
524 
+    (when starttls
525 
+      (let ((capabilities (send-pop-command-get-results pop "capa" t)))
526 
+	(when (and capabilities (match-re "STLS" capabilities :case-fold t
527 
+					  :return nil))
528 
+	  (send-pop-command-get-results pop "STLS")
529 
+	  (setf (post-office-socket pop) (socket:make-ssl-client-stream
530 
+					  (post-office-socket pop) :method :tlsv1)))))
531 
+
532 
+    ; now login
533 
+    (send-pop-command-get-results pop (format nil "user ~a" user))
534 
+    (send-pop-command-get-results pop (format nil "pass ~a" password))
535 
+
536 
+    (let ((res (send-pop-command-get-results pop "stat")))
537 
+      (setf (mailbox-message-count pop) (car res)))
538 
+
539 
+
540 
+
541 
+    pop)))
542 
+
543 
+
544 
+(defmethod send-command-get-results ((mb imap-mailbox)
545 
+				     command untagged-handler tagged-handler)
546 
+  ;; send a command and retrieve results until we get the tagged
547 
+  ;; response for the command we sent
548 
+  ;;
549 
+  (let ((tag (get-next-tag)))
550 
+    (format (post-office-socket mb)
551 
+	    "~a ~a~a" tag command *crlf*)
552 
+    (force-output (post-office-socket mb))
553 
+
554 
+    (if* *debug-imap*
555 
+       then (format t
556 
+		    "~a ~a~a" tag command *crlf*)
557 
+	    (force-output))
558 
+    (loop
559 
+      (multiple-value-bind (got-tag cmd count extra comment)
560 
+	  (get-and-parse-from-imap-server mb)
561 
+	(if* (eq got-tag :untagged)
562 
+	   then (funcall untagged-handler mb cmd count extra comment)
563 
+	 elseif (equal tag got-tag)
564 
+	   then (funcall tagged-handler mb cmd count extra comment)
565 
+		(return)
566 
+	   else (po-error :error-response
567 
+			  :format-control "received tag ~s out of order"
568 
+			  :format-arguments (list got-tag)
569 
+			  :server-string comment))))))
570 
+
571 
+
572 
+(defun get-next-tag ()
573 
+  (let ((tag (pop *cur-imap-tags*)))
574 
+    (if*  tag
575 
+       thenret
576 
+       else (setq *cur-imap-tags* *imap-tags*)
577 
+	    (pop *cur-imap-tags*))))
578 
+
579 
+(defun handle-untagged-response (mb command count extra comment)
580 
+  ;; default function to handle untagged responses, which are
581 
+  ;; really just returning general state information about
582 
+  ;; the mailbox
583 
+  (case command
584 
+    (:exists (setf (mailbox-message-count mb) count))
585 
+    (:recent (setf (mailbox-recent-messages mb) count))
586 
+    (:flags  (setf (mailbox-flags mb) (kwd-intern-possible-list extra)))
587 
+    (:bye ; occurs when connection times out or mailbox lock is stolen
588 
+     (ignore-errors (close (post-office-socket mb)))
589 
+     (po-error :server-shutdown-connection
590 
+		 :server-string "server shut down the connection"))
591 
+    (:no ; used when grabbing a lock from another process
592 
+     (po-condition :problem :server-string comment))
593 
+    (:ok ; a whole variety of things
594 
+     (if* extra
595 
+	then (if* (equalp (car extra) "unseen")
596 
+		then (setf (first-unseen mb) (cadr extra))
597 
+	      elseif (equalp (car extra) "uidvalidity")
598 
+		then (setf (mailbox-uidvalidity mb) (cadr extra))
599 
+	      elseif (equalp (car extra) "uidnext")
600 
+		then (setf (mailbox-uidnext mb) (cadr extra))
601 
+	      elseif (equalp (car extra) "permanentflags")
602 
+		then (setf (mailbox-permanent-flags mb)
603 
+		       (kwd-intern-possible-list (cadr extra)))
604 
+		else (po-condition :unknown-ok :server-string comment))))
605 
+    (t (po-condition :unknown-untagged :server-string comment)))
606 
+
607 
+  )
608 
+
609 
+
610 
+(defmethod begin-extended-results-sequence ((mb pop-mailbox))
611 
+  (setf (state mb) 1))
612 
+
613 
+(defmethod get-extended-results-sequence ((mb pop-mailbox) buffer &key (start 0) (end (length buffer)))
614 
+  (declare (optimize (speed 3) (safety 1)))
615 
+  (let ((inpos start)
616 
+	(outpos start)
617 
+	(sock (post-office-socket mb))
618 
+	ch
619 
+	stop)
620 
+    (macrolet ((add-to-buffer ()
621 
+		 `(progn
622 
+		    (setf (schar buffer outpos) ch)
623 
+		    (incf outpos))))
624 
+      (while (and (< inpos end) (/= (state mb) 4))
625 
+	(setf stop (read-sequence buffer sock :start inpos :end end :partial-fill t))
626 
+	(while (< inpos stop)
627 
+	  (setf ch (schar buffer inpos))
628 
+	  (if* (eq ch #\return)
629 
+	     thenret			; ignore crs
630 
+	     else (ecase (state mb)
631 
+		    (1 (if* (eq ch #\.)	; at beginning of line
632 
+			  then (setf (state mb) 2)
633 
+			elseif (eq ch #\linefeed)
634 
+			  then
635 
+			       (add-to-buffer) ; state stays at 1
636 
+			  else
637 
+			       (setf (state mb) 3)
638 
+			       (add-to-buffer)))
639 
+		    (2			; seen first dot
640 
+		     (if* (eq ch #\linefeed)
641 
+			then		; end of results
642 
+			     (setf (state mb) 4)
643 
+			     (return)
644 
+			else
645 
+			     (setf (state mb) 3)
646 
+			     (add-to-buffer))) ; normal reading
647 
+		    (3			; middle of line
648 
+		     (if* (eq ch #\linefeed)
649 
+			then (setf (state mb) 1))
650 
+		     (add-to-buffer))))
651 
+	  (incf inpos))
652 
+	(setf inpos outpos))
653 
+      outpos)))
654 
+
655 
+(defmacro end-of-extended-results-p (mb)
656 
+  `(= (state ,mb) 4))
657 
+
658 
+(defmethod end-extended-results-sequence ((mb pop-mailbox))
659 
+  (declare (optimize (speed 3) (safety 1)))
660 
+  (let ((buffer (make-string 4096)))
661 
+    (until (end-of-extended-results-p mb)
662 
+      (get-extended-results-sequence mb buffer)))
663 
+  (setf (state mb) :invalid-state)
664 
+  t)
665 
+
666 
+(defmacro with-extended-results-sequence ((mailbox) &body body)
667 
+  (let ((mb (gensym)))
668 
+    `(let ((,mb ,mailbox))
669 
+       (begin-extended-results-sequence ,mb)
670 
+       (unwind-protect
671 
+	   (progn
672 
+	     ,@body)
673 
+	 ;; cleanup
674 
+	 (end-extended-results-sequence ,mb)))))
675 
+
676 
+
677 
+
678 
+
679 
+(defun send-pop-command-get-results (pop command &optional extrap)
680 
+  (declare (optimize (speed 3) (safety 1)))
681 
+  ;; send the given command to the pop server
682 
+  ;; if extrap is true and if the response is +ok, then data
683 
+  ;;  will follow the command (up to and excluding the first line consisting
684 
+  ;;  of just a period)
685 
+  ;;
686 
+  ;; if the pop server returns an error code we signal a lisp error.
687 
+  ;; otherwise
688 
+  ;; return
689 
+  ;;  extrap is nil -- return the list of tokens on the line after +ok
690 
+  ;;  extrap is true -- return the extra object (a big string)
691 
+  ;;
692 
+  (format (post-office-socket pop) "~a~a" command *crlf*)
693 
+  (force-output (post-office-socket pop))
694 
+
695 
+  (if* *debug-imap*
696 
+     then (format t "~a~a" command *crlf*)
697 
+	  (force-output t))
698 
+
699 
+  (multiple-value-bind (result parsed line)
700 
+      (get-and-parse-from-pop-server pop)
701 
+    (if* (not (eq result :ok))
702 
+       then (po-error :error-response
703 
+		      :server-string line))
704 
+
705 
+    (if* extrap
706 
+       then ;; get the rest of the data
707 
+	    ;; many but not all pop servers return the size of the data
708 
+	    ;; after the +ok, so we use that to initially size the
709 
+	    ;; retreival buffer.
710 
+	    (let* ((buf (get-line-buffer (+ (if* (fixnump (car parsed))
711 
+					       then (car parsed)
712 
+					       else 2048 ; reasonable size
713 
+						    )
714 
+					    50)))
715 
+		   (buflen (length buf))
716 
+		   (pos 0))
717 
+	      (with-extended-results-sequence (pop)
718 
+		(until (end-of-extended-results-p pop)
719 
+		  (if* (>= pos buflen)
720 
+		     then    ;; grow buffer
721 
+			  (if* (>= buflen (1- array-total-size-limit))
722 
+			     then	; can't grow it any further
723 
+				  (po-error
724 
+				   :response-too-large
725 
+				   :format-control
726 
+				   "response from mail server is too large to hold in a lisp array"))
727 
+			  (let ((new-buf (get-line-buffer (* buflen 2))))
728 
+			    (init-line-buffer new-buf buf)
729 
+			    (free-line-buffer buf)
730 
+			    (setq buf new-buf)
731 
+			    (setq buflen (length buf))))
732 
+		  (setf pos (get-extended-results-sequence pop buf :start pos :end buflen))))
733 
+	      (prog1 (subseq buf 0 pos)
734 
+		(free-line-buffer buf)))
735 
+       else parsed)))
736 
+
737 
+
738 
+
739 
+
740 
+(defun convert-flags-plist (plist)
741 
+  ;; scan the plist looking for "flags" indicators and
742 
+  ;; turn value into a list of symbols rather than strings
743 
+  (do ((xx plist (cddr xx)))
744 
+      ((null xx) plist)
745 
+    (if* (equalp "flags" (car xx))
746 
+       then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))))))
747 
+
748 
+
749 
+(defmethod select-mailbox ((mb imap-mailbox) name)
750 
+  ;; select the given mailbox
751 
+  (send-command-get-results mb
752 
+			    (format nil "select ~a" name)
753 
+			    #'handle-untagged-response
754 
+			    #'(lambda (mb command count extra comment)
755 
+				(declare (ignore mb count extra))
756 
+				(if* (not (eq command :ok))
757 
+				   then (po-error
758 
+					 :problem
759 
+					 :format-control
760 
+					 "imap mailbox select failed"
761 
+					 :server-string comment))))
762 
+  (setf (mailbox-name mb) name)
763 
+  t
764 
+  )
765 
+
766 
+
767 
+(defmethod fetch-letter ((mb imap-mailbox) number &key uid)
768 
+  ;; return the whole letter
769 
+  (fetch-field number "body[]"
770 
+	       (fetch-parts mb number "body[]" :uid uid)
771 
+	       :uid uid))
772 
+
773 
+
774 
+(defmethod fetch-letter ((pb pop-mailbox) number &key uid)
775 
+  (declare (ignore uid))
776 
+  (send-pop-command-get-results pb
777 
+				(format nil "RETR ~d" number)
778 
+				t ; extra stuff
779 
+				))
780 
+
781 
+(defmethod begin-fetch-letter-sequence ((mb imap-mailbox) number &key uid)
782 
+  (setf (fetch-letter-offset mb) 0)
783 
+  (setf (fetch-letter-number mb) number)
784 
+  (setf (fetch-letter-uid mb) uid)
785 
+  (setf (fetch-letter-finished mb) nil))
786 
+
787 
+
788 
+(defmethod begin-fetch-letter-sequence ((mb pop-mailbox) number &key uid)
789 
+  (declare (ignore uid))
790 
+  (send-pop-command-get-results mb (format nil "RETR ~d" number))
791 
+  (begin-extended-results-sequence mb))
792 
+
793 
+(defmethod fetch-letter-sequence ((mb imap-mailbox) buffer
794 
+				  &key (start 0) (end (length buffer)))
795 
+  (let* ((num (fetch-letter-number mb))
796 
+	 (offset (fetch-letter-offset mb))
797 
+	 (uid (fetch-letter-uid mb))
798 
+	 (buflen (- end start))
799 
+	 (data (fetch-field num (format nil "body[]<~d>" offset)
800 
+			    (fetch-parts mb num
801 
+					 (format nil "body[]<~d.~d>" offset buflen)
802 
+					 :uid uid)
803 
+			    :uid uid))
804 
+	 (datalen (length data)))
805 
+
806 
+    (setf (subseq buffer start end) data)
807 
+
808 
+    (if* (and (> buflen 0) (= datalen 0))
809 
+       then (setf (fetch-letter-finished mb) t))
810 
+
811 
+    (setf (fetch-letter-offset mb) (+ offset buflen))
812 
+
813 
+    (+ start datalen)))
814 
+
815 
+
816 
+(defmethod fetch-letter-sequence ((mb pop-mailbox) buffer &key (start 0) (end (length buffer)))
817 
+  (get-extended-results-sequence mb buffer :start start :end end))
818 
+
819 
+(defmethod end-fetch-letter-sequence ((mb imap-mailbox))
820 
+  )
821 
+
822 
+(defmethod end-fetch-letter-sequence ((mb pop-mailbox))
823 
+  (end-extended-results-sequence mb))
824 
+
825 
+(defmethod end-of-letter-p ((mb imap-mailbox))
826 
+  (fetch-letter-finished mb))
827 
+
828 
+(defmethod end-of-letter-p ((mb pop-mailbox))
829 
+  (end-of-extended-results-p mb))
830 
+
831 
+(defmacro with-fetch-letter-sequence ((mailbox &rest args) &body body)
832 
+  (let ((mb (gensym)))
833 
+    `(let ((,mb ,mailbox))
834 
+       (begin-fetch-letter-sequence ,mb ,@args)
835 
+       (unwind-protect
836 
+	   (progn
837 
+	     ,@body)
838 
+	 ;; cleanup
839 
+	 (end-fetch-letter-sequence ,mb)))))
840 
+
841 
+(defmethod fetch-parts ((mb imap-mailbox) number parts &key uid)
842 
+  (let (res)
843 
+    (send-command-get-results
844 
+     mb
845 
+     (format nil "~afetch ~a ~a"
846 
+	     (if* uid then "uid " else "")
847 
+	     (message-set-string number)
848 
+	     (or parts "body[]")
849 
+	     )
850 
+     #'(lambda (mb command count extra comment)
851 
+	 (if* (eq command :fetch)
852 
+	    then (push (list count (internalize-flags extra)) res)
853 
+	    else (handle-untagged-response
854 
+		  mb command count extra comment)))
855 
+     #'(lambda (mb command count extra comment)
856 
+	 (declare (ignore mb count extra))
857 
+	 (if* (not (eq command :ok))
858 
+	    then (po-error :problem
859 
+			   :format-control "imap mailbox fetch failed"
860 
+			   :server-string comment))))
861 
+    res))
862 
+
863 
+
864 
+(defun fetch-field (letter-number field-name info &key uid)
865 
+  ;; given the information from a fetch-letter, return the
866 
+  ;; particular field for the particular letter
867 
+  ;;
868 
+  ;; info is as returned by fetch
869 
+  ;; field-name is a string, case doesn't matter.
870 
+  ;;
871 
+  (dolist (item info)
872 
+    ;; item is (messagenumber plist-info)
873 
+    ;; the same messagenumber may appear in multiple items
874 
+    (let (use-this)
875 
+      (if* uid
876 
+	 then ; uid appears as a property in the value, not
877 
+	      ; as the top level message sequence number
878 
+	      (do ((xx (cadr item) (cddr xx)))
879 
+		  ((null xx))
880 
+		(if* (equalp "uid" (car xx))
881 
+		   then (if* (eql letter-number (cadr xx))
882 
+			   then (return (setq use-this t))
883 
+			   else (return))))
884 
+	 else ; just a message sequence number
885 
+	      (setq use-this (eql letter-number (car item))))
886 
+
887 
+      (if* use-this
888 
+	 then (do ((xx (cadr item) (cddr xx)))
889 
+		  ((null xx))
890 
+		(if* (equalp field-name (car xx))
891 
+		   then (return-from fetch-field (cadr xx))))))))
892 
+
893 
+
894 
+
895 
+(defun internalize-flags (stuff)
896 
+  ;; given a plist like object, look for items labelled "flags" and
897 
+  ;; convert the contents to internal flags objects
898 
+  (do ((xx stuff (cddr xx)))
899 
+      ((null xx))
900 
+    (if* (equalp (car xx) "flags")
901 
+       then ; we can end up with sublists of forms if we
902 
+	    ; do add-flags with a list of flags.  this seems like
903 
+	    ; a bug in the imap server.. but we have to deal with it
904 
+	      (setf (cadr xx) (kwd-intern-possible-list (cadr xx)))
905 
+	      (return)))
906 
+
907 
+  stuff)
908 
+
909 
+
910 
+
911 
+
912 
+(defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid)
913 
+  ;; delete all the mesasges and do the expunge to make
914 
+  ;; it permanent if expunge is true
915 
+  (alter-flags mb messages :add-flags :\\deleted :uid uid)
916 
+  (if* expunge then (expunge-mailbox mb)))
917 
+
918 
+(defmethod delete-letter ((pb pop-mailbox) messages  &key (expunge nil) uid)
919 
+  ;; delete all the messages.   We can't expunge without quitting so
920 
+  ;; we don't expunge
921 
+  (declare (ignore expunge uid))
922 
+
923 
+  (if* (or (numberp messages)
924 
+	   (and (consp messages) (eq :seq (car messages))))
925 
+     then (setq messages (list messages)))
926 
+
927 
+  (if* (not (consp messages))
928 
+     then (po-error :syntax-error
929 
+		    :format-control "expect a mesage number or list of messages, not ~s"
930 
+		 :format-arguments (list messages)))
931 
+
932 
+  (dolist (message messages)
933 
+    (if* (numberp message)
934 
+       then (send-pop-command-get-results pb
935 
+					  (format nil "DELE ~d" message))
936 
+     elseif (and (consp message) (eq :seq (car message)))
937 
+       then (do ((start (cadr message) (1+ start))
938 
+		 (end (caddr message)))
939 
+		((> start end))
940 
+	      (send-pop-command-get-results pb
941 
+					    (format nil "DELE ~d" start)))
942 
+       else (po-error :syntax-error
943 
+		      :format-control "bad message number ~s"
944 
+		      :format-arguments (list message)))))
945 
+
946 
+
947 
+
948 
+
949 
+
950 
+(defmethod noop ((mb imap-mailbox))
951 
+  ;; just poke the server... keeping it awake and checking for
952 
+  ;; new letters
953 
+  (send-command-get-results mb
954 
+			    "noop"
955 
+			    #'handle-untagged-response
956 
+			    #'(lambda (mb command count extra comment)
957 
+				(check-for-success
958 
+				 mb command count extra
959 
+				 comment
960 
+				 "noop"))))
961 
+
962 
+
963 
+(defmethod noop ((pb pop-mailbox))
964 
+  ;; send the stat command instead so we can update the message count
965 
+  (let ((res (send-pop-command-get-results pb "stat")))
966 
+      (setf (mailbox-message-count pb) (car res)))
967 
+  )
968 
+
969 
+
970 
+(defmethod unique-id ((pb pop-mailbox) &optional message)
971 
+  ;; if message is given, return the unique id of that
972 
+  ;; message,
973 
+  ;; if message is not given then return a list of lists:
974 
+  ;;  (message  unique-id)
975 
+  ;; for all messages not marked as deleted
976 
+  ;;
977 
+  (if* message
978 
+     then (let ((res (send-pop-command-get-results pb
979 
+						   (format nil
980 
+							   "UIDL ~d"
981 
+							   message))))
982 
+	    (cadr res))
983 
+     else ; get all of them
984 
+	  (let* ((res (send-pop-command-get-results pb "UIDL" t))
985 
+		 (end (length res))
986 
+		 kind
987 
+		 mnum
988 
+		 mid
989 
+		 (next 0))
990 
+
991 
+
992 
+	    (let ((coll))
993 
+	      (loop
994 
+		(multiple-value-setq (kind mnum next)
995 
+		  (get-next-token res next end))
996 
+
997 
+		(if* (eq :eof kind) then (return))
998 
+
999 
+		(if* (not (eq :number kind))
1000 
+		   then ; hmm. bogus
1001 
+			(po-error :unexpected
1002 
+				  :format-control "uidl returned illegal message number in ~s"
1003 
+				  :format-arguments (list res)))
1004 
+
1005 
+		; now get message id
1006 
+
1007 
+		(multiple-value-setq (kind mid next)
1008 
+		    (get-next-token res next end))
1009 
+
1010 
+		(if* (eq :number kind)
1011 
+		   then ; looked like a number to the tokenizer,
1012 
+			; make it a string to be consistent
1013 
+			(setq mid (format nil "~d" mid))
1014 
+		 elseif (not (eq :string kind))
1015 
+		   then ; didn't find the uid
1016 
+			(po-error :unexpected
1017 
+				  :format-control "uidl returned illegal message id in ~s"
1018 
+				  :format-arguments (list res)))
1019 
+
1020 
+		(push (list mnum mid) coll))
1021 
+
1022 
+	      (nreverse coll)))))
1023 
+
1024 
+(defmethod top-lines ((pb pop-mailbox) message lines)
1025 
+  ;; return the header and the given number of top lines of the message
1026 
+
1027 
+  (let ((res (send-pop-command-get-results pb
1028 
+					   (format nil
1029 
+						   "TOP ~d ~d"
1030 
+						   message
1031 
+						   lines)
1032 
+					   t ; extra
1033 
+					   )))
1034 
+    res))
1035 
+
1036 
+
1037 
+
1038 
+
1039 
+(defmethod reset-mailbox ((pb pop-mailbox))
1040 
+  ;; undo's deletes
1041 
+  (send-pop-command-get-results pb "RSET")
1042 
+  )
1043 
+
1044 
+
1045 
+
1046 
+(defun check-for-success (mb command count extra comment command-string )
1047 
+  (declare (ignore mb count extra))
1048 
+  (if* (not (eq command :ok))
1049 
+     then (po-error :error-response
1050 
+		    :format-control "imap ~a failed"
1051 
+		    :format-arguments (list command-string)
1052 
+		    :server-string comment)))
1053 
+
1054 
+
1055 
+
1056 
+
1057 
+
1058 
+(defmethod mailbox-list ((mb imap-mailbox) &key (reference "") (pattern ""))
1059 
+  ;; return a list of mailbox names with respect to a given
1060 
+  (let (res)
1061 
+    (send-command-get-results mb
1062 
+			      (format nil "list ~s ~s" reference pattern)
1063 
+			      #'(lambda (mb command count extra comment)
1064 
+				  (if* (eq command :list)
1065 
+				     then (push extra res)
1066 
+				     else (handle-untagged-response
1067 
+					   mb command count extra
1068 
+					   comment)))
1069 
+			      #'(lambda (mb command count extra comment)
1070 
+				  (check-for-success
1071 
+				   mb command count extra
1072 
+				   comment "list")))
1073 
+
1074 
+    ;; the car of each list is a set of keywords, make that so
1075 
+    (dolist (rr res)
1076 
+      (setf (car rr) (mapcar #'kwd-intern (car rr))))
1077 
+
1078 
+    res
1079 
+
1080 
+
1081 
+    ))
1082 
+
1083 
+
1084 
+(defmethod create-mailbox ((mb imap-mailbox) mailbox-name)
1085 
+  ;; create a mailbox name of the given name.
1086 
+  ;; use mailbox-separator if you want to create a hierarchy
1087 
+  (send-command-get-results mb
1088 
+			    (format nil "create ~s" mailbox-name)
1089 
+			    #'handle-untagged-response
1090 
+			    #'(lambda (mb command count extra comment)
1091 
+				  (check-for-success
1092 
+				   mb command count extra
1093 
+				   comment "create")))
1094 
+  t)
1095 
+
1096 
+
1097 
+(defmethod delete-mailbox ((mb imap-mailbox) mailbox-name)
1098 
+  ;; create a mailbox name of the given name.
1099 
+  ;; use mailbox-separator if you want to create a hierarchy
1100 
+  (send-command-get-results mb
1101 
+			    (format nil "delete ~s" mailbox-name)
1102 
+			    #'handle-untagged-response
1103 
+			    #'(lambda (mb command count extra comment)
1104 
+				  (check-for-success
1105 
+				   mb command count extra
1106 
+				   comment "delete"))))
1107 
+
1108 
+(defmethod rename-mailbox ((mb imap-mailbox) old-mailbox-name new-mailbox-name)
1109 
+  ;; create a mailbox name of the given name.
1110 
+  ;; use mailbox-separator if you want to create a hierarchy
1111 
+  (send-command-get-results mb
1112 
+			    (format nil "rename ~s ~s"
1113 
+				    old-mailbox-name
1114 
+				    new-mailbox-name)
1115 
+			    #'handle-untagged-response
1116 
+			    #'(lambda (mb command count extra comment)
1117 
+				  (check-for-success
1118 
+				   mb command count extra
1119 
+				   comment
1120 
+				   "rename"))))
1121 
+
1122 
+
1123 
+
1124 
+(defmethod alter-flags ((mb imap-mailbox)
1125 
+			messages &key (flags nil flags-p)
1126 
+				      add-flags remove-flags
1127 
+				      silent uid)
1128 
+  ;;
1129 
+  ;; change the flags using the store command
1130 
+  ;;
1131 
+  (let (cmd val res)
1132 
+    (if* flags-p
1133 
+       then (setq cmd "flags" val flags)
1134 
+     elseif add-flags
1135 
+       then (setq cmd "+flags" val add-flags)
1136 
+     elseif remove-flags
1137 
+       then (setq cmd "-flags" val remove-flags)
1138 
+       else (return-from alter-flags nil))
1139 
+
1140 
+    (if* (atom val) then (setq val (list val)))
1141 
+
1142 
+    (send-command-get-results mb
1143 
+			      (format nil "~astore ~a ~a~a ~a"
1144 
+				      (if* uid then "uid " else "")
1145 
+				      (message-set-string messages)
1146 
+				      cmd
1147 
+				      (if* silent
1148 
+					 then ".silent"
1149 
+					 else "")
1150 
+				      (if* val
1151 
+					 thenret
1152 
+					 else "()"))
1153 
+			      #'(lambda (mb command count extra comment)
1154 
+				  (if* (eq command :fetch)
1155 
+				     then (push (list count
1156 
+						      (convert-flags-plist
1157 
+						       extra))
1158 
+						res)
1159 
+				     else (handle-untagged-response
1160 
+					   mb command count extra
1161 
+					   comment)))
1162 
+
1163 
+			      #'(lambda (mb command count extra comment)
1164 
+				  (check-for-success
1165 
+				   mb command count extra
1166 
+				   comment "store")))
1167 
+    res))
1168 
+
1169 
+
1170 
+(defun message-set-string (messages)
1171 
+  ;; return a string that describes the messages which may be a
1172 
+  ;; single number or a sequence of numbers
1173 
+
1174 
+  (if* (atom messages)
1175 
+     then (format nil "~a" messages)
1176 
+     else (if* (and (consp messages)
1177 
+		    (eq :seq (car messages)))
1178 
+	     then (format nil "~a:~a" (cadr messages) (caddr messages))
1179 
+	     else (let ((str (make-string-output-stream))
1180 
+			(precomma nil))
1181 
+		    (dolist (msg messages)
1182 
+		      (if* precomma then (format str ","))
1183 
+		      (if* (atom msg)
1184 
+			 then (format str "~a" msg)
1185 
+		       elseif (eq :seq (car msg))
1186 
+			 then (format str
1187 
+				      "~a:~a" (cadr msg) (caddr msg))
1188 
+			 else (po-error :syntax-error
1189 
+					:format-control "bad message list ~s"
1190 
+					:format-arguments (list msg)))
1191 
+		      (setq precomma t))
1192 
+		    (get-output-stream-string str)))))
1193 
+
1194 
+
1195 
+
1196 
+
1197 
+
1198 
+
1199 
+(defmethod expunge-mailbox ((mb imap-mailbox))
1200 
+  ;; remove messages marked as deleted
1201 
+  (let (res)
1202 
+    (send-command-get-results mb
1203 
+			      "expunge"
1204 
+			      #'(lambda (mb command count extra
1205 
+					 comment)
1206 
+				  (if* (eq command :expunge)
1207 
+				     then (push count res)
1208 
+				     else (handle-untagged-response
1209 
+					   mb command count extra
1210 
+					   comment)))
1211 
+			      #'(lambda (mb command count extra comment)
1212 
+				  (check-for-success
1213 
+				   mb command count extra
1214 
+				   comment "expunge")))
1215 
+    (nreverse res)))
1216 
+
1217 
+
1218 
+
1219 
+(defmethod close-mailbox ((mb imap-mailbox))
1220 
+  ;; remove messages marked as deleted
1221 
+  (send-command-get-results mb
1222 
+			    "close"
1223 
+			    #'handle-untagged-response
1224 
+
1225 
+			    #'(lambda (mb command count extra comment)
1226 
+				(check-for-success
1227 
+				 mb command count extra
1228 
+				 comment "close")))
1229 
+  t)
1230 
+
1231 
+
1232 
+
1233 
+(defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination
1234 
+			    &key uid)
1235 
+  (send-command-get-results mb
1236 
+			    (format nil "~acopy ~a ~s"
1237 
+				    (if* uid then "uid " else "")
1238 
+				    (message-set-string message-list)
1239 
+				    destination)
1240 
+			    #'handle-untagged-response
1241 
+			    #'(lambda (mb command count extra comment)
1242 
+				(check-for-success
1243 
+				 mb command count extra
1244 
+				 comment "copy")))
1245 
+  t)
1246 
+
1247 
+
1248 
+;; search command
1249 
+
1250 
+(defmethod search-mailbox ((mb imap-mailbox) search-expression &key uid)
1251 
+  (let (res)
1252 
+    (send-command-get-results mb
1253 
+			      (format nil "~asearch ~a"
1254 
+				      (if* uid then "uid " else "")
1255 
+				      (build-search-string search-expression))
1256 
+			      #'(lambda (mb command count extra comment)
1257 
+				  (if* (eq command :search)
1258 
+				     then (setq res (append res extra))
1259 
+				     else (handle-untagged-response
1260 
+					   mb command count extra
1261 
+					   comment)))
1262 
+			      #'(lambda (mb command count extra comment)
1263 
+				  (check-for-success
1264 
+				   mb command count extra
1265 
+				   comment "search")))
1266 
+    res))
1267 
+
1268 
+
1269 
+(defmacro defsearchop (name &rest operands)
1270 
+  (if* (null operands)
1271 
+     then `(setf (get ',name 'imap-search-no-args) t)
1272 
+     else `(setf (get ',name 'imap-search-args) ',operands)))
1273 
+
1274 
+(defsearchop :all)
1275 
+(defsearchop :answered)
1276 
+(defsearchop :bcc :str)
1277 
+(defsearchop :before :date)
1278 
+(defsearchop :body :str)
1279 
+(defsearchop :cc :str)
1280 
+(defsearchop :deleted)
1281 
+(defsearchop :draft)
1282 
+(defsearchop :flagged)
1283 
+(defsearchop :from :str)
1284 
+(defsearchop :header :str :str)
1285 
+(defsearchop :keyword :flag)
1286 
+(defsearchop :larger :number)
1287 
+(defsearchop :new)
1288 
+(defsearchop :old)
1289 
+(defsearchop :on :date)
1290 
+(defsearchop :recent)
1291 
+(defsearchop :seen)
1292 
+(defsearchop :sentbefore :date)
1293 
+(defsearchop :senton :date)
1294 
+(defsearchop :sentsince :date)
1295 
+(defsearchop :since :date)
1296 
+(defsearchop :smaller :number)
1297 
+(defsearchop :subject :str)
1298 
+(defsearchop :text :str)
1299 
+(defsearchop :to :str)
1300 
+(defsearchop :uid :messageset)
1301 
+(defsearchop :unanswered)
1302 
+(defsearchop :undeleted)
1303 
+(defsearchop :undraft)
1304 
+(defsearchop :unflagged)
1305 
+(defsearchop :unkeyword :flag)
1306 
+(defsearchop :unseen)
1307 
+
1308 
+
1309 
+
1310 
+(defun build-search-string (search)
1311 
+  ;; take the lisp search form and turn it into a string that can be
1312 
+  ;; passed to imap
1313 
+
1314 
+  (if* (null search)
1315 
+     then ""
1316 
+     else (let ((str (make-string-output-stream)))
1317 
+	    (bss-int search str)
1318 
+	    (get-output-stream-string str))))
1319 
+
1320 
+(defun bss-int (search str)
1321 
+  ;;* it turns out that imap (on linux) is very picky about spaces....
1322 
+  ;; any extra whitespace will result in failed searches
1323 
+  ;;
1324 
+  (labels ((and-ify (srch str)
1325 
+	     (let ((spaceout nil))
1326 
+	       (dolist (xx srch)
1327 
+		 (if* spaceout then (format str " "))
1328 
+		 (bss-int xx str)
1329 
+		 (setq spaceout t))))
1330 
+	   (or-ify (srch str)
1331 
+	     ; only binary or allowed in imap but we support n-ary
1332 
+	     ; or in this interface
1333 
+	     (if* (null (cdr srch))
1334 
+		then (bss-int (car srch) str)
1335 
+	      elseif (cddr srch)
1336 
+		then ; over two clauses
1337 
+		     (format str "or (")
1338 
+		     (bss-int (car srch) str)
1339 
+		     (format str  ") (")
1340 
+		     (or-ify (cdr srch) str)
1341 
+		     (format str ")")
1342 
+		else ; 2 args
1343 
+		     (format str "or (" )
1344 
+		     (bss-int (car srch) str)
1345 
+		     (format str ") (")
1346 
+		     (bss-int (cadr srch) str)
1347 
+		     (format str ")")))
1348 
+	   (set-ify (srch str)
1349 
+	     ;; a sequence of messages
1350 
+	     (do* ((xsrch srch (cdr xsrch))
1351 
+		   (val (car xsrch) (car xsrch)))
1352 
+		 ((null xsrch))
1353 
+	       (if* (integerp val)
1354 
+		  then (format str "~s" val)
1355 
+		elseif (and (consp val)
1356 
+			    (eq :seq (car val))
1357 
+			    (eq 3 (length val)))
1358 
+		  then (format str "~s:~s" (cadr val) (caddr val))
1359 
+		  else (po-error :syntax-error
1360 
+				 :format-control "illegal set format ~s"
1361 
+				 :format-arguments (list val)))
1362 
+	       (if* (cdr xsrch) then (format str ","))))
1363 
+	   (arg-process (str args arginfo)
1364 
+	     ;; process and print each arg to str
1365 
+	     ;; assert (length of args and arginfo are the same)
1366 
+	     (do* ((x-args args (cdr x-args))
1367 
+		   (val (car x-args) (car x-args))
1368 
+		   (x-arginfo arginfo (cdr x-arginfo)))
1369 
+		 ((null x-args))
1370 
+	       (ecase (car x-arginfo)
1371 
+		 (:str
1372 
+		  ; print it as a string
1373 
+		  (format str " \"~a\"" (car x-args)))
1374 
+		 (:date
1375 
+
1376 
+		  (if* (integerp val)
1377 
+		     then (setq val (universal-time-to-rfc822-date
1378 
+				     val))
1379 
+		   elseif (not (stringp val))
1380 
+		     then (po-error :syntax-error
1381 
+				    :format-control "illegal value for date search ~s"
1382 
+				    :format-arguments (list val)))
1383 
+		  ;; val is now a string
1384 
+		  (format str " ~s" val))
1385 
+		 (:number
1386 
+
1387 
+		  (if* (not (integerp val))
1388 
+		     then (po-error :syntax-error
1389 
+				    :format-control "illegal value for number in search ~s"
1390 
+				    :format-arguments (list val)))
1391 
+		  (format str " ~s" val))
1392 
+		 (:flag
1393 
+
1394 
+		  ;; should be a symbol in the kwd package
1395 
+		  (setq val (string val))
1396 
+		  (format str " ~s" val))
1397 
+		 (:messageset
1398 
+		  (if* (numberp val)
1399 
+		     then (format str " ~s" val)
1400 
+		   elseif (consp val)
1401 
+		     then (set-ify val str)
1402 
+		     else (po-error :syntax-error
1403 
+				    :format-control "illegal message set ~s"
1404 
+				    :format-arguments (list val))))
1405 
+
1406 
+		 ))))
1407 
+
1408 
+    (if* (symbolp search)
1409 
+       then (if* (get search 'imap-search-no-args)
1410 
+	       then (format str "~a"  (string-upcase
1411 
+				       (string search)))
1412 
+	       else (po-error :syntax-error
1413 
+			      :format-control "illegal search word: ~s"
1414 
+			      :format-arguments (list search)))
1415 
+     elseif (consp search)
1416 
+       then (case (car search)
1417 
+	      (and (if* (null (cdr search))
1418 
+		      then (bss-int :all str)
1419 
+		    elseif (null (cddr search))
1420 
+		      then (bss-int (cadr search) str)
1421 
+		      else (and-ify (cdr search)  str)))
1422 
+	      (or  (if* (null (cdr search))
1423 
+		      then (bss-int :all str)
1424 
+		    elseif (null (cddr search))
1425 
+		      then (bss-int (cadr search) str)
1426 
+		      else (or-ify (cdr search)  str)))
1427 
+	      (not (if* (not (eql (length search) 2))
1428 
+		      then (po-error :syntax-error
1429 
+				     :format-control "not takes one argument: ~s"
1430 
+				     :format-arguments (list search)))
1431 
+		   (format str "not (" )
1432 
+		   (bss-int (cadr search) str)
1433 
+		   (format str ")"))
1434 
+	      (:seq
1435 
+	       (set-ify (list search) str))
1436 
+	      (t (let (arginfo)
1437 
+		   (if* (and (symbolp (car search))
1438 
+			     (setq arginfo (get (car search)
1439 
+						'imap-search-args)))
1440 
+		      then
1441 
+			   (format str "~a" (string-upcase
1442 
+					     (string (car search))))
1443 
+			   (if* (not (equal (length (cdr search))
1444 
+					    (length arginfo)))
1445 
+			      then (po-error :syntax-error
1446 
+					     :format-control "wrong number of arguments to ~s"
1447 
+					     :format-arguments search))
1448 
+
1449 
+			   (arg-process str (cdr search) arginfo)
1450 
+
1451 
+		    elseif (integerp (car search))
1452 
+		      then (set-ify search str)
1453 
+		      else (po-error :syntax-error
1454 
+				     :format-control "Illegal form ~s in search string"
1455 
+				     :format-arguments (list search))))))
1456 
+     elseif (integerp search)
1457 
+       then ;  a message number
1458 
+	    (format str "~s" search)
1459 
+       else (po-error :syntax-error
1460 
+		      :format-control "Illegal form ~s in search string"
1461 
+		      :format-arguments (list search)))))
1462 
+
1463 
+
1464 
+
1465 
+
1466 
+
1467 
+(defun parse-mail-header (text)
1468 
+  ;; given the partial text of a mail message that includes
1469 
+  ;; at least the header part, return an assoc list of
1470 
+  ;; (header . content)  items
1471 
+  ;; Note that the header is string with most likely mixed case names
1472 
+  ;; as it's conventional to capitalize header names.
1473 
+  (let ((next 0)
1474 
+	(end (length text))
1475 
+	header
1476 
+	value
1477 
+	kind
1478 
+	headers)
1479 
+    (labels ((next-header-line ()
1480 
+	       ;; find the next header line return
1481 
+	       ;; :eof - no more
1482 
+	       ;; :start - beginning of header value, header and
1483 
+	       ;;	         value set
1484 
+	       ;; :continue - continuation of previous header line
1485 
+
1486 
+
1487 
+	       (let ((state 1)
1488 
+		     beginv  ; charpos beginning value
1489 
+		     beginh  ; charpos beginning header
1490 
+		     ch
1491 
+		     )
1492 
+		 (tagbody again
1493 
+
1494 
+		   (return-from next-header-line
1495 
+
1496 
+		     (loop  ; for each character
1497 
+
1498 
+		       (if* (>= next end)
1499 
+			  then (return :eof))
1500 
+
1501 
+		       (setq ch (char text next))
1502 
+		       (if* (eq ch #\return)
1503 
+			  thenret  ; ignore return, (handle following linefeed)
1504 
+			  else (case state
1505 
+				 (1 ; no characters seen
1506 
+				  (if* (eq ch #\linefeed)
1507 
+				     then (incf next)
1508 
+					  (return :eof)
1509 
+				   elseif (member ch
1510 
+						  '(#\space
1511 
+						    #\tab))
1512 
+				     then ; continuation
1513 
+					  (setq state 2)
1514 
+				     else (setq beginh next)
1515 
+					  (setq state 3)
1516 
+					  ))
1517 
+				 (2 ; looking for first non blank in value
1518 
+				  (if* (eq ch #\linefeed)
1519 
+				     then ; empty continuation line, ignore
1520 
+					  (incf next)
1521 
+					  (if* header
1522 
+					     then ; header and no value
1523 
+						  (setq value "")
1524 
+						  (return :start))
1525 
+					  (setq state 1)
1526 
+					  (go again)
1527 
+				   elseif (not (member ch
1528 
+						       (member ch
1529 
+							       '(#\space
1530 
+								 #\tab))))
1531 
+				     then ; begin value part
1532 
+					  (setq beginv next)
1533 
+					  (setq state 4)))
1534 
+				 (3 ; reading the header
1535 
+				  (if* (eq ch #\linefeed)
1536 
+				     then ; bogus header line, ignore
1537 
+					  (setq state 1)
1538 
+					  (go again)
1539 
+				   elseif (eq ch #\:)
1540 
+				     then (setq header
1541 
+					    (subseq text beginh next))
1542 
+					  (setq state 2)))
1543 
+				 (4 ; looking for the end of the value
1544 
+				  (if* (eq ch #\linefeed)
1545 
+				     then (setq value
1546 
+					    (subseq text beginv
1547 
+						    (if* (eq #\return
1548 
+							     (char text
1549 
+								   (1- next)))
1550 
+						       then (1- next)
1551 
+						       else next)))
1552 
+					  (incf next)
1553 
+					  (return (if* header
1554 
+						     then :start
1555 
+						     else :continue))))))
1556 
+		       (incf next)))))))
1557 
+
1558 
+
1559 
+
1560 
+      (loop ; for each header line
1561 
+	(setq header nil)
1562 
+	(if* (eq :eof (setq kind (next-header-line)))
1563 
+	   then (return))
1564 
+	(case kind
1565 
+	  (:start (push (cons header value) headers))
1566 
+	  (:continue
1567 
+	   (if* headers
1568 
+	      then ; append to previous one
1569 
+		   (setf (cdr (car headers))
1570 
+		     (concatenate 'string (cdr (car headers))
1571 
+				  " "
1572 
+				  value)))))))
1573 
+    (values headers
1574 
+	    (subseq text next end))))
1575 
+
1576 
+
1577 
+(defun make-envelope-from-text (text)
1578 
+  ;; given at least the headers part of a message return
1579 
+  ;; an envelope structure containing the contents
1580 
+  ;; This is useful for parsing the headers of things returned by
1581 
+  ;; a pop server
1582 
+  ;;
1583 
+  (let ((headers (parse-mail-header text)))
1584 
+
1585 
+    (make-envelope
1586 
+     :date     (cdr (assoc "date" headers :test #'equalp))
1587 
+     :subject  (cdr (assoc "subject" headers :test #'equalp))
1588 
+     :from     (cdr (assoc "from" headers :test #'equalp))
1589 
+     :sender   (cdr (assoc "sender" headers :test #'equalp))
1590 
+     :reply-to (cdr (assoc "reply-to" headers :test #'equalp))
1591 
+     :to       (cdr (assoc "to" headers :test #'equalp))
1592 
+     :cc       (cdr (assoc "cc" headers :test #'equalp))
1593 
+     :bcc      (cdr (assoc "bcc" headers :test #'equalp))
1594 
+     :in-reply-to (cdr (assoc "in-reply-to" headers :test #'equalp))
1595 
+     :message-id (cdr (assoc "message-id" headers :test #'equalp))
1596 
+     )))
1597 
+
1598 
+
1599 
+
1600 
+
1601 
+
1602 
+
1603 
+
1604 
+
1605 
+
1606 
+
1607 
+(defmethod get-and-parse-from-imap-server ((mb imap-mailbox))
1608 
+  ;; read the next line and parse it
1609 
+  ;;
1610 
+  ;;
1611 
+  (multiple-value-bind (line count)
1612 
+      (get-line-from-server mb)
1613 
+    (if* *debug-imap*
1614 
+       then (format t "from server: ")
1615 
+	    (dotimes (i count)(write-char (schar line i)))
1616 
+	    (terpri)
1617 
+	    (force-output))
1618 
+
1619 
+    (parse-imap-response line count)
1620 
+    ))
1621 
+
1622 
+
1623 
+
1624 
+(defmethod get-and-parse-from-pop-server ((mb pop-mailbox))
1625 
+  ;; read the next line from the pop server
1626 
+  ;;
1627 
+  ;; return 3 values:
1628 
+  ;;   :ok or :error
1629 
+  ;;   a list of rest of the tokens on the line
1630 
+  ;;   the whole line after the +ok or -err
1631 
+
1632 
+  (multiple-value-bind (line count)
1633 
+      (get-line-from-server mb)
1634 
+
1635 
+    (if* *debug-imap*
1636 
+       then (format t "from server: " count)
1637 
+	    (dotimes (i count)(write-char (schar line i)))
1638 
+	    (terpri))
1639 
+
1640 
+    (parse-pop-response line count)))
1641 
+
1642 
+
1643 
+
1644 
+;; Parse and return the data from each line
1645 
+;; values returned
1646 
+;;  tag -- either a string or the symbol :untagged
1647 
+;;  command -- a keyword symbol naming the command, like :ok
1648 
+;;  count -- a number which preceeded the command, or nil if
1649 
+;;	     there wasn't a command
1650 
+;;  bracketted - a list of objects found in []'s after the command
1651 
+;;            or in ()'s after the command  or sometimes just
1652 
+;;	      out in the open after the command (like the search)
1653 
+;;  comment  -- the whole of the part after the command
1654 
+;;
1655 
+(defun parse-imap-response (line end)
1656 
+  (let (kind value next
1657 
+	tag count command extra-data
1658 
+	comment)
1659 
+
1660 
+    ;; get tag
1661 
+    (multiple-value-setq (kind value next)
1662 
+      (get-next-token line 0 end))
1663 
+
1664 
+    (case kind
1665 
+      (:string (setq tag (if* (equal value "*")
1666 
+			    then :untagged
1667 
+			    else value)))
1668 
+      (t (po-error :unexpected
1669 
+		   :format-control "Illegal tag on response: ~s"
1670 
+		   :format-arguments (list (subseq line 0 count))
1671 
+		   :server-string (subseq line 0 end)
1672 
+		   )))
1673 
+
1674 
+    ;; get command
1675 
+    (multiple-value-setq (kind value next)
1676 
+      (get-next-token line next end))
1677 
+
1678 
+    (tagbody again
1679 
+      (case kind
1680 
+	(:number (setq count value)
1681 
+		 (multiple-value-setq (kind value next)
1682 
+		   (get-next-token line next end))
1683 
+		 (go again))
1684 
+	(:string (setq command (kwd-intern value)))
1685 
+	(t (po-error :unexpected
1686 
+		     :format-control "Illegal command on response: ~s"
1687 
+		     :format-arguments (list (subseq line 0 count))
1688 
+		     :server-string (subseq line 0 end)))))
1689 
+
1690 
+    (setq comment (subseq line next end))
1691 
+
1692 
+    ;; now the part after the command... this gets tricky
1693 
+    (loop
1694 
+      (multiple-value-setq (kind value next)
1695 
+	(get-next-token line next end))
1696 
+
1697 
+      (case kind
1698 
+	((:lbracket :lparen)
1699 
+	 (multiple-value-setq (kind value next)
1700 
+	   (get-next-sexpr line (1- next) end))
1701 
+	 (case kind
1702 
+	   (:sexpr (push value extra-data))
1703 
+	   (t (po-error :syntax-error :format-control "bad sexpr form"))))
1704 
+	(:eof (return nil))
1705 
+	((:number :string :nil) (push value extra-data))
1706 
+	(t  ; should never happen
1707 
+	 (return)))
1708 
+
1709 
+      (if* (not (member command '(:list :search) :test #'eq))
1710 
+	 then ; only one item returned
1711 
+	      (setq extra-data (car extra-data))
1712 
+	      (return)))
1713 
+
1714 
+    (if* (member command '(:list :search) :test #'eq)
1715 
+       then (setq extra-data (nreverse extra-data)))
1716 
+
1717 
+
1718 
+    (values tag command count extra-data comment)))
1719 
+
1720 
+
1721 
+
1722 
+(defun get-next-sexpr (line start end)
1723 
+  ;; read a whole s-expression
1724 
+  ;; return 3 values
1725 
+  ;;   kind -- :sexpr  or :rparen or :rbracket
1726 
+  ;;   value - the sexpr value
1727 
+  ;;   next  - next charpos to scan
1728 
+  ;;
1729 
+  (let ( kind value next)
1730 
+    (multiple-value-setq (kind value next) (get-next-token line start end))
1731 
+
1732 
+    (case kind
1733 
+      ((:string :number :nil)
1734 
+       (values :sexpr value next))
1735 
+      (:eof (po-error :syntax-error
1736 
+		      :format-control "eof inside sexpr"))
1737 
+      ((:lbracket :lparen)
1738 
+       (let (res)
1739 
+	 (loop
1740 
+	   (multiple-value-setq (kind value next)
1741 
+	     (get-next-sexpr line next end))
1742 
+	   (case kind
1743 
+	     (:sexpr (push value res))
1744 
+	     ((:rparen :rbracket)
1745 
+	      (return (values :sexpr (nreverse res) next)))
1746 
+	     (t (po-error :syntax-error
1747 
+			  :format-control "bad sexpression"))))))
1748 
+      ((:rbracket :rparen)
1749 
+       (values kind nil next))
1750 
+      (t (po-error :syntax-error
1751 
+		   :format-control "bad sexpression")))))
1752 
+
1753 
+
1754 
+(defun parse-pop-response (line end)
1755 
+  ;; return 3 values:
1756 
+  ;;   :ok or :error
1757 
+  ;;   a list of rest of the tokens on the line, the tokens
1758 
+  ;;	 being either strings or integers
1759 
+  ;;   the whole line after the +ok or -err
1760 
+  ;;
1761 
+  (let (res lineres result)
1762 
+    (multiple-value-bind (kind value next)
1763 
+	(get-next-token line 0 end)
1764 
+
1765 
+      (case kind
1766 
+	(:string (setq result (if* (equal "+OK" value)
1767 
+				 then :ok
1768 
+				 else :error)))
1769 
+	(t (po-error :unexpected
1770 
+		     :format-control "bad response from server"
1771 
+		     :server-string (subseq line 0 end))))
1772 
+
1773 
+      (setq lineres (subseq line next end))
1774 
+
1775 
+      (loop
1776 
+	(multiple-value-setq (kind value next)
1777 
+	  (get-next-token line next end))
1778 
+
1779 
+	(case kind
1780 
+	  (:eof (return))
1781 
+	  ((:string :number) (push value res))))
1782 
+
1783 
+      (values result (nreverse res) lineres))))
1784 
+
1785 
+
1786 
+
1787 
+
1788 
+
1789 
+
1790 
+
1791 
+
1792 
+
1793 
+
1794 
+(defparameter *char-to-kind*
1795 
+    (let ((arr (make-array 256 :initial-element nil)))
1796 
+
1797 
+      (do ((i #.(char-code #\0) (1+ i)))
1798 
+	  ((> i #.(char-code #\9)))
1799 
+	(setf (aref arr i) :number))
1800 
+
1801 
+      (setf (aref arr #.(char-code #\space)) :space)
1802 
+      (setf (aref arr #.(char-code #\tab)) :space)
1803 
+      (setf (aref arr #.(char-code #\return)) :space)
1804 
+      (setf (aref arr #.(char-code #\linefeed)) :space)
1805 
+
1806 
+      (setf (aref arr #.(char-code #\[)) :lbracket)
1807 
+      (setf (aref arr #.(char-code #\])) :rbracket)
1808 
+      (setf (aref arr #.(char-code #\()) :lparen)
1809 
+      (setf (aref arr #.(char-code #\))) :rparen)
1810 
+      (setf (aref arr #.(char-code #\")) :dquote)
1811 
+
1812 
+      (setf (aref arr #.(char-code #\^b)) :big-string) ; our own invention
1813 
+
1814 
+      arr))
1815 
+
1816 
+
1817 
+(defun get-next-token (line start end)
1818 
+  ;; scan past whitespace for the next token
1819 
+  ;; return three values:
1820 
+  ;;  kind:  :string , :number, :eof, :lbracket, :rbracket,
1821 
+  ;;		:lparen, :rparen
1822 
+  ;;  value:  the value, either a string or number or nil
1823 
+  ;;  next:   the character pos to start scanning for the next token
1824 
+  ;;
1825 
+  (let (ch chkind colstart (count 0) (state :looking)
1826 
+	collector right-bracket-is-normal)
1827 
+    (loop
1828 
+      ; pick up the next character
1829 
+      (if* (>= start end)
1830 
+	 then (if* (eq state :looking)
1831 
+		 then (return (values :eof nil start))
1832 
+		 else (setq ch #\space))
1833 
+	 else (setq ch (schar line start)))
1834 
+
1835 
+      (setq chkind (aref *char-to-kind* (char-code ch)))
1836 
+
1837 
+      (case state
1838 
+	(:looking
1839 
+	 (case chkind
1840 
+	   (:space nil)
1841 
+	   (:number (setq state :number)
1842 
+		    (setq colstart start)
1843 
+		    (setq count (- (char-code ch) #.(char-code #\0))))
1844 
+	   ((:lbracket :lparen :rbracket :rparen)
1845 
+	    (return (values chkind nil (1+ start))))
1846 
+	   (:dquote
1847 
+	    (setq collector (make-array 10
1848 
+					:element-type 'character
1849 
+					:adjustable t
1850 
+					:fill-pointer 0))
1851 
+	    (setq state :qstring))
1852 
+	   (:big-string
1853 
+	    (setq colstart (1+ start))
1854 
+	    (setq state :big-string))
1855 
+	   (t (setq colstart start)
1856 
+	      (setq state :literal))))
1857 
+	(:number
1858 
+	 (case chkind
1859 
+	   ((:space :lbracket :lparen :rbracket :rparen
1860 
+	     :dquote) ; end of number
1861 
+	    (return (values :number count  start)))
1862 
+	   (:number ; more number
1863 
+	    (setq count (+ (* count 10)
1864 
+			   (- (char-code ch) #.(char-code #\0)))))
1865 
+	   (t ; turn into an literal
1866 
+	    (setq state :literal))))
1867 
+	(:literal
1868 
+	 (case chkind
1869 
+	   ((:space :rbracket :lparen :rparen :dquote) ; end of literal
1870 
+	    (if* (and (eq chkind :rbracket)
1871 
+		      right-bracket-is-normal)
1872 
+	       then nil ; don't stop now
1873 
+	       else (let ((seq (subseq line colstart start)))
1874 
+		      (if* (equal "NIL" seq)
1875 
+			 then (return (values :nil
1876 
+					      nil
1877 
+					      start))
1878 
+			 else (return (values :string
1879 
+					      seq
1880 
+					      start))))))
1881 
+	   (t (if* (eq chkind :lbracket)
1882 
+		 then ; imbedded left bracket so right bracket isn't
1883 
+		      ; a break char
1884 
+		      (setq right-bracket-is-normal t))
1885 
+	      nil)))
1886 
+	(:qstring
1887 
+	 ;; quoted string
1888 
+	 ; (format t "start is ~s  kind is ~s~%" start chkind)
1889 
+	 (case chkind
1890 
+	   (:dquote
1891 
+	    ;; end of string
1892 
+	    (return (values :string collector (1+ start))))
1893 
+	   (t (if* (eq ch #\\)
1894 
+		 then ; escaping the next character
1895 
+		      (incf start)
1896 
+		      (if* (>= start end)
1897 
+			 then (po-error :unexpected
1898 
+					:format-control "eof in string returned"))
1899 
+		      (setq ch (schar line start)))
1900 
+	      (vector-push-extend ch collector)
1901 
+
1902 
+	      (if* (>= start end)
1903 
+		 then ; we overran the end of the input
1904 
+		      (po-error :unexpected
1905 
+				:format-control "eof in string returned")))))
1906 
+	(:big-string
1907 
+	 ;; super string... just a block of data
1908 
+	 ; (format t "start is ~s  kind is ~s~%" start chkind)
1909 
+	 (case chkind
1910 
+	   (:big-string
1911 
+	    ;; end of string
1912 
+	    (return (values :string
1913 
+			    (subseq line colstart start)
1914 
+			    (1+ start))))
1915 
+	   (t nil)))
1916 
+
1917 
+
1918 
+	)
1919 
+
1920 
+      (incf start))))
1921 
+
1922 
+
1923 
+
1924 
+;  this used to be exported from the excl package
1925 
+#+(version>= 6 0)
1926 
+(defvar *keyword-package* (find-package :keyword))
1927 
+
1928 
+(defun kwd-intern-possible-list (form)
1929 
+  (if* (null form)
1930 
+     then nil
1931 
+   elseif (atom form)
1932 
+     then (kwd-intern form)
1933 
+     else (mapcar #'kwd-intern-possible-list form)))
1934 
+
1935 
+
1936 
+(defun kwd-intern (string)
1937 
+  ;; convert the string to the current preferred case
1938 
+  ;; and then intern
1939 
+  (intern (case excl::*current-case-mode*
1940 
+	    ((:case-sensitive-lower
1941 
+	      :case-insensitive-lower) (string-downcase string))
1942 
+	    (t (string-upcase string)))
1943 
+	  *keyword-package*))
1944 
+
1945 
+
1946 
+
1947 
+
1948 
+
1949 
+
1950 
+
1951 
+
1952 
+
1953 
+
1954 
+
1955 
+
1956 
+
1957 
+
1958 
+;; low level i/o to server
1959 
+
1960 
+(defun get-line-from-server (mailbox)
1961 
+  ;; Return two values:  a buffer and a character count.
1962 
+  ;; The character count includes up to but excluding the cr lf that
1963 
+  ;;  was read from the socket.
1964 
+  ;;
1965 
+  (let* ((buff (get-line-buffer 0))
1966 
+	 (len  (length buff))
1967 
+	 (i 0)
1968 
+	 (p (post-office-socket mailbox))
1969 
+	 (ch nil)
1970 
+	 (whole-count)
1971 
+	 )
1972 
+
1973 
+    (handler-case
1974 
+	(flet ((grow-buffer (size)
1975 
+		 (let ((newbuff (get-line-buffer size)))
1976 
+		   (dotimes (j i)
1977 
+		     (setf (schar newbuff j) (schar buff j)))
1978 
+		   (free-line-buffer buff)
1979 
+		   (setq buff newbuff)
1980 
+		   (setq len (length buff)))))
1981 
+
1982 
+	  ;; increase the buffer to at least size
1983 
+	  ;; this is somewhat complex to ensure that we aren't doing
1984 
+	  ;; buffer allocation within the with-timeout form, since
1985 
+	  ;; that could trigger a gc which could then cause the
1986 
+	  ;; with-timeout form to expire.
1987 
+	  (loop
1988 
+
1989 
+	    (if* whole-count
1990 
+	       then ; we should now read in this may bytes and
1991 
+		    ; append it to this buffer
1992 
+		    (multiple-value-bind (ans this-count)
1993 
+			(get-block-of-data-from-server mailbox whole-count)
1994 
+		      ; now put this data in the current buffer
1995 
+		      (if* (> (+ i whole-count 5) len)
1996 
+			 then  ; grow the initial buffer
1997 
+			      (grow-buffer (+ i whole-count 100)))
1998 
+
1999 
+		      (dotimes (ind this-count)
2000 
+			(setf (schar buff i) (schar ans ind))
2001 
+			(incf i))
2002 
+		      (setf (schar buff i) #\^b) ; end of inset string
2003 
+		      (incf i)
2004 
+		      (free-line-buffer ans)
2005 
+		      (setq whole-count nil)
2006 
+		      )
2007 
+	     elseif ch
2008 
+	       then ; we're growing the buffer holding the line data
2009 
+		    (grow-buffer (+ len 200))
2010 
+		    (setf (schar buff i) ch)
2011 
+		    (incf i))
2012 
+
2013 
+
2014 
+	    (block timeout
2015 
+	      (mp:with-timeout ((timeout mailbox)
2016 
+				(po-error :timeout
2017 
+					  :format-control "imap server failed to respond"))
2018 
+		;; read up to lf  (lf most likely preceeded by cr)
2019 
+		(loop
2020 
+		  (setq ch (read-char p))
2021 
+		  (if* (eq #\linefeed ch)
2022 
+		     then ; end of line. Don't save the return
2023 
+			  (if* (and (> i 0)
2024 
+				    (eq (schar buff (1- i)) #\return))
2025 
+			     then ; remove #\return, replace with newline
2026 
+				  (decf i)
2027 
+				  (setf (schar buff i) #\newline)
2028 
+				  )
2029 
+			  ;; must check for an extended return value which
2030 
+			  ;; is indicated by a {nnn} at the end of the line
2031 
+			  (block count-check
2032 
+			    (let ((ind (1- i)))
2033 
+			      (if* (and (>= i 0) (eq (schar buff ind) #\}))
2034 
+				 then (let ((count 0)
2035 
+					    (mult 1))
2036 
+					(loop
2037 
+					  (decf ind)
2038 
+					  (if* (< ind 0)
2039 
+					     then ; no of the form {nnn}
2040 
+						  (return-from count-check))
2041 
+					  (setf ch (schar buff ind))
2042 
+					  (if* (eq ch #\{)
2043 
+					     then ; must now read that many bytes
2044 
+						  (setf (schar buff ind) #\^b)
2045 
+						  (setq whole-count count)
2046 
+						  (setq i (1+ ind))
2047 
+						  (return-from timeout)
2048 
+					   elseif (<= #.(char-code #\0)
2049 
+						      (char-code ch)
2050 
+						      #.(char-code #\9))
2051 
+					     then ; is a digit
2052 
+						  (setq count
2053 
+						    (+ count
2054 
+						       (* mult
2055 
+							  (- (char-code ch)
2056 
+							     #.(char-code #\0)))))
2057 
+						  (setq mult (* 10 mult))
2058 
+					     else ; invalid form, get out
2059 
+						  (return-from count-check)))))))
2060 
+
2061 
+
2062 
+			  (return-from get-line-from-server
2063 
+			    (values buff i))
2064 
+		     else ; save character
2065 
+			  (if* (>= i len)
2066 
+			     then ; need bigger buffer
2067 
+				  (return))
2068 
+			  (setf (schar buff i) ch)
2069 
+			  (incf i)))))))
2070 
+      (error (con)
2071 
+	;; most likely error is that the server went away
2072 
+	(ignore-errors (close p))
2073 
+	(po-error :server-shutdown-connection
2074 
+		  :format-control "condition  signalled: ~a~%most likely server shut down the connection."
2075 
+		  :format-arguments (list con)))
2076 
+      )))
2077 
+
2078 
+
2079 
+(defun get-block-of-data-from-server  (mb count &key save-returns)
2080 
+  ;; read count bytes from the server returning it in a line buffer object
2081 
+  ;; return as a second value the number of characters saved
2082 
+  ;; (we drop #\return's so that lines are separated by a #\newline
2083 
+  ;; like lisp likes).
2084 
+  ;;
2085 
+  (let ((buff (get-line-buffer count))
2086 
+	(p (post-office-socket mb))
2087 
+	(ind 0))
2088 
+    (mp:with-timeout ((timeout mb)
2089 
+		      (po-error :timeout
2090 
+				:format-control "imap server timed out"))
2091 
+
2092 
+      (dotimes (i count)
2093 
+	(if* (eq #\return (setf (schar buff ind) (read-char p)))
2094 
+	   then (if* save-returns then (incf ind)) ; drop #\returns
2095 
+	   else (incf ind)))
2096 
+
2097 
+
2098 
+      (values buff ind))))
2099 
+
2100 
+
2101 
+;;-- reusable line buffers
2102 
+
2103 
+(defvar *line-buffers* nil)
2104 
+
2105 
+#+(version>= 8 1)
2106 
+(defvar *line-buffers-lock* (make-basic-lock :name "line-buffers"))
2107 
+
2108 
+(defmacro with-locked-line-buffers (&rest body)
2109 
+#+(version>= 8 1)
2110 
+  `(with-locked-structure (*line-buffers-lock*
2111 
+			   :non-smp :without-scheduling)
2112 
+     ,@body)
2113 
+#-(version>= 8 1)
2114 
+  `(sys::without-scheduling ,@body)
2115 
+  )
2116 
+
2117 
+(defun get-line-buffer (size)
2118 
+  ;; get a buffer of at least size bytes
2119 
+  (setq size (min size (1- array-total-size-limit)))
2120 
+  (let ((found
2121 
+	 (with-locked-line-buffers
2122 
+	   (dolist (buff *line-buffers*)
2123 
+	     (if* (>= (length buff) size)
2124 
+		then ;; use this one
2125 
+		     (setq *line-buffers* (delete buff *line-buffers*))
2126 
+		     (return buff))))))
2127 
+    (or found  (make-string size))))
2128 
+
2129 
+(defun free-line-buffer (buff)
2130 
+  (with-locked-line-buffers
2131 
+    (push buff *line-buffers*)))
2132 
+
2133 
+(defun init-line-buffer (new old)
2134 
+  ;; copy old into new
2135 
+  (declare (optimize (speed 3)))
2136 
+  (dotimes (i (length old))
2137 
+    (declare (fixnum i))
2138 
+    (setf (schar new i) (schar old i))))
2139 
+
2140 
+
2141 
+
2142 
+  ;;;;;;;
2143 
+
2144 
+; date functions
2145 
+
2146 
+(defun universal-time-to-rfc822-date (ut)
2147 
+  ;; convert a lisp universal time to rfc 822 date
2148 
+  ;;
2149 
+  (multiple-value-bind
2150 
+      (sec min hour date month year day-of-week dsp time-zone)
2151 
+      (decode-universal-time ut 0)
2152 
+    (declare (ignore time-zone sec min hour day-of-week dsp time-zone))
2153 
+    (format nil "~d-~a-~d"
2154 
+	    date
2155 
+	    (svref
2156 
+	     '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
2157 
+		"Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
2158 
+	     month
2159 
+	     )
2160 
+	    year)))
2161 
+
2162 
+
2163 
+
2164 
+
2165 
+;; utility
2166 
+
2167 
+(defmacro with-imap-connection ((mb &rest options) &body body)
2168 
+  `(let ((,mb (make-imap-connection ,@options)))
2169 
+     (unwind-protect
2170 
+	 (progn
2171 
+	   ,@body)
2172 
+       (close-connection ,mb))))
2173 
+
2174 
+
2175 
+(defmacro with-pop-connection ((mb &rest options) &body body)
2176 
+  `(let ((,mb (make-pop-connection ,@options)))
2177 
+     (unwind-protect
2178 
+	 (progn
2179 
+	   ,@body)
2180 
+       (close-connection ,mb))))
2181 
+
2182 
+