;; -*- mode: common-lisp; package: net.post-office -*-
 ;;
 ;; imap.cl
 ;; imap and pop interface
 ;;
 ;; copyright (c) 1999-2002 Franz Inc, Berkeley, CA - All rights reserved.

 ;; copyright (c) 2002-2012 Franz Inc, Oakland, CA - All rights reserved.

 ;;
 ;; This code is free software; you can redistribute it and/or
 ;; modify it under the terms of the version 2.1 of

 ;; the GNU Lesser General Public License as published by

 ;; the Free Software Foundation, as clarified by the AllegroServe
 ;; prequel found in license-allegroserve.txt.
 ;;
 ;; This code is distributed in the hope that it will be useful,
 ;; but without any warranty; without even the implied warranty of
 ;; merchantability or fitness for a particular purpose.  See the GNU
 ;; Lesser General Public License for more details.
 ;;
 ;; $Id: imap.cl,v 1.32 2009/03/25 22:46:02 layer Exp $
 
 ;; Description:
 ;;- This code in this file obeys the Lisp Coding Standard found in
 ;;- http://www.franz.com/~jkf/coding_standards.html
 ;;-
 
 
 (defpackage :net.post-office

   (:nicknames #:post-office)
   (:use :cl :excl)

   (:export

    #:address-name
    #:address-additional
    #:address-mailbox
    #:address-host

    #:alter-flags
    #:close-connection
    #:close-mailbox
    #:copy-to-mailbox
    #:create-mailbox
    #:delete-letter
    #:delete-mailbox

    #:envelope-date
    #:envelope-subject
    #:envelope-from
    #:envelope-sender
    #:envelope-reply-to
    #:envelope-to
    #:envelope-cc
    #:envelope-bcc
    #:envelope-in-reply-to
    #:envelope-message-id

    #:expunge-mailbox
    #:fetch-field
    #:fetch-letter
    #:fetch-letter-sequence
    #:end-of-letter-p
    #:with-fetch-letter-sequence
    #:fetch-parts
    #:*imap-version-number*
    #:make-envelope-from-text
    #:mailbox-flags      ; accessor
    #:mailbox-permanent-flags ; acc
    #:mailbox-list
    #:mailbox-list-flags
    #:mailbox-list-separator
    #:mailbox-list-name
    #:mailbox-message-count ; accessor
    #:mailbox-recent-messages ; ac
    #:mailbox-separator  ; accessor
    #:mailbox-uidvalidity
    #:mailbox-uidnext
    #:make-imap-connection
    #:make-pop-connection
    #:with-imap-connection
    #:with-pop-connection
    #:noop
    #:parse-mail-header

    #:top-lines  ; pop only

    #:unique-id  ; pop only

    #:po-condition
    #:po-condition-identifier
    #:po-condition-server-string
    #:po-error

    #:rename-mailbox
    #:reset-mailbox
    #:search-mailbox
    #:select-mailbox

    )
   )
 
 (in-package :net.post-office)
 
 (provide :imap)
 
 (defparameter *imap-version-number* '(:major 1 :minor 14)) ; major.minor
 
 ;; todo
 ;;  have the list of tags selected done on a per connection basis to
 ;;  eliminate any possible multithreading problems
 ;;
 ;;
 
 (defvar *debug-imap* nil)
 
 
 
 
 
 (defclass post-office ()
   ((socket :initarg :socket

            :accessor post-office-socket)

    (host :initarg :host

          :accessor  post-office-host
          :initform nil)

    (user  :initarg :user

           :accessor post-office-user
           :initform nil)

    (state :accessor post-office-state

           :initarg :state
           :initform :unconnected)

 
    (timeout

     ;; time to wait for network activity for actions that should
     ;; happen very quickly when things are operating normally
     :initarg :timeout
     :initform 60

     :accessor timeout)

   ))
 
 (defclass imap-mailbox (post-office)
   ((mailbox-name   ; currently selected mailbox
     :accessor mailbox-name
     :initform nil)
 

    (separator

     ;; string that separates mailbox names in the hierarchy
     :accessor mailbox-separator
     :initform "")

    ;;; these slots hold information about the currently selected mailbox:

     (message-count  ; how many in the mailbox
     :accessor mailbox-message-count
     :initform 0)

    (recent-messages ; how many messages since we last checked
     :accessor mailbox-recent-messages
     :initform 0)

    (uidvalidity  ; used to denote messages uniquely

     :accessor mailbox-uidvalidity

     :initform 0)

 
    (uidnext

     :accessor mailbox-uidnext ;; predicted next uid
     :initform 0)

    (flags       ; list of flags that can be stored in a message

     :accessor mailbox-flags

     :initform nil)

    (permanent-flags  ; list of flags that be stored permanently
     :accessor mailbox-permanent-flags
     :initform nil)

    (first-unseen   ; number of the first unseen message
     :accessor first-unseen
     :initform 0)

    ;;; end list of values for the currently selected mailbox

    ;;; state information for fetch-letter-sequence

    (fetch-letter-offset

     :accessor fetch-letter-offset)

    (fetch-letter-number

     :accessor fetch-letter-number)
    (fetch-letter-uid
     :accessor fetch-letter-uid)
    (fetch-letter-finished
     :accessor fetch-letter-finished)
    )
   )
 
 
 (defclass pop-mailbox (post-office)
   ((message-count  ; how many in the mailbox
     :accessor mailbox-message-count
     :initform 0)

    (fetch-letter-state

     :accessor state
     :initform :invalid)))

 
 
 
 (defstruct (mailbox-list (:type list))
   ;; a list of these are returned by mailbox-list
   flags
   separator
   name)
 
 
 
 (defstruct (envelope (:type list))
   ;; returned by fetch-letter as the value of the envelope property
   date
   subject
   from
   sender
   reply-to
   to
   cc
   bcc
   in-reply-to
   message-id)
 
 
 (defstruct (address (:type list))
   name     ;; often the person's full name
   additional
   mailbox  ;; the login name

   host     ;; the name of the machine

   )
 
 
 
 ;--------------------------------
 ; conditions
 ;
 ; We define a set of conditions that are signalled due to events
 ; in the imap interface.
 ; Each condition has an indentifier which is a keyword.  That can
 ; be used in the handling code to identify the class of error.
 ; All our conditions are po-condition or po-error (which is a subclass of
 ; po-condition).
 ;

 ; A condition will have a server-string value if it as initiated by

 ; something returned by the server.

 ; A condition will have a format-control value if we want to display
 ; something we generated in response to
 ;

 ;
 ;
 ;; identifiers used in conditions/errors
 
 ; :problem  condition

 ;       the server responded with 'no' followed by an explanation.
 ;       this mean that something unusual happend and doesn't necessarily
 ;       mean that the command has completely failed (but it might).

 ;

 ; :unknown-ok   condition

 ;       the server responded with an 'ok' followed by something
 ;       we don't recognize.  It's probably safe to ignore this.

 ;
 ;  :unknown-untagged condition

 ;       the server responded with some untagged command we don't
 ;       recognize.  it's probaby ok to ignore this.

 ;
 ;  :error-response  error

 ;       the command failed.

 ;
 ;  :syntax-error   error

 ;       the data passed to a function in this interface was malformed

 ;
 ;  :unexpected    error

 ;       the server responded an unexpected way.

 ;
 ;  :server-shutdown-connection error

 ;       the server has shut down the connection, don't attempt to

 ;       send any more commands to this connection, or even close it.
 ;
 ;  :timeout  error

 ;       server failed to respond within the timeout period

 ;
 ;  :response-too-large error

 ;       contents of a response is too large to store in a Lisp array.

 
 
 ;; conditions
 (define-condition po-condition ()
   ;; used to notify user of things that shouldn't necessarily stop
   ;; program flow

   ((identifier

     ;; keyword identifying the error (or :unknown)

     :reader po-condition-identifier

     :initform :unknown

     :initarg :identifier)

    (server-string

     ;; message from the imap server
     :reader po-condition-server-string
     :initform ""

     :initarg :server-string)
    (message
     :reader po-condition-message
     :initform ""
     :initarg :message)
    (arguments
     :reader po-condition-arguments
     :initform nil
     :initarg :arguments))
   

   (:report
    (lambda (con stream)
      (with-slots (identifier server-string) con

        ;; a condition either has a server-string or it has a

        ;; format-control string
        (format stream "Post Office condition: ~s~%" identifier)

        (unless (string= (po-condition-message con)
                         "")
          (apply #'format stream
                 (po-condition-message con)
                 (po-condition-arguments con)))
        (when server-string
          (format stream
                  "~&Message from server: ~s"
                  (string-left-trim " " server-string)))))))

 
 
 (define-condition po-error (po-condition error)

   ;; used to denote things that should stop program flow
   ())
 
 
 
 ;; aignalling the conditions
 

 (defun po-condition (identifier &key server-string format-control

                           format-arguments)

   (signal (make-instance 'po-condition

             :identifier identifier
             :server-string server-string

             :message format-control
             :arguments format-arguments)))

 (defun po-error (identifier &key server-string

                       format-control format-arguments)

   (error (make-instance 'po-error

             :identifier identifier
             :server-string server-string

             :message format-control
             :arguments format-arguments)))

 
 ;----------------------------------------------
 
 
 
 
 
 
 (defparameter *imap-tags* '("t01" "t02" "t03" "t04" "t05" "t06" "t07"))
 (defvar *cur-imap-tags* nil)
 
 (defvar *crlf*
     (let ((str (make-string 2)))
       (setf (aref str 0) #\return)
       (setf (aref str 1) #\linefeed)
       str))
 
 ;; returns values: socket starttls
 ;; server is a cons of the form:
 ;; (server-name &key (port 25) (ssl nil) (starttls nil) ...ssl-client-keywords...)
 (defun connect-to-imap/pop-server (server-info server-type)
   (macrolet ((pop-keyword (k l) `(prog1 (getf ,l ,k) (remf ,l ,k)))

              (server-port (ssl type) `(cond ((eq ,type :imap) (if ,ssl 993 143))
                                             ((eq ,type :pop) (if ,ssl 995 110)))))

     (let* ((server (car server-info))

            (ssl-args (cdr server-info))
            ssl port starttls sock)

       (setq ssl (pop-keyword :ssl ssl-args))

       (setq port (or (pop-keyword :port ssl-args)
                      (server-port ssl server-type)))

       (setq starttls (pop-keyword :starttls ssl-args))
       (setq sock (socket:make-socket :remote-host server

                                      :remote-port port))

       (when ssl

         (setq sock (apply #'cl+ssl:make-ssl-client-stream
                           sock
                           :external-format :iso-8859-1
                           ssl-args)))

       (values sock starttls))) )
 

 (defun make-imap-connection (host &key (port 143)

                                        user
                                        password
                                        (timeout 30))

   (multiple-value-bind (sock starttls)
       (if (consp host)

           (connect-to-imap/pop-server host :imap)
         (socket:make-socket :remote-host host :remote-port port))

     (let ((imap (make-instance 'imap-mailbox

                   :socket sock
                   :host   host
                   :timeout timeout
                   :state :unauthorized)))

     (multiple-value-bind (tag cmd count extra comment)

         (get-and-parse-from-imap-server imap)

       (declare (ignorable cmd count extra))
       (if* (not (eq :untagged tag))

          then  (po-error :error-response
                          :server-string comment)))

     ; check for starttls negotiation
     (when starttls
       (let (capabilities)

         (send-command-get-results
          imap "CAPABILITY"
          #'(lambda (mb cmd count extra comment)
              (declare (ignorable mb cmd count extra))
              (setq capabilities comment))
          #'(lambda (mb cmd count extra comment)
              (check-for-success mb cmd count extra comment
                                 "CAPABILITY")))
         (when (and capabilities (match-re "STARTTLS" capabilities :case-fold t
                                           :return nil))
           ;; negotiate starttls
           (send-command-get-results imap "STARTTLS"
                                     #'handle-untagged-response
                                     #'(lambda (mb cmd count extra comment)
                                         (check-for-success mb cmd count extra comment
                                                            "STARTTLS")
                                         (setf (post-office-socket mb)
                                           (socket:make-ssl-client-stream
                                            (post-office-socket mb) :method :tlsv1)))))))

 
     ; now login

     (send-command-get-results imap

                               (format nil "login ~a ~a" user password)
                               #'handle-untagged-response
                               #'(lambda (mb command count extra comment)
                                   (check-for-success mb command count extra
                                                      comment
                                                      "login")))

     ; find the separator character
     (let ((res (mailbox-list imap)))

       ;;

       (let ((sep (cadr  (car res))))

         (if* sep
            then (setf (mailbox-separator imap) sep))))

     imap)))
 
 
 (defmethod close-connection ((mb imap-mailbox))

   (let ((sock (post-office-socket mb)))
     (if* sock
        then (ignore-errors

              (send-command-get-results
               mb
               "logout"
               ; don't want to get confused by untagged
               ; bye command, which is expected here
               #'(lambda (mb command count extra)
                   (declare (ignore mb command count extra))
                   nil)
               #'(lambda (mb command count extra comment)
                   (check-for-success mb command count extra
                                      comment
                                      "logout")))))

     (setf (post-office-socket mb) nil)
     (if* sock then (ignore-errors (close sock)))
     t))
 
 
 (defmethod close-connection ((pb pop-mailbox))
   (let ((sock (post-office-socket pb)))
     (if* sock
        then (ignore-errors

              (send-pop-command-get-results
               pb
               "QUIT")))

     (setf (post-office-socket pb) nil)
     (if* sock then (ignore-errors (close sock)))
     t))
 
 
 
 (defun make-pop-connection (host &key (port 110)

                                       user
                                       password
                                       (timeout 30))

   (multiple-value-bind (sock starttls)
       (if (consp host)

           (connect-to-imap/pop-server host :pop)
         (socket:make-socket :remote-host host :remote-port port))

     (let ((pop (make-instance 'pop-mailbox

                 :socket sock
                 :host   host
                 :timeout timeout
                 :state :unauthorized)))

     (multiple-value-bind (result)

         (get-and-parse-from-pop-server pop)

       (if* (not (eq :ok result))

          then  (po-error :error-response
                          :format-control
                          "unexpected line from server after connect")))

     ; check for starttls negotiation
     (when starttls
       (let ((capabilities (send-pop-command-get-results pop "capa" t)))

         (when (and capabilities (match-re "STLS" capabilities :case-fold t
                                           :return nil))
           (send-pop-command-get-results pop "STLS")
           (setf (post-office-socket pop) (socket:make-ssl-client-stream
                                           (post-office-socket pop) :method :tlsv1)))))

     ; now login
     (send-pop-command-get-results pop (format nil "user ~a" user))
     (send-pop-command-get-results pop (format nil "pass ~a" password))
 
     (let ((res (send-pop-command-get-results pop "stat")))
       (setf (mailbox-message-count pop) (car res)))

     pop)))
 

 
 (defmethod send-command-get-results ((mb imap-mailbox)

                                      command untagged-handler tagged-handler)

   ;; send a command and retrieve results until we get the tagged
   ;; response for the command we sent
   ;;
   (let ((tag (get-next-tag)))
     (format (post-office-socket mb)

             "~a ~a~a" tag command *crlf*)

     (force-output (post-office-socket mb))

     (when *debug-imap*
       (format t
               "~a ~a~a" tag command *crlf*)
       (force-output))
     

     (loop

        (multiple-value-bind (got-tag cmd count extra comment)
            (get-and-parse-from-imap-server mb)
          (if* (eq got-tag :untagged)
             then (funcall untagged-handler mb cmd count extra comment)
           elseif (equal tag got-tag)
             then (funcall tagged-handler mb cmd count extra comment)
                  (return)
             else (po-error :error-response
                            :format-control "received tag ~s out of order"
                            :format-arguments (list got-tag)
                            :server-string comment))))))

 
 
 (defun get-next-tag ()
   (let ((tag (pop *cur-imap-tags*)))
     (if*  tag
        thenret
        else (setq *cur-imap-tags* *imap-tags*)

             (pop *cur-imap-tags*))))

 
 (defun handle-untagged-response (mb command count extra comment)

   ;; default function to handle untagged responses, which are

   ;; really just returning general state information about
   ;; the mailbox
   (case command
     (:exists (setf (mailbox-message-count mb) count))
     (:recent (setf (mailbox-recent-messages mb) count))
     (:flags  (setf (mailbox-flags mb) (kwd-intern-possible-list extra)))
     (:bye ; occurs when connection times out or mailbox lock is stolen
      (ignore-errors (close (post-office-socket mb)))
      (po-error :server-shutdown-connection

                  :server-string "server shut down the connection"))

     (:no ; used when grabbing a lock from another process
      (po-condition :problem :server-string comment))
     (:ok ; a whole variety of things
      (if* extra

         then (if* (equalp (car extra) "unseen")
                 then (setf (first-unseen mb) (cadr extra))
               elseif (equalp (car extra) "uidvalidity")
                 then (setf (mailbox-uidvalidity mb) (cadr extra))
               elseif (equalp (car extra) "uidnext")
                 then (setf (mailbox-uidnext mb) (cadr extra))
               elseif (equalp (car extra) "permanentflags")
                 then (setf (mailbox-permanent-flags mb)
                        (kwd-intern-possible-list (cadr extra)))
                 else (po-condition :unknown-ok :server-string comment))))

     (t (po-condition :unknown-untagged :server-string comment)))

   )
 
 
 (defmethod begin-extended-results-sequence ((mb pop-mailbox))
   (setf (state mb) 1))
 
 (defmethod get-extended-results-sequence ((mb pop-mailbox) buffer &key (start 0) (end (length buffer)))
   (declare (optimize (speed 3) (safety 1)))
   (let ((inpos start)

         (outpos start)
         (sock (post-office-socket mb))
         ch
         stop)

     (macrolet ((add-to-buffer ()

                  `(progn
                     (setf (schar buffer outpos) ch)
                     (incf outpos))))

       (while (and (< inpos end) (/= (state mb) 4))

         (setf stop (read-sequence buffer sock :start inpos :end end :partial-fill t))
         (while (< inpos stop)
           (setf ch (schar buffer inpos))
           (if* (eq ch #\return)
              thenret                    ; ignore crs
              else (ecase (state mb)
                     (1 (if* (eq ch #\.) ; at beginning of line
                           then (setf (state mb) 2)
                         elseif (eq ch #\linefeed)
                           then
                                (add-to-buffer) ; state stays at 1
                           else
                                (setf (state mb) 3)
                                (add-to-buffer)))
                     (2                  ; seen first dot
                      (if* (eq ch #\linefeed)
                         then            ; end of results
                              (setf (state mb) 4)
                              (return)
                         else
                              (setf (state mb) 3)
                              (add-to-buffer))) ; normal reading
                     (3                  ; middle of line
                      (if* (eq ch #\linefeed)
                         then (setf (state mb) 1))
                      (add-to-buffer))))
           (incf inpos))
         (setf inpos outpos))

       outpos)))
 
 (defmacro end-of-extended-results-p (mb)
   `(= (state ,mb) 4))
 
 (defmethod end-extended-results-sequence ((mb pop-mailbox))
   (declare (optimize (speed 3) (safety 1)))
   (let ((buffer (make-string 4096)))
     (until (end-of-extended-results-p mb)
       (get-extended-results-sequence mb buffer)))
   (setf (state mb) :invalid-state)
   t)
 
 (defmacro with-extended-results-sequence ((mailbox) &body body)
   (let ((mb (gensym)))
     `(let ((,mb ,mailbox))
        (begin-extended-results-sequence ,mb)
        (unwind-protect

            (progn
              ,@body)
          ;; cleanup
          (end-extended-results-sequence ,mb)))))

 
 (defun send-pop-command-get-results (pop command &optional extrap)
   (declare (optimize (speed 3) (safety 1)))
   ;; send the given command to the pop server
   ;; if extrap is true and if the response is +ok, then data

   ;;  will follow the command (up to and excluding the first line consisting

   ;;  of just a period)

   ;;

   ;; if the pop server returns an error code we signal a lisp error.
   ;; otherwise
   ;; return
   ;;  extrap is nil -- return the list of tokens on the line after +ok
   ;;  extrap is true -- return the extra object (a big string)
   ;;
   (format (post-office-socket pop) "~a~a" command *crlf*)
   (force-output (post-office-socket pop))

   (if* *debug-imap*
      then (format t "~a~a" command *crlf*)

           (force-output t))

 
   (multiple-value-bind (result parsed line)
       (get-and-parse-from-pop-server pop)
     (if* (not (eq result :ok))
        then (po-error :error-response

                       :server-string line))

 
     (if* extrap
        then ;; get the rest of the data

             ;; many but not all pop servers return the size of the data
             ;; after the +ok, so we use that to initially size the
             ;; retreival buffer.
             (let* ((buf (get-line-buffer (+ (if* (fixnump (car parsed))
                                                then (car parsed)
                                                else 2048 ; reasonable size
                                                     )
                                             50)))
                    (buflen (length buf))
                    (pos 0))
               (with-extended-results-sequence (pop)
                 (until (end-of-extended-results-p pop)
                   (if* (>= pos buflen)
                      then    ;; grow buffer
                           (if* (>= buflen (1- array-total-size-limit))
                              then       ; can't grow it any further
                                   (po-error
                                    :response-too-large
                                    :format-control
                                    "response from mail server is too large to hold in a lisp array"))
                           (let ((new-buf (get-line-buffer (* buflen 2))))
                             (init-line-buffer new-buf buf)
                             (free-line-buffer buf)
                             (setq buf new-buf)
                             (setq buflen (length buf))))
                   (setf pos (get-extended-results-sequence pop buf :start pos :end buflen))))
               (prog1 (subseq buf 0 pos)
                 (free-line-buffer buf)))

        else parsed)))

 
 
 
 (defun convert-flags-plist (plist)

   ;; scan the plist looking for "flags" indicators and

   ;; turn value into a list of symbols rather than strings
   (do ((xx plist (cddr xx)))
       ((null xx) plist)
     (if* (equalp "flags" (car xx))
        then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))))))
 
 
 (defmethod select-mailbox ((mb imap-mailbox) name)
   ;; select the given mailbox
   (send-command-get-results mb

                             (format nil "select ~a" name)
                             #'handle-untagged-response
                             #'(lambda (mb command count extra comment)
                                 (declare (ignore mb count extra))
                                 (if* (not (eq command :ok))
                                    then (po-error
                                          :problem
                                          :format-control
                                          "imap mailbox select failed"
                                          :server-string comment))))

   (setf (mailbox-name mb) name)
   t
   )
 
 
 (defmethod fetch-letter ((mb imap-mailbox) number &key uid)
   ;; return the whole letter
   (fetch-field number "body[]"

                (fetch-parts mb number "body[]" :uid uid)
                :uid uid))

 
 
 (defmethod fetch-letter ((pb pop-mailbox) number &key uid)
   (declare (ignore uid))

   (send-pop-command-get-results pb

                                 (format nil "RETR ~d" number)
                                 t ; extra stuff
                                 ))

 
 (defmethod begin-fetch-letter-sequence ((mb imap-mailbox) number &key uid)
   (setf (fetch-letter-offset mb) 0)
   (setf (fetch-letter-number mb) number)
   (setf (fetch-letter-uid mb) uid)
   (setf (fetch-letter-finished mb) nil))
 
 
 (defmethod begin-fetch-letter-sequence ((mb pop-mailbox) number &key uid)
   (declare (ignore uid))
   (send-pop-command-get-results mb (format nil "RETR ~d" number))
   (begin-extended-results-sequence mb))
 

 (defmethod fetch-letter-sequence ((mb imap-mailbox) buffer

                                   &key (start 0) (end (length buffer)))

   (let* ((num (fetch-letter-number mb))

          (offset (fetch-letter-offset mb))
          (uid (fetch-letter-uid mb))
          (buflen (- end start))
          (data (fetch-field num (format nil "body[]<~d>" offset)
                             (fetch-parts mb num
                                          (format nil "body[]<~d.~d>" offset buflen)
                                          :uid uid)
                             :uid uid))
          (datalen (length data)))

 
     (setf (subseq buffer start end) data)

     (if* (and (> buflen 0) (= datalen 0))
        then (setf (fetch-letter-finished mb) t))

     (setf (fetch-letter-offset mb) (+ offset buflen))

     (+ start datalen)))

 
 (defmethod fetch-letter-sequence ((mb pop-mailbox) buffer &key (start 0) (end (length buffer)))
   (get-extended-results-sequence mb buffer :start start :end end))
 
 (defmethod end-fetch-letter-sequence ((mb imap-mailbox))
   )
 
 (defmethod end-fetch-letter-sequence ((mb pop-mailbox))
   (end-extended-results-sequence mb))
 
 (defmethod end-of-letter-p ((mb imap-mailbox))
   (fetch-letter-finished mb))
 
 (defmethod end-of-letter-p ((mb pop-mailbox))
   (end-of-extended-results-p mb))
 
 (defmacro with-fetch-letter-sequence ((mailbox &rest args) &body body)
   (let ((mb (gensym)))
     `(let ((,mb ,mailbox))
        (begin-fetch-letter-sequence ,mb ,@args)
        (unwind-protect

            (progn
              ,@body)
          ;; cleanup
          (end-fetch-letter-sequence ,mb)))))

 (defmethod fetch-parts ((mb imap-mailbox) number parts &key uid)
   (let (res)

     (send-command-get-results

      mb
      (format nil "~afetch ~a ~a"

              (if* uid then "uid " else "")
              (message-set-string number)
              (or parts "body[]")
              )

      #'(lambda (mb command count extra comment)

          (if* (eq command :fetch)
             then (push (list count (internalize-flags extra)) res)
             else (handle-untagged-response
                   mb command count extra comment)))

      #'(lambda (mb command count extra comment)

          (declare (ignore mb count extra))
          (if* (not (eq command :ok))
             then (po-error :problem
                            :format-control "imap mailbox fetch failed"
                            :server-string comment))))

     res))
 

 (defun fetch-field (letter-number field-name info &key uid)

   ;; given the information from a fetch-letter, return the

   ;; particular field for the particular letter
   ;;
   ;; info is as returned by fetch
   ;; field-name is a string, case doesn't matter.
   ;;
   (dolist (item info)
     ;; item is (messagenumber plist-info)
     ;; the same messagenumber may appear in multiple items
     (let (use-this)
       (if* uid

          then ; uid appears as a property in the value, not
               ; as the top level message sequence number
               (do ((xx (cadr item) (cddr xx)))
                   ((null xx))
                 (if* (equalp "uid" (car xx))
                    then (if* (eql letter-number (cadr xx))
                            then (return (setq use-this t))
                            else (return))))
          else ; just a message sequence number
               (setq use-this (eql letter-number (car item))))

       (if* use-this

          then (do ((xx (cadr item) (cddr xx)))
                   ((null xx))
                 (if* (equalp field-name (car xx))
                    then (return-from fetch-field (cadr xx))))))))

 
 (defun internalize-flags (stuff)

   ;; given a plist like object, look for items labelled "flags" and

   ;; convert the contents to internal flags objects
   (do ((xx stuff (cddr xx)))
       ((null xx))
     (if* (equalp (car xx) "flags")

        then ; we can end up with sublists of forms if we

             ; do add-flags with a list of flags.  this seems like
             ; a bug in the imap server.. but we have to deal with it
               (setf (cadr xx) (kwd-intern-possible-list (cadr xx)))
               (return)))

   stuff)
 

 
 
 (defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid)

   ;; delete all the mesasges and do the expunge to make

   ;; it permanent if expunge is true
   (alter-flags mb messages :add-flags :\\deleted :uid uid)
   (if* expunge then (expunge-mailbox mb)))
 
 (defmethod delete-letter ((pb pop-mailbox) messages  &key (expunge nil) uid)
   ;; delete all the messages.   We can't expunge without quitting so
   ;; we don't expunge
   (declare (ignore expunge uid))

 
   (if* (or (numberp messages)

            (and (consp messages) (eq :seq (car messages))))

      then (setq messages (list messages)))

   (if* (not (consp messages))
      then (po-error :syntax-error

                     :format-control "expect a mesage number or list of messages, not ~s"
                  :format-arguments (list messages)))

   (dolist (message messages)
     (if* (numberp message)
        then (send-pop-command-get-results pb

                                           (format nil "DELE ~d" message))

      elseif (and (consp message) (eq :seq (car message)))
        then (do ((start (cadr message) (1+ start))

                  (end (caddr message)))
                 ((> start end))
               (send-pop-command-get-results pb
                                             (format nil "DELE ~d" start)))

        else (po-error :syntax-error

                       :format-control "bad message number ~s"
                       :format-arguments (list message)))))

 
 (defmethod noop ((mb imap-mailbox))
   ;; just poke the server... keeping it awake and checking for
   ;; new letters
   (send-command-get-results mb

                             "noop"
                             #'handle-untagged-response
                             #'(lambda (mb command count extra comment)
                                 (check-for-success
                                  mb command count extra
                                  comment
                                  "noop"))))

 
 
 (defmethod noop ((pb pop-mailbox))
   ;; send the stat command instead so we can update the message count
   (let ((res (send-pop-command-get-results pb "stat")))
       (setf (mailbox-message-count pb) (car res)))
   )
 
 
 (defmethod unique-id ((pb pop-mailbox) &optional message)
   ;; if message is given, return the unique id of that

   ;; message,

   ;; if message is not given then return a list of lists:
   ;;  (message  unique-id)
   ;; for all messages not marked as deleted
   ;;
   (if* message
      then (let ((res (send-pop-command-get-results pb

                                                    (format nil
                                                            "UIDL ~d"
                                                            message))))
             (cadr res))

      else ; get all of them

           (let* ((res (send-pop-command-get-results pb "UIDL" t))
                  (end (length res))
                  kind
                  mnum
                  mid
                  (next 0))

             (let ((coll))
               (loop
                 (multiple-value-setq (kind mnum next)
                   (get-next-token res next end))

                 (if* (eq :eof kind) then (return))

                 (if* (not (eq :number kind))
                    then ; hmm. bogus
                         (po-error :unexpected
                                   :format-control "uidl returned illegal message number in ~s"
                                   :format-arguments (list res)))

                 ; now get message id

                 (multiple-value-setq (kind mid next)
                     (get-next-token res next end))

                 (if* (eq :number kind)
                    then ; looked like a number to the tokenizer,
                         ; make it a string to be consistent
                         (setq mid (format nil "~d" mid))
                  elseif (not (eq :string kind))
                    then ; didn't find the uid
                         (po-error :unexpected
                                   :format-control "uidl returned illegal message id in ~s"
                                   :format-arguments (list res)))

                 (push (list mnum mid) coll))

               (nreverse coll)))))

 
 (defmethod top-lines ((pb pop-mailbox) message lines)
   ;; return the header and the given number of top lines of the message

   (let ((res (send-pop-command-get-results pb

                                            (format nil
                                                    "TOP ~d ~d"
                                                    message
                                                    lines)
                                            t ; extra
                                            )))

     res))

 
 
 (defmethod reset-mailbox ((pb pop-mailbox))
   ;; undo's deletes
   (send-pop-command-get-results pb "RSET")
   )

 
 
 (defun check-for-success (mb command count extra comment command-string )
   (declare (ignore mb count extra))
   (if* (not (eq command :ok))
      then (po-error :error-response

                     :format-control "imap ~a failed"
                     :format-arguments (list command-string)
                     :server-string comment)))

 
 
 (defmethod mailbox-list ((mb imap-mailbox) &key (reference "") (pattern ""))
   ;; return a list of mailbox names with respect to a given
   (let (res)
     (send-command-get-results mb

                               (format nil "list ~s ~s" reference pattern)
                               #'(lambda (mb command count extra comment)
                                   (if* (eq command :list)
                                      then (push extra res)
                                      else (handle-untagged-response
                                            mb command count extra
                                            comment)))
                               #'(lambda (mb command count extra comment)
                                   (check-for-success
                                    mb command count extra
                                    comment "list")))

     ;; the car of each list is a set of keywords, make that so
     (dolist (rr res)
       (setf (car rr) (mapcar #'kwd-intern (car rr))))

     res

     ))
 
 
 (defmethod create-mailbox ((mb imap-mailbox) mailbox-name)
   ;; create a mailbox name of the given name.
   ;; use mailbox-separator if you want to create a hierarchy
   (send-command-get-results mb

                             (format nil "create ~s" mailbox-name)
                             #'handle-untagged-response
                             #'(lambda (mb command count extra comment)
                                   (check-for-success
                                    mb command count extra
                                    comment "create")))

   t)
 
 
 (defmethod delete-mailbox ((mb imap-mailbox) mailbox-name)
   ;; create a mailbox name of the given name.
   ;; use mailbox-separator if you want to create a hierarchy
   (send-command-get-results mb

                             (format nil "delete ~s" mailbox-name)
                             #'handle-untagged-response
                             #'(lambda (mb command count extra comment)
                                   (check-for-success
                                    mb command count extra
                                    comment "delete"))))

 
 (defmethod rename-mailbox ((mb imap-mailbox) old-mailbox-name new-mailbox-name)
   ;; create a mailbox name of the given name.
   ;; use mailbox-separator if you want to create a hierarchy
   (send-command-get-results mb

                             (format nil "rename ~s ~s"
                                     old-mailbox-name
                                     new-mailbox-name)
                             #'handle-untagged-response
                             #'(lambda (mb command count extra comment)
                                   (check-for-success
                                    mb command count extra
                                    comment
                                    "rename"))))

 
 
 
 (defmethod alter-flags ((mb imap-mailbox)

                         messages &key (flags nil flags-p)
                                       add-flags remove-flags
                                       silent uid)

   ;;
   ;; change the flags using the store command
   ;;
   (let (cmd val res)
     (if* flags-p
        then (setq cmd "flags" val flags)
      elseif add-flags
        then (setq cmd "+flags" val add-flags)
      elseif remove-flags
        then (setq cmd "-flags" val remove-flags)
        else (return-from alter-flags nil))

     (if* (atom val) then (setq val (list val)))

     (send-command-get-results mb

                               (format nil "~astore ~a ~a~a ~a"
                                       (if* uid then "uid " else "")
                                       (message-set-string messages)
                                       cmd
                                       (if* silent
                                          then ".silent"
                                          else "")
                                       (if* val
                                          thenret
                                          else "()"))
                               #'(lambda (mb command count extra comment)
                                   (if* (eq command :fetch)
                                      then (push (list count
                                                       (convert-flags-plist
                                                        extra))
                                                 res)
                                      else (handle-untagged-response
                                            mb command count extra
                                            comment)))
 
                               #'(lambda (mb command count extra comment)
                                   (check-for-success
                                    mb command count extra
                                    comment "store")))

     res))
 
 
 (defun message-set-string (messages)
   ;; return a string that describes the messages which may be a
   ;; single number or a sequence of numbers

   (if* (atom messages)
      then (format nil "~a" messages)
      else (if* (and (consp messages)

                     (eq :seq (car messages)))
              then (format nil "~a:~a" (cadr messages) (caddr messages))
              else (let ((str (make-string-output-stream))
                         (precomma nil))
                     (dolist (msg messages)
                       (if* precomma then (format str ","))
                       (if* (atom msg)
                          then (format str "~a" msg)
                        elseif (eq :seq (car msg))
                          then (format str
                                       "~a:~a" (cadr msg) (caddr msg))
                          else (po-error :syntax-error
                                         :format-control "bad message list ~s"
                                         :format-arguments (list msg)))
                       (setq precomma t))
                     (get-output-stream-string str)))))

 (defmethod expunge-mailbox ((mb imap-mailbox))
   ;; remove messages marked as deleted
   (let (res)
     (send-command-get-results mb

                               "expunge"
                               #'(lambda (mb command count extra
                                          comment)
                                   (if* (eq command :expunge)
                                      then (push count res)
                                      else (handle-untagged-response
                                            mb command count extra
                                            comment)))
                               #'(lambda (mb command count extra comment)
                                   (check-for-success
                                    mb command count extra
                                    comment "expunge")))

     (nreverse res)))

 (defmethod close-mailbox ((mb imap-mailbox))
   ;; remove messages marked as deleted
   (send-command-get-results mb

                             "close"
                             #'handle-untagged-response

                             #'(lambda (mb command count extra comment)
                                 (check-for-success
                                  mb command count extra
                                  comment "close")))

   t)

 
 
 (defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination

                             &key uid)

   (send-command-get-results mb

                             (format nil "~acopy ~a ~s"
                                     (if* uid then "uid " else "")
                                     (message-set-string message-list)
                                     destination)
                             #'handle-untagged-response
                             #'(lambda (mb command count extra comment)
                                 (check-for-success
                                  mb command count extra
                                  comment "copy")))

   t)
 
 
 ;; search command
 
 (defmethod search-mailbox ((mb imap-mailbox) search-expression &key uid)
   (let (res)
     (send-command-get-results mb

                               (format nil "~asearch ~a"
                                       (if* uid then "uid " else "")
                                       (build-search-string search-expression))
                               #'(lambda (mb command count extra comment)
                                   (if* (eq command :search)
                                      then (setq res (append res extra))
                                      else (handle-untagged-response
                                            mb command count extra
                                            comment)))
                               #'(lambda (mb command count extra comment)
                                   (check-for-success
                                    mb command count extra
                                    comment "search")))

     res))

 (defmacro defsearchop (name &rest operands)
   (if* (null operands)
      then `(setf (get ',name 'imap-search-no-args) t)
      else `(setf (get ',name 'imap-search-args) ',operands)))
 
 (defsearchop :all)
 (defsearchop :answered)
 (defsearchop :bcc :str)
 (defsearchop :before :date)
 (defsearchop :body :str)
 (defsearchop :cc :str)
 (defsearchop :deleted)
 (defsearchop :draft)
 (defsearchop :flagged)
 (defsearchop :from :str)
 (defsearchop :header :str :str)
 (defsearchop :keyword :flag)
 (defsearchop :larger :number)
 (defsearchop :new)
 (defsearchop :old)
 (defsearchop :on :date)
 (defsearchop :recent)
 (defsearchop :seen)
 (defsearchop :sentbefore :date)
 (defsearchop :senton :date)
 (defsearchop :sentsince :date)
 (defsearchop :since :date)
 (defsearchop :smaller :number)
 (defsearchop :subject :str)
 (defsearchop :text :str)
 (defsearchop :to :str)
 (defsearchop :uid :messageset)
 (defsearchop :unanswered)
 (defsearchop :undeleted)
 (defsearchop :undraft)
 (defsearchop :unflagged)
 (defsearchop :unkeyword :flag)
 (defsearchop :unseen)
 
 
 
 (defun build-search-string (search)
   ;; take the lisp search form and turn it into a string that can be
   ;; passed to imap
 
   (if* (null search)
      then ""
      else (let ((str (make-string-output-stream)))

             (bss-int search str)
             (get-output-stream-string str))))

 
 (defun bss-int (search str)
   ;;* it turns out that imap (on linux) is very picky about spaces....
   ;; any extra whitespace will result in failed searches
   ;;
   (labels ((and-ify (srch str)

              (let ((spaceout nil))
                (dolist (xx srch)
                  (if* spaceout then (format str " "))
                  (bss-int xx str)
                  (setq spaceout t))))
            (or-ify (srch str)
              ; only binary or allowed in imap but we support n-ary
              ; or in this interface
              (if* (null (cdr srch))
                 then (bss-int (car srch) str)
               elseif (cddr srch)
                 then ; over two clauses
                      (format str "or (")
                      (bss-int (car srch) str)
                      (format str  ") (")
                      (or-ify (cdr srch) str)
                      (format str ")")
                 else ; 2 args
                      (format str "or (" )
                      (bss-int (car srch) str)
                      (format str ") (")
                      (bss-int (cadr srch) str)
                      (format str ")")))
            (set-ify (srch str)
              ;; a sequence of messages
              (do* ((xsrch srch (cdr xsrch))
                    (val (car xsrch) (car xsrch)))
                  ((null xsrch))
                (if* (integerp val)
                   then (format str "~s" val)
                 elseif (and (consp val)
                             (eq :seq (car val))
                             (eq 3 (length val)))
                   then (format str "~s:~s" (cadr val) (caddr val))
                   else (po-error :syntax-error
                                  :format-control "illegal set format ~s"
                                  :format-arguments (list val)))
                (if* (cdr xsrch) then (format str ","))))
            (arg-process (str args arginfo)
              ;; process and print each arg to str
              ;; assert (length of args and arginfo are the same)
              (do* ((x-args args (cdr x-args))
                    (val (car x-args) (car x-args))
                    (x-arginfo arginfo (cdr x-arginfo)))
                  ((null x-args))
                (ecase (car x-arginfo)
                  (:str
                   ; print it as a string
                   (format str " \"~a\"" (car x-args)))
                  (:date
 
                   (if* (integerp val)
                      then (setq val (universal-time-to-rfc822-date
                                      val))
                    elseif (not (stringp val))
                      then (po-error :syntax-error
                                     :format-control "illegal value for date search ~s"
                                     :format-arguments (list val)))
                   ;; val is now a string
                   (format str " ~s" val))
                  (:number
 
                   (if* (not (integerp val))
                      then (po-error :syntax-error
                                     :format-control "illegal value for number in search ~s"
                                     :format-arguments (list val)))
                   (format str " ~s" val))
                  (:flag
 
                   ;; should be a symbol in the kwd package
                   (setq val (string val))
                   (format str " ~s" val))
                  (:messageset
                   (if* (numberp val)
                      then (format str " ~s" val)
                    elseif (consp val)
                      then (set-ify val str)
                      else (po-error :syntax-error
                                     :format-control "illegal message set ~s"
                                     :format-arguments (list val))))
 
                  ))))

     (if* (symbolp search)
        then (if* (get search 'imap-search-no-args)

                then (format str "~a"  (string-upcase
                                        (string search)))
                else (po-error :syntax-error
                               :format-control "illegal search word: ~s"
                               :format-arguments (list search)))

      elseif (consp search)
        then (case (car search)

               (and (if* (null (cdr search))
                       then (bss-int :all str)
                     elseif (null (cddr search))
                       then (bss-int (cadr search) str)
                       else (and-ify (cdr search)  str)))
               (or  (if* (null (cdr search))
                       then (bss-int :all str)
                     elseif (null (cddr search))
                       then (bss-int (cadr search) str)
                       else (or-ify (cdr search)  str)))
               (not (if* (not (eql (length search) 2))
                       then (po-error :syntax-error
                                      :format-control "not takes one argument: ~s"
                                      :format-arguments (list search)))
                    (format str "not (" )
                    (bss-int (cadr search) str)
                    (format str ")"))
               (:seq
                (set-ify (list search) str))
               (t (let (arginfo)
                    (if* (and (symbolp (car search))
                              (setq arginfo (get (car search)
                                                 'imap-search-args)))
                       then
                            (format str "~a" (string-upcase
                                              (string (car search))))
                            (if* (not (equal (length (cdr search))
                                             (length arginfo)))
                               then (po-error :syntax-error
                                              :format-control "wrong number of arguments to ~s"
                                              :format-arguments search))
 
                            (arg-process str (cdr search) arginfo)
 
                     elseif (integerp (car search))
                       then (set-ify search str)
                       else (po-error :syntax-error
                                      :format-control "Illegal form ~s in search string"
                                      :format-arguments (list search))))))

      elseif (integerp search)
        then ;  a message number

             (format str "~s" search)

        else (po-error :syntax-error

                       :format-control "Illegal form ~s in search string"
                       :format-arguments (list search)))))

 (defun parse-mail-header (text)

   ;; given the partial text of a mail message that includes
   ;; at least the header part, return an assoc list of
   ;; (header . content)  items
   ;; Note that the header is string with most likely mixed case names
   ;; as it's conventional to capitalize header names.
   (let ((next 0)

         (end (length text))
         header
         value
         kind
         headers)

     (labels ((next-header-line ()

                ;; find the next header line return
                ;; :eof - no more
                ;; :start - beginning of header value, header and
                ;;                value set
                ;; :continue - continuation of previous header line
 
 
                (let ((state 1)
                      beginv  ; charpos beginning value
                      beginh  ; charpos beginning header
                      ch
                      )
                  (tagbody again
 
                    (return-from next-header-line
 
                      (loop  ; for each character
 
                        (if* (>= next end)
                           then (return :eof))
 
                        (setq ch (char text next))
                        (if* (eq ch #\return)
                           thenret  ; ignore return, (handle following linefeed)
                           else (case state
                                  (1 ; no characters seen
                                   (if* (eq ch #\linefeed)
                                      then (incf next)
                                           (return :eof)
                                    elseif (member ch
                                                   '(#\space
                                                     #\tab))
                                      then ; continuation
                                           (setq state 2)
                                      else (setq beginh next)
                                           (setq state 3)
                                           ))
                                  (2 ; looking for first non blank in value
                                   (if* (eq ch #\linefeed)
                                      then ; empty continuation line, ignore
                                           (incf next)
                                           (if* header
                                              then ; header and no value
                                                   (setq value "")
                                                   (return :start))
                                           (setq state 1)
                                           (go again)
                                    elseif (not (member ch
                                                        (member ch
                                                                '(#\space
                                                                  #\tab))))
                                      then ; begin value part
                                           (setq beginv next)
                                           (setq state 4)))
                                  (3 ; reading the header
                                   (if* (eq ch #\linefeed)
                                      then ; bogus header line, ignore
                                           (setq state 1)
                                           (go again)
                                    elseif (eq ch #\:)
                                      then (setq header
                                             (subseq text beginh next))
                                           (setq state 2)))
                                  (4 ; looking for the end of the value
                                   (if* (eq ch #\linefeed)
                                      then (setq value
                                             (subseq text beginv
                                                     (if* (eq #\return
                                                              (char text
                                                                    (1- next)))
                                                        then (1- next)
                                                        else next)))
                                           (incf next)
                                           (return (if* header
                                                      then :start
                                                      else :continue))))))
                        (incf next)))))))

       (loop ; for each header line

         (setq header nil)
         (if* (eq :eof (setq kind (next-header-line)))
            then (return))
         (case kind
           (:start (push (cons header value) headers))
           (:continue
            (if* headers
               then ; append to previous one
                    (setf (cdr (car headers))
                      (concatenate 'string (cdr (car headers))
                                   " "
                                   value)))))))

     (values headers

             (subseq text next end))))

 
 
 (defun make-envelope-from-text (text)
   ;; given at least the headers part of a message return
   ;; an envelope structure containing the contents
   ;; This is useful for parsing the headers of things returned by
   ;; a pop server
   ;;
   (let ((headers (parse-mail-header text)))

     (make-envelope
      :date     (cdr (assoc "date" headers :test #'equalp))
      :subject  (cdr (assoc "subject" headers :test #'equalp))
      :from     (cdr (assoc "from" headers :test #'equalp))
      :sender   (cdr (assoc "sender" headers :test #'equalp))
      :reply-to (cdr (assoc "reply-to" headers :test #'equalp))
      :to       (cdr (assoc "to" headers :test #'equalp))
      :cc       (cdr (assoc "cc" headers :test #'equalp))
      :bcc      (cdr (assoc "bcc" headers :test #'equalp))
      :in-reply-to (cdr (assoc "in-reply-to" headers :test #'equalp))
      :message-id (cdr (assoc "message-id" headers :test #'equalp))
      )))
 
 
 
 
 

 (defmethod get-and-parse-from-imap-server ((mb imap-mailbox))
   ;; read the next line and parse it
   ;;
   ;;
   (multiple-value-bind (line count)
       (get-line-from-server mb)

     (if* *debug-imap*

        then (format t "from server: ")

             (dotimes (i count)(write-char (schar line i)))
             (terpri)
             (force-output))

     (parse-imap-response line count)
     ))
 
 
 
 (defmethod get-and-parse-from-pop-server ((mb pop-mailbox))
   ;; read the next line from the pop server
   ;;
   ;; return 3 values:

   ;;   :ok or :error

   ;;   a list of rest of the tokens on the line
   ;;   the whole line after the +ok or -err
 
   (multiple-value-bind (line count)
       (get-line-from-server mb)

 
     (if* *debug-imap*

        then (format t "from server: ")

             (dotimes (i count)(write-char (schar line i)))
             (terpri))

     (parse-pop-response line count)))
 

 ;; Parse and return the data from each line
 ;; values returned
 ;;  tag -- either a string or the symbol :untagged
 ;;  command -- a keyword symbol naming the command, like :ok
 ;;  count -- a number which preceeded the command, or nil if

 ;;           there wasn't a command

 ;;  bracketted - a list of objects found in []'s after the command

 ;;            or in ()'s after the command  or sometimes just

 ;;            out in the open after the command (like the search)

 ;;  comment  -- the whole of the part after the command
 ;;
 (defun parse-imap-response (line end)
   (let (kind value next

         tag count command extra-data
         comment)

     ;; get tag
     (multiple-value-setq (kind value next)
       (get-next-token line 0 end))

     (case kind
       (:string (setq tag (if* (equal value "*")

                             then :untagged
                             else value)))

       (t (po-error :unexpected

                    :format-control "Illegal tag on response: ~s"
                    :format-arguments (list (subseq line 0 count))
                    :server-string (subseq line 0 end)
                    )))

     ;; get command
     (multiple-value-setq (kind value next)
       (get-next-token line next end))

     (tagbody again
       (case kind

         (:number (setq count value)
                  (multiple-value-setq (kind value next)
                    (get-next-token line next end))
                  (go again))
         (:string (setq command (kwd-intern value)))
         (t (po-error :unexpected
                      :format-control "Illegal command on response: ~s"
                      :format-arguments (list (subseq line 0 count))
                      :server-string (subseq line 0 end)))))

 
     (setq comment (subseq line next end))

     ;; now the part after the command... this gets tricky
     (loop
       (multiple-value-setq (kind value next)

         (get-next-token line next end))

       (case kind

         ((:lbracket :lparen)
          (multiple-value-setq (kind value next)
            (get-next-sexpr line (1- next) end))
          (case kind
            (:sexpr (push value extra-data))
            (t (po-error :syntax-error :format-control "bad sexpr form"))))
         (:eof (return nil))
         ((:number :string :nil) (push value extra-data))
         (t  ; should never happen
          (return)))

       (if* (not (member command '(:list :search) :test #'eq))

          then ; only one item returned
               (setq extra-data (car extra-data))
               (return)))

 
     (if* (member command '(:list :search) :test #'eq)
        then (setq extra-data (nreverse extra-data)))

     (values tag command count extra-data comment)))

 
 
 (defun get-next-sexpr (line start end)
   ;; read a whole s-expression
   ;; return 3 values
   ;;   kind -- :sexpr  or :rparen or :rbracket
   ;;   value - the sexpr value
   ;;   next  - next charpos to scan

   ;;

   (let ( kind value next)
     (multiple-value-setq (kind value next) (get-next-token line start end))

     (case kind
       ((:string :number :nil)
        (values :sexpr value next))

       (:eof (po-error :syntax-error

                       :format-control "eof inside sexpr"))

       ((:lbracket :lparen)
        (let (res)

          (loop
            (multiple-value-setq (kind value next)
              (get-next-sexpr line next end))
            (case kind
              (:sexpr (push value res))
              ((:rparen :rbracket)
               (return (values :sexpr (nreverse res) next)))
              (t (po-error :syntax-error
                           :format-control "bad sexpression"))))))

       ((:rbracket :rparen)
        (values kind nil next))
       (t (po-error :syntax-error

                    :format-control "bad sexpression")))))

 
 
 (defun parse-pop-response (line end)
   ;; return 3 values:

   ;;   :ok or :error

   ;;   a list of rest of the tokens on the line, the tokens

   ;;     being either strings or integers

   ;;   the whole line after the +ok or -err
   ;;
   (let (res lineres result)
     (multiple-value-bind (kind value next)

         (get-next-token line 0 end)

       (case kind

         (:string (setq result (if* (equal "+OK" value)
                                  then :ok
                                  else :error)))
         (t (po-error :unexpected
                      :format-control "bad response from server"
                      :server-string (subseq line 0 end))))

       (setq lineres (subseq line next end))
 
       (loop

         (multiple-value-setq (kind value next)
           (get-next-token line next end))

         (case kind
           (:eof (return))
           ((:string :number) (push value res))))

       (values result (nreverse res) lineres))))

 (defparameter *char-to-kind*
     (let ((arr (make-array 256 :initial-element nil)))

       (do ((i #.(char-code #\0) (1+ i)))

           ((> i #.(char-code #\9)))
         (setf (aref arr i) :number))

       (setf (aref arr #.(char-code #\space)) :space)
       (setf (aref arr #.(char-code #\tab)) :space)
       (setf (aref arr #.(char-code #\return)) :space)
       (setf (aref arr #.(char-code #\linefeed)) :space)

       (setf (aref arr #.(char-code #\[)) :lbracket)
       (setf (aref arr #.(char-code #\])) :rbracket)
       (setf (aref arr #.(char-code #\()) :lparen)
       (setf (aref arr #.(char-code #\))) :rparen)
       (setf (aref arr #.(char-code #\")) :dquote)

       (setf (aref arr #.(char-code #\^b)) :big-string) ; our own invention

       arr))

 (defun get-next-token (line start end)
   ;; scan past whitespace for the next token
   ;; return three values:
   ;;  kind:  :string , :number, :eof, :lbracket, :rbracket,

   ;;            :lparen, :rparen

   ;;  value:  the value, either a string or number or nil
   ;;  next:   the character pos to start scanning for the next token
   ;;
   (let (ch chkind colstart (count 0) (state :looking)

         collector right-bracket-is-normal)

     (loop

       ; pick up the next character
       (if* (>= start end)

          then (if* (eq state :looking)
                  then (return (values :eof nil start))
                  else (setq ch #\space))
          else (setq ch (schar line start)))

       (setq chkind (aref *char-to-kind* (char-code ch)))

       (case state

         (:looking
          (case chkind
            (:space nil)
            (:number (setq state :number)
                     (setq colstart start)
                     (setq count (- (char-code ch) #.(char-code #\0))))
            ((:lbracket :lparen :rbracket :rparen)
             (return (values chkind nil (1+ start))))
            (:dquote
             (setq collector (make-array 10
                                         :element-type 'character
                                         :adjustable t
                                         :fill-pointer 0))
             (setq state :qstring))
            (:big-string
             (setq colstart (1+ start))
             (setq state :big-string))
            (t (setq colstart start)
               (setq state :literal))))
         (:number
          (case chkind
            ((:space :lbracket :lparen :rbracket :rparen
              :dquote) ; end of number
             (return (values :number count  start)))
            (:number ; more number
             (setq count (+ (* count 10)
                            (- (char-code ch) #.(char-code #\0)))))
            (t ; turn into an literal
             (setq state :literal))))
         (:literal
          (case chkind
            ((:space :rbracket :lparen :rparen :dquote) ; end of literal
             (if* (and (eq chkind :rbracket)
                       right-bracket-is-normal)
                then nil ; don't stop now
                else (let ((seq (subseq line colstart start)))
                       (if* (equal "NIL" seq)
                          then (return (values :nil
                                               nil
                                               start))
                          else (return (values :string
                                               seq
                                               start))))))
            (t (if* (eq chkind :lbracket)
                  then ; imbedded left bracket so right bracket isn't
                       ; a break char
                       (setq right-bracket-is-normal t))
               nil)))
         (:qstring
          ;; quoted string
          ; (format t "start is ~s  kind is ~s~%" start chkind)
          (case chkind
            (:dquote
             ;; end of string
             (return (values :string collector (1+ start))))
            (t (if* (eq ch #\\)
                  then ; escaping the next character
                       (incf start)
                       (if* (>= start end)
                          then (po-error :unexpected
                                         :format-control "eof in string returned"))
                       (setq ch (schar line start)))
               (vector-push-extend ch collector)
 
               (if* (>= start end)
                  then ; we overran the end of the input
                       (po-error :unexpected
                                 :format-control "eof in string returned")))))
         (:big-string
          ;; super string... just a block of data
          ; (format t "start is ~s  kind is ~s~%" start chkind)
          (case chkind
            (:big-string
             ;; end of string
             (return (values :string
                             (subseq line colstart start)
                             (1+ start))))
            (t nil)))
 
 
         )

       (incf start))))

 
 ;  this used to be exported from the excl package

 #+(or (and allegro (version>= 6 0))
       (not allegro))

 (defvar *keyword-package* (find-package :keyword))
 
 (defun kwd-intern-possible-list (form)
   (if* (null form)
      then nil
    elseif (atom form)
      then (kwd-intern form)
      else (mapcar #'kwd-intern-possible-list form)))
 

 (defun kwd-intern (string)
   ;; convert the string to the current preferred case
   ;; and then intern
   (intern (case excl::*current-case-mode*

             ((:case-sensitive-lower
               :case-insensitive-lower) (string-downcase string))
             (t (string-upcase string)))
           *keyword-package*))

 ;; low level i/o to server
 
 (defun get-line-from-server (mailbox)
   ;; Return two values:  a buffer and a character count.
   ;; The character count includes up to but excluding the cr lf that
   ;;  was read from the socket.

   ;;

   ;; TODO: make it able to read from ssl socket

   (let* ((buff (get-line-buffer 0))

          (len  (length buff))
          (i 0)
          (p (post-office-socket mailbox))
          (ch nil)
          (whole-count)
          )

     (handler-case

         (flet ((grow-buffer (size)
                  (let ((newbuff (get-line-buffer size)))
                    (dotimes (j i)
                      (setf (schar newbuff j) (schar buff j)))
                    (free-line-buffer buff)
                    (setq buff newbuff)
                    (setq len (length buff)))))
 
           ;; increase the buffer to at least size
           ;; this is somewhat complex to ensure that we aren't doing
           ;; buffer allocation within the with-timeout form, since
           ;; that could trigger a gc which could then cause the
           ;; with-timeout form to expire.
           (loop
 

              (if* whole-count
                 then                    ; we should now read in this may bytes and
                                         ; append it to this buffer
                                         (multiple-value-bind (ans this-count)
                                             (get-block-of-data-from-server mailbox whole-count)
                                         ; now put this data in the current buffer
                                           (if* (> (+ i whole-count 5) len)
                                              then ; grow the initial buffer
                                                    (grow-buffer (+ i whole-count 100)))
 
                                           (dotimes (ind this-count)
                                             (setf (schar buff i) (schar ans ind))
                                             (incf i))
                                           (setf (schar buff i) #\^b) ; end of inset string
                                           (incf i)
                                           (free-line-buffer ans)
                                           (setq whole-count nil)
                                           )
               elseif ch
                 then                    ; we're growing the buffer holding the line data
                      (grow-buffer (+ len 200))
                      (setf (schar buff i) ch)
                      (incf i))
 
 
              (block timeout
                (mp:with-timeout ((timeout mailbox)
                                   (po-error :timeout
                                             :format-control "imap server failed to respond"))
                  ;; read up to lf  (lf most likely preceeded by cr)
                  (loop
                     (setq ch (read-char p))
                     (if* (eq #\linefeed ch)
                        then             ; end of line. Don't save the return
                             (if* (and (> i 0)
                                       (eq (schar buff (1- i)) #\return))
                                then     ; remove #\return, replace with newline
                                     (decf i)
                                     (setf (schar buff i) #\newline)
                                     )
                             ;; must check for an extended return value which
                             ;; is indicated by a {nnn} at the end of the line
                             (block count-check
                               (let ((ind (1- i)))
                                 (if* (and (>= i 0) (eq (schar buff ind) #\}))
                                    then (let ((count 0)
                                               (mult 1))
                                           (loop
                                              (decf ind)
                                              (if* (< ind 0)
                                                 then ; no of the form {nnn}
                                                      (return-from count-check))
                                              (setf ch (schar buff ind))
                                              (if* (eq ch #\{)
                                                 then ; must now read that many bytes
                                                      (setf (schar buff ind) #\^b)
                                                      (setq whole-count count)
                                                      (setq i (1+ ind))
                                                      (return-from timeout)
                                               elseif (<= #.(char-code #\0)
                                                            (char-code ch)
                                                            #.(char-code #\9))
                                                 then ; is a digit
                                                      (setq count
                                                            (+ count
                                                               (* mult
                                                                  (- (char-code ch)
                                                                     #.(char-code #\0)))))
                                                      (setq mult (* 10 mult))
                                                 else ; invalid form, get out
                                                      (return-from count-check)))))))
 
 
                             (return-from get-line-from-server
                               (values buff i))
                        else             ; save character
                             (if* (>= i len)
                                then     ; need bigger buffer
                                     (return))
                             (setf (schar buff i) ch)
                             (incf i)))))))

       (error (con)

         ;; most likely error is that the server went away
         (ignore-errors (close p))
         (po-error :server-shutdown-connection
                   :format-control "condition  signalled: ~a~%most likely server shut down the connection."
                   :format-arguments (list con)))

       )))
 
 
 (defun get-block-of-data-from-server  (mb count &key save-returns)
   ;; read count bytes from the server returning it in a line buffer object

   ;; return as a second value the number of characters saved

   ;; (we drop #\return's so that lines are separated by a #\newline
   ;; like lisp likes).
   ;;
   (let ((buff (get-line-buffer count))

         (p (post-office-socket mb))
         (ind 0))

     (mp:with-timeout ((timeout mb)

                       (po-error :timeout
                                 :format-control "imap server timed out"))

       (dotimes (i count)

         (if* (eq #\return (setf (schar buff ind) (read-char p)))
            then (if* save-returns then (incf ind)) ; drop #\returns
            else (incf ind)))

       (values buff ind))))

 ;;-- reusable line buffers
 
 (defvar *line-buffers* nil)
 

 #+(and allegro (version>= 8 1))
 (defvar *line-buffers-lock* (make-basic-lock :name "line-buffers"))

 
 (defmacro with-locked-line-buffers (&rest body)

   #+(and allegro (version>= 8 1))
   `(with-locked-structure (*line-buffers-lock*
                         :non-smp :without-scheduling)
      ,@body)
   #-(and allegro (version>= 8 1))

   `(mp:without-scheduling ,@body)

   )
 
 (defun get-line-buffer (size)
   ;; get a buffer of at least size bytes
   (setq size (min size (1- array-total-size-limit)))

   (let ((found

          (with-locked-line-buffers
            (dolist (buff *line-buffers*)
              (if* (>= (length buff) size)
                 then ;; use this one
                      (setq *line-buffers* (delete buff *line-buffers*))
                      (return buff))))))

     (or found  (make-string size))))
 
 (defun free-line-buffer (buff)
   (with-locked-line-buffers
     (push buff *line-buffers*)))
 
 (defun init-line-buffer (new old)
   ;; copy old into new
   (declare (optimize (speed 3)))
   (dotimes (i (length old))
     (declare (fixnum i))
     (setf (schar new i) (schar old i))))
 

 
   ;;;;;;;
 
 ; date functions
 
 (defun universal-time-to-rfc822-date (ut)
   ;; convert a lisp universal time to rfc 822 date
   ;;
   (multiple-value-bind
       (sec min hour date month year day-of-week dsp time-zone)
       (decode-universal-time ut 0)
     (declare (ignore time-zone sec min hour day-of-week dsp time-zone))
     (format nil "~d-~a-~d"

             date
             (svref
              '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
                 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
              month
              )
             year)))

 
 
 ;; utility
 
 (defmacro with-imap-connection ((mb &rest options) &body body)
   `(let ((,mb (make-imap-connection ,@options)))
      (unwind-protect

          (progn
            ,@body)

        (close-connection ,mb))))
 
 
 (defmacro with-pop-connection ((mb &rest options) &body body)
   `(let ((,mb (make-pop-connection ,@options)))
      (unwind-protect

          (progn
            ,@body)

        (close-connection ,mb))))