Download
(require 'imap)
(require 'qp)
(require 'timezone)
(require 'message)
(require 'cl)
(setq imap-log nil)
(defun imapua-toggle-imap-logging ()
(interactive)
(if imap-log
(setq imap-log nil)
(setq imap-log (get-buffer-create "*imap-log*"))))
(defgroup imap-mail-user-agent nil
"an IMAP based MUA."
:group 'applications)
(defcustom imapua-host-name ""
"* the name of server to connect to"
:type '(string)
:group 'imap-mail-user-agent)
(defcustom imapua-bcc-to-sender 't
"* should the sender be sent copies of all mails?"
:type '(boolean)
:group 'imap-mail-user-agent)
(defcustom imapua-initial-folder-name ""
"* the name to popup when selecting a target folder for moves."
:type '(string)
:group 'imap-mail-user-agent)
(defcustom imapua-trash-folder-name "Trash"
"* the folder name of the folder to save deleted emails in."
:type '(string)
:group 'imap-mail-user-agent)
(defcustom imapua-spam-folder-name "Spam-today"
"* the folder name of the folder to save spam messages in."
:type '(string)
:group 'imap-mail-user-agent)
(defgroup imap-mail-user-agent-colors nil
"colors for the IMAP user agent."
:group 'imap-mail-user-agent)
(defcustom imapua-folder-color "DarkGreen"
"* color for folders"
:type '(string)
:group 'imap-mail-user-agent-colors)
(defcustom imapua-unseen-message-color "Blue"
"* color for unread messages"
:type '(string)
:group 'imap-mail-user-agent-colors)
(defcustom imapua-read-message-color "Black"
"* color for read messages"
:type '(string)
:group 'imap-mail-user-agent-colors)
(defcustom imapua-marked-message-color "Red"
"* color for marked messages"
:type '(string)
:group 'imap-mail-user-agent-colors)
(defcustom imapua-deleted-message-color "Red"
"* color for deleted messages"
:type '(string)
:group 'imap-mail-user-agent-colors)
(defcustom imapua-message-header-color "DarkGreen"
"* color for header in message buffer"
:type '(string)
:group 'imap-mail-user-agent-colors)
(defvar imapua-connection nil
"the imap connection is a process bound buffer")
(defvar imapua-mode-initialized-p nil
"is the mode initialized already?")
(defvar imapua-mode-hook nil
"the mode hooks")
(defvar imapua-mode-map nil
"the mode map")
(defvar imapua-message-keymap-initializedp nil
"is the message view mode map initialized yet?")
(defvar imapua-message-mode-hook nil
"the mode hooks")
(defvar imapua-host nil
"the imap server")
(defvar imapua-port 143
"the imap server port")
(defvar imapua-username nil
"the user's name")
(defvar imapua-password nil
"the user's password")
(defvar imapua-folder-list nil
"the cached list of folders.")
(defvar imapua-folder-history nil
"the history of foldere names.")
(defvar imapua-buffer nil
"the buffer being used.")
(defun imapua-trim (str)
"Remove excessive whitespace from STR."
(let ((mystr str))
(while (string-match "[ \t][ \t]+" mystr)
(setq mystr (concat (substring mystr 0 (match-beginning 0))
" " (substring mystr (match-end 0)))))
(when (string-match "^[ \t]+" mystr)
(setq mystr (concat
(substring mystr 0 (match-beginning 0))
(substring mystr (match-end 0)))))
(when (string-match "[:space:]$" mystr)
(setq mystr (concat (substring mystr 0 (match-beginning 0)))))
mystr))
(defun imapua-kill-buffer-hook ()
"ensure the IMAP connection is logged out when the buffer dies"
(imapua-logout))
(defun imapua-ensure-connected ()
"get a connection to the mail store."
(if (imap-opened imapua-connection)
imapua-connection
(progn
(if (not imapua-host)
(if (not (equal imapua-host-name ""))
(setq imapua-host imapua-host-name)
(setq imapua-host (read-from-minibuffer "host: "))))
(setq imapua-connection (imap-open imapua-host imapua-port 'network))
(assert imapua-connection nil "the imap connection could not be opened")
(if (not (and imapua-username imapua-password))
(progn
(if (not imapua-username)
(setq imapua-username (read-from-minibuffer "username: ")))
(if (not imapua-password)
(setq imapua-password (read-passwd "password: ")))))
(condition-case nil
(progn
(imap-authenticate imapua-username imapua-password imapua-connection)
(imap-mailbox-list "*" "" "." imapua-connection))
(error nil)))))
(defun imapua-refresh-folder-list ()
"Refresh the list of folders available from the imap server."
(imap-mailbox-list "*" "" "." imapua-connection)
(setq imapua-folder-list
(sort
(imap-mailbox-map
(lambda (folder-name)
folder-name) imapua-connection) 'string<)))
(defun imapua-field-format (width str &optional padding-only)
"Return a string padded or truncated to fit in the field width.
If padding-only is non-nil then truncation will not be performed."
(if (> (length str) width)
(if (not padding-only)
(concat (substring str 0 (- width 3)) "...")
str)
(concat str (make-string (- width (length str)) ?\ ))))
(defun imapua-from-format (from-addr)
"Return the best string representing the from address.
The supplied address is a vector of 3 different address types.
imap.el returns the from address in element 0, but it's more reliable
to concatentate the domain (element 3) and the username (element 2)"
(let ((friendly-name (elt from-addr 0))
(other-name (elt from-addr 1))
(smtp-addr (elt from-addr 2))
(domain (elt from-addr 3)))
(concat smtp-addr "@" domain)))
(defun imapua-date-format (date-string)
"Return the best string representation of the supplied date string.
The timezone package is used to parse the string."
(let ((date-struct (timezone-parse-date date-string)))
(concat
(elt date-struct 0)
"-"
(let ((month (elt date-struct 1)))
(if (< (length month) 2)
(concat "0" month)
month))
"-"
(let ((day (elt date-struct 2)))
(if (< (length day) 2)
(concat "0" day)
day))
" "
(elt date-struct 3) " ")))
(defun imapua-recentp (uid)
"Return true if the flag list contains the \\Recent flag."
(if uid
(let ((flag-list (imap-message-get uid 'FLAGS imapua-connection))
(recentp
(lambda (flag-list fn)
(if (listp flag-list)
(if flag-list
(let ((flag (car flag-list)))
(if (string= "\\Recent" flag)
't
(funcall fn (cdr flag-list) fn)))
nil)
nil))))
(funcall recentp flag-list recentp))))
(defun imapua-seenp (uid)
"Return true if the flag list contains the \\Seen flag."
(if uid
(let ((flag-list (imap-message-get uid 'FLAGS imapua-connection))
(seenp
(lambda (flag-list fn)
(if (listp flag-list)
(let ((flag (car flag-list)))
(if (and (stringp flag) (string= "\\Seen" flag))
't
(if (cdr flag-list)
(funcall fn (cdr flag-list) fn)
nil)))
nil))))
(funcall seenp flag-list seenp))))
(defun imapua-deletedp (uid)
"Return true if the flag list contains the \\Deleted flag."
(if uid
(let ((flag-list (imap-message-get uid 'FLAGS imapua-connection))
(deletedp
(lambda (flag-list fn)
(if (listp flag-list)
(let ((flag (car flag-list)))
(if (and (stringp flag) (string= "\\Deleted" flag))
't
(if (cdr flag-list)
(funcall fn (cdr flag-list) fn)
nil)))
nil))))
(funcall deletedp flag-list deletedp))))
(defun imapua-has-recent-p (folder-name)
"Has the specified folder got a recent marker?"
(catch 'exit-recur
(mapc (lambda (item)
(if (equal (upcase-initials item) "\\Marked")
(throw 'exit-recur 't)))
(imap-mailbox-get 'list-flags folder-name imapua-connection))
nil))
(defun imapua-parse-bs (lst &optional super-part)
"Turn a mime structure into an alist.
The keys of the alist are tags for different parts of the
message, for example 'type is the mime type. Multipart messages
are coded exactly the same except they have each subpart in the
alist as well. Each subpart is keyed by it's part id (as a
string)."
(defun part-num-to-str (super-part part)
"Convert a part number to a compound string"
(if super-part
(format "%s.%s" super-part part)
(format "%s" part)))
(defun ext-parse (bs lst)
"Parse the extension data."
(unless (eq 'NIL (elt lst 0))
(nconc bs (list (cons 'body (list (elt lst 0))))))
(unless (eq 'NIL (elt lst 1))
(nconc bs (list (cons 'disposition (list (elt lst 1))))))
(unless (eq 'NIL (elt lst 3))
(nconc bs (list (cons 'transfer-encoding (list (elt lst 3))))))
bs)
(let ((bs (list '()))
(part 1)
(el (car lst)))
(while (listp el)
(let ((part-str (part-num-to-str super-part part)))
(nconc bs (list (cons part-str (imapua-parse-bs el part-str))))
(setq part (+ 1 part))
(setq lst (cdr lst))
(setq el (car lst))
))
(if (not (listp (cadr lst)))
(progn
(nconc bs (list (cons 'type (list (cons el (cadr lst))))))
(ext-parse bs (cddr lst)))
(progn
(nconc bs (list (cons 'type el)))
(ext-parse bs (cdr lst))))
(cdr bs)))
(defun imapua-bs-to-part-list (bs)
"Make a part list from a bodystructure.
A part list is a flat list of all mime types, which are
alists. The part id is made an entry in the mime type with the
key: 'partnum"
(defun part-spec-p (str)
"Is str a valid IMAP part specifier?"
(and (stringp str) (string-match "[0-9][0-9.]*" str)))
(let ((parts (list '())))
(defun iterator (lst)
(mapc (lambda (item)
(and (listp item)
(part-spec-p (car item))
(nconc parts (list (cons (cons 'partnum (car item))
(cdr item))))
(iterator item))) lst))
(iterator bs)
(cdr parts)))
(defun imapua-part-list-assoc (key value malist)
"This is an massoc function.
Find the specified key/value pair in the malist.
An malist is a Multi Association LIST: a list of alists."
(let ((found (catch 'found
(mapc (lambda (alist)
(if (equal value (cdr (assoc key alist)))
(throw 'found alist))) malist))))
found))
(defun imapua (&optional host-name tcp-port)
"Open the imap server and get a folder list.
With a non-nil prefix argument the imap server host name is requested.
This means you can have multiple imapua sessions in one emacs session."
(interactive
(if current-prefix-arg
(let ((host-str (read-from-minibuffer "Imap server host name: ")))
(string-match "\\(.+\\) \\([0-9]+\\)" host-str 0)
(list (if (not (match-string 1 host-str))
"localhost"
(match-string 1 host-str))
(if (not (match-string 2 host-str))
143
(string-to-number (match-string 2 host-str)))))))
(let ((folder-buffer (get-buffer-create
(concat "mail-folders"
(if host-name
(concat host-name ":" (number-to-string tcp-port)))))))
(switch-to-buffer folder-buffer)
(if (not imapua-mode-initialized-p)
(progn
(imapua-mode)
(if host-name
(progn
(make-local-variable 'imapua-host)
(setq imapua-host host-name)
(make-local-variable 'imapua-port)
(setq imapua-port tcp-port)))))
(imapua-redraw)))
(defun imapua-check-mail ()
"Set this to be the 'display-time-mail-function'.
If you want to know about updates this is the function to use."
(interactive)
(save-excursion
(if (get-buffer "mail-folders")
(with-current-buffer (get-buffer "mail-folders")
(if imapua-connection
(condition-case cause
(progn
(imapua-refresh-folder-list)
(imapua-has-recent-p "INBOX"))
(error
(if imapua-connection
(setq imapua-connection nil)))))))))
(defun imapua-mode ()
"A mail user agent based on IMAP folders.
You can open many folders and messages simultaneously. Folders can be
expanded and contracted.
The keys defined are:
\\{imapua-mode-map}"
(interactive)
(kill-all-local-variables)
(unless imapua-mode-map
(setq imapua-mode-map (make-sparse-keymap))
(define-key imapua-mode-map "\r" 'imapua-open)
(define-key imapua-mode-map "+" 'imapua-create-folder)
(define-key imapua-mode-map "/" 'isearch-forward-regexp)
(define-key imapua-mode-map "B" 'bury-buffer)
(define-key imapua-mode-map "K" 'imapua-kill-folder)
(define-key imapua-mode-map "X" 'imapua-spam)
(define-key imapua-mode-map "d" 'imapua-delete)
(define-key imapua-mode-map "g" 'imapua-redraw)
(define-key imapua-mode-map "n" 'next-line)
(define-key imapua-mode-map "m" 'imapua-move)
(define-key imapua-mode-map "p" 'previous-line)
(define-key imapua-mode-map "s" 'imapua-send-mail)
(define-key imapua-mode-map "S" 'imapua-show-structure)
(define-key imapua-mode-map "u" 'imapua-undelete)
(define-key imapua-mode-map "x" 'imapua-expunge))
(use-local-map imapua-mode-map)
(put 'imapua-mode 'mode-class 'special)
(setq mode-name "IMAP-UA")
(setq major-mode 'imapua-mode)
(setq buffer-read-only 't)
(make-local-variable 'imapua-mode-initialized-p)
(setq imapua-mode-initialized-p 't)
(make-local-variable 'paragraph-start)
(setq paragraph-start "^[A-Za-z0-9]")
(buffer-disable-undo)
(make-local-variable 'kill-buffer-hook)
(add-hook 'kill-buffer-hook 'imapua-kill-buffer-hook)
(make-local-variable 'imapua-connection)
(make-local-variable 'imapua-username)
(make-local-variable 'imapua-password)
(run-hooks 'imapua-mode-hook))
(define-derived-mode imapua-message-mode message-mode "IMAP UA Message" "IMPAUA Msg \\{imapua-message-mode-map}"
(unless imapua-message-keymap-initializedp
(define-key imapua-message-mode-map "\r" 'imapua-message-open-attachment)
(define-key imapua-message-mode-map "a" 'message-wide-reply)
(define-key imapua-message-mode-map "r" 'message-reply)
(setq imapua-message-keymap-initializedp 't))
(put 'imapua-message-mode 'mode-class 'special)
(make-local-variable 'paragraph-start)
(setq paragraph-start paragraph-separate)
(setq buffer-read-only 't)
(run-hooks 'imapua-message-mode-hook))
(defun imapua-show-structure (folder-name uid)
(interactive (list (get-text-property (point) 'FOLDER)
(get-text-property (point) 'UID)))
(imap-mailbox-select folder-name nil imapua-connection)
(imap-fetch uid "(BODYSTRUCTURE)" 't nil imapua-connection)
(print (imap-message-get uid 'BODYSTRUCTURE imapua-connection))
)
(defun imapua-open ()
"expand/contract the folder or open the message that point is on.
Messages are opened with the first found text part displayed. If
a message has no text part then there will just be a list of
other parts.
The position between the header and the message text is marked with
the buffer local variable @var{imapua-message-text-end-of-headers}."
(interactive)
(imapua-ensure-connected)
(beginning-of-line)
(if (looking-at "^[^ \t\n\r]+")
(let ((folder-name (match-string-no-properties 0)))
(if (imap-mailbox-get 'OPENED folder-name imapua-connection)
(imap-mailbox-put 'OPENED nil folder-name imapua-connection)
(imap-mailbox-put 'OPENED 't folder-name imapua-connection))
(imapua-redraw))
(let ((msg nil)
(folder-name (get-text-property (point) 'FOLDER))
(uid (get-text-property (point) 'UID)))
(setq msg (cons uid (imapua-date-format
(imap-message-envelope-date uid imapua-connection))))
(imap-message-flags-add (number-to-string uid) "\\Seen" nil imapua-connection)
(imapua-msg-redraw (current-buffer) folder-name msg)
(imapua-message-open folder-name uid))))
(defun imapua-message-open (folder-name uid)
(interactive "Mfolder-name:\nnUid:")
(defun lookup (key lst)
"Find the value following the key, eg:
(lookup 'nic '(bob 12 fred 73 mike 18 nic 34 jim 22))
=> 34"
(if (member key lst)
(cadr (member key lst))))
(imap-mailbox-select folder-name nil imapua-connection)
(imap-fetch uid "(BODYSTRUCTURE ENVELOPE RFC822.HEADER)" 't nil imapua-connection)
(let* ((buf (let ((buf-name (concat "message-" folder-name "-" (number-to-string uid))))
(when (get-buffer buf-name)
(switch-to-buffer buf-name)
(error "imapua: message already opened"))
(get-buffer-create buf-name)))
(bs-def (imap-message-get uid 'BODYSTRUCTURE imapua-connection))
(bs (imapua-parse-bs bs-def))
(parts (imapua-bs-to-part-list bs))
(text-part (if parts
(imapua-part-list-assoc 'type '(("text" . "plain")) parts)
bs)))
(let ((hdr (imap-message-get uid 'RFC822.HEADER imapua-connection)))
(with-current-buffer buf
(insert hdr)
(subst-char-in-region (point-min) (point-max) ?\r ?\ )
(message-sort-headers)
(make-local-variable 'imapua-message-text-end-of-headers)
(setq imapua-message-text-end-of-headers (point))
(put 'imapua-message-text-end-of-headers 'permanent-local 't)
(insert "--text follows this line--\n\n")))
(when text-part
(imapua-message-fill-text uid (if text-part text-part bs) buf))
(save-excursion
(switch-to-buffer buf)
(set-buffer-modified-p nil)
(goto-char imapua-message-text-end-of-headers)
(imapua-message-mode))
(imapua-part-list-display imapua-connection folder-name uid buf parts)
))
(defun imapua-part-list-display (connection folder uid buffer part-list)
"Display the list of parts."
(defun mime-to-string (mimetypeheader)
(if (listp mimetypeheader)
(concat (car (car mimetypeheader))
"/"
(cdr (car mimetypeheader)))
mimetypeheader))
(with-current-buffer buffer
(make-local-variable 'imapua-connection)
(setq imapua-connection connection)
(let ((buffer-read-only nil))
(save-excursion
(goto-char (point-max))
(insert "\n\n--attachment links follows this line--\n\n")
(mapc (lambda (part)
(let ((partnum (cdr (assoc 'partnum part)))
(name (lookup "name" (cadr (assoc 'body part)))))
(if (> (- (point) (line-beginning-position)) 72)
(insert "\n"))
(let ((pt (point)))
(insert "Attached:"
(if name
(concat "'" name "' {" (mime-to-string (cdr (assoc 'type part))) "}")
(mime-to-string (cdr (assoc 'type part))))
"[" partnum "]\t")
(add-text-properties pt (point) `(PARTNUM ,partnum FOLDER ,folder UID ,uid)))))
part-list)
(set-buffer-modified-p nil)))))
(defun imapua-message-fill-text (uid text-part buffer)
"Insert the text-part for rhe specified uid in the buffer provided."
(imap-fetch uid
(format "(BODY[%s])" (or (cdr (assoc 'partnum text-part)) "1"))
't nil imapua-connection)
(let* ((transfer-encoding (cadr (assoc 'transfer-encoding text-part)))
(body-details (cadr (assoc 'body text-part)))
(charset (lookup "charset" body-details))
(start-of-body 0)
(body (elt (car (imap-message-get uid 'BODYDETAIL imapua-connection)) 2)))
(save-excursion
(switch-to-buffer buffer)
(setq start-of-body (point))
(insert (imapua-decode-string body
transfer-encoding
(cond
((and (equal charset "us-ascii")
(equal transfer-encoding "8bit")) 'utf-8)
(charset charset)
('t 'emacs-mule)))))))
(defun imapua-message-open-attachment ()
(interactive)
(let ((folder-name (get-text-property (point) 'FOLDER))
(uid (get-text-property (point) 'UID))
(partnum (get-text-property (point) 'PARTNUM)))
(imapua-message-open-part folder-name uid partnum imapua-connection)))
(defun imapua-message-open-part (folder-name uid partnum &optional imap-con)
"open the specified part.
This may have a problem with non-multipart parts but it's not
really for them. IMAPUA uses it to open attachments from
multipart messages.
In IMAPUA the imap connection is obtained through the
buffer. Programs can pass the imap-con in directly though."
(interactive "MFolder-name:\nnUid:\nMPart:")
(or imap-con (setq imap-con imapua-connection))
(imap-mailbox-select folder-name nil imap-con)
(imap-fetch uid (format "(BODY[%s])" partnum) 't nil imap-con)
(imap-fetch uid "(BODYSTRUCTURE)" 't nil imap-con)
(let ((multipart (imapua-parse-bs (imap-message-get uid 'BODYSTRUCTURE imap-con))))
(let* ((msg-buffer (current-buffer))
(part-list (imapua-bs-to-part-list multipart))
(part (imapua-part-list-assoc 'partnum partnum part-list))
(mimetype (cadr (assoc 'type part)))
(start-of-body 0)
(mimetype-str (concat (car mimetype) "/" (cdr mimetype)))
(buffer (get-buffer-create "*attached*")))
(switch-to-buffer buffer)
(setq start-of-body (point))
(mailcap-parse-mailcaps)
(let ((mailcap-viewer
(if (equal mimetype-str "application/octet-stream")
(concat (read-from-minibuffer
(format "open %s with:" mimetype-str))
" %s")
(mailcap-mime-info mimetype-str)))
(mailcap-ext-pattern (mailcap-mime-info mimetype-str "nametemplate")))
(defun string-replace (re replace string)
(string-match re string)
(replace-match replace nil nil string))
(if mailcap-viewer
(progn
(imapua-attachment-emacs-handle)
(kill-buffer buffer))
(insert (imapua-decode-string
(elt (car (imap-message-get uid 'BODYDETAIL imap-con)) 2)
(cadr (assoc 'transfer-encoding part))
(lookup "charset" (cadr (assoc 'body part)))))
(normal-mode)
(set-buffer-modified-p nil)
(goto-char (point-min)))))))
(defun imapua-attachment-emacs-handle ()
"Handle an attachment with some inline emacs viewer"
(let ((charset (or (lookup "charset" (cadr (assoc 'body part)))
(progn (set-buffer-multibyte nil)
'no-conversion)))
(enc (cadr (assoc 'transfer-encoding part)))
(fname (if mailcap-ext-pattern
(string-replace "%" (make-temp-file "imapua") mailcap-ext-pattern)
(make-temp-file "imapua"))))
(defun split-string-into-cons (str)
"Splits the string into a cons cell."
(let ((matchpt (string-match split-string-default-separators str)))
(cons (substring str 0 matchpt)
(list (substring str (- (match-end 0) 1))))))
(insert (imapua-decode-string
(elt (car (imap-message-get uid 'BODYDETAIL imap-con)) 2)
enc charset))
(write-region (point-min) (point-max) fname)
(setq buffer-file-name fname)
(if (functionp mailcap-viewer)
(if (string-match "[a-zA-Z0-9-]+-mode$" (symbol-name mailcap-viewer))
(with-current-buffer buffer
(funcall mailcap-viewer))
(funcall mailcap-viewer buffer))
(let* ((proc-buf (generate-new-buffer "*imapua-attachment*"))
(proc (apply 'start-process-shell-command
`("*imapua*" ,proc-buf
,@(split-string (format mailcap-viewer fname)) )) ))
(set-process-sentinel proc 'imapua-attachment-sentinel)))))
(defun imapua-attachment-sentinel (process event)
"Sentinel monitors attachement processes"
(let ((buf (process-buffer process))
(state (process-status process)))
(if (and (not (eq state 'run))
(not (eq state 'stop))
(< (buffer-size buf) 1))
(kill-buffer buf)
(switch-to-buffer buf))))
(defun imapua-decode-string (content transfer-encoding char-encoding)
"Decode the specified content string."
(let* ((transfer-enc (if transfer-encoding
(upcase transfer-encoding)
'NONE))
(char-enc (let ((encoding
(if char-encoding
(intern (downcase
(if (stringp char-encoding)
char-encoding
(symbol-name char-encoding))))
char-encoding)))
(if (and encoding (memq encoding coding-system-list))
encoding
'no-conversion))))
(cond
((equal transfer-enc "QUOTED-PRINTABLE")
(decode-coding-string
(quoted-printable-decode-string
(replace-regexp-in-string "\r" "" content))
char-enc))
((equal transfer-enc "BASE64")
(decode-coding-string (base64-decode-string content) char-enc))
('t
(decode-coding-string content char-enc)))))
(defvar imapua-message-date-regex
"[0-9]\\{1,4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} "
"Regex for matching an imapua message date")
(defvar imapua-message-time-regex
"\\(\\([0-9][\t ]\\)\\|\\([0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\)\\)"
"Regex for matching an imapua message time")
(defvar imapua-message-line-regex
(concat "^[\t ]+"
imapua-message-date-regex
imapua-message-time-regex
"[\t ]+\\([^\t\n ]+\\)"
"[\t ]+\\([^\t\n]+\\)$")
"Regex for matching an imapua message.
Broadly this is: date time from subject")
(defun imapua-send-mail ()
"send a mail.
The mail is BCCed to the sender if the option:
imapua-bcc-to-sender
is set to true."
(interactive)
(message-mail))
(defun imapua-mark-regex (regex)
"Mark a message for some other operation"
(interactive "Mregex to match message lines: ")
(save-excursion
(goto-char (imapua-beginning-of-folder (get-text-property (point) 'FOLDER)))
(while (re-search-forward regex nil 't)
(progn
(let ((inhibit-read-only 't))
(add-text-properties
(point-at-bol)
(point-at-eol)
`(marked t
face (foreground-color . ,imapua-marked-message-color))))))))
(defun imapua-beginning-of-folder (folder-name)
"Find the folder and move point to the start of it"
(beginning-of-buffer)
(re-search-forward (concat "^" folder-name " $")))
(defun imapua-delete-marked ()
"Delete messages that have been marked in the current folder."
(interactive)
(save-excursion
(let ((folder-name (get-text-property (point) 'FOLDER)))
(imapua-beginning-of-folder folder-name)
(imap-mailbox-select folder-name nil imapua-connection)
(while (re-search-forward imapua-message-line-regex nil 't)
(progn
(if (get-text-property (point-at-bol) 'marked)
(let ((uid (get-text-property (point-at-bol) 'UID)))
(imap-fetch uid "(ENVELOPE)" 't nil imapua-connection)
(imap-message-copy (number-to-string uid) imapua-trash-folder-name 't 't imapua-connection)
(imap-message-flags-add (number-to-string uid) "\\Deleted" nil imapua-connection)
(let ((msg (cons uid
(imapua-date-format
(imap-message-envelope-date uid imapua-connection)))))
(imapua-msg-redraw (current-buffer) folder-name msg)))))))))
(defun imapua-undelete (folder-name uid)
"undelete a message.
When called interactively the folder-name and uid are obtained from
the text properties of whatever is at (point)."
(interactive (list (get-text-property (point) 'FOLDER)
(get-text-property (point) 'UID)))
(imapua-ensure-connected)
(imap-mailbox-select folder-name nil imapua-connection)
(imap-fetch uid "(ENVELOPE)" 't nil imapua-connection)
(imap-message-flags-del (number-to-string uid) "\\Deleted" nil imapua-connection)
(let ((msg (cons uid
(imapua-date-format
(imap-message-envelope-date uid imapua-connection)))))
(imapua-msg-redraw (current-buffer) folder-name msg)))
(defun imapua-delete (folder-name uid)
"delete a message.
When called interactively the folder-name and uid are obtained from
the text properties of whatever is at (point)."
(interactive (list (get-text-property (point) 'FOLDER)
(get-text-property (point) 'UID)))
(beginning-of-line)
(imapua-ensure-connected)
(imap-mailbox-select folder-name nil imapua-connection)
(imap-fetch uid "(ENVELOPE)" 't nil imapua-connection)
(imap-message-copy (number-to-string uid) imapua-trash-folder-name 't 't imapua-connection)
(imap-message-flags-add (number-to-string uid) "\\Deleted" nil imapua-connection)
(let ((msg (cons uid
(imapua-date-format
(imap-message-envelope-date uid imapua-connection)))))
(imapua-msg-redraw (current-buffer) folder-name msg)))
(defun imapua-spam (folder-name uid)
"Move the message to a .Spam folder.
The Spam folder name is obtained from IMAPUA-SPAM-FOLDER-NAME
which can be customized."
(interactive (list (get-text-property (point) 'FOLDER)
(get-text-property (point) 'UID)))
(imapua-move folder-name uid imapua-spam-folder-name))
(defun imapua-move (folder-name uid to-folder)
"move a message from one folder to another."
(interactive
(let ((dest-folder
(completing-read
"Folder name: "
(mapcar
(lambda (folder-name)
(cons folder-name 't)) imapua-folder-list)
nil nil imapua-initial-folder-name 'imapua-folder-history)))
(list (get-text-property (point) 'FOLDER)
(get-text-property (point) 'UID)
dest-folder)))
(imapua-ensure-connected)
(imap-mailbox-select folder-name nil imapua-connection)
(imap-fetch uid "(ENVELOPE)" 't nil imapua-connection)
(imap-message-copy (number-to-string uid) to-folder 't 't imapua-connection)
(imapua-delete folder-name uid))
(defun imapua-expunge (folder-name doit)
"expunges the current folder.
This ensures that deleted messages are removed from the obarray."
(interactive (list (get-text-property (point) 'FOLDER)
(y-or-n-p "Expunge current folder?")))
(imapua-ensure-connected)
(if folder-name
(imap-mailbox-select folder-name nil imapua-connection))
(imap-mailbox-expunge 't imapua-connection)
(imap-mailbox-unselect imapua-connection)
(imapua-redraw))
(defun imapua-extract-folder-name (&optional pt)
"Extract the folder-name from the current line."
(save-excursion
(if pt
(goto-char pt))
(buffer-substring-no-properties
(line-beginning-position)
(save-excursion
(search-forward " " (line-end-position))))))
(defun imapua-create-folder (new-folder-name)
"create a new folder under the specified parent folder."
(interactive (list (completing-read
"New folder name: "
(mapcar
(lambda (folder-name)
(cons folder-name 't)) imapua-folder-list))))
(imap-mailbox-create new-folder-name imapua-connection)
(imap-mailbox-list "*" "" "." imapua-connection)
(imapua-redraw))
(defun imapua-kill-folder (folder-name)
"kill the folder at point"
(interactive (let* ((folder (imapua-extract-folder-name))
(confirm (y-or-n-p (concat "Delete folder " folder))))
(if confirm (list folder))))
(if folder-name
(progn
(imap-mailbox-delete folder-name imapua-connection)
(imap-mailbox-list "*" "" "." imapua-connection)
(imapua-redraw))))
(defun imapua-logout ()
"logout the mail server connection"
(interactive)
(if imapua-connection
(imap-close imapua-connection))
(setq imapua-connection nil))
(defun imapua-redraw ()
"redraw the buffer based on the imap state.
Opened folders have their messages re-read and re-drawn."
(interactive)
(defun insert-with-prop (text prop-list)
(let ((pt (point)))
(insert text)
(add-text-properties pt (point) prop-list)))
(imapua-ensure-connected)
(let ((stored-pos (point-marker))
(inhibit-read-only 't)
(display-buffer (current-buffer)))
(delete-region (point-min) (point-max))
(imapua-refresh-folder-list)
(mapc
(lambda (folder-name)
(with-current-buffer display-buffer
(insert-with-prop folder-name `(face (foreground-color . ,imapua-folder-color)))
(if (imapua-has-recent-p folder-name)
(insert-with-prop " * " `(face (foreground-color . ,imapua-unseen-message-color))))
(insert " \n")
(if (imap-mailbox-get 'OPENED folder-name imapua-connection)
(let* ((selection
(progn
(imap-mailbox-unselect imapua-connection)
(imap-mailbox-select folder-name nil imapua-connection)))
(existing (imap-mailbox-get 'exists folder-name imapua-connection))
(message-range (concat "1:" (number-to-string existing))))
(imap-fetch message-range "(UID FLAGS ENVELOPE)" nil 't imapua-connection)
(mapc
(lambda (msg)
(let ((msg-redraw-func (imapua-get-msg-redraw-func folder-name)))
(funcall msg-redraw-func display-buffer folder-name msg)))
(sort
(imap-message-map
(lambda (uid property)
(cons uid
(condition-case nil
(timezone-make-date-sortable (imapua-date-format (elt property 0)) "GMT" "GMT")
(range-error nil))))
'ENVELOPE imapua-connection)
(lambda (left right)
(string< (cdr left) (cdr right)))))
(insert "\n")))))
imapua-folder-list)
(goto-char stored-pos)))
(defun imapua-get-msg-redraw-func (folder-name)
'imapua-msg-redraw)
(defun imapua-msg-redraw (display-buffer folder-name msg)
"redraw a single message line.
msg is a dotted pair such that:
( uid . msg-date )"
(with-current-buffer display-buffer
(let* ((inhibit-read-only 't)
(uid (car msg))
(date (imapua-date-format (imap-message-envelope-date uid imapua-connection)))
(from-addr
(imapua-from-format
(let ((env-from (imap-message-envelope-from uid imapua-connection)))
(if (consp env-from)
(car env-from)
`("-" "unknown email" "-" "-")))))
(subject
(imapua-field-format 1 (imap-message-envelope-subject uid imapua-connection) 't))
(line-start (point))
(color (cond
((imapua-deletedp uid) imapua-deleted-message-color)
((not (imapua-seenp uid)) imapua-unseen-message-color)
(t 'black))))
(beginning-of-line)
(if (> (- (line-end-position) (point)) 0)
(progn
(delete-region (line-beginning-position) (line-end-position))
(delete-char 1)))
(insert
" " (imapua-field-format 20 date)
" " (imapua-field-format 30 from-addr)
" " subject "\n")
(add-text-properties line-start (point)
`(UID ,uid FOLDER ,folder-name
face (foreground-color . ,color))))))
(add-hook 'kill-emacs (lambda () (imapua-logout)))
(provide 'imapua)