+Fri Nov 5 19:10:02 1999 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
+
+ * gnus.el: Pterodactyl Gnus v0.98 is released.
+
+1999-11-05 01:27:49 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-agent.el (gnus-agent-expire): Remove bad line in NOV.
+
+1999-11-04 22:20:35 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * mml.el (mml-generate-mime-1): Read attached binary file in
+ binary mode.
+
+1999-11-03 16:08:56 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-sum.el (gnus-summary-toggle-header): Fix arg bug.
+
+1999-11-03 15:27:38 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * mailcap.el (mailcap-viewer-lessp): Fix bug.
+
+1999-11-02 17:28:33 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-sum.el (gnus-summary-search-article): Fix loop search bug.
+
+1999-10-31 21:24:59 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-art.el (gnus-article-mime-match-handle-first): New function.
+ (gnus-article-mime-match-handle-function): New variable.
+ (gnus-article-view-part): Make `b' customizable.
+
+1999-10-29 14:30:07 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-sum.el (gnus-article-get-xrefs): Test eobp.
+
+1999-09-27 Hrvoje Niksic <hniksic@srce.hr>
+
+ * mm-decode.el (mm-attachment-override-types): Exclude text/plain.
+
+1999-10-26 23:27:44 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * mm-decode.el (mm-dissect-buffer): CTE may come without CTL.
+
+1999-10-26 21:44:05 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-srvr.el (gnus-browse-foreign-server): Use
+ `buffer-substring' instead of `read'.
+
+1999-10-23 Simon Josefsson <jas@pdc.kth.se>
+
+ * nnimap.el, imap.el, rfc2104.el: New files.
+
+ * gnus.el (gnus-valid-select-methods): Add nnimap.
+
+ * gnus-group.el (gnus-group-group-map): Add
+ gnus-group-nnimap-edit-acl, gnus-group-nnimap-expunge.
+ (gnus-group-nnimap-expunge): New function.
+ (gnus-group-nnimap-edit-acl): New function.
+
+ * gnus-agent.el (gnus-agent-group-mode-map): Add
+ gnus-agent-synchronize.
+ (gnus-agent-synchronize): New function.
+ (gnus-agent-fetch-group-1): Check if server is open.
+
+ * nnagent.el (nnagent-request-set-mark): Save marks.
+
+ * mail-source.el (mail-source-keyword-map): New imap mail-source.
+ (mail-source-fetcher-alist): Map to imap fetcher function.
+ (mail-source-fetch-imap): New function.
+
+ * gnus-art.el (article-hide-pgp): Hide all headers, not just
+ Hash:.
+
+1999-10-22 11:03:00 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-topic.el (gnus-topic-sort-topics-1): New function.
+ (gnus-topic-sort-topics): New function.
+ (gnus-topic-make-menu-bar): Add sort-topics.
+ (gnus-topic-move): New function.
+ (gnus-topic-move-group): Move the topic if no group selected.
+
+1999-10-13 21:31:50 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-art.el (gnus-article-setup-buffer): Fix buffer leak.
+
+1999-10-13 12:52:18 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * mm-view.el (mm-inline-message): Fix leaving group bug.
+
+1999-10-07 17:59:49 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-msg.el (gnus-post-method): Use normal method if current is
+ not available.
+
+1999-10-07 17:09:34 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * nnmail.el (nnmail-insert-xref): Dealing with empty articles.
+ (nnmail-insert-lines): Ditto.
+
+1999-10-07 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * nnfolder.el (nnfolder-insert-newsgroup-line): Insert a blank
+ line.
+
+ * message.el (message-unsent-separator): One more separator.
+
+1999-10-06 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * nnfolder.el (nnfolder-request-move-article): For empty article,
+ search till (point-max).
+ (nnfolder-retrieve-headers): Ditto.
+ (nnfolder-request-accept-article): Ditto.
+ (nnfolder-save-mail): Ditto.
+ (nnfolder-insert-newsgroup-line): Ditto.
+
+1999-10-05 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * qp.el (quoted-printable-encode-region): Check eobp.
+
+1999-10-03 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * nntp.el (nntp-retrieve-headers-with-xover): Fix hanging problem.
+
+1999-10-02 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * nntp.el (nntp-send-xover-command): Wait for nothing if not
+ wait-for-reply.
+
+1999-09-29 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * mm-uu.el (mm-uu-forward-begin-line): Change the regexp.
+ (mm-uu-forward-end-line): Ditto.
+
+1999-09-29 Didier Verna <verna@inf.enst.fr>
+
+ * binhex.el (binhex-decode-region): don't consider the value of
+ `enable-multibyte-characters' in XEmacs.
+
+ * gnus-start.el (gnus-read-descriptions-file): ditto.
+
+ * mm-util.el (mm-multibyte-p): ditto.
+ (mm-with-unibyte-buffer): ditto.
+ (mm-find-charset-region): use `mm-multibyte-p'.
+
+ * mm-bodies.el (mm-decode-body): ditto.
+ (mm-decode-string): ditto.
+
+ * lpath.el ((string-match "XEmacs" emacs-version)): Don't define
+ `enable-multibyte-characters' in XEmacs.
+
+1999-09-29 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * mm-util.el (mm-binary-coding-system): Try binary first.
+
+1999-09-14 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * rfc1843.el (rfc1843-decode-article-body): Don't decode twice.
+
+1999-09-10 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-art.el (article-make-date-line): Add time-zone in iso8601
+ format.
+ (article-date-ut): Find correct insert position.
+
+1999-09-03 Shenghuo ZHU <zsh@cs.rochester.edu>
+
+ * mm-uu.el (mm-uu-dissect): Do not dissect quoted-printable
+ forwarded message.
+
+1999-09-27 20:33:41 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-topic.el (gnus-topic-find-groups): Work for unactivated
+ groups.
+
+ * message.el (message-resend): Use message mode when prompting.
+
+ * gnus-art.el (article-hide-headers): Mark wash.
+ (article-emphasize): Ditto.
+
+1999-09-27 19:52:14 Vladimir Volovich <vvv@vvv.vsu.ru>
+
+ * message.el (message-newline-and-reformat): Work for SC.
+
+1999-09-27 19:38:33 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-msg.el (gnus-group-posting-charset-alist): 2047 in de.*.
+
+ * gnus-sum.el (gnus-newsgroup-ignored-charsets): Add x-unknown.
+
+>>>>>>> 5.100
Mon Sep 27 15:18:05 1999 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
* gnus.el: Pterodactyl Gnus v0.97 is released.
* gnus-art.el (gnus-treat-predicate): Work for (not 5).
-1999-08-27 Peter von der Ahé <pahe@daimi.au.dk>
+1999-08-27 Peter von der Ah
\e-Aé <pahe@daimi.au.dk>
\e$)A
* message.el (message-send): More helpful error message if sending
fails
* gnus-agent.el (gnus-agent-get-undownloaded-list): Don't
mark cached articles as `undownloaded'.
-Tue Jul 20 02:39:56 1999 Peter von der Ahé <peter@ahe.dk>
+Tue Jul 20 02:39:56 1999 Peter von der Ah
\e-Aé <peter@ahe.dk>
\e$)A
* gnus-sum.el (gnus-summary-exit): Allow gnus-use-adaptive-scoring
to have buffer local values.
* mm-uu.el (mm-uu-dissect): Use mm-make-handle.
-1998-12-01 01:53:49 François Pinard <pinard@iro.umontreal.ca>
+1998-12-01 01:53:49 Fran
\e-Açois Pinard <pinard@iro.umontreal.ca>
\e$)A
* nndoc.el (nndoc-mime-parts-type-p): Do related.
* rfc2047.el (rfc2047-q-encode-region): Would bug out.
-1998-09-13 François Pinard <pinard@iro.umontreal.ca>
+1998-09-13 Fran
\e-Açois Pinard <pinard@iro.umontreal.ca>
\e$)A
* nndoc.el: Make nndoc-dissection-alist simpler for MIME, adjust all
related functions. Handle message/rfc822 parts. Display subject on
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Create Date: Oct 1, 1998
-;; $Revision: 1.1.1.10 $
+;; $Revision: 1.1.1.11 $
;; Time-stamp: <Tue Oct 6 23:48:38 EDT 1998 zsh>
;; Keywords: binhex
(save-excursion
(goto-char start)
(when (re-search-forward binhex-begin-line end t)
- (if (boundp 'enable-multibyte-characters)
+ (if (and (not (string-match "XEmacs\\|Lucid" emacs-version))
+ (boundp 'enable-multibyte-characters))
(let ((multibyte
(default-value 'enable-multibyte-characters)))
(setq-default enable-multibyte-characters nil)
- (setq work-buffer
- (generate-new-buffer " *binhex-work*"))
+ (setq work-buffer (generate-new-buffer " *binhex-work*"))
(setq-default enable-multibyte-characters multibyte))
(setq work-buffer (generate-new-buffer " *binhex-work*")))
(buffer-disable-undo work-buffer)
"Jc" gnus-enter-category-buffer
"Jj" gnus-agent-toggle-plugged
"Js" gnus-agent-fetch-session
+ "JY" gnus-agent-synchronize
"JS" gnus-group-send-drafts
"Ja" gnus-agent-add-group
"Jr" gnus-agent-remove-group)
(setf (cadddr c) (delete group (cadddr c))))))
(gnus-category-write)))
+(defun gnus-agent-synchronize ()
+ "Synchronize local, unplugged, data with backend.
+Currently sends flag setting requests, if any."
+ (interactive)
+ (save-excursion
+ (dolist (gnus-command-method gnus-agent-covered-methods)
+ (when (file-exists-p (gnus-agent-lib-file "flags"))
+ (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*"))
+ (erase-buffer)
+ (insert-file-contents (gnus-agent-lib-file "flags"))
+ (if (null (gnus-check-server gnus-command-method))
+ (message "Couldn't open server %s" (nth 1 gnus-command-method))
+ (while (not (eobp))
+ (if (null (eval (read (current-buffer))))
+ (progn (forward-line)
+ (kill-line -1))
+ (write-file (gnus-agent-lib-file "flags"))
+ (error "Couldn't set flags from file %s"
+ (gnus-agent-lib-file "flags"))))
+ (write-file (gnus-agent-lib-file "flags")))))))
+
;;;
;;; Server mode commands
;;;
gnus-newsgroup-scored gnus-headers gnus-score
gnus-use-cache articles arts
category predicate info marks score-param)
+ (unless (gnus-check-group group)
+ (error "Can't open server for %s" group))
;; Fetch headers.
(when (and (or (gnus-active group) (gnus-activate-group group))
(setq articles (gnus-agent-fetch-headers group))
(or (not (numberp
(setq art (read (current-buffer)))))
(< art article)))
- (if (file-exists-p
- (gnus-agent-article-name
- (number-to-string art) group))
+ (if (and (numberp art)
+ (file-exists-p
+ (gnus-agent-article-name
+ (number-to-string art) group)))
(progn
(unless lowest
(setq lowest art))
:group 'gnus-article-headers
:type 'boolean)
+(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
+ "Function called with a MIME handle as the argument.
+This is meant for people who want to view first matched part.
+For `undisplayed-alternative' (default), the first undisplayed
+part or alternative part is used. For `undisplayed', the first
+undisplayed part is used. For a function, the first part which
+the function return `t' is used. For `nil', the first part is
+used."
+ :group 'gnus-article-mime
+ :type '(choice
+ (item :tag "first" :value nil)
+ (item :tag "undisplayed" :value undisplayed)
+ (item :tag "undisplayed or alternative"
+ :value undisplayed-alternative)
+ (function)))
+
;;;
;;; The treatment variables
;;;
(when (setq beg (text-property-any
(point-min) (point-max) 'message-rank (+ 2 max)))
;; We delete the unwanted headers.
+ (push 'headers gnus-article-wash-types)
(add-text-properties (point-min) (+ 5 (point-min))
'(article-type headers dummy-invisible t))
(delete-region beg (point-max))))))))
(when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
(push 'pgp gnus-article-wash-types)
(delete-region (match-beginning 0) (match-end 0))
- ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too
- (when (looking-at "Hash:.*$")
- (delete-region (point) (1+ (gnus-point-at-eol))))
+ ;; Remove armor headers (rfc2440 6.2)
+ (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t)
+ (point)))
(setq beg (point))
;; Hide the actual signature.
(and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
(date (if (vectorp header) (mail-header-date header)
header))
(inhibit-point-motion-hooks t)
- (newline t)
+ pos
bface eface)
(when (and date (not (string= date "")))
(save-excursion
(let ((buffer-read-only nil))
;; Delete any old Date headers.
(while (re-search-forward date-regexp nil t)
- (if newline
+ (if pos
(delete-region (progn (beginning-of-line) (point))
- (progn (end-of-line) (point)))
+ (progn (forward-line 1) (point)))
(delete-region (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point))))
- (setq newline nil))
- (when (re-search-forward tdate-regexp nil t)
+ (progn (end-of-line) (point)))
+ (setq pos (point))))
+ (when (and (not pos) (re-search-forward tdate-regexp nil t))
(forward-line 1))
+ (if pos (goto-char pos))
(insert (article-make-date-line date (or type 'ut)))
- (when newline
+ (when (not pos)
(insert "\n")
(forward-line -1))
;; Do highlighting.
(format-time-string gnus-article-time-format time))))
;; ISO 8601.
((eq type 'iso8601)
- (concat
- "Date: "
- (format-time-string "%Y%m%dT%H%M%S" time)))
+ (let ((tz (car (current-time-zone time))))
+ (concat
+ "Date: "
+ (format-time-string "%Y%m%dT%H%M%S" time)
+ (format "%s%02d%02d"
+ (if (> tz 0) "+" "-") (/ (abs tz) 3600)
+ (/ (% (abs tz) 3600) 60)))))
;; Do an X-Sent lapsed format.
((eq type 'lapsed)
;; If the date is seriously mangled, the timezone functions are
face (nth 3 elem))
(while (re-search-forward regexp nil t)
(when (and (match-beginning visible) (match-beginning invisible))
+ (push 'emphasis gnus-article-wash-types)
(gnus-article-hide-text
(match-beginning invisible) (match-end invisible) props)
(gnus-article-unhide-text-type
(if (get-buffer name)
(save-excursion
(set-buffer name)
+ (if gnus-article-mime-handles
+ (mm-destroy-parts gnus-article-mime-handles))
(kill-all-local-variables)
(buffer-disable-undo)
(setq buffer-read-only t)
(interactive "p")
(gnus-article-part-wrapper n 'gnus-mime-inline-part))
-(defun gnus-article-view-part (n)
+(defun gnus-article-mime-match-handle-first (condition)
+ (if condition
+ (let ((alist gnus-article-mime-handle-alist) ihandle n)
+ (while (setq ihandle (pop alist))
+ (if (and (cond
+ ((functionp condition)
+ (funcall condition (cdr ihandle)))
+ ((eq condition 'undisplayed)
+ (not (or (mm-handle-undisplayer (cdr ihandle))
+ (equal (mm-handle-media-type (cdr ihandle))
+ "multipart/alternative"))))
+ ((eq condition 'undisplayed-alternative)
+ (not (mm-handle-undisplayer (cdr ihandle))))
+ (t t))
+ (gnus-article-goto-part (car ihandle))
+ (or (not n) (< (car ihandle) n)))
+ (setq n (car ihandle))))
+ (or n 1))
+ 1))
+
+(defun gnus-article-view-part (&optional n)
"View MIME part N, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(save-current-buffer
(set-buffer gnus-article-buffer)
+ (or (numberp n) (setq n (gnus-article-mime-match-handle-first
+ gnus-article-mime-match-handle-function)))
(when (> n (length gnus-article-mime-handle-alist))
(error "No such part"))
(let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
"u" gnus-group-make-useful-group
"a" gnus-group-make-archive-group
"k" gnus-group-make-kiboze-group
+ "l" gnus-group-nnimap-edit-acl
"m" gnus-group-make-group
"E" gnus-group-edit-group
"e" gnus-group-edit-group-method
"w" gnus-group-make-web-group
"r" gnus-group-rename-group
"c" gnus-group-customize
+ "x" gnus-group-nnimap-expunge
"\177" gnus-group-delete-group
[delete] gnus-group-delete-group)
'summary 'group)))
(error "Couldn't enter %s" dir))))
+(eval-and-compile
+ (autoload 'nnimap-expunge "nnimap")
+ (autoload 'nnimap-acl-get "nnimap")
+ (autoload 'nnimap-acl-edit "nnimap"))
+
+(defun gnus-group-nnimap-expunge (group)
+ "Expunge deleted articles in current nnimap GROUP."
+ (interactive (list (gnus-group-group-name)))
+ (let ((mailbox (gnus-group-real-name group)) method)
+ (unless group
+ (error "No group on current line"))
+ (unless (gnus-get-info group)
+ (error "Killed group; can't be edited"))
+ (unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group))))
+ (error "%s is not an nnimap group" group))
+ (nnimap-expunge mailbox (cadr method))))
+
+(defun gnus-group-nnimap-edit-acl (group)
+ "Edit the Access Control List of current nnimap GROUP."
+ (interactive (list (gnus-group-group-name)))
+ (let ((mailbox (gnus-group-real-name group)) method acl)
+ (unless group
+ (error "No group on current line"))
+ (unless (gnus-get-info group)
+ (error "Killed group; can't be edited"))
+ (unless (eq (car (setq method (gnus-find-method-for-group group))) 'nnimap)
+ (error "%s is not an nnimap group" group))
+ (gnus-edit-form (setq acl (nnimap-acl-get mailbox (cadr method)))
+ (format "Editing the access control list for `%s'.
+
+ An access control list is a list of (identifier . rights) elements.
+
+ The identifier string specifies the corresponding user. The
+ identifier \"anyone\" is reserved to refer to the universal identity.
+
+ Rights is a string listing a (possibly empty) set of alphanumeric
+ characters, each character listing a set of operations which is being
+ controlled. Letters are reserved for ``standard'' rights, listed
+ below. Digits are reserved for implementation or site defined rights.
+
+ l - lookup (mailbox is visible to LIST/LSUB commands)
+ r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL,
+ SEARCH, COPY from mailbox)
+ s - keep seen/unseen information across sessions (STORE SEEN flag)
+ w - write (STORE flags other than SEEN and DELETED)
+ i - insert (perform APPEND, COPY into mailbox)
+ p - post (send mail to submission address for mailbox,
+ not enforced by IMAP4 itself)
+ c - create (CREATE new sub-mailboxes in any implementation-defined
+ hierarchy)
+ d - delete (STORE DELETED flag, perform EXPUNGE)
+ a - administer (perform SETACL)" group)
+ `(lambda (form)
+ (nnimap-acl-edit
+ ,mailbox ',method ',acl form)))))
+
;; Group sorting commands
;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
(defcustom gnus-group-posting-charset-alist
'(("^no\\." iso-8859-1)
(message-this-is-mail nil)
+ ("^de\\." nil)
(".*" iso-8859-1)
(message-this-is-news iso-8859-1))
"Alist of regexps (to match group names) and default charsets to be unencoded when posting."
;; Override normal method.
((and (eq gnus-post-method 'current)
(not (eq (car group-method) 'nndraft))
+ (gnus-get-function group-method 'request-post t)
(not arg))
group-method)
((and gnus-post-method
(delete-matching-lines gnus-ignored-newsgroups))
(while (not (eobp))
(ignore-errors
- (push (cons (read cur)
+ (push (cons (let ((p (point)))
+ (skip-chars-forward "^ \t")
+ (buffer-substring p (point)))
(max 0 (- (1+ (read cur)) (read cur))))
groups))
(forward-line))))
(let ((str (buffer-substring
(point) (progn (end-of-line) (point))))
(coding
- (and (boundp 'enable-multibyte-characters)
- enable-multibyte-characters
+ (and (or gnus-xemacs
+ (and (boundp 'enable-multibyte-characters)
+ enable-multibyte-characters))
(fboundp 'gnus-mule-get-coding-system)
(gnus-mule-get-coding-system (symbol-name group)))))
(when coding
(symbol :tag "Charset")))
:group 'gnus-charset)
-(defcustom gnus-newsgroup-ignored-charsets '(unknown-8bit)
+(defcustom gnus-newsgroup-ignored-charsets '(unknown-8bit x-unknown)
"List of charsets that should be ignored.
When these charsets are used in the \"charset\" parameter, the
default charset will be used instead."
(save-restriction
(nnheader-narrow-to-headers)
(goto-char (point-min))
- (when (or (and (eq (downcase (char-after)) ?x)
+ (when (or (and (not (eobp))
+ (eq (downcase (char-after)) ?x)
(looking-at "Xref:"))
(search-forward "\nXref:" nil t))
(goto-char (1+ (match-end 0)))
(require 'gnus-async)
(require 'gnus-art)
(let ((gnus-select-article-hook nil) ;Disable hook.
+ (gnus-article-prepare-hook nil)
(gnus-mark-article-hook nil) ;Inhibit marking as read.
(gnus-use-article-prefetch nil)
(gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay.
(get-buffer-window (current-buffer))
(point))
(forward-line 1)
+ (set-window-point
+ (get-buffer-window (current-buffer))
+ (point))
(set-buffer sum)
(setq point (point)))
;; We didn't find it, so we go to the next article.
(let* ((buffer-read-only nil)
(inhibit-point-motion-hooks t)
hidden e)
- (save-restriction
- (article-narrow-to-head)
- (setq hidden (gnus-article-hidden-text-p 'headers)))
+ (setq hidden
+ (if (numberp arg)
+ (>= arg 0)
+ (save-restriction
+ (article-narrow-to-head)
+ (gnus-article-hidden-text-p 'headers))))
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(delete-region (point-min) (1- (point))))
(save-restriction
(narrow-to-region (point-min) (point))
(article-decode-encoded-words)
- (if (or hidden
- (and (numberp arg) (< arg 0)))
+ (if hidden
(let ((gnus-treat-hide-headers nil)
(gnus-treat-hide-boring-headers nil))
(gnus-treat-article 'head))
(if (member group gnus-zombie-list)
gnus-level-zombie gnus-level-killed))))
(and
- unread ; nil means that the group is dead.
+ info ; nil means that the group is dead.
(<= clevel level)
(>= clevel lowest) ; Is inside the level we want.
(or all
- (if (eq unread t)
+ (if (or (eq unread t)
+ (eq unread nil))
gnus-group-list-inactive-groups
(> unread 0))
(and gnus-list-groups-with-ticked-articles
["Create" gnus-topic-create-topic t]
["Mark" gnus-topic-mark-topic t]
["Indent" gnus-topic-indent t]
+ ["Sort" gnus-topic-sort-topics t]
["Toggle hide empty" gnus-topic-toggle-display-empty-topics t]
["Edit parameters" gnus-topic-edit-parameters t])
["List active" gnus-topic-list-active t]))))
(completing-read "Move to topic: " gnus-topic-alist nil t)))
(let ((groups (gnus-group-process-prefix n))
(topicl (assoc topic gnus-topic-alist))
- (start-group (progn (forward-line 1) (gnus-group-group-name)))
(start-topic (gnus-group-topic-name))
+ (start-group (progn (forward-line 1) (gnus-group-group-name)))
entry)
- (mapcar
- (lambda (g)
- (gnus-group-remove-mark g)
- (when (and
- (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
- (not copyp))
- (setcdr entry (gnus-delete-first g (cdr entry))))
- (nconc topicl (list g)))
- groups)
- (gnus-topic-enter-dribble)
- (if start-group
- (gnus-group-goto-group start-group)
- (gnus-topic-goto-topic start-topic))
- (gnus-group-list-groups)))
+ (if (and (not groups) (not copyp) start-topic)
+ (gnus-topic-move start-topic topic)
+ (mapcar
+ (lambda (g)
+ (gnus-group-remove-mark g)
+ (when (and
+ (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
+ (not copyp))
+ (setcdr entry (gnus-delete-first g (cdr entry))))
+ (nconc topicl (list g)))
+ groups)
+ (gnus-topic-enter-dribble)
+ (if start-group
+ (gnus-group-goto-group start-group)
+ (gnus-topic-goto-topic start-topic))
+ (gnus-group-list-groups))))
(defun gnus-topic-remove-group (&optional arg)
"Remove the current group from the topic."
(interactive "P")
(gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
+(defun gnus-topic-sort-topics-1 (top reverse)
+ (if (cdr top)
+ (let ((subtop
+ (mapcar `(lambda (top)
+ (gnus-topic-sort-topics-1 top ,reverse))
+ (sort (cdr top)
+ '(lambda (t1 t2)
+ (string-lessp (caar t1) (caar t2)))))))
+ (setcdr top (if reverse (reverse subtop) subtop))))
+ top)
+
+(defun gnus-topic-sort-topics (&optional topic reverse)
+ "Sort topics in TOPIC alphabeticaly by topic name.
+If REVERSE, reverse the sorting order."
+ (interactive
+ (list (completing-read "Sort topics in : " gnus-topic-alist nil t
+ (gnus-current-topic))
+ current-prefix-arg))
+ (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
+ gnus-topic-topology)))
+ (gnus-topic-sort-topics-1 topic-topology reverse)
+ (gnus-topic-enter-dribble)
+ (gnus-group-list-groups)
+ (gnus-topic-goto-topic topic)))
+
+(defun gnus-topic-move (current to)
+ "Move the CURRENT topic to TO."
+ (interactive
+ (list
+ (gnus-group-topic-name)
+ (completing-read "Move to topic: " gnus-topic-alist nil t)))
+ (unless (and current to)
+ (error "Can't find topic"))
+ (let ((current-top (cdr (gnus-topic-find-topology current)))
+ (to-top (cdr (gnus-topic-find-topology to))))
+ (unless current-top
+ (error "Can't find topic `%s'" current))
+ (unless to-top
+ (error "Can't find topic `%s'" to))
+ (if (gnus-topic-find-topology to current-top 0) ;; Don't care the level
+ (error "Can't move `%s' to its sub-level" current))
+ (gnus-topic-find-topology current nil nil 'delete)
+ (while (cdr to-top)
+ (setq to-top (cdr to-top)))
+ (setcdr to-top (list current-top))
+ (gnus-topic-enter-dribble)
+ (gnus-group-list-groups)
+ (gnus-topic-goto-topic current)))
+
(provide 'gnus-topic)
;;; gnus-topic.el ends here
(if full-names
(symbol-name sym)
(gnus-group-real-name (symbol-name sym)))
- (cdr (symbol-value sym))
+ (or (cdr (symbol-value sym))
+ (car (symbol-value sym)))
(car (symbol-value sym))))))
hashtb)))
:link '(custom-manual "(gnus)Exiting Gnus")
:group 'gnus)
-(defconst gnus-version-number "0.97"
+(defconst gnus-version-number "0.98"
"Version number for this version of Gnus.")
(defconst gnus-version (format "Pterodactyl Gnus v%s" gnus-version-number)
("nngateway" post-mail address prompt-address physical-address)
("nnweb" none)
("nnlistserv" none)
- ("nnagent" post-mail))
+ ("nnagent" post-mail)
+ ("nnimap" post-mail address prompt-address physical-address))
"*An alist of valid select methods.
The first element of each list lists should be a string with the name
of the select method. The other elements may be the category of
--- /dev/null
+;;; imap.el --- imap library
+;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <jas@pdc.kth.se>
+;; Keywords: mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; imap.el is a elisp library providing an interface for talking to
+;; IMAP servers.
+;;
+;; imap.el is roughly divided in two parts, one that parses IMAP
+;; responses from the server and storing data into buffer-local
+;; variables, and one for utility functions which send commands to
+;; server, waits for an answer, and return information. The latter
+;; part is layered on top of the previous.
+;;
+;; The imap.el API consist of the following functions, other functions
+;; in this file should not be called directly and the result of doing
+;; so are at best undefined.
+;;
+;; Global commands:
+;;
+;; imap-open, imap-opened, imap-authenticate, imap-close,
+;; imap-capability, imap-namespace, imap-error-text
+;;
+;; Mailbox commands:
+;;
+;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox,
+;; imap-current-mailbox-p, imap-search, imap-mailbox-select,
+;; imap-mailbox-examine, imap-mailbox-unselect, imap-mailbox-expunge
+;; imap-mailbox-close, imap-mailbox-create, imap-mailbox-delete
+;; imap-mailbox-rename, imap-mailbox-lsub, imap-mailbox-list
+;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
+;; imap-mailbox-acl-get, imap-mailbox-acl-set, imap-mailbox-acl-delete
+;;
+;; Message commands:
+;;
+;; imap-fetch-asynch, imap-fetch,
+;; imap-current-message, imap-list-to-message-set,
+;; imap-message-get, imap-message-map
+;; imap-message-envelope-date, imap-message-envelope-subject,
+;; imap-message-envelope-from, imap-message-envelope-sender,
+;; imap-message-envelope-reply-to, imap-message-envelope-to,
+;; imap-message-envelope-cc, imap-message-envelope-bcc
+;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
+;; imap-message-body, imap-message-flag-permanent-p
+;; imap-message-flags-set, imap-message-flags-del
+;; imap-message-flags-add, imap-message-copyuid
+;; imap-message-copy, imap-message-appenduid
+;; imap-message-append, imap-envelope-from
+;; imap-body-lines
+;;
+;; It is my hope that theese commands should be pretty self
+;; explanatory for someone that know IMAP. All functions have
+;; additional documentation on how to invoke them.
+;;
+;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
+;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
+;; (NAMESPACE), RFC2359 (UIDPLUS), and the kerberos V4 part of RFC1731
+;; (with use of external program `imtest'). It also take advantage
+;; the UNSELECT extension in Cyrus IMAPD.
+;;
+;; Without the work of John McClary Prevost and Jim Radford this library
+;; would not have seen the light of day. Many thanks.
+;;
+;; This is a transcript of short interactive session for demonstration
+;; purposes.
+;;
+;; (imap-open "my.mail.server")
+;; => " *imap* my.mail.server:0"
+;;
+;; The rest are invoked with current buffer as the buffer returned by
+;; `imap-open'. It is possible to do all without this, but it would
+;; look ugly here since `buffer' is always the last argument for all
+;; imap.el API functions.
+;;
+;; (imap-authenticate "myusername" "mypassword")
+;; => auth
+;;
+;; (imap-mailbox-lsub "*")
+;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
+;;
+;; (imap-mailbox-list "INBOX.n%")
+;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
+;;
+;; (imap-mailbox-select "INBOX.nnimap")
+;; => "INBOX.nnimap"
+;;
+;; (imap-mailbox-get 'exists)
+;; => 166
+;;
+;; (imap-mailbox-get 'uidvalidity)
+;; => "908992622"
+;;
+;; (imap-search "FLAGGED SINCE 18-DEC-98")
+;; => (235 236)
+;;
+;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
+;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...."
+;;
+;; Todo:
+;;
+;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
+;; o Don't use `read' at all (important places already fixed)
+;; o Accept list of articles instead of message set string in most
+;; imap-message-* functions.
+;; o Cyrus IMAPd 1.6.x `imtest' support in the imtest wrapper
+;; o Format-spec'ify the ssl horror
+;;
+;; Revision history:
+;;
+;; - this is unreleased software
+;;
+
+;;; Code:
+
+(eval-and-compile
+ (require 'cl)
+ (autoload 'open-ssl-stream "ssl")
+ (autoload 'base64-decode-string "base64")
+ (autoload 'rfc2104-hash "rfc2104")
+ (autoload 'md5 "md5")
+ (autoload 'utf7-encode "utf7")
+ (autoload 'utf7-decode "utf7")
+ (autoload 'format-spec "format-spec")
+ (autoload 'format-spec-make "format-spec"))
+
+;; User variables.
+
+(defvar imap-imtest-program "imtest -kp %s %p"
+ "How to call program for Kerberos 4 authentication.
+%s is replaced with server and %p with port to connect to. The
+program should accept IMAP commands on stdin and return responses to
+stdout.")
+
+(defvar imap-ssl-program 'auto
+ "Program to use for SSL connections. It is called like this
+
+`imap-ssl-program' `imap-ssl-arguments' -ssl2 -connect host:port
+
+where -ssl2 can also be -ssl3 to indicate which ssl version to use. It
+should accept IMAP commands on stdin and return responses to stdout.
+
+For SSLeay set this to \"s_client\" and `imap-ssl-arguments' to nil,
+for OpenSSL set this to \"openssl\" and `imap-ssl-arguments' to
+\"s_client\".
+
+If 'auto it tries s_client first and then openssl.")
+
+(defvar imap-ssl-arguments nil
+ "Arguments to pass to `imap-ssl-program'.
+
+For SSLeay set this to nil, for OpenSSL to \"s_client\".
+
+If `imap-ssl-program' is 'auto this variable has no effect.")
+
+(defvar imap-default-user (user-login-name)
+ "Default username to use.")
+
+(defvar imap-error nil
+ "Error codes from the last command.")
+
+;; Various variables.
+
+(defvar imap-fetch-data-hook nil
+ "Hooks called after receiving each FETCH response.")
+
+(defvar imap-streams '(kerberos4 ssl network)
+ "Priority of streams to consider when opening connection to
+server.")
+
+(defvar imap-stream-alist
+ '((kerberos4 imap-kerberos4s-p imap-kerberos4-open)
+ (ssl imap-ssl-p imap-ssl-open)
+ (network imap-network-p imap-network-open))
+ "Definition of network streams.
+
+(NAME CHECK OPEN)
+
+NAME names the stream, CHECK is a function returning non-nil if the
+server support the stream and OPEN is a function for opening the
+stream.")
+
+(defvar imap-authenticators '(kerberos4 cram-md5 login anonymous)
+ "Priority of authenticators to consider when authenticating to
+server.")
+
+(defvar imap-authenticator-alist
+ '((kerberos4 imap-kerberos4a-p imap-kerberos4-auth)
+ (cram-md5 imap-cram-md5-p imap-cram-md5-auth)
+ (login imap-login-p imap-login-auth)
+ (anonymous imap-anonymous-p imap-anonymous-auth))
+ "Definition of authenticators.
+
+(NAME CHECK AUTHENTICATE)
+
+NAME names the authenticator. CHECK is a function returning non-nil if
+the server support the authenticator and AUTHENTICATE is a function
+for doing the actuall authentification.")
+
+(defvar imap-utf7-p nil
+ "If non-nil, do utf7 encoding/decoding of mailbox names.
+Since the UTF7 decoding currently only decodes into ISO-8859-1
+characters, you may disable this decoding if you need to access UTF7
+encoded mailboxes which doesn't translate into ISO-8859-1.")
+
+;; Internal constants. Change theese and die.
+
+(defconst imap-default-port 143)
+(defconst imap-default-ssl-port 993)
+(defconst imap-default-stream 'network)
+(defconst imap-coding-system-for-read 'binary)
+(defconst imap-coding-system-for-write 'binary)
+(defconst imap-local-variables '(imap-server
+ imap-port
+ imap-client-eol
+ imap-server-eol
+ imap-auth
+ imap-stream
+ imap-username
+ imap-password
+ imap-current-mailbox
+ imap-current-target-mailbox
+ imap-message-data
+ imap-capability
+ imap-namespace
+ imap-state
+ imap-reached-tag
+ imap-failed-tags
+ imap-tag
+ imap-process
+ imap-mailbox-data))
+
+;; Internal variables.
+
+(defvar imap-stream nil)
+(defvar imap-auth nil)
+(defvar imap-server nil)
+(defvar imap-port nil)
+(defvar imap-username nil)
+(defvar imap-password nil)
+(defvar imap-state 'closed
+ "IMAP state. Valid states are `closed', `initial', `nonauth',
+`auth', `selected' and `examine'.")
+
+(defvar imap-server-eol "\r\n"
+ "The EOL string sent from the server.")
+
+(defvar imap-client-eol "\r\n"
+ "The EOL string we send to the server.")
+
+(defvar imap-current-mailbox nil
+ "Current mailbox name.")
+
+(defvar imap-current-target-mailbox nil
+ "Current target mailbox for COPY and APPEND commands.")
+
+(defvar imap-mailbox-data nil
+ "Obarray with mailbox data.")
+
+(defvar imap-mailbox-prime 997
+ "Length of imap-mailbox-data.")
+
+(defvar imap-current-message nil
+ "Current message number.")
+
+(defvar imap-message-data nil
+ "Obarray with message data.")
+
+(defvar imap-message-prime 997
+ "Length of imap-message-data.")
+
+(defvar imap-capability nil
+ "Capability for server.")
+
+(defvar imap-namespace nil
+ "Namespace for current server.")
+
+(defvar imap-reached-tag 0
+ "Lower limit on command tags that have been parsed.")
+
+(defvar imap-failed-tags nil
+ "Alist of tags that failed. Each element is a list with four
+elements; tag (a integer), response state (a symbol, `OK', `NO' or
+`BAD'), response code (a string), and human readable response text (a
+string).")
+
+(defvar imap-tag 0
+ "Command tag number.")
+
+(defvar imap-process nil
+ "Process.")
+
+(defvar imap-continuation nil
+ "Non-nil indicates that the server emitted a continuation request. The
+actually value is really the text on the continuation line.")
+
+(defvar imap-log "*imap-log*"
+ "Imap session trace.")
+
+(defvar imap-debug nil;"*imap-debug*"
+ "Random debug spew.")
+
+\f
+;; Utility functions:
+
+(defsubst imap-disable-multibyte ()
+ "Enable multibyte in the current buffer."
+ (when (fboundp 'set-buffer-multibyte)
+ (set-buffer-multibyte nil)))
+
+(defun imap-read-passwd (prompt &rest args)
+ "Read a password using PROMPT. If ARGS, PROMPT is used as an
+argument to `format'."
+ (let ((prompt (if args
+ (apply 'format prompt args)
+ prompt)))
+ (funcall (if (or (fboundp 'read-passwd)
+ (and (load "subr" t)
+ (fboundp 'read-passwd))
+ (and (load "passwd" t)
+ (fboundp 'read-passwd)))
+ 'read-passwd
+ (autoload 'ange-ftp-read-passwd "ange-ftp")
+ 'ange-ftp-read-passwd)
+ prompt)))
+
+(defsubst imap-utf7-encode (string)
+ (if imap-utf7-p
+ (and string
+ (condition-case ()
+ (utf7-encode string t)
+ (error (message
+ "imap: Could not UTF7 encode `%s', using it unencoded..."
+ string)
+ string)))
+ string))
+
+(defsubst imap-utf7-decode (string)
+ (if imap-utf7-p
+ (and string
+ (condition-case ()
+ (utf7-decode string t)
+ (error (message
+ "imap: Could not UTF7 decode `%s', using it undecoded..."
+ string)
+ string)))
+ string))
+
+(defsubst imap-ok-p (status)
+ (if (eq status 'OK)
+ t
+ (setq imap-error status)
+ nil))
+
+(defun imap-error-text (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (nth 3 (car imap-failed-tags))))
+
+\f
+;; Server functions; stream stuff:
+
+(defun imap-kerberos4s-p (buffer)
+ (imap-capability 'AUTH=KERBEROS_V4 buffer))
+
+(defun imap-kerberos4-open (name buffer server port)
+ (message "Opening Kerberized IMAP connection...")
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ imap-imtest-program
+ (format-spec-make ?s server ?p (number-to-string port))))))
+ (when process
+ (with-current-buffer buffer
+ (setq imap-client-eol "\n")
+ ;; Result of authentication is a string: __Full privacy protection__
+ (while (and (memq (process-status process) '(open run))
+ (goto-char (point-min))
+ (not (and (imap-parse-greeting)
+ (re-search-forward "__\\(.*\\)__\n" nil t))))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (let ((response (match-string 1)))
+ (erase-buffer)
+ (message "Kerberized IMAP connection: %s" response)
+ (if (and response (let ((case-fold-search nil))
+ (not (string-match "failed" response))))
+ process
+ (if (memq (process-status process) '(open run))
+ (imap-send-command-wait "LOGOUT"))
+ (delete-process process)
+ nil))))))
+
+(defun imap-ssl-p (buffer)
+ nil)
+
+(defun imap-ssl-open-2 (name buffer server port &optional extra-ssl-args)
+ (let* ((port (or port imap-default-ssl-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (ssl-program-name imap-ssl-program)
+ (ssl-program-arguments (append imap-ssl-arguments extra-ssl-args
+ (list "-connect"
+ (format "%s:%d" server port))))
+ (process (ignore-errors (open-ssl-stream name buffer server port))))
+ (when process
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (while (and (memq (process-status process) '(open run))
+ (goto-char (point-max))
+ (forward-line -1)
+ (not (imap-parse-greeting)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (erase-buffer))
+ (when (memq (process-status process) '(open run))
+ process))))
+
+(defun imap-ssl-open-1 (name buffer server port &optional extra-ssl-args)
+ (or (and (eq imap-ssl-program 'auto)
+ (let ((imap-ssl-program "s_client")
+ (imap-ssl-arguments nil))
+ (message "imap: Opening IMAP connection with %s %s..."
+ imap-ssl-program (car-safe extra-ssl-args))
+ (imap-ssl-open-2 name buffer server port extra-ssl-args)))
+ (and (eq imap-ssl-program 'auto)
+ (let ((imap-ssl-program "openssl")
+ (imap-ssl-arguments '("s_client")))
+ (message "imap: Opening IMAP connection with %s %s..."
+ imap-ssl-program (car-safe extra-ssl-args))
+ (imap-ssl-open-2 name buffer server port extra-ssl-args)))
+ (and (not (eq imap-ssl-program 'auto))
+ (progn (message "imap: Opening IMAP connection with %s %s..."
+ imap-ssl-program (car-safe extra-ssl-args))
+ (imap-ssl-open-2 name buffer server port extra-ssl-args)))))
+
+(defun imap-ssl-open (name buffer server port)
+ (or (imap-ssl-open-1 name buffer server port '("-ssl3"))
+ (imap-ssl-open-1 name buffer server port '("-ssl2"))))
+
+(defun imap-network-p (buffer)
+ t)
+
+(defun imap-network-open (name buffer server port)
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (open-network-stream name buffer server port)))
+ (when process
+ (while (and (memq (process-status process) '(open run))
+ (goto-char (point-min))
+ (not (imap-parse-greeting)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (when (memq (process-status process) '(open run))
+ process))))
+
+;; Server functions; authenticator stuff:
+
+(defun imap-interactive-login (buffer loginfunc)
+ "Login to server in BUFFER. LOGINFUNC is passed a username and a
+password, it should return t if it where sucessful authenticating
+itself to the server, nil otherwise. Returns t if login was
+successful, nil otherwise."
+ (with-current-buffer buffer
+ (make-variable-buffer-local 'imap-username)
+ (make-variable-buffer-local 'imap-password)
+ (let (user passwd ret)
+;; (condition-case ()
+ (while (or (not user) (not passwd))
+ (setq user (or imap-username
+ (read-from-minibuffer
+ (concat "IMAP username for " imap-server ": ")
+ (or user imap-default-user))))
+ (setq passwd (or imap-password
+ (imap-read-passwd
+ (concat "IMAP password for " user "@"
+ imap-server ": "))))
+ (when (and user passwd)
+ (if (funcall loginfunc user passwd)
+ (progn
+ (setq ret t
+ imap-username user)
+ (if (and (not imap-password)
+ (y-or-n-p "Store password for this session? "))
+ (setq imap-password passwd)))
+ (message "Login failed...")
+ (setq passwd nil)
+ (sit-for 1))))
+;; (quit (with-current-buffer buffer
+;; (setq user nil
+;; passwd nil)))
+;; (error (with-current-buffer buffer
+;; (setq user nil
+;; passwd nil))))
+ ret)))
+
+(defun imap-kerberos4a-p (buffer)
+ (imap-capability 'AUTH=KERBEROS_V4 buffer))
+
+(defun imap-kerberos4-auth (buffer)
+ (eq imap-stream 'kerberos4))
+
+(defun imap-cram-md5-p (buffer)
+ (imap-capability 'AUTH=CRAM-MD5 buffer))
+
+(defun imap-cram-md5-auth (buffer)
+ "Login to server using the AUTH CRAM-MD5 method."
+ (imap-interactive-login
+ buffer
+ (lambda (user passwd)
+ (imap-ok-p
+ (imap-send-command-wait
+ (list
+ "AUTHENTICATE CRAM-MD5"
+ (lambda (challenge)
+ (let* ((decoded (base64-decode-string challenge))
+ (hash (rfc2104-hash 'md5 64 16 passwd decoded))
+ (response (concat user " " hash))
+ (encoded (base64-encode-string response)))
+ encoded))))))))
+
+(defun imap-login-p (buffer)
+ (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))
+
+(defun imap-login-auth (buffer)
+ "Login to server using the LOGIN command."
+ (imap-interactive-login buffer
+ (lambda (user passwd)
+ (imap-ok-p (imap-send-command-wait
+ (concat "LOGIN \"" user "\" \""
+ passwd "\""))))))
+
+(defun imap-anonymous-p (buffer)
+ t)
+
+(defun imap-anonymous-auth (buffer)
+ (with-current-buffer buffer
+ (imap-ok-p (imap-send-command-wait
+ (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
+ (system-name)) "\"")))))
+
+;; Server functions:
+
+(defun imap-open-1 (buffer)
+ (with-current-buffer buffer
+ (erase-buffer)
+ (setq imap-current-mailbox nil
+ imap-current-message nil
+ imap-state 'initial
+ imap-process (condition-case ()
+ (funcall (nth 2 (assq imap-stream
+ imap-stream-alist))
+ "imap" buffer imap-server imap-port)
+ ((error quit) nil)))
+ (when imap-process
+ (set-process-filter imap-process 'imap-arrival-filter)
+ (set-process-sentinel imap-process 'imap-sentinel)
+ (while (and (eq imap-state 'initial)
+ (memq (process-status imap-process) '(open run)))
+ (message "Waiting for response from %s..." imap-server)
+ (accept-process-output imap-process 1))
+ (message "Waiting for response from %s...done" imap-server)
+ (and (memq (process-status imap-process) '(open run))
+ imap-process))))
+
+(defun imap-open (server &optional port stream auth buffer)
+ "Open a IMAP connection to host SERVER at PORT returning a
+buffer. If PORT is unspecified, a default value is used (143 except
+for SSL which use 993).
+STREAM indicates the stream to use, see `imap-streams' for available
+streams. If nil, it choices the best stream the server is capable of.
+AUTH indicates authenticator to use, see `imap-authenticators' for
+available authenticators. If nil, it choices the best stream the
+server is capable of.
+BUFFER can be a buffer or a name of a buffer, which is created if
+necessery. If nil, the buffer name is generated."
+ (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
+ (with-current-buffer (get-buffer-create buffer)
+ (if (imap-opened buffer)
+ (imap-close buffer))
+ (mapc 'make-variable-buffer-local imap-local-variables)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (setq imap-server (or server imap-server))
+ (setq imap-port (or port imap-port))
+ (setq imap-auth (or auth imap-auth))
+ (setq imap-stream (or stream imap-stream))
+ (when (let ((imap-stream (or imap-stream imap-default-stream)))
+ (imap-open-1 buffer))
+ ;; Choose stream.
+ (let (stream-changed)
+ (when (null imap-stream)
+ (let ((streams imap-streams))
+ (while (setq stream (pop streams))
+ (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
+ (setq stream-changed (not (eq (or imap-stream
+ imap-default-stream)
+ stream))
+ imap-stream stream
+ streams nil)))
+ (unless imap-stream
+ (error "Couldn't figure out a stream for server"))))
+ (when stream-changed
+ (message "Reconnecting with %s..." imap-stream)
+ (imap-close buffer)
+ (imap-open-1 buffer)
+ (setq imap-capability nil)))
+ (if (imap-opened buffer)
+ ;; Choose authenticator
+ (when (null imap-auth)
+ (let ((auths imap-authenticators))
+ (while (setq auth (pop auths))
+ (if (funcall (nth 1 (assq auth imap-authenticator-alist))
+ buffer)
+ (setq imap-auth auth
+ auths nil)))
+ (unless imap-auth
+ (error "Couldn't figure out authenticator for server"))))))
+ (when (imap-opened buffer)
+ (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))
+ buffer)))
+
+(defun imap-opened (&optional buffer)
+ "Return non-nil if connection to imap server in BUFFER is open. If
+BUFFER is nil then the current buffer is used."
+ (and (setq buffer (get-buffer (or buffer (current-buffer))))
+ (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (and imap-process
+ (memq (process-status imap-process) '(open run))))))
+
+(defun imap-authenticate (&optional user passwd buffer)
+ "Authenticate to server in BUFFER, using current buffer if nil. It
+uses the authenticator specified when opening the server. If the
+authenticator requires username/passwords, they are queried from the
+user and optionally stored in the buffer. If USER and/or PASSWD is
+specified, the user will not be questioned and the username and/or
+password is remembered in the buffer."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (eq imap-state 'nonauth)
+ (make-variable-buffer-local 'imap-username)
+ (make-variable-buffer-local 'imap-password)
+ (if user (setq imap-username user))
+ (if passwd (setq imap-password passwd))
+ (if (funcall (nth 2 (assq imap-auth imap-authenticator-alist)) buffer)
+ (setq imap-state 'auth)))))
+
+(defun imap-close (&optional buffer)
+ "Close connection to server in BUFFER. If BUFFER is nil, the current
+buffer is used."
+ (with-current-buffer (or buffer (current-buffer))
+ (and (imap-opened)
+ (not (imap-ok-p (imap-send-command-wait "LOGOUT")))
+ (message "Server %s didn't let me log out" imap-server))
+ (when (and imap-process
+ (memq (process-status imap-process) '(open run)))
+ (delete-process imap-process))
+ (setq imap-current-mailbox nil
+ imap-current-message nil
+ imap-process nil)
+ (erase-buffer)
+ t))
+
+(defun imap-capability (&optional identifier buffer)
+ "Return a list of identifiers which server in BUFFER support. If
+IDENTIFIER, return non-nil if it's among the servers capabilities. If
+BUFFER is nil, the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (unless imap-capability
+ (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
+ (setq imap-capability '(IMAP2))))
+ (if identifier
+ (memq (intern (upcase (symbol-name identifier))) imap-capability)
+ imap-capability)))
+
+(defun imap-namespace (&optional buffer)
+ "Return a namespace hierarchy at server in BUFFER. If BUFFER is nil,
+the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (unless imap-namespace
+ (when (imap-capability 'NAMESPACE)
+ (imap-send-command-wait "NAMESPACE")))
+ imap-namespace))
+
+(defun imap-send-command-wait (command &optional buffer)
+ (imap-wait-for-tag (imap-send-command command buffer) buffer))
+
+\f
+;; Mailbox functions:
+
+(defun imap-mailbox-put (propname value &optional mailbox buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (if imap-mailbox-data
+ (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
+ propname value)
+ (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
+ propname value mailbox (current-buffer)))
+ t))
+
+(defsubst imap-mailbox-get-1 (propname &optional mailbox)
+ (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
+ propname))
+
+(defun imap-mailbox-get (propname &optional mailbox buffer)
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
+
+(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (let (result)
+ (mapatoms
+ (lambda (s)
+ (push (funcall func (if mailbox-decoder
+ (funcall mailbox-decoder (symbol-name s))
+ (symbol-name s))) result))
+ imap-mailbox-data)
+ result)))
+
+(defun imap-mailbox-map (func &optional buffer)
+ "Map a function across each mailbox in `imap-mailbox-data',
+returning a list. Function should take a mailbox name (a string) as
+the only argument."
+ (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
+
+(defun imap-current-mailbox (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-utf7-decode imap-current-mailbox)))
+
+(defun imap-current-mailbox-p-1 (mailbox &optional examine)
+ (and (string= mailbox imap-current-mailbox)
+ (or (and examine
+ (eq imap-state 'examine))
+ (and (not examine)
+ (eq imap-state 'selected)))))
+
+(defun imap-current-mailbox-p (mailbox &optional examine buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
+
+(defun imap-mailbox-select-1 (mailbox &optional examine)
+ "Select MAILBOX on server in BUFFER. If EXAMINE is non-nil, do a
+read-only select."
+ (if (imap-current-mailbox-p-1 mailbox examine)
+ imap-current-mailbox
+ (setq imap-current-mailbox mailbox)
+ (if (imap-ok-p (imap-send-command-wait
+ (concat (if examine "EXAMINE" "SELECT") " \""
+ mailbox "\"")))
+ (progn
+ (setq imap-message-data (make-vector imap-message-prime 0)
+ imap-state (if examine 'examine 'selected))
+ imap-current-mailbox)
+ ;; Failed SELECT/EXAMINE unselects current mailbox
+ (setq imap-current-mailbox nil))))
+
+(defun imap-mailbox-select (mailbox &optional examine buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-utf7-decode
+ (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
+
+(defun imap-mailbox-examine (mailbox &optional buffer)
+ "Examine MAILBOX on server in BUFFER"
+ (imap-mailbox-select mailbox 'exmine buffer))
+
+(defun imap-mailbox-unselect (&optional buffer)
+ "Close current folder in BUFFER, without expunging articles."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (or (eq imap-state 'auth)
+ (and (imap-capability 'UNSELECT)
+ (imap-ok-p (imap-send-command-wait "UNSELECT")))
+ (and (imap-ok-p
+ (imap-send-command-wait (concat "EXAMINE \""
+ imap-current-mailbox
+ "\"")))
+ (imap-ok-p (imap-send-command-wait "CLOSE"))))
+ (setq imap-current-mailbox nil
+ imap-message-data nil
+ imap-state 'auth)
+ t)))
+
+(defun imap-mailbox-expunge (&optional buffer)
+ "Expunge articles in current folder in BUFFER. If BUFFER is
+nil the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (and imap-current-mailbox (not (eq imap-state 'examine)))
+ (imap-ok-p (imap-send-command-wait "EXPUNGE")))))
+
+(defun imap-mailbox-close (&optional buffer)
+ "Expunge articles and close current folder in BUFFER. If BUFFER is
+nil the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (and imap-current-mailbox
+ (imap-ok-p (imap-send-command-wait "CLOSE")))
+ (setq imap-current-mailbox nil
+ imap-message-data nil
+ imap-state 'auth)
+ t)))
+
+(defun imap-mailbox-create-1 (mailbox)
+ (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
+
+(defun imap-mailbox-create (mailbox &optional buffer)
+ "Create MAILBOX on server in BUFFER. If BUFFER is nil the current
+buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
+
+(defun imap-mailbox-delete (mailbox &optional buffer)
+ "Delete MAILBOX on server in BUFFER. If BUFFER is nil the current
+buffer is assumed."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p
+ (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
+
+(defun imap-mailbox-rename (oldname newname &optional buffer)
+ "Rename mailbox OLDNAME to NEWNAME on server in BUFFER. If BUFFER is
+nil the current buffer is assumed."
+ (let ((oldname (imap-utf7-encode oldname))
+ (newname (imap-utf7-encode newname)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p
+ (imap-send-command-wait (list "RENAME \"" oldname "\" "
+ "\"" newname "\""))))))
+
+(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
+ "Return a list of subscribed mailboxes on server in BUFFER.
+If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is
+non-nil, a hierarchy delimiter is added to root. REFERENCE is a
+implementation-specific string that has to be passed to lsub command."
+ (with-current-buffer (or buffer (current-buffer))
+ ;; Make sure we know the hierarchy separator for root's hierarchy
+ (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
+ (imap-send-command-wait (concat "LIST \"" reference "\" \""
+ (imap-utf7-encode root) "\"")))
+ ;; clear list data (NB not delimiter and other stuff)
+ (imap-mailbox-map-1 (lambda (mailbox)
+ (imap-mailbox-put 'lsub nil mailbox)))
+ (when (imap-ok-p
+ (imap-send-command-wait
+ (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
+ (and add-delimiter (imap-mailbox-get-1 'delimiter root))
+ "%\"")))
+ (let (out)
+ (imap-mailbox-map-1 (lambda (mailbox)
+ (when (imap-mailbox-get-1 'lsub mailbox)
+ (push (imap-utf7-decode mailbox) out))))
+ (nreverse out)))))
+
+(defun imap-mailbox-list (root &optional reference add-delimiter buffer)
+ "Return a list of mailboxes matching ROOT on server in BUFFER.
+If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
+root. REFERENCE is a implementation-specific string that has to be
+passed to list command."
+ (with-current-buffer (or buffer (current-buffer))
+ ;; Make sure we know the hierarchy separator for root's hierarchy
+ (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
+ (imap-send-command-wait (concat "LIST \"" reference "\" \""
+ (imap-utf7-encode root) "\"")))
+ ;; clear list data (NB not delimiter and other stuff)
+ (imap-mailbox-map-1 (lambda (mailbox)
+ (imap-mailbox-put 'list nil mailbox)))
+ (when (imap-ok-p
+ (imap-send-command-wait
+ (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
+ (and add-delimiter (imap-mailbox-get-1 'delimiter root))
+ "%\"")))
+ (let (out)
+ (imap-mailbox-map-1 (lambda (mailbox)
+ (when (imap-mailbox-get-1 'list mailbox)
+ (push (imap-utf7-decode mailbox) out))))
+ (nreverse out)))))
+
+(defun imap-mailbox-subscribe (mailbox &optional buffer)
+ "Send the SUBSCRIBE command on the mailbox to server in
+BUFFER. Returns non-nil if successful."
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
+ (imap-utf7-encode mailbox)
+ "\"")))))
+
+(defun imap-mailbox-unsubscribe (mailbox &optional buffer)
+ "Send the SUBSCRIBE command on the mailbox to server in
+BUFFER. Returns non-nil if successful."
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
+ (imap-utf7-encode mailbox)
+ "\"")))))
+
+(defun imap-mailbox-status (mailbox items &optional buffer)
+ "Get status items ITEM in MAILBOX from server in BUFFER. ITEMS can
+be a symbol or a list of symbols, valid symbols are one of the STATUS
+data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity or
+'unseen. If ITEMS is a list of symbols, a list of values is returned,
+if ITEMS is a symbol only it's value is returned."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (imap-ok-p
+ (imap-send-command-wait (list "STATUS \""
+ (imap-utf7-encode mailbox)
+ "\" "
+ (format "%s"
+ (if (listp items)
+ items
+ (list items))))))
+ (if (listp items)
+ (mapcar (lambda (item)
+ (imap-mailbox-get-1 item mailbox))
+ items)
+ (imap-mailbox-get-1 items mailbox)))))
+
+(defun imap-mailbox-acl-get (&optional mailbox buffer)
+ "Get ACL on mailbox from server in BUFFER."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (when (imap-ok-p
+ (imap-send-command-wait (list "GETACL \""
+ (or mailbox imap-current-mailbox)
+ "\"")))
+ (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
+
+(defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
+ "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in
+BUFFER."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p
+ (imap-send-command-wait (list "SETACL \""
+ (or mailbox imap-current-mailbox)
+ "\" "
+ identifier
+ " "
+ rights))))))
+
+(defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
+ "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from
+server in BUFFER."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p
+ (imap-send-command-wait (list "DELETEACL \""
+ (or mailbox imap-current-mailbox)
+ "\" "
+ identifier))))))
+
+\f
+;; Message functions:
+
+(defun imap-current-message (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ imap-current-message))
+
+(defun imap-list-to-message-set (list)
+ (mapconcat (lambda (item)
+ (number-to-string item))
+ (if (listp list)
+ list
+ (list list))
+ ","))
+
+(defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
+ (if (listp uids)
+ (imap-list-to-message-set uids)
+ uids)
+ props))))
+
+(defun imap-fetch (uids props &optional receive nouidfetch buffer)
+ "Fetch properties PROPS from message set UIDS from server in
+BUFFER. UIDS can be a string, number or a list of numbers. If RECEIVE
+is non-nil return theese properties."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (imap-ok-p (imap-send-command-wait
+ (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
+ (if (listp uids)
+ (imap-list-to-message-set uids)
+ uids)
+ props)))
+ (if (or (null receive) (stringp uids))
+ t
+ (if (listp uids)
+ (mapcar (lambda (uid)
+ (if (listp receive)
+ (mapcar (lambda (prop)
+ (imap-message-get uid prop))
+ receive)
+ (imap-message-get uid receive)))
+ uids)
+ (imap-message-get uids receive))))))
+
+(defun imap-message-put (uid propname value &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (if imap-message-data
+ (put (intern (number-to-string uid) imap-message-data)
+ propname value)
+ (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
+ uid propname value (current-buffer)))
+ t))
+
+(defun imap-message-get (uid propname &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (get (intern-soft (number-to-string uid) imap-message-data)
+ propname)))
+
+(defun imap-message-map (func propname &optional buffer)
+ "Map a function across each mailbox in `imap-message-data',
+returning a list."
+ (with-current-buffer (or buffer (current-buffer))
+ (let (result)
+ (mapatoms
+ (lambda (s)
+ (push (funcall func (get s 'UID) (get s propname)) result))
+ imap-message-data)
+ result)))
+
+(defmacro imap-message-envelope-date (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 0)))
+
+(defmacro imap-message-envelope-subject (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 1)))
+
+(defmacro imap-message-envelope-from (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 2)))
+
+(defmacro imap-message-envelope-sender (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 3)))
+
+(defmacro imap-message-envelope-reply-to (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 4)))
+
+(defmacro imap-message-envelope-to (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 5)))
+
+(defmacro imap-message-envelope-cc (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 6)))
+
+(defmacro imap-message-envelope-bcc (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 7)))
+
+(defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 8)))
+
+(defmacro imap-message-envelope-message-id (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (elt (imap-message-get ,uid 'ENVELOPE) 9)))
+
+(defmacro imap-message-body (uid &optional buffer)
+ `(with-current-buffer (or ,buffer (current-buffer))
+ (imap-message-get ,uid 'BODY)))
+
+(defun imap-search (predicate &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-mailbox-put 'search 'dummy)
+ (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
+ (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
+ (error "Missing SEARCH response to a SEARCH command")
+ (imap-mailbox-get-1 'search imap-current-mailbox)))))
+
+(defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
+ "Return t iff FLAG can be permanently (between IMAP sessions) saved
+on articles, in MAILBOX on server in BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
+ (member flag (imap-mailbox-get 'permanentflags mailbox)))))
+
+(defun imap-message-flags-set (articles flags &optional silent buffer)
+ (when (and articles flags)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait
+ (concat "UID STORE " articles
+ " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+
+(defun imap-message-flags-del (articles flags &optional silent buffer)
+ (when (and articles flags)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait
+ (concat "UID STORE " articles
+ " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+
+(defun imap-message-flags-add (articles flags &optional silent buffer)
+ (when (and articles flags)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-ok-p (imap-send-command-wait
+ (concat "UID STORE " articles
+ " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+
+(defun imap-message-copyuid-1 (mailbox)
+ (if (imap-capability 'UIDPLUS)
+ (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
+ (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
+ (let ((old-mailbox imap-current-mailbox)
+ (state imap-state)
+ (imap-message-data (make-vector 2 0)))
+ (when (imap-mailbox-examine mailbox)
+ (prog1
+ (and (imap-fetch "*" "UID")
+ (list (imap-mailbox-get-1 'uidvalidity mailbox)
+ (apply 'max (imap-message-map
+ (lambda (uid prop) uid) 'UID))))
+ (if old-mailbox
+ (imap-mailbox-select old-mailbox (eq state 'examine))
+ (imap-mailbox-unselect)))))))
+
+(defun imap-message-copyuid (mailbox &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
+
+(defun imap-message-copy (articles mailbox
+ &optional dont-create no-copyuid buffer)
+ "Copy ARTICLES (a string message set) to MAILBOX on server in
+BUFFER, creating mailbox if it doesn't exist. If dont-create is
+non-nil, it will not create a mailbox. On success, return a list with
+the UIDVALIDITY of the mailbox the article(s) was copied to as the
+first element, rest of list contain the saved articles' UIDs."
+ (when articles
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
+ (imap-current-target-mailbox mailbox))
+ (if (imap-ok-p (imap-send-command-wait cmd))
+ t
+ (when (and (not dont-create)
+ (imap-mailbox-get-1 'trycreate mailbox))
+ (imap-mailbox-create-1 mailbox)
+ (imap-ok-p (imap-send-command-wait cmd)))))
+ (or no-copyuid
+ (imap-message-copyuid-1 mailbox)))))))
+
+(defun imap-message-appenduid-1 (mailbox)
+ (if (imap-capability 'UIDPLUS)
+ (imap-mailbox-get-1 'appenduid mailbox)
+ (let ((old-mailbox imap-current-mailbox)
+ (state imap-state)
+ (imap-message-data (make-vector 2 0)))
+ (when (imap-mailbox-examine mailbox)
+ (prog1
+ (and (imap-fetch "*" "UID")
+ (list (imap-mailbox-get-1 'uidvalidity mailbox)
+ (apply 'max (imap-message-map
+ (lambda (uid prop) uid) 'UID))))
+ (if old-mailbox
+ (imap-mailbox-select old-mailbox (eq state 'examine))
+ (imap-mailbox-unselect)))))))
+
+(defun imap-message-appenduid (mailbox &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
+
+(defun imap-message-append (mailbox article &optional flags date-time buffer)
+ "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER. FLAGS and
+DATE-TIME is currently not used. Return a cons holding uidvalidity of
+MAILBOX and UID the newly created article got, or nil on failure."
+ (let ((mailbox (imap-utf7-encode mailbox)))
+ (with-current-buffer (or buffer (current-buffer))
+ (and (let ((imap-current-target-mailbox mailbox))
+ (imap-ok-p
+ (imap-send-command-wait
+ (list "APPEND \"" mailbox "\" " article))))
+ (imap-message-appenduid-1 mailbox)))))
+
+(defun imap-body-lines (body)
+ "Return number of lines in article by looking at the mime bodystructure
+BODY."
+ (if (listp body)
+ (if (stringp (car body))
+ (cond ((and (string= (car body) "TEXT")
+ (numberp (nth 7 body)))
+ (nth 7 body))
+ ((and (string= (car body) "MESSAGE")
+ (numberp (nth 9 body)))
+ (nth 9 body))
+ (t 0))
+ (apply '+ (mapcar 'imap-body-lines body)))
+ 0))
+
+(defun imap-envelope-from (from)
+ "Return a from string line."
+ (and from
+ (concat (aref from 0)
+ (if (aref from 0) " <")
+ (aref from 2)
+ "@"
+ (aref from 3)
+ (if (aref from 0) ">"))))
+
+\f
+;; Internal functions.
+
+(defun imap-send-command-1 (cmdstr)
+ (setq cmdstr (concat cmdstr imap-client-eol))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert cmdstr)))
+ (process-send-string imap-process cmdstr))
+
+(defun imap-send-command (command &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (if (not (listp command)) (setq command (list command)))
+ (let ((tag (setq imap-tag (1+ imap-tag)))
+ cmd cmdstr)
+ (setq cmdstr (concat (number-to-string imap-tag) " "))
+ (while (setq cmd (pop command))
+ (cond ((stringp cmd)
+ (setq cmdstr (concat cmdstr cmd)))
+ ((bufferp cmd)
+ (setq cmdstr
+ (concat cmdstr (format "{%d}" (with-current-buffer cmd
+ (buffer-size)))))
+ (unwind-protect
+ (progn
+ (imap-send-command-1 cmdstr)
+ (setq cmdstr nil)
+ (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
+ (setq command nil) ;; abort command if no cont-req
+ (let ((process imap-process)
+ (stream imap-stream))
+ (with-current-buffer cmd
+ (when (eq stream 'kerberos4)
+ ;; XXX modifies buffer!
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n")))
+ (and imap-log
+ (with-current-buffer (get-buffer-create
+ imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring cmd)))
+ (process-send-region process (point-min)
+ (point-max)))
+ (process-send-string process imap-client-eol))))
+ (setq imap-continuation nil)))
+ ((functionp cmd)
+ (imap-send-command-1 cmdstr)
+ (setq cmdstr nil)
+ (unwind-protect
+ (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
+ (setq command nil) ;; abort command if no cont-req
+ (setq command (cons (funcall cmd imap-continuation)
+ command)))
+ (setq imap-continuation nil)))
+ (t
+ (error "Unknown command type"))))
+ (if cmdstr
+ (imap-send-command-1 cmdstr))
+ tag)))
+
+(defun imap-wait-for-tag (tag &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (while (and (null imap-continuation)
+ (< imap-reached-tag tag))
+ (or (and (not (memq (process-status imap-process) '(open run)))
+ (sit-for 1))
+ (accept-process-output imap-process 1)))
+ (or (assq tag imap-failed-tags)
+ (if imap-continuation
+ 'INCOMPLETE
+ 'OK))))
+
+(defun imap-sentinel (process string)
+ (delete-process process))
+
+(defun imap-find-next-line ()
+ "Return point at end of current line, taking into account
+literals. Return nil if no complete line has arrived."
+ (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
+ imap-server-eol)
+ nil t)
+ (if (match-string 1)
+ (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
+ nil
+ (goto-char (+ (point) (string-to-number (match-string 1))))
+ (imap-find-next-line))
+ (point))))
+
+(defun imap-arrival-filter (proc string)
+ "IMAP process filter."
+ (with-current-buffer (process-buffer proc)
+ (goto-char (point-max))
+ (insert string)
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert string)))
+ (let (end)
+ (goto-char (point-min))
+ (while (setq end (imap-find-next-line))
+ (save-restriction
+ (narrow-to-region (point-min) end)
+ (delete-backward-char (length imap-server-eol))
+ (goto-char (point-min))
+ (unwind-protect
+ (cond ((eq imap-state 'initial)
+ (imap-parse-greeting))
+ ((or (eq imap-state 'auth)
+ (eq imap-state 'nonauth)
+ (eq imap-state 'selected)
+ (eq imap-state 'examine))
+ (imap-parse-response))
+ (t
+ (message "Unknown state %s in arrival filter"
+ imap-state)))
+ (delete-region (point-min) (point-max))))))))
+
+\f
+;; Imap parser.
+
+(defsubst imap-forward ()
+ (or (eobp) (forward-char)))
+
+;; number = 1*DIGIT
+;; ; Unsigned 32-bit integer
+;; ; (0 <= n < 4,294,967,296)
+
+(defsubst imap-parse-number ()
+ (when (looking-at "[0-9]+")
+ (prog1
+ (string-to-number (match-string 0))
+ (goto-char (match-end 0)))))
+
+;; literal = "{" number "}" CRLF *CHAR8
+;; ; Number represents the number of CHAR8s
+
+(defsubst imap-parse-literal ()
+ (when (looking-at "{\\([0-9]+\\)}\r\n")
+ (let ((pos (match-end 0))
+ (len (string-to-number (match-string 1))))
+ (if (< (point-max) (+ pos len))
+ nil
+ (goto-char (+ pos len))
+ (buffer-substring-no-properties pos (+ pos len))))))
+
+;; string = quoted / literal
+;;
+;; quoted = DQUOTE *QUOTED-CHAR DQUOTE
+;;
+;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
+;; "\" quoted-specials
+;;
+;; quoted-specials = DQUOTE / "\"
+;;
+;; TEXT-CHAR = <any CHAR except CR and LF>
+
+(defsubst imap-parse-string ()
+ (let (strstart strend)
+ (cond ((and (eq (char-after) ?\")
+ (setq strstart (point))
+ (setq strend (search-forward "\"" nil t 2)))
+ (buffer-substring-no-properties (1+ strstart) (1- strend)))
+ ((eq (char-after) ?{)
+ (imap-parse-literal)))))
+
+;; nil = "NIL"
+
+(defsubst imap-parse-nil ()
+ (if (looking-at "NIL")
+ (goto-char (match-end 0))))
+
+;; nstring = string / nil
+
+(defsubst imap-parse-nstring ()
+ (or (imap-parse-string)
+ (and (imap-parse-nil)
+ nil)))
+
+;; astring = atom / string
+;;
+;; atom = 1*ATOM-CHAR
+;;
+;; ATOM-CHAR = <any CHAR except atom-specials>
+;;
+;; atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards /
+;; quoted-specials
+;;
+;; list-wildcards = "%" / "*"
+;;
+;; quoted-specials = DQUOTE / "\"
+
+(defsubst imap-parse-astring ()
+ (or (imap-parse-string)
+ (buffer-substring (point)
+ (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
+ (goto-char (1- (match-end 0)))
+ (end-of-line)
+ (point)))))
+
+;; address = "(" addr-name SP addr-adl SP addr-mailbox SP
+;; addr-host ")"
+;;
+;; addr-adl = nstring
+;; ; Holds route from [RFC-822] route-addr if
+;; ; non-NIL
+;;
+;; addr-host = nstring
+;; ; NIL indicates [RFC-822] group syntax.
+;; ; Otherwise, holds [RFC-822] domain name
+;;
+;; addr-mailbox = nstring
+;; ; NIL indicates end of [RFC-822] group; if
+;; ; non-NIL and addr-host is NIL, holds
+;; ; [RFC-822] group name.
+;; ; Otherwise, holds [RFC-822] local-part
+;; ; after removing [RFC-822] quoting
+;;
+;; addr-name = nstring
+;; ; If non-NIL, holds phrase from [RFC-822]
+;; ; mailbox after removing [RFC-822] quoting
+;;
+
+(defsubst imap-parse-address ()
+ (let (address)
+ (when (eq (char-after) ?\()
+ (imap-forward)
+ (setq address (vector (prog1 (imap-parse-nstring)
+ (imap-forward))
+ (prog1 (imap-parse-nstring)
+ (imap-forward))
+ (prog1 (imap-parse-nstring)
+ (imap-forward))
+ (imap-parse-nstring)))
+ (when (eq (char-after) ?\))
+ (imap-forward)
+ address))))
+
+;; address-list = "(" 1*address ")" / nil
+;;
+;; nil = "NIL"
+
+(defsubst imap-parse-address-list ()
+ (if (eq (char-after) ?\()
+ (let (address addresses)
+ (imap-forward)
+ (while (and (not (eq (char-after) ?\)))
+ ;; next line for MS Exchange bug
+ (progn (and (eq (char-after) ? ) (imap-forward)) t)
+ (setq address (imap-parse-address)))
+ (setq addresses (cons address addresses)))
+ (when (eq (char-after) ?\))
+ (imap-forward)
+ (nreverse addresses)))
+ (assert (imap-parse-nil))))
+
+;; mailbox = "INBOX" / astring
+;; ; INBOX is case-insensitive. All case variants of
+;; ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
+;; ; not as an astring. An astring which consists of
+;; ; the case-insensitive sequence "I" "N" "B" "O" "X"
+;; ; is considered to be INBOX and not an astring.
+;; ; Refer to section 5.1 for further
+;; ; semantic details of mailbox names.
+
+(defsubst imap-parse-mailbox ()
+ (let ((mailbox (imap-parse-astring)))
+ (if (string-equal "INBOX" (upcase mailbox))
+ "INBOX"
+ mailbox)))
+
+;; greeting = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
+;;
+;; resp-cond-auth = ("OK" / "PREAUTH") SP resp-text
+;; ; Authentication condition
+;;
+;; resp-cond-bye = "BYE" SP resp-text
+
+(defun imap-parse-greeting ()
+ "Parse a IMAP greeting."
+ (cond ((looking-at "\\* OK ")
+ (setq imap-state 'nonauth))
+ ((looking-at "\\* PREAUTH ")
+ (setq imap-state 'auth))
+ ((looking-at "\\* BYE ")
+ (setq imap-state 'closed))))
+
+;; response = *(continue-req / response-data) response-done
+;;
+;; continue-req = "+" SP (resp-text / base64) CRLF
+;;
+;; response-data = "*" SP (resp-cond-state / resp-cond-bye /
+;; mailbox-data / message-data / capability-data) CRLF
+;;
+;; response-done = response-tagged / response-fatal
+;;
+;; response-fatal = "*" SP resp-cond-bye CRLF
+;; ; Server closes connection immediately
+;;
+;; response-tagged = tag SP resp-cond-state CRLF
+;;
+;; resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
+;; ; Status condition
+;;
+;; resp-cond-bye = "BYE" SP resp-text
+;;
+;; mailbox-data = "FLAGS" SP flag-list /
+;; "LIST" SP mailbox-list /
+;; "LSUB" SP mailbox-list /
+;; "SEARCH" *(SP nz-number) /
+;; "STATUS" SP mailbox SP "("
+;; [status-att SP number *(SP status-att SP number)] ")" /
+;; number SP "EXISTS" /
+;; number SP "RECENT"
+;;
+;; message-data = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
+;;
+;; capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
+;; *(SP capability)
+;; ; IMAP4rev1 servers which offer RFC 1730
+;; ; compatibility MUST list "IMAP4" as the first
+;; ; capability.
+
+(defun imap-parse-response ()
+ "Parse a IMAP command response."
+ (let (token)
+ (case (setq token (read (current-buffer)))
+ (+ (setq imap-continuation
+ (or (buffer-substring (min (point-max) (1+ (point)))
+ (point-max))
+ t)))
+ (* (case (prog1 (setq token (read (current-buffer)))
+ (imap-forward))
+ (OK (imap-parse-resp-text))
+ (NO (imap-parse-resp-text))
+ (BAD (imap-parse-resp-text))
+ (BYE (imap-parse-resp-text))
+ (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list)))
+ (LIST (imap-parse-data-list 'list))
+ (LSUB (imap-parse-data-list 'lsub))
+ (SEARCH (imap-mailbox-put
+ 'search
+ (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
+ (STATUS (imap-parse-status))
+ (CAPABILITY (setq imap-capability
+ (read (concat "(" (upcase (buffer-substring
+ (point) (point-max)))
+ ")"))))
+ (ACL (imap-parse-acl))
+ (t (case (prog1 (read (current-buffer))
+ (imap-forward))
+ (EXISTS (imap-mailbox-put 'exists token))
+ (RECENT (imap-mailbox-put 'recent token))
+ (EXPUNGE t)
+ (FETCH (imap-parse-fetch token))
+ (t (message "Garbage: %s" (buffer-string)))))))
+ (t (let (status)
+ (if (not (integerp token))
+ (message "Garbage: %s" (buffer-string))
+ (case (prog1 (setq status (read (current-buffer)))
+ (imap-forward))
+ (OK (progn
+ (setq imap-reached-tag (max imap-reached-tag token))
+ (imap-parse-resp-text)))
+ (NO (progn
+ (setq imap-reached-tag (max imap-reached-tag token))
+ (save-excursion
+ (imap-parse-resp-text))
+ (let (code text)
+ (when (eq (char-after) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (imap-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (push (list token status code text)
+ imap-failed-tags))))
+ (BAD (progn
+ (setq imap-reached-tag (max imap-reached-tag token))
+ (save-excursion
+ (imap-parse-resp-text))
+ (let (code text)
+ (when (eq (char-after) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (imap-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (push (list token status code text) imap-failed-tags)
+ (error "Internal error, tag %s status %s code %s text %s"
+ token status code text))))
+ (t (message "Garbage: %s" (buffer-string))))))))))
+
+;; resp-text = ["[" resp-text-code "]" SP] text
+;;
+;; text = 1*TEXT-CHAR
+;;
+;; TEXT-CHAR = <any CHAR except CR and LF>
+
+(defun imap-parse-resp-text ()
+ (imap-parse-resp-text-code))
+
+;; resp-text-code = "ALERT" /
+;; "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
+;; "NEWNAME" SP string SP string /
+;; "PARSE" /
+;; "PERMANENTFLAGS" SP "("
+;; [flag-perm *(SP flag-perm)] ")" /
+;; "READ-ONLY" /
+;; "READ-WRITE" /
+;; "TRYCREATE" /
+;; "UIDNEXT" SP nz-number /
+;; "UIDVALIDITY" SP nz-number /
+;; "UNSEEN" SP nz-number /
+;; resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
+;;
+;; resp_code_apnd = "APPENDUID" SPACE nz_number SPACE uniqueid
+;;
+;; resp_code_copy = "COPYUID" SPACE nz_number SPACE set SPACE set
+;;
+;; set = sequence-num / (sequence-num ":" sequence-num) /
+;; (set "," set)
+;; ; Identifies a set of messages. For message
+;; ; sequence numbers, these are consecutive
+;; ; numbers from 1 to the number of messages in
+;; ; the mailbox
+;; ; Comma delimits individual numbers, colon
+;; ; delimits between two numbers inclusive.
+;; ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
+;; ; 14,15 for a mailbox with 15 messages.
+;;
+;; sequence-num = nz-number / "*"
+;; ; * is the largest number in use. For message
+;; ; sequence numbers, it is the number of messages
+;; ; in the mailbox. For unique identifiers, it is
+;; ; the unique identifier of the last message in
+;; ; the mailbox.
+;;
+;; flag-perm = flag / "\*"
+;;
+;; flag = "\Answered" / "\Flagged" / "\Deleted" /
+;; "\Seen" / "\Draft" / flag-keyword / flag-extension
+;; ; Does not include "\Recent"
+;;
+;; flag-extension = "\" atom
+;; ; Future expansion. Client implementations
+;; ; MUST accept flag-extension flags. Server
+;; ; implementations MUST NOT generate
+;; ; flag-extension flags except as defined by
+;; ; future standard or standards-track
+;; ; revisions of this specification.
+;;
+;; flag-keyword = atom
+;;
+;; resp-text-atom = 1*<any ATOM-CHAR except "]">
+
+(defun imap-parse-resp-text-code ()
+ (when (eq (char-after) ?\[)
+ (imap-forward)
+ (cond ((search-forward "PERMANENTFLAGS " nil t)
+ (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
+ ((search-forward "UIDNEXT " nil t)
+ (imap-mailbox-put 'uidnext (read (current-buffer))))
+ ((search-forward "UNSEEN " nil t)
+ (imap-mailbox-put 'unseen (read (current-buffer))))
+ ((looking-at "UIDVALIDITY \\([0-9]+\\)")
+ (imap-mailbox-put 'uidvalidity (match-string 1)))
+ ((search-forward "READ-ONLY" nil t)
+ (imap-mailbox-put 'read-only t))
+ ((search-forward "NEWNAME " nil t)
+ (let (oldname newname)
+ (setq oldname (imap-parse-string))
+ (imap-forward)
+ (setq newname (imap-parse-string))
+ (imap-mailbox-put 'newname newname oldname)))
+ ((search-forward "TRYCREATE" nil t)
+ (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
+ ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
+ (imap-mailbox-put 'appenduid
+ (list (match-string 1)
+ (string-to-number (match-string 2)))
+ imap-current-target-mailbox))
+ ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
+ (imap-mailbox-put 'copyuid (list (match-string 1)
+ (match-string 2)
+ (match-string 3))
+ imap-current-target-mailbox))
+ ((search-forward "ALERT] " nil t)
+ (message "Imap server %s information: %s" imap-server
+ (buffer-substring (point) (point-max)))))))
+
+;; mailbox-list = "(" [mbx-list-flags] ")" SP
+;; (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
+;;
+;; mbx-list-flags = *(mbx-list-oflag SP) mbx-list-sflag
+;; *(SP mbx-list-oflag) /
+;; mbx-list-oflag *(SP mbx-list-oflag)
+;;
+;; mbx-list-oflag = "\Noinferiors" / flag-extension
+;; ; Other flags; multiple possible per LIST response
+;;
+;; mbx-list-sflag = "\Noselect" / "\Marked" / "\Unmarked"
+;; ; Selectability flags; only one per LIST response
+;;
+;; QUOTED-CHAR = <any TEXT-CHAR except quoted-specials> /
+;; "\" quoted-specials
+;;
+;; quoted-specials = DQUOTE / "\"
+
+(defun imap-parse-data-list (type)
+ (let (flags delimiter mailbox)
+ (setq flags (imap-parse-flag-list))
+ (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
+ (setq delimiter (match-string 1))
+ (goto-char (1+ (match-end 0)))
+ (when (setq mailbox (imap-parse-mailbox))
+ (imap-mailbox-put type t mailbox)
+ (imap-mailbox-put 'list-flags flags mailbox)
+ (imap-mailbox-put 'delimiter delimiter mailbox)))))
+
+;; msg_att ::= "(" 1#("ENVELOPE" SPACE envelope /
+;; "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
+;; "INTERNALDATE" SPACE date_time /
+;; "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
+;; "RFC822.SIZE" SPACE number /
+;; "BODY" ["STRUCTURE"] SPACE body /
+;; "BODY" section ["<" number ">"] SPACE nstring /
+;; "UID" SPACE uniqueid) ")"
+;;
+;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year
+;; SPACE time SPACE zone <">
+;;
+;; section ::= "[" [section_text / (nz_number *["." nz_number]
+;; ["." (section_text / "MIME")])] "]"
+;;
+;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
+;; SPACE header_list / "TEXT"
+;;
+;; header_fld_name ::= astring
+;;
+;; header_list ::= "(" 1#header_fld_name ")"
+
+(defsubst imap-parse-header-list ()
+ (when (eq (char-after) ?\()
+ (let (strlist)
+ (while (not (eq (char-after) ?\)))
+ (imap-forward)
+ (push (imap-parse-astring) strlist))
+ (imap-forward)
+ (nreverse strlist))))
+
+(defsubst imap-parse-fetch-body-section ()
+ (let ((section
+ (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
+ (if (eq (char-before) ? )
+ (prog1
+ (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
+ (search-forward "]" nil t))
+ section)))
+
+(defun imap-parse-fetch (response)
+ (when (eq (char-after) ?\()
+ (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
+ rfc822size body bodydetail bodystructure)
+ (while (not (eq (char-after) ?\)))
+ (imap-forward)
+ (let ((token (read (current-buffer))))
+ (imap-forward)
+ (cond ((eq token 'UID)
+ (setq uid (ignore-errors (read (current-buffer)))))
+ ((eq token 'FLAGS)
+ (setq flags (imap-parse-flag-list)))
+ ((eq token 'ENVELOPE)
+ (setq envelope (imap-parse-envelope)))
+ ((eq token 'INTERNALDATE)
+ (setq internaldate (imap-parse-string)))
+ ((eq token 'RFC822)
+ (setq rfc822 (imap-parse-nstring)))
+ ((eq token 'RFC822.HEADER)
+ (setq rfc822header (imap-parse-nstring)))
+ ((eq token 'RFC822.TEXT)
+ (setq rfc822text (imap-parse-nstring)))
+ ((eq token 'RFC822.SIZE)
+ (setq rfc822size (read (current-buffer))))
+ ((eq token 'BODY)
+ (if (eq (char-before) ?\[)
+ (push (list
+ (upcase (imap-parse-fetch-body-section))
+ (and (eq (char-after) ?<)
+ (buffer-substring (1+ (point))
+ (search-forward ">" nil t)))
+ (progn (imap-forward)
+ (imap-parse-nstring)))
+ bodydetail)
+ (setq body (imap-parse-body))))
+ ((eq token 'BODYSTRUCTURE)
+ (setq bodystructure (imap-parse-body))))))
+ (when uid
+ (setq imap-current-message uid)
+ (imap-message-put uid 'UID uid)
+ (and flags (imap-message-put uid 'FLAGS flags))
+ (and envelope (imap-message-put uid 'ENVELOPE envelope))
+ (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
+ (and rfc822 (imap-message-put uid 'RFC822 rfc822))
+ (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
+ (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
+ (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
+ (and body (imap-message-put uid 'BODY body))
+ (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
+ (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
+ (run-hooks 'imap-fetch-data-hook)))))
+
+;; mailbox-data = ...
+;; "STATUS" SP mailbox SP "("
+;; [status-att SP number
+;; *(SP status-att SP number)] ")"
+;; ...
+;;
+;; status-att = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
+;; "UNSEEN"
+
+(defun imap-parse-status ()
+ (let ((mailbox (imap-parse-mailbox)))
+ (when (and mailbox (search-forward "(" nil t))
+ (while (not (eq (char-after) ?\)))
+ (let ((token (read (current-buffer))))
+ (cond ((eq token 'MESSAGES)
+ (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
+ ((eq token 'RECENT)
+ (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
+ ((eq token 'UIDNEXT)
+ (imap-mailbox-put 'uidnext (read (current-buffer)) mailbox))
+ ((eq token 'UIDVALIDITY)
+ (and (looking-at " \\([0-9]+\\)")
+ (imap-mailbox-put 'uidvalidity (match-string 1) mailbox)
+ (goto-char (match-end 1))))
+ ((eq token 'UNSEEN)
+ (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
+ (t
+ (message "Unknown status data %s in mailbox %s ignored"
+ token mailbox))))))))
+
+;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
+;; rights)
+;;
+;; identifier ::= astring
+;;
+;; rights ::= astring
+
+(defun imap-parse-acl ()
+ (let ((mailbox (imap-parse-mailbox))
+ identifier rights acl)
+ (while (eq (char-after) ?\ )
+ (imap-forward)
+ (setq identifier (imap-parse-astring))
+ (imap-forward)
+ (setq rights (imap-parse-astring))
+ (setq acl (append acl (list (cons identifier rights)))))
+ (imap-mailbox-put 'acl acl mailbox)))
+
+;; flag-list = "(" [flag *(SP flag)] ")"
+;;
+;; flag = "\Answered" / "\Flagged" / "\Deleted" /
+;; "\Seen" / "\Draft" / flag-keyword / flag-extension
+;; ; Does not include "\Recent"
+;;
+;; flag-keyword = atom
+;;
+;; flag-extension = "\" atom
+;; ; Future expansion. Client implementations
+;; ; MUST accept flag-extension flags. Server
+;; ; implementations MUST NOT generate
+;; ; flag-extension flags except as defined by
+;; ; future standard or standards-track
+;; ; revisions of this specification.
+
+(defun imap-parse-flag-list ()
+ (let ((str (buffer-substring-no-properties
+ (point) (search-forward ")" nil t)))
+ pos)
+ (while (setq pos (string-match "\\\\" str (and pos (+ 2 pos))))
+ (setq str (replace-match "\\\\" nil t str)))
+ (mapcar 'symbol-name (read str))))
+
+;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP
+;; env-reply-to SP env-to SP env-cc SP env-bcc SP
+;; env-in-reply-to SP env-message-id ")"
+;;
+;; env-bcc = "(" 1*address ")" / nil
+;;
+;; env-cc = "(" 1*address ")" / nil
+;;
+;; env-date = nstring
+;;
+;; env-from = "(" 1*address ")" / nil
+;;
+;; env-in-reply-to = nstring
+;;
+;; env-message-id = nstring
+;;
+;; env-reply-to = "(" 1*address ")" / nil
+;;
+;; env-sender = "(" 1*address ")" / nil
+;;
+;; env-subject = nstring
+;;
+;; env-to = "(" 1*address ")" / nil
+
+(defun imap-parse-envelope ()
+ (when (eq (char-after) ?\()
+ (imap-forward)
+ (vector (prog1 (imap-parse-nstring) ;; date
+ (imap-forward))
+ (prog1 (imap-parse-nstring) ;; subject
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; from
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; sender
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; reply-to
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; to
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; cc
+ (imap-forward))
+ (prog1 (imap-parse-address-list) ;; bcc
+ (imap-forward))
+ (prog1 (imap-parse-nstring) ;; in-reply-to
+ (imap-forward))
+ (prog1 (imap-parse-nstring) ;; message-id
+ (imap-forward)))))
+
+;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
+
+(defsubst imap-parse-string-list ()
+ (cond ((eq (char-after) ?\() ;; body-fld-param
+ (let (strlist str)
+ (imap-forward)
+ (while (setq str (imap-parse-string))
+ (push str strlist)
+ (imap-forward))
+ (nreverse strlist)))
+ ((imap-parse-nil)
+ nil)))
+
+;; body-extension = nstring / number /
+;; "(" body-extension *(SP body-extension) ")"
+;; ; Future expansion. Client implementations
+;; ; MUST accept body-extension fields. Server
+;; ; implementations MUST NOT generate
+;; ; body-extension fields except as defined by
+;; ; future standard or standards-track
+;; ; revisions of this specification.
+
+(defun imap-parse-body-extension ()
+ (if (eq (char-after) ?\()
+ (let (b-e)
+ (imap-forward)
+ (push (imap-parse-body-extension) b-e)
+ (while (eq (char-after) ?\ )
+ (imap-forward)
+ (push (imap-parse-body-extension) b-e))
+ (assert (eq (char-after) ?\)))
+ (imap-forward)
+ (nreverse b-e))
+ (or (imap-parse-number)
+ (imap-parse-nstring))))
+
+;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
+;; *(SP body-extension)]]
+;; ; MUST NOT be returned on non-extensible
+;; ; "BODY" fetch
+;;
+;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
+;; *(SP body-extension)]]
+;; ; MUST NOT be returned on non-extensible
+;; ; "BODY" fetch
+
+(defsubst imap-parse-body-ext ()
+ (let (ext)
+ (when (eq (char-after) ?\ ) ;; body-fld-dsp
+ (imap-forward)
+ (let (dsp)
+ (if (eq (char-after) ?\()
+ (progn
+ (imap-forward)
+ (push (imap-parse-string) dsp)
+ (imap-forward)
+ (push (imap-parse-string-list) dsp)
+ (imap-forward))
+ (assert (imap-parse-nil)))
+ (push (nreverse dsp) ext))
+ (when (eq (char-after) ?\ ) ;; body-fld-lang
+ (imap-forward)
+ (if (eq (char-after) ?\()
+ (push (imap-parse-string-list) ext)
+ (push (imap-parse-nstring) ext))
+ (while (eq (char-after) ?\ ) ;; body-extension
+ (imap-forward)
+ (setq ext (append (imap-parse-body-extension) ext)))))
+ ext))
+
+;; body = "(" body-type-1part / body-type-mpart ")"
+;;
+;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
+;; *(SP body-extension)]]
+;; ; MUST NOT be returned on non-extensible
+;; ; "BODY" fetch
+;;
+;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang
+;; *(SP body-extension)]]
+;; ; MUST NOT be returned on non-extensible
+;; ; "BODY" fetch
+;;
+;; body-fields = body-fld-param SP body-fld-id SP body-fld-desc SP
+;; body-fld-enc SP body-fld-octets
+;;
+;; body-fld-desc = nstring
+;;
+;; body-fld-dsp = "(" string SP body-fld-param ")" / nil
+;;
+;; body-fld-enc = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
+;; "QUOTED-PRINTABLE") DQUOTE) / string
+;;
+;; body-fld-id = nstring
+;;
+;; body-fld-lang = nstring / "(" string *(SP string) ")"
+;;
+;; body-fld-lines = number
+;;
+;; body-fld-md5 = nstring
+;;
+;; body-fld-octets = number
+;;
+;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil
+;;
+;; body-type-1part = (body-type-basic / body-type-msg / body-type-text)
+;; [SP body-ext-1part]
+;;
+;; body-type-basic = media-basic SP body-fields
+;; ; MESSAGE subtype MUST NOT be "RFC822"
+;;
+;; body-type-msg = media-message SP body-fields SP envelope
+;; SP body SP body-fld-lines
+;;
+;; body-type-text = media-text SP body-fields SP body-fld-lines
+;;
+;; body-type-mpart = 1*body SP media-subtype
+;; [SP body-ext-mpart]
+;;
+;; media-basic = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
+;; "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
+;; ; Defined in [MIME-IMT]
+;;
+;; media-message = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
+;; ; Defined in [MIME-IMT]
+;;
+;; media-subtype = string
+;; ; Defined in [MIME-IMT]
+;;
+;; media-text = DQUOTE "TEXT" DQUOTE SP media-subtype
+;; ; Defined in [MIME-IMT]
+
+(defun imap-parse-body ()
+ (let (body)
+ (when (eq (char-after) ?\()
+ (imap-forward)
+ (if (eq (char-after) ?\()
+ (let (subbody)
+ (while (and (eq (char-after) ?\()
+ (setq subbody (imap-parse-body)))
+ (push subbody body))
+ (imap-forward)
+ (push (imap-parse-string) body) ;; media-subtype
+ (when (eq (char-after) ?\ ) ;; body-ext-mpart:
+ (imap-forward)
+ (if (eq (char-after) ?\() ;; body-fld-param
+ (push (imap-parse-string-list) body)
+ (push (and (imap-parse-nil) nil) body))
+ (setq body
+ (append (imap-parse-body-ext) body))) ;; body-ext-...
+ (assert (eq (char-after) ?\)))
+ (imap-forward)
+ (nreverse body))
+
+ (push (imap-parse-string) body) ;; media-type
+ (imap-forward)
+ (push (imap-parse-string) body) ;; media-subtype
+ (imap-forward)
+ ;; next line for Sun SIMS bug
+ (and (eq (char-after) ? ) (imap-forward))
+ (if (eq (char-after) ?\() ;; body-fld-param
+ (push (imap-parse-string-list) body)
+ (push (and (imap-parse-nil) nil) body))
+ (imap-forward)
+ (push (imap-parse-nstring) body) ;; body-fld-id
+ (imap-forward)
+ (push (imap-parse-nstring) body) ;; body-fld-desc
+ (imap-forward)
+ (push (imap-parse-string) body) ;; body-fld-enc
+ (imap-forward)
+ (push (imap-parse-number) body) ;; body-fld-octets
+
+ ;; ok, we're done parsing the required parts, what comes now is one
+ ;; of three things:
+ ;;
+ ;; envelope (then we're parsing body-type-msg)
+ ;; body-fld-lines (then we're parsing body-type-text)
+ ;; body-ext-1part (then we're parsing body-type-basic)
+ ;;
+ ;; the problem is that the two first are in turn optionally followed
+ ;; by the third. So we parse the first two here (if there are any)...
+
+ (when (eq (char-after) ?\ )
+ (imap-forward)
+ (let (lines)
+ (cond ((eq (char-after) ?\() ;; body-type-msg:
+ (push (imap-parse-envelope) body) ;; envelope
+ (imap-forward)
+ (push (imap-parse-body) body) ;; body
+ (imap-forward)
+ (push (imap-parse-number) body)) ;; body-fld-lines
+ ((setq lines (imap-parse-number)) ;; body-type-text:
+ (push lines body)) ;; body-fld-lines
+ (t
+ (backward-char))))) ;; no match...
+
+ ;; ...and then parse the third one here...
+
+ (when (eq (char-after) ?\ ) ;; body-ext-1part:
+ (imap-forward)
+ (push (imap-parse-nstring) body) ;; body-fld-md5
+ (setq body (append (imap-parse-body-ext) body)));; body-ext-1part..
+
+ (assert (eq (char-after) ?\)))
+ (imap-forward)
+ (nreverse body)))))
+
+(when imap-debug ; (untrace-all)
+ (require 'trace)
+ (buffer-disable-undo (get-buffer-create imap-debug))
+ (mapc (lambda (f) (trace-function-background f imap-debug))
+ '(
+imap-read-passwd
+imap-utf7-encode
+imap-utf7-decode
+imap-error-text
+imap-kerberos4s-p
+imap-kerberos4-open
+imap-ssl-p
+imap-ssl-open-2
+imap-ssl-open-1
+imap-ssl-open
+imap-network-p
+imap-network-open
+imap-interactive-login
+imap-kerberos4a-p
+imap-kerberos4-auth
+imap-cram-md5-p
+imap-cram-md5-auth
+imap-login-p
+imap-login-auth
+imap-anonymous-p
+imap-anonymous-auth
+imap-open-1
+imap-open
+imap-opened
+imap-authenticate
+imap-close
+imap-capability
+imap-namespace
+imap-send-command-wait
+imap-mailbox-put
+imap-mailbox-get
+imap-mailbox-map-1
+imap-mailbox-map
+imap-current-mailbox
+imap-current-mailbox-p-1
+imap-current-mailbox-p
+imap-mailbox-select-1
+imap-mailbox-select
+imap-mailbox-examine
+imap-mailbox-unselect
+imap-mailbox-expunge
+imap-mailbox-close
+imap-mailbox-create-1
+imap-mailbox-create
+imap-mailbox-delete
+imap-mailbox-rename
+imap-mailbox-lsub
+imap-mailbox-list
+imap-mailbox-subscribe
+imap-mailbox-unsubscribe
+imap-mailbox-status
+imap-mailbox-acl-get
+imap-mailbox-acl-set
+imap-mailbox-acl-delete
+imap-current-message
+imap-list-to-message-set
+imap-fetch-asynch
+imap-fetch
+imap-message-put
+imap-message-get
+imap-message-map
+imap-search
+imap-message-flag-permanent-p
+imap-message-flags-set
+imap-message-flags-del
+imap-message-flags-add
+imap-message-copyuid-1
+imap-message-copyuid
+imap-message-copy
+imap-message-appenduid-1
+imap-message-appenduid
+imap-message-append
+imap-body-lines
+imap-envelope-from
+imap-send-command-1
+imap-send-command
+imap-wait-for-tag
+imap-sentinel
+imap-find-next-line
+imap-arrival-filter
+imap-parse-greeting
+imap-parse-response
+imap-parse-resp-text
+imap-parse-resp-text-code
+imap-parse-data-list
+imap-parse-fetch
+imap-parse-status
+imap-parse-acl
+imap-parse-flag-list
+imap-parse-envelope
+imap-parse-body-extension
+imap-parse-body
+ )))
+
+(provide 'imap)
+
+;;; imap.el ends here
font-lock-defaults user-full-name user-login-name
gnus-newsgroup-name gnus-article-x-face-too-ugly
gnus-newsgroup-charset gnus-newsgroup-emphasis-alist
- mail-mode-hook enable-multibyte-characters
+ mail-mode-hook
adaptive-fill-first-line-regexp adaptive-fill-regexp
url-current-mime-headers buffer-file-coding-system
w3-image-mappings url-current-mime-type
(:password)
(:authentication password))
(maildir
- (:path "~/Maildir/new/")))
+ (:path "~/Maildir/new/"))
+ (imap
+ (:server (getenv "MAILHOST"))
+ (:port)
+ (:stream)
+ (:authentication)
+ (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
+ (:password)
+ (:mailbox "INBOX")
+ (:predicate "UNSEEN UNDELETED")))
"Mapping from keywords to default values.
All keywords that can be used must be listed here."))
'((file mail-source-fetch-file)
(directory mail-source-fetch-directory)
(pop mail-source-fetch-pop)
- (maildir mail-source-fetch-maildir))
+ (maildir mail-source-fetch-maildir)
+ (imap mail-source-fetch-imap))
"A mapping from source type to fetcher function.")
(defvar mail-source-password-cache nil)
(incf found (mail-source-callback callback file))))
found)))
+(eval-and-compile
+ (autoload 'imap-open "imap")
+ (autoload 'imap-authenticate "imap")
+ (autoload 'imap-mailbox-select "imap")
+ (autoload 'imap-search "imap")
+ (autoload 'imap-fetch "imap")
+ (autoload 'imap-mailbox-unselect "imap")
+ (autoload 'imap-close "imap")
+ (autoload 'imap-error-text "imap")
+ (autoload 'nnheader-ms-strip-cr "nnheader"))
+
+(defun mail-source-fetch-imap (source callback)
+ "Fetcher for imap sources."
+ (mail-source-bind (imap source)
+ (let ((found 0)
+ (buf (get-buffer-create (generate-new-buffer-name " *imap source*")))
+ (mail-source-string (format "imap:%s:%s" server mailbox)))
+ (if (and (imap-open server port stream authentication buf)
+ (imap-authenticate user password buf)
+ (imap-mailbox-select mailbox nil buf))
+ (let (str (coding-system-for-write 'binary))
+ (with-temp-file mail-source-crash-box
+ ;; if predicate is nil, use all uids
+ (dolist (uid (imap-search (or predicate "1:*") buf))
+ (when (setq str (imap-fetch uid "RFC822" 'RFC822 nil buf))
+ (insert "From imap " (current-time-string) "\n")
+ (save-excursion
+ (insert str "\n\n"))
+ (while (re-search-forward "^From " nil t)
+ (replace-match ">From "))
+ (goto-char (point-max))))
+ (nnheader-ms-strip-cr))
+ (incf found (mail-source-callback callback server))
+ (imap-mailbox-unselect buf)
+ (imap-close buf))
+ (imap-close buf)
+ (error (imap-error-text buf)))
+ (kill-buffer buf)
+ found)))
+
(provide 'mail-source)
;;; mail-source.el ends here
(x-lisp (not (stringp (or (cdr-safe (assq 'viewer x)) ""))))
(y-lisp (not (stringp (or (cdr-safe (assq 'viewer y)) "")))))
(cond
- ((and x-lisp (not y-lisp))
- t)
- ((and (not y-lisp) x-wild (not y-wild))
- t)
+ ((and x-wild (not y-wild))
+ nil)
((and (not x-wild) y-wild)
t)
+ ((and (not y-lisp) x-lisp)
+ t)
(t nil))))
(defun mailcap-mime-info (string &optional request)
"^ *---+ +Original message +---+ *$\\|"
"^ *--+ +begin message +--+ *$\\|"
"^ *---+ +Original message follows +---+ *$\\|"
+ "^ *---+ +Undelivered message follows +---+ *$\\|"
"^|? *---+ +Message text follows: +---+ *|?$")
"A regexp that matches the separator before the text of a failed message.")
quoted)
(save-excursion
(beginning-of-line)
- (setq quoted (looking-at (regexp-quote message-yank-prefix))))
+ (if (looking-at (sc-cite-regexp))
+ (setq quoted (buffer-substring (match-beginning 0) (match-end 0)))))
(insert "\n\n\n\n")
+ (delete-region (point) (re-search-forward "[ \t]*"))
(when quoted
- (insert message-yank-prefix))
+ (insert quoted))
(fill-paragraph nil)
(goto-char point)
(forward-line 2)))
;;;###autoload
(defun message-resend (address)
"Resend the current article to ADDRESS."
- (interactive "sResend message to: ")
+ (interactive
+ (list
+ (let ((mail-abbrev-mode-regexp ""))
+ (read-from-minibuffer
+ "Resend message to: " nil message-mode-map))))
(message "Resending message to %s..." address)
(save-excursion
(let ((cur (current-buffer))
;; buffer-file-coding-system
;;Article buffer is nil coding system
;;in XEmacs
- enable-multibyte-characters
+ (mm-multibyte-p)
(or (not (eq mule-charset 'ascii))
(setq mule-charset mail-parse-charset)))
(mm-decode-coding-region (point-min) (point-max) mule-charset))))))
(let (mule-charset)
(when (and charset
(setq mule-charset (mm-charset-to-coding-system charset))
- enable-multibyte-characters
+ (mm-multibyte-p)
(or (not (eq mule-charset 'ascii))
(setq mule-charset mail-parse-charset)))
(mm-decode-coding-string string mule-charset))))
"message/rfc822")
"A list of MIME types to be displayed automatically.")
-(defvar mm-attachment-override-types '("text/plain" "text/x-vcard")
+(defvar mm-attachment-override-types '("text/x-vcard")
"Types that should have \"attachment\" ignored if they can be displayed inline.")
(defvar mm-automatic-external-display nil
(if (or (not ctl)
(not (string-match "/" (car ctl))))
(mm-dissect-singlepart
- '("text/plain") nil no-strict-mime
+ '("text/plain")
+ (and cte (intern (downcase (mail-header-remove-whitespace
+ (mail-header-remove-comments
+ cte)))))
+ no-strict-mime
(and cd (ignore-errors (mail-header-parse-content-disposition cd)))
description)
(setq type (split-string (car ctl) "/"))
(defvar mm-binary-coding-system
(cond
- ((mm-coding-system-p 'no-conversion) 'no-conversion)
((mm-coding-system-p 'binary) 'binary)
+ ((mm-coding-system-p 'no-conversion) 'no-conversion)
(t nil))
"100% binary coding system.")
(defsubst mm-multibyte-p ()
"Say whether multibyte is enabled."
- (and (boundp 'enable-multibyte-characters)
- enable-multibyte-characters))
+ (or (string-match "XEmacs\\|Lucid" emacs-version)
+ (and (boundp 'enable-multibyte-characters)
+ enable-multibyte-characters)))
(defmacro mm-with-unibyte-buffer (&rest forms)
"Create a temporary buffer, and evaluate FORMS there like `progn'.
See also `with-temp-file' and `with-output-to-string'."
(let ((temp-buffer (make-symbol "temp-buffer"))
(multibyte (make-symbol "multibyte")))
- `(if (not (boundp 'enable-multibyte-characters))
+ `(if (or (string-match "XEmacs\\|Lucid" emacs-version)
+ (not (boundp 'enable-multibyte-characters)))
(with-temp-buffer ,@forms)
(let ((,multibyte (default-value 'enable-multibyte-characters))
,temp-buffer)
(defun mm-find-charset-region (b e)
"Return a list of charsets in the region."
(cond
- ((and (boundp 'enable-multibyte-characters)
- enable-multibyte-characters
+ ((and (mm-multibyte-p)
(fboundp 'find-charset-region))
(find-charset-region b e))
((not (boundp 'current-language-environment))
;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
;;; Peter von der Ah\'e <pahe@daimi.au.dk>
-(defconst mm-uu-forward-begin-line "^-+ \\(?:Start of \\)?Forwarded message")
-(defconst mm-uu-forward-end-line "^-+ End\\(?: of\\)? forwarded message")
+(defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message")
+(defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message")
(defvar mm-uu-begin-line nil)
(setq cte (intern (downcase (mail-header-remove-whitespace
(mail-header-remove-comments
cte))))))
- (if (eq cte 'base64)
+ (if (memq cte '(base64 quoted-printable))
(setq charset 'gnus-encoded ;; a fake charset
cte nil)))
(goto-char (point-max)))
(setq handles gnus-article-mime-handles))
(when handles
(setq gnus-article-mime-handles
- (append gnus-article-mime-handles handles)))
+ (nconc gnus-article-mime-handles
+ (if (listp (car handles))
+ handles (list handles)))))
(mm-handle-set-undisplayer
handle
`(lambda ()
(insert-buffer-substring (cdr (assq 'buffer cont))))
((and (setq filename (cdr (assq 'filename cont)))
(not (equal (cdr (assq 'nofile cont)) "yes")))
- (mm-insert-file-contents filename nil nil nil nil t))
+ (let ((coding-system-for-read mm-binary-coding-system))
+ (mm-insert-file-contents filename nil nil nil nil t)))
(t
(insert (cdr (assq 'contents cont)))))
(setq encoding (mm-encode-buffer type)
(gnus-request-accept-article "nndraft:queue" nil t t))
(deffoo nnagent-request-set-mark (group action server)
- action)
+ (with-temp-buffer
+ (insert (format "(%s-request-set-mark \"%s\" '%s \"%s\")\n"
+ (nth 0 gnus-command-method) group action
+ (or server (nth 1 gnus-command-method))))
+ (append-to-file (point-min) (point-max) (gnus-agent-lib-file "flags")))
+ nil)
;; Use nnml functions for just about everything.
(nnoo-import nnagent
(set-buffer nnfolder-current-buffer)
(when (nnfolder-goto-article article)
(setq start (point))
- (search-forward "\n\n" nil t)
- (setq stop (1- (point)))
+ (setq stop (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max)))
(set-buffer nntp-server-buffer)
(insert (format "221 %d Article retrieved.\n" article))
(insert-buffer-substring nnfolder-current-buffer start stop)
(goto-char (point-min))
(while (re-search-forward
(concat "^" nnfolder-article-marker)
- (save-excursion (search-forward "\n\n" nil t) (point)) t)
+ (save-excursion (and (search-forward "\n\n" nil t) (point)))
+ t)
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point))))
(setq result (eval accept-form))
(save-excursion
(set-buffer buf)
(goto-char (point-min))
- (search-forward "\n\n" nil t)
- (forward-line -1)
+ (if (search-forward "\n\n" nil t)
+ (forward-line -1)
+ (goto-char (point-max)))
(while (re-search-backward (concat "^" nnfolder-article-marker) nil t)
(delete-region (point) (progn (forward-line 1) (point))))
(when nnmail-cache-accepted-message-ids
(while (setq group-art (pop group-art-list))
;; Kill any previous newsgroup markers.
(goto-char (point-min))
- (search-forward "\n\n" nil t)
- (forward-line -1)
+ (if (search-forward "\n\n" nil t)
+ (forward-line -1)
+ (goto-char (point-max)))
(while (search-backward (concat "\n" nnfolder-article-marker) nil t)
(delete-region (1+ (point)) (progn (forward-line 2) (point))))
(defun nnfolder-insert-newsgroup-line (group-art)
(save-excursion
(goto-char (point-min))
- (when (search-forward "\n\n" nil t)
- (forward-char -1)
- (insert (format (concat nnfolder-article-marker "%d %s\n")
- (cdr group-art) (current-time-string))))))
+ (unless (search-forward "\n\n" nil t)
+ (goto-char (point-max))
+ (insert "\n"))
+ (forward-char -1)
+ (insert (format (concat nnfolder-article-marker "%d %s\n")
+ (cdr group-art) (current-time-string)))))
(defun nnfolder-active-number (group)
;; Find the next article number in GROUP.
--- /dev/null
+;;; nnimap.el --- imap backend for Gnus
+;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <jas@pdc.kth.se>
+;; Jim Radford <radford@robby.caltech.edu>
+;; Keywords: mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Todo, major things:
+;;
+;; o Fix Gnus to view correct number of unread/total articles in group buffer
+;; o Fix Gnus to handle leading '.' in group names (fixed?)
+;; o Finish disconnected mode (moving articles between mailboxes unplugged)
+;; o Sieve
+;; o MIME (partial article fetches)
+;; o Split to other backends, different split rules for different
+;; servers/inboxes
+;;
+;; Todo, minor things:
+;;
+;; o Support escape characters in `message-tokenize-header'
+;; o Split-fancy.
+;; o Support NOV nnmail-extra-headers.
+;; o Verify that we don't use IMAP4rev1 specific things (RFC2060 App B)
+;; o Dont uid fetch 1,* in nnimap-retrive-groups (slow)
+;; o Split up big fetches (1,* header especially) in smaller chunks
+;; o What do I do with gnus-newsgroup-*?
+;; o Tell Gnus about new groups (how can we tell?)
+;; o Respooling (fix Gnus?) (unnecessery?)
+;; o Add support for the following: (if applicable)
+;; request-list-newsgroups, request-regenerate
+;; list-active-group,
+;; request-associate-buffer, request-restore-buffer,
+;; o Do The Right Thing when UIDVALIDITY changes (what's the right thing?)
+;; o Support RFC2221 (Login referrals)
+;; o IMAP2BIS compatibility? (RFC2061)
+;; o ACAP stuff (perhaps a different project, would be nice to ACAPify
+;; .newsrc.eld)
+;; o What about Gnus's article editing, can we support it?
+;; o Use \Draft to support the draft group??
+
+;;; Code:
+
+(eval-and-compile
+ (require 'imap))
+
+(require 'nnoo)
+(require 'nnmail)
+(require 'nnheader)
+(require 'mm-util)
+(require 'gnus)
+(require 'gnus-async)
+(require 'gnus-range)
+(require 'gnus-start)
+(require 'gnus-int)
+
+(nnoo-declare nnimap)
+
+(defconst nnimap-version "nnimap 0.131")
+
+(defvoo nnimap-address nil
+ "Address of physical IMAP server. If nil, use the virtual server's name.")
+
+(defvoo nnimap-server-port nil
+ "Port number on physical IMAP server.
+If nil, defaults to 993 for SSL connections and 143 otherwise.")
+
+;; Splitting variables
+
+(defvar nnimap-split-crosspost t
+ "If non-nil, do crossposting if several split methods match the mail.
+If nil, the first match found will be used.")
+
+(defvar nnimap-split-inbox nil
+ "*Name of mailbox to split mail from.
+
+Mail is read from this mailbox and split according to rules in
+`nnimap-split-rules'.
+
+This can be a string or a list of strings.")
+
+(defvar nnimap-split-rule nil
+ "*Mail will be split according to theese rules.
+
+Mail is read from mailbox(es) specified in `nnimap-split-inbox'.
+
+If you'd like, for instance, one mail group for mail from the
+\"gnus-imap\" mailing list, one group for junk mail and leave
+everything else in the incoming mailbox, you could do something like
+this:
+
+(setq nnimap-split-rule '((\"INBOX.gnus-imap\" \"From:.*gnus-imap\")
+ (\"INBOX.junk\" \"Subject:.*buy\")))
+
+As you can see, `nnimap-split-rule' is a list of lists, where the first
+element in each \"rule\" is the name of the IMAP mailbox, and the
+second is a regexp that nnimap will try to match on the header to find
+a fit.
+
+The first element can also be a list. In that case, the first element
+is the server the second element is the group on that server in which
+the matching article will be stored.
+
+The second element can also be a function. In that case, it will be
+called narrowed to the headers with the first element of the rule as
+the argument. It should return a non-nil value if it thinks that the
+mail belongs in that group.")
+
+;; Authorization / Privacy variables
+
+(defvoo nnimap-auth-method nil
+ "Obsolete.")
+
+(defvoo nnimap-stream nil
+ "How nnimap will connect to the server.
+
+The default, nil, will try to use the \"best\" method the server can
+handle.
+
+Change this if
+
+1) you want to connect with SSL. The SSL integration with IMAP is
+ brain-dead so you'll have to tell it specifically.
+
+2) your server is more capable than your environment -- i.e. your
+ server accept Kerberos login's but you haven't installed the
+ `imtest' program or your machine isn't configured for Kerberos.
+
+Possible choices: kerberos4, ssl, network")
+
+(defvoo nnimap-authenticator nil
+ "How nnimap authenticate itself to the server.
+
+The default, nil, will try to use the \"best\" method the server can
+handle.
+
+There is only one reason for fiddling with this variable, and that is
+if your server is more capable than your environment -- i.e. you
+connect to a server that accept Kerberos login's but you haven't
+installed the `imtest' program or your machine isn't configured for
+Kerberos.
+
+Possible choices: kerberos4, cram-md5, login, anonymous.")
+
+(defvoo nnimap-directory (nnheader-concat gnus-directory "overview/")
+ "Directory to keep NOV cache files for nnimap groups. See also
+`nnimap-nov-file-name'.")
+
+(defvoo nnimap-nov-file-name "nnimap."
+ "NOV cache base filename. The group name and
+`nnimap-nov-file-name-suffix' will be appended. A typical complete
+file name would be ~/News/overview/nnimap.pdc.INBOX.ding.nov, or
+~/News/overview/nnimap/pdc/INBOX/ding/nov if
+`nnmail-use-long-file-names' is nil")
+
+(defvoo nnimap-nov-file-name-suffix ".novcache"
+ "Suffix for NOV cache base filename.")
+
+(defvoo nnimap-nov-is-evil nil
+ "If non-nil, nnimap will never generate or use a local nov database
+for this backend. Using nov databases will speed up header fetching
+considerably. Unlike other backends, you do not need to take special
+care if you flip this variable.")
+
+(defvoo nnimap-expunge-on-close 'always ; 'ask, 'never
+ "When a IMAP group with articles marked for deletion is closed, this
+variable determine if nnimap should actually remove the articles or
+not.
+
+If always, nnimap always perform a expunge when closing the group.
+If never, nnimap never expunges articles marked for deletion.
+If ask, nnimap will ask you if you wish to expunge marked articles.
+
+When setting this variable to `never', you can only expunge articles
+by using `G x' (gnus-group-nnimap-expunge) from the Group buffer.")
+
+(defvoo nnimap-list-pattern "*"
+ "A string LIMIT or list of strings with mailbox wildcards used to
+limit available groups. Se below for available wildcards.
+
+The LIMIT string can be a cons cell (REFERENCE . LIMIT), where
+REFERENCE will be passed as the first parameter to LIST/LSUB. The
+semantics of this are server specific, on the University of Washington
+server you can specify a directory.
+
+Example:
+ '(\"INBOX\" \"mail/*\" (\"~friend/mail/\" . \"list/*\"))
+
+There are two wildcards * and %. * matches everything, % matches
+everything in the current hierarchy.")
+
+(defvoo nnimap-news-groups nil
+ "IMAP support a news-like mode, also known as bulletin board mode,
+where replies is sent via IMAP instead of SMTP.
+
+This variable should contain a regexp matching groups where you wish
+replies to be stored to the mailbox directly.
+
+Example:
+ '(\"^[^I][^N][^B][^O][^X].*$\")
+
+This will match all groups not beginning with \"INBOX\".
+
+Note that there is nothing technically different between mail-like and
+news-like mailboxes. If you wish to have a group with todo items or
+similar which you wouldn't want to set up a mailing list for, you can
+use this to make replies go directly to the group.")
+
+(defvoo nnimap-server-address nil
+ "Obsolete. Use `nnimap-address'.")
+
+(defcustom nnimap-authinfo-file "~/.authinfo"
+ "Authorization information for IMAP servers. In .netrc format."
+ :type
+ '(choice file
+ (repeat :tag "Entries"
+ :menu-tag "Inline"
+ (list :format "%v"
+ :value ("" ("login" . "") ("password" . ""))
+ (string :tag "Host")
+ (checklist :inline t
+ (cons :format "%v"
+ (const :format "" "login")
+ (string :format "Login: %v"))
+ (cons :format "%v"
+ (const :format "" "password")
+ (string :format "Password: %v")))))))
+
+(defcustom nnimap-prune-cache t
+ "If non-nil, nnimap check wheter articles still exist on server
+before using data stored in NOV cache."
+ :type 'boolean)
+
+(defvar nnimap-request-list-method 'imap-mailbox-list
+ "Method to use to request a list of all folders from the server.
+If this is 'imap-mailbox-lsub, then use a server-side subscription list to
+restrict visible folders.")
+
+;; Internal variables:
+
+(defvar nnimap-debug "*nnimap-debug*")
+(defvar nnimap-current-move-server nil)
+(defvar nnimap-current-move-group nil)
+(defvar nnimap-current-move-article nil)
+(defvar nnimap-length)
+(defvar nnimap-progress-chars '(?| ?/ ?- ?\\))
+(defvar nnimap-progress-how-often 20)
+(defvar nnimap-counter)
+(defvar nnimap-callback-callback-function nil
+ "Gnus callback the nnimap asynchronous callback should call.")
+(defvar nnimap-callback-buffer nil
+ "Which buffer the asynchronous article prefetch callback should work in.")
+
+;; Various server variables.
+
+\f
+;; Internal variables.
+(defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers.
+(defvar nnimap-current-server nil) ;; Current server
+(defvar nnimap-server-buffer nil) ;; Current servers' buffer
+
+(nnoo-define-basics nnimap)
+
+;; Utility functions:
+
+(defun nnimap-replace-in-string (string regexp to)
+ "Replace substrings in STRING matching REGEXP with TO."
+ (if (string-match regexp string)
+ (concat (substring string 0 (match-beginning 0))
+ to
+ (nnimap-replace-in-string (substring string (match-end 0))
+ regexp to))
+ string))
+
+(defsubst nnimap-get-server-buffer (server)
+ "Return buffer for SERVER, if nil use current server."
+ (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist)))
+
+(defun nnimap-possibly-change-server (server)
+ "Return buffer for SERVER, changing the current server as a side-effect.
+If SERVER is nil, uses the current server."
+ (setq nnimap-current-server (or server nnimap-current-server)
+ nnimap-server-buffer (nnimap-get-server-buffer nnimap-current-server)))
+
+(defun nnimap-verify-uidvalidity (group server)
+ "Verify stored uidvalidity match current one in GROUP on SERVER."
+ (let* ((gnusgroup (gnus-group-prefixed-name
+ group (gnus-server-to-method
+ (format "nnimap:%s" server))))
+ (new-uidvalidity (imap-mailbox-get 'uidvalidity))
+ (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)))
+ (if old-uidvalidity
+ (if (not (equal old-uidvalidity new-uidvalidity))
+ nil ;; uidvalidity clash
+ (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity)
+ t)
+ (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity))
+ t)))
+
+(defun nnimap-find-minmax-uid (group &optional examine)
+ "Find lowest and highest active article nummber in GROUP.
+If EXAMINE is non-nil the group is selected read-only."
+ (with-current-buffer nnimap-server-buffer
+ (when (imap-mailbox-select group examine)
+ (let (minuid maxuid)
+ (when (> (imap-mailbox-get 'exists) 0)
+ (imap-fetch "1,*" "UID" nil 'nouidfetch)
+ (imap-message-map (lambda (uid Uid)
+ (setq minuid (if minuid (min minuid uid) uid)
+ maxuid (if maxuid (max maxuid uid) uid)))
+ 'UID))
+ (list (imap-mailbox-get 'exists) minuid maxuid)))))
+
+(defun nnimap-possibly-change-group (group &optional server)
+ "Make GROUP the current group, and SERVER the current server."
+ (when (nnimap-possibly-change-server server)
+ (with-current-buffer nnimap-server-buffer
+ (if (or (null group) (imap-current-mailbox-p group))
+ imap-current-mailbox
+ (if (imap-mailbox-select group)
+ (if (or (nnimap-verify-uidvalidity
+ group (or server nnimap-current-server))
+ (zerop (imap-mailbox-get 'exists group))
+ (yes-or-no-p
+ (format
+ "nnimap: Group %s is not uidvalid. Continue? " group)))
+ imap-current-mailbox
+ (imap-mailbox-unselect)
+ (error "nnimap: Group %s is not uid-valid." group))
+ (nnheader-report 'nnimap (imap-error-text)))))))
+
+(defun nnimap-replace-whitespace (string)
+ "Return STRING with all whitespace replaced with space."
+ (when string
+ (while (string-match "[\r\n\t]+" string)
+ (setq string (replace-match " " t t string)))
+ string))
+
+;; Required backend functions
+
+(defun nnimap-retrieve-headers-progress ()
+ "Hook to insert NOV line for current article into `nntp-server-buffer'."
+ (and (numberp nnmail-large-newsgroup)
+ (zerop (% (incf nnimap-counter) nnimap-progress-how-often))
+ (> nnimap-length nnmail-large-newsgroup)
+ (nnheader-message 6 "nnimap: Retrieving headers... %c"
+ (nth (/ (% nnimap-counter
+ (* (length nnimap-progress-chars)
+ nnimap-progress-how-often))
+ nnimap-progress-how-often)
+ nnimap-progress-chars)))
+ (with-current-buffer nntp-server-buffer
+ (nnheader-insert-nov
+ (with-current-buffer nnimap-server-buffer
+ (vector imap-current-message
+ (nnimap-replace-whitespace
+ (imap-message-envelope-subject imap-current-message))
+ (nnimap-replace-whitespace
+ (imap-envelope-from
+ (car-safe (imap-message-envelope-from
+ imap-current-message))))
+ (nnimap-replace-whitespace
+ (imap-message-envelope-date imap-current-message))
+ (nnimap-replace-whitespace
+ (imap-message-envelope-message-id imap-current-message))
+ (nnimap-replace-whitespace
+ (let ((str (if (imap-capability 'IMAP4rev1)
+ (nth 2 (assoc
+ "HEADER.FIELDS REFERENCES"
+ (imap-message-get
+ imap-current-message 'BODYDETAIL)))
+ (imap-message-get imap-current-message
+ 'RFC822.HEADER))))
+ (if (> (length str) (length "References: "))
+ (substring str (length "References: "))
+ (if (and (setq str (imap-message-envelope-in-reply-to
+ imap-current-message))
+ (string-match "<[^>]+>" str))
+ (substring str (match-beginning 0) (match-end 0))))))
+ (imap-message-get imap-current-message 'RFC822.SIZE)
+ (imap-body-lines (imap-message-body imap-current-message))
+ nil ;; xref
+ nil))))) ;; extra-headers
+
+(defun nnimap-retrieve-which-headers (articles fetch-old)
+ "Get a range of articles to fetch based on ARTICLES and FETCH-OLD."
+ (with-current-buffer nnimap-server-buffer
+ (if (numberp (car-safe articles))
+ (imap-search
+ (concat "UID "
+ (nnimap-range-to-string
+ (gnus-compress-sequence
+ (append (gnus-uncompress-sequence
+ (and fetch-old
+ (cons (if (numberp fetch-old)
+ (max 1 (- (car articles) fetch-old))
+ 1)
+ (1- (car articles)))))
+ articles)))))
+ (mapcar (lambda (msgid)
+ (imap-search
+ (format "HEADER Message-Id %s" msgid)))
+ articles))))
+
+(defun nnimap-group-overview-filename (group server)
+ "Make pathname for GROUP on SERVER."
+ (let ((dir (file-name-as-directory (expand-file-name nnimap-directory)))
+ (file (nnheader-translate-file-chars
+ (concat nnimap-nov-file-name
+ (if (equal server "")
+ "unnamed"
+ server) "." group nnimap-nov-file-name-suffix) t)))
+ (if (or nnmail-use-long-file-names
+ (file-exists-p (concat dir file)))
+ (concat dir file)
+ (concat dir (mm-encode-coding-string
+ (nnheader-replace-chars-in-string file ?. ?/)
+ nnmail-pathname-coding-system)))))
+
+(defun nnimap-retrieve-headers-from-file (group server)
+ (with-current-buffer nntp-server-buffer
+ (let ((nov (nnimap-group-overview-filename group server)))
+ (when (file-exists-p nov)
+ (mm-insert-file-contents nov)
+ (set-buffer-modified-p nil)
+ (let ((min (progn (goto-char (point-min))
+ (when (not (eobp))
+ (read (current-buffer)))))
+ (max (progn (goto-char (point-max))
+ (forward-line -1)
+ (when (not (bobp))
+ (read (current-buffer))))))
+ (if (and (numberp min) (numberp max))
+ (cons min max)
+ ;; junk, remove it, it's saved later
+ (erase-buffer)
+ nil))))))
+
+(defun nnimap-retrieve-headers-from-server (articles group server)
+ (with-current-buffer nnimap-server-buffer
+ (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress))
+ (nnimap-length (gnus-range-length articles))
+ (nnimap-counter 0))
+ (imap-fetch (nnimap-range-to-string articles)
+ (concat "(UID RFC822.SIZE ENVELOPE BODY "
+ (if (imap-capability 'IMAP4rev1)
+ "BODY.PEEK[HEADER.FIELDS (References)])"
+ "RFC822.HEADER.LINES (References))")))
+ (and (numberp nnmail-large-newsgroup)
+ (> nnimap-length nnmail-large-newsgroup)
+ (nnheader-message 6 "nnimap: Retrieving headers...done")))))
+
+(defun nnimap-use-nov-p (group server)
+ (or gnus-nov-is-evil nnimap-nov-is-evil
+ (unless (and (gnus-make-directory
+ (file-name-directory
+ (nnimap-group-overview-filename group server)))
+ (file-writable-p
+ (nnimap-group-overview-filename group server)))
+ (message "nnimap: Nov cache not writable, %s"
+ (nnimap-group-overview-filename group server)))))
+
+(deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
+ (when (nnimap-possibly-change-group group server)
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (if (nnimap-use-nov-p group server)
+ (nnimap-retrieve-headers-from-server
+ (gnus-compress-sequence articles) group server)
+ (let (uids cached low high)
+ (when (setq uids (nnimap-retrieve-which-headers articles fetch-old)
+ low (car uids)
+ high (car (last uids)))
+ (if (setq cached (nnimap-retrieve-headers-from-file group server))
+ (progn
+ ;; fetch articles with uids before cache block
+ (when (< low (car cached))
+ (goto-char (point-min))
+ (nnimap-retrieve-headers-from-server
+ (cons low (1- (car cached))) group server))
+ ;; fetch articles with uids after cache block
+ (when (> high (cdr cached))
+ (goto-char (point-max))
+ (nnimap-retrieve-headers-from-server
+ (cons (1+ (cdr cached)) high) group server))
+ (when nnimap-prune-cache
+ ;; remove nov's for articles which has expired on server
+ (goto-char (point-min))
+ (dolist (uid (gnus-set-difference articles uids))
+ (when (re-search-forward (format "^%d\t" uid) nil t)
+ (gnus-delete-line)))))
+ ;; nothing cached, fetch whole range from server
+ (nnimap-retrieve-headers-from-server
+ (cons low high) group server))
+ (when (buffer-modified-p)
+ (nnmail-write-region
+ 1 (point-max) (nnimap-group-overview-filename group server)
+ nil 'nomesg))
+ (nnheader-nov-delete-outside-range low high))))
+ 'nov)))
+
+(defun nnimap-open-connection (server)
+ (if (not (imap-open nnimap-address nnimap-server-port nnimap-stream
+ nnimap-authenticator nnimap-server-buffer))
+ (nnheader-report 'nnimap "Can't open connection to server %s" server)
+ (unless (or (imap-capability 'IMAP4 nnimap-server-buffer)
+ (imap-capability 'IMAP4rev1 nnimap-server-buffer))
+ (imap-close nnimap-server-buffer)
+ (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server))
+ (let (list alist user passwd)
+ (and (fboundp 'gnus-parse-netrc)
+ (setq list (gnus-parse-netrc nnimap-authinfo-file)
+ alist (or (and (gnus-netrc-get
+ (gnus-netrc-machine list server) "machine")
+ (gnus-netrc-machine list server))
+ (gnus-netrc-machine list nnimap-address))
+ user (gnus-netrc-get alist "login")
+ passwd (gnus-netrc-get alist "password")))
+ (if (imap-authenticate user passwd nnimap-server-buffer)
+ (prog1
+ (push (list server nnimap-server-buffer)
+ nnimap-server-buffer-alist)
+ (nnimap-possibly-change-server server))
+ (imap-close nnimap-server-buffer)
+ (kill-buffer nnimap-server-buffer)
+ (nnheader-report 'nnimap "Could not authenticate to %s" server)))))
+
+(deffoo nnimap-open-server (server &optional defs)
+ (nnheader-init-server-buffer)
+ (if (nnimap-server-opened server)
+ t
+ (unless (assq 'nnimap-server-buffer defs)
+ (push (list 'nnimap-server-buffer (concat " *nnimap* " server)) defs))
+ ;; translate `nnimap-server-address' to `nnimap-address' in defs
+ ;; for people that configured nnimap with a very old version
+ (unless (assq 'nnimap-address defs)
+ (if (assq 'nnimap-server-address defs)
+ (push (list 'nnimap-address
+ (cadr (assq 'nnimap-server-address defs))) defs)
+ (push (list 'nnimap-address server) defs)))
+ (nnoo-change-server 'nnimap server defs)
+ (if (null nnimap-server-buffer)
+ (error "this shouldn't happen"))
+ (or (imap-opened nnimap-server-buffer)
+ (nnimap-open-connection server))))
+
+(deffoo nnimap-server-opened (&optional server)
+ "If SERVER is the current virtual server, and the connection to the
+physical server is alive, this function return a non-nil value. If
+SERVER is nil, it is treated as the current server."
+ ;; clean up autologouts??
+ (and (or server nnimap-current-server)
+ (nnoo-server-opened 'nnimap (or server nnimap-current-server))
+ (imap-opened (nnimap-get-server-buffer server))))
+
+(deffoo nnimap-close-server (&optional server)
+ "Close connection to server and free all resources connected to
+it. Return nil if the server couldn't be closed for some reason."
+ (let ((server (or server nnimap-current-server)))
+ (when (or (nnimap-server-opened server)
+ (imap-opened (nnimap-get-server-buffer server)))
+ (imap-close (nnimap-get-server-buffer server))
+ (kill-buffer (nnimap-get-server-buffer server))
+ (setq nnimap-server-buffer nil
+ nnimap-current-server nil
+ nnimap-server-buffer-alist
+ (delq server nnimap-server-buffer-alist)))
+ (nnoo-close-server 'nnimap server)))
+
+(deffoo nnimap-request-close ()
+ "Close connection to all servers and free all resources that the
+backend have reserved. All buffers that have been created by that
+backend should be killed. (Not the nntp-server-buffer, though.) This
+function is generally only called when Gnus is shutting down."
+ (mapcar (lambda (server) (nnimap-close-server (car server)))
+ nnimap-server-buffer-alist)
+ (setq nnimap-server-buffer-alist nil))
+
+(deffoo nnimap-status-message (&optional server)
+ "This function returns the last error message from server."
+ (when (nnimap-possibly-change-server server)
+ (nnoo-status-message 'nnimap server)))
+
+(defun nnimap-demule (string)
+ (funcall (if (and (fboundp 'string-as-multibyte)
+ (subrp (symbol-function 'string-as-multibyte)))
+ 'string-as-multibyte
+ 'identity)
+ (or string "")))
+
+(defun nnimap-callback ()
+ (remove-hook 'imap-fetch-data-hook 'nnimap-callback)
+ (with-current-buffer nnimap-callback-buffer
+ (insert
+ (with-current-buffer nnimap-server-buffer
+ (nnimap-demule (imap-message-get (imap-current-message) 'RFC822)))) ;xxx
+ (nnheader-ms-strip-cr)
+ (funcall nnimap-callback-callback-function t)))
+
+(defun nnimap-request-article-part (article part prop
+ &optional group server to-buffer)
+ (when (nnimap-possibly-change-group group server)
+ (let ((article (if (stringp article)
+ (car-safe (imap-search
+ (format "HEADER Message-Id %s" article)
+ nnimap-server-buffer))
+ article)))
+ (when article
+ (gnus-message 9 "nnimap: Fetching (part of) article %d..." article)
+ (if (not nnheader-callback-function)
+ (with-current-buffer (or to-buffer nntp-server-buffer)
+ (erase-buffer)
+ (insert (nnimap-demule (imap-fetch article part prop nil
+ nnimap-server-buffer)))
+ (nnheader-ms-strip-cr)
+ (gnus-message 9 "nnimap: Fetching (part of) article %d...done"
+ article)
+ (if (bobp)
+ (nnheader-report 'nnimap "No such article: %s"
+ (imap-error-text nnimap-server-buffer))
+ (cons group article)))
+ (add-hook 'imap-fetch-data-hook 'nnimap-callback)
+ (setq nnimap-callback-callback-function nnheader-callback-function
+ nnimap-callback-buffer nntp-server-buffer)
+ (imap-fetch-asynch article part nil nnimap-server-buffer)
+ (cons group article))))))
+
+(deffoo nnimap-asynchronous-p ()
+ t)
+
+(deffoo nnimap-request-article (article &optional group server to-buffer)
+ (nnimap-request-article-part
+ article "RFC822.PEEK" 'RFC822 group server to-buffer))
+
+(deffoo nnimap-request-head (article &optional group server to-buffer)
+ (nnimap-request-article-part
+ article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer))
+
+(deffoo nnimap-request-body (article &optional group server to-buffer)
+ (nnimap-request-article-part
+ article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer))
+
+(deffoo nnimap-request-group (group &optional server fast)
+ (nnimap-request-update-info-internal
+ group
+ (gnus-get-info (gnus-group-prefixed-name
+ group (gnus-server-to-method (format "nnimap:%s" server))))
+ server)
+ (when (nnimap-possibly-change-group group server)
+ (let (info)
+ (cond (fast group)
+ ((null (setq info (nnimap-find-minmax-uid group t)))
+ (nnheader-report 'nnimap "Could not get active info for %s"
+ group))
+ (t
+ (nnheader-insert "211 %d %d %d %s\n" (or (nth 0 info) 0)
+ (max 1 (or (nth 1 info) 1))
+ (or (nth 2 info) 0) group)
+ (nnheader-report 'nnimap "Group %s selected" group)
+ t)))))
+
+(defun nnimap-close-group (group &optional server)
+ (with-current-buffer nnimap-server-buffer
+ (when (and (imap-opened)
+ (nnimap-possibly-change-group group server))
+ (case nnimap-expunge-on-close
+ ('always (imap-mailbox-expunge)
+ (imap-mailbox-close))
+ ('ask (if (and (imap-search "DELETED")
+ (gnus-y-or-n-p (format
+ "Expunge articles in group `%s'? "
+ imap-current-mailbox)))
+ (progn (imap-mailbox-expunge)
+ (imap-mailbox-close))
+ (imap-mailbox-unselect)))
+ (t (imap-mailbox-unselect)))
+ (not imap-current-mailbox))))
+
+(defun nnimap-pattern-to-list-arguments (pattern)
+ (mapcar (lambda (p)
+ (cons (car-safe p) (or (cdr-safe p) p)))
+ (if (and (listp pattern)
+ (listp (cdr pattern)))
+ pattern
+ (list pattern))))
+
+(deffoo nnimap-request-list (&optional server)
+ (when (nnimap-possibly-change-server server)
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer))
+ (gnus-message 5 "nnimap: Generating active list%s..."
+ (if (> (length server) 0) (concat " for " server) ""))
+ (with-current-buffer nnimap-server-buffer
+ (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern))
+ (dolist (mbx (funcall nnimap-request-list-method
+ (cdr pattern) (car pattern)))
+ (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx))
+ (let ((info (nnimap-find-minmax-uid mbx 'examine)))
+ (when info
+ ;; Escape SPC in mailboxes xxx relies on gnus internals
+ (with-current-buffer nntp-server-buffer
+ (insert (format "%s %d %d y\n"
+ (nnimap-replace-in-string mbx " " "\\ ")
+ (or (nth 2 info) 0)
+ (max 1 (or (nth 1 info) 1)))))))))))
+ (gnus-message 5 "nnimap: Generating active list%s...done"
+ (if (> (length server) 0) (concat " for " server) ""))
+ t))
+
+(deffoo nnimap-request-post (&optional server)
+ (let ((success t))
+ (dolist (mbx (message-tokenize-header
+ (message-fetch-field "Newsgroups")) success)
+ (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method)))
+ (or (gnus-active to-newsgroup)
+ (gnus-activate-group to-newsgroup)
+ (if (gnus-y-or-n-p (format "No such group: %s. Create it? "
+ to-newsgroup))
+ (or (and (gnus-request-create-group
+ to-newsgroup gnus-command-method)
+ (gnus-activate-group to-newsgroup nil nil
+ gnus-command-method))
+ (error "Couldn't create group %s" to-newsgroup)))
+ (error "No such group: %s" to-newsgroup))
+ (unless (nnimap-request-accept-article mbx (nth 1 gnus-command-method))
+ (setq success nil))))))
+
+;; Optional backend functions
+
+(deffoo nnimap-retrieve-groups (groups &optional server)
+ (when (nnimap-possibly-change-server server)
+ (gnus-message 5 "nnimap: Checking mailboxes...")
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (dolist (group groups)
+ (gnus-message 7 "nnimap: Checking mailbox %s" group)
+ (or (member "\\NoSelect"
+ (imap-mailbox-get 'list-flags group nnimap-server-buffer))
+ (let ((info (nnimap-find-minmax-uid group 'examine)))
+ ;; Escape SPC in mailboxes xxx relies on gnus internals
+ (insert (format "211 %d %d %d %s\n" (or (nth 0 info) 0)
+ (max 1 (or (nth 1 info) 1))
+ (or (nth 2 info) 0)
+ (nnimap-replace-in-string group " " "\\ ")))))))
+ (gnus-message 5 "nnimap: Checking mailboxes...done")
+ 'groups))
+
+(deffoo nnimap-request-update-info-internal (group info &optional server)
+ (when (nnimap-possibly-change-group group server)
+ (when info ;; xxx what does this mean? should we create a info?
+ (with-current-buffer nnimap-server-buffer
+ (gnus-message 5 "nnimap: Updating info for %s..."
+ (gnus-info-group info))
+
+ (when (nnimap-mark-permanent-p 'read)
+ (let (seen unseen)
+ ;; read info could contain articles marked unread by other
+ ;; imap clients! we correct this
+ (setq seen (gnus-uncompress-range (gnus-info-read info))
+ unseen (imap-search "UNSEEN UNDELETED")
+ seen (gnus-set-difference seen unseen)
+ ;; seen might lack articles marked as read by other
+ ;; imap clients! we correct this
+ seen (append seen (imap-search "SEEN"))
+ ;; remove dupes
+ seen (sort seen '<)
+ seen (gnus-compress-sequence seen t)
+ ;; we can't return '(1) since this isn't a "list of ranges",
+ ;; and we can't return '((1)) since g-list-of-unread-articles
+ ;; is buggy so we return '((1 . 1)).
+ seen (if (and (integerp (car seen))
+ (null (cdr seen)))
+ (list (cons (car seen) (car seen)))
+ seen))
+ (gnus-info-set-read info seen)))
+
+ (mapc (lambda (pred)
+ (when (and (nnimap-mark-permanent-p (cdr pred))
+ (member (nnimap-mark-to-flag (cdr pred))
+ (imap-mailbox-get 'flags)))
+ (gnus-info-set-marks
+ info
+ (nnimap-update-alist-soft
+ (cdr pred)
+ (gnus-compress-sequence
+ (imap-search (nnimap-mark-to-predicate (cdr pred))))
+ (gnus-info-marks info))
+ t)))
+ gnus-article-mark-lists)
+
+ (gnus-message 5 "nnimap: Updating info for %s...done"
+ (gnus-info-group info))
+
+ info))))
+
+(deffoo nnimap-request-type (group &optional article)
+ (if (and nnimap-news-groups (string-match nnimap-news-groups group))
+ 'news
+ 'mail))
+
+(deffoo nnimap-request-set-mark (group actions &optional server)
+ (when (nnimap-possibly-change-group group server)
+ (with-current-buffer nnimap-server-buffer
+ (let (action)
+ (gnus-message 7 "nnimap: Setting marks in %s..." group)
+ (while (setq action (pop actions))
+ (let ((range (nth 0 action))
+ (what (nth 1 action))
+ (cmdmarks (nth 2 action))
+ marks)
+ ;; cache flags are pointless on the server
+ (setq cmdmarks (delq 'cache cmdmarks))
+ ;; flag dormant articles as ticked
+ (if (memq 'dormant cmdmarks)
+ (setq cmdmarks (cons 'tick cmdmarks)))
+ ;; remove stuff we are forbidden to store
+ (mapcar (lambda (mark)
+ (if (imap-message-flag-permanent-p
+ (nnimap-mark-to-flag mark))
+ (setq marks (cons mark marks))))
+ cmdmarks)
+ (when (and range marks)
+ (cond ((eq what 'del)
+ (imap-message-flags-del
+ (nnimap-range-to-string range)
+ (nnimap-mark-to-flag marks nil t)))
+ ((eq what 'add)
+ (imap-message-flags-add
+ (nnimap-range-to-string range)
+ (nnimap-mark-to-flag marks nil t)))
+ ((eq what 'set)
+ (imap-message-flags-set
+ (nnimap-range-to-string range)
+ (nnimap-mark-to-flag marks nil t)))))))
+ (gnus-message 7 "nnimap: Setting marks in %s...done" group))))
+ nil)
+
+(defun nnimap-split-to-groups (rules)
+ ;; tries to match all rules in nnimap-split-rule against content of
+ ;; nntp-server-buffer, returns a list of groups that matched.
+ (with-current-buffer nntp-server-buffer
+ ;; Fold continuation lines.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ (if (functionp rules)
+ (funcall rules)
+ (let (to-groups regrepp)
+ (catch 'split-done
+ (dolist (rule rules to-groups)
+ (let ((group (car rule))
+ (regexp (cadr rule)))
+ (goto-char (point-min))
+ (when (and (if (stringp regexp)
+ (progn
+ (setq regrepp (string-match "\\\\[0-9&]" group))
+ (re-search-forward regexp nil t))
+ (funcall regexp group))
+ ;; Don't enter the article into the same group twice.
+ (not (assoc group to-groups)))
+ (push (if regrepp
+ (nnmail-expand-newtext group)
+ group)
+ to-groups)
+ (or nnimap-split-crosspost
+ (throw 'split-done to-groups))))))))))
+
+(defun nnimap-split-find-rule (server inbox)
+ nnimap-split-rule)
+
+(defun nnimap-split-find-inbox (server)
+ (if (listp nnimap-split-inbox)
+ nnimap-split-inbox
+ (list nnimap-split-inbox)))
+
+(defun nnimap-split-articles (&optional group server)
+ (when (nnimap-possibly-change-server server)
+ (with-current-buffer nnimap-server-buffer
+ (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server)))
+ ;; iterate over inboxes
+ (while (and (setq inbox (pop inboxes))
+ (nnimap-possibly-change-group inbox)) ;; SELECT
+ ;; find split rule for this server / inbox
+ (when (setq rule (nnimap-split-find-rule server inbox))
+ ;; iterate over articles
+ (dolist (article (imap-search "UNSEEN UNDELETED"))
+ (when (nnimap-request-head article)
+ ;; copy article to right group(s)
+ (setq removeorig nil)
+ (dolist (to-group (nnimap-split-to-groups rule))
+ (if (imap-message-copy (number-to-string article)
+ to-group nil 'nocopyuid)
+ (progn
+ (message "IMAP split moved %s:%s:%d to %s" server inbox
+ article to-group)
+ (setq removeorig t)
+ ;; Add the group-art list to the history list.
+ (push (list (cons to-group 0)) nnmail-split-history))
+ (message "IMAP split failed to move %s:%s:%d to %s" server
+ inbox article to-group)))
+ ;; remove article if it was successfully copied somewhere
+ (and removeorig
+ (imap-message-flags-add (format "%d" article)
+ "\\Seen \\Deleted")))))
+ (when (imap-mailbox-select inbox) ;; just in case
+ ;; todo: UID EXPUNGE (if available) to remove splitted articles
+ (imap-mailbox-expunge)
+ (imap-mailbox-close)))
+ t))))
+
+(deffoo nnimap-request-scan (&optional group server)
+ (nnimap-split-articles group server))
+
+(deffoo nnimap-request-newgroups (date &optional server)
+ (when (nnimap-possibly-change-server server)
+ (with-current-buffer nntp-server-buffer
+ (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..."
+ (if (> (length server) 0) " on " "") server)
+ (erase-buffer)
+ (dolist (pattern (nnimap-pattern-to-list-arguments
+ nnimap-list-pattern))
+ (dolist (mbx (imap-mailbox-lsub "*" (car pattern) nil
+ nnimap-server-buffer))
+ (or (member-if (lambda (mailbox)
+ (string= (downcase mailbox) "\\noselect"))
+ (imap-mailbox-get 'list-flags mbx
+ nnimap-server-buffer))
+ ;; Escape SPC in mailboxes xxx relies on gnus internals
+ (let ((info (nnimap-find-minmax-uid mbx 'examine)))
+ (when info
+ (insert (format "%s %d %d y\n"
+ (nnimap-replace-in-string mbx " " "\\ ")
+ (or (nth 2 info) 0)
+ (max 1 (or (nth 1 info) 1)))))))))
+ (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done"
+ (if (> (length server) 0) " on " "") server))
+ t))
+
+(deffoo nnimap-request-create-group (group &optional server args)
+ (when (nnimap-possibly-change-server server)
+ (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer)
+ (imap-mailbox-create group nnimap-server-buffer))))
+
+(defun nnimap-time-substract (time1 time2)
+ "Return TIME for TIME1 - TIME2."
+ (let* ((ms (- (car time1) (car time2)))
+ (ls (- (nth 1 time1) (nth 1 time2))))
+ (if (< ls 0)
+ (list (- ms 1) (+ (expt 2 16) ls))
+ (list ms ls))))
+
+(defun nnimap-date-days-ago (daysago)
+ "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago."
+ (let ((date (format-time-string "%d-%b-%Y"
+ (nnimap-time-substract
+ (current-time)
+ (days-to-time daysago)))))
+ (if (eq ?0 (string-to-char date))
+ (substring date 1)
+ date)))
+
+(defun nnimap-request-expire-articles-progress ()
+ (gnus-message 5 "nnimap: Marking article %d for deletion..."
+ imap-current-message))
+
+;; Notice that we don't actually delete anything, we just mark them deleted.
+(deffoo nnimap-request-expire-articles (articles group &optional server force)
+ (let ((artseq (gnus-compress-sequence articles)))
+ (when (and artseq (nnimap-possibly-change-group group server))
+ (with-current-buffer nnimap-server-buffer
+ (if force
+ (and (imap-message-flags-add
+ (nnimap-range-to-string artseq) "\\Deleted")
+ (setq articles nil))
+ (let ((days (or (and nnmail-expiry-wait-function
+ (funcall nnmail-expiry-wait-function group))
+ nnmail-expiry-wait)))
+ (cond ((eq days 'immediate)
+ (and (imap-message-flags-add
+ (nnimap-range-to-string artseq) "\\Deleted")
+ (setq articles nil)))
+ ((numberp days)
+ (let ((oldarts (imap-search
+ (format "UID %s NOT SINCE %s"
+ (nnimap-range-to-string artseq)
+ (nnimap-date-days-ago days))))
+ (imap-fetch-data-hook
+ '(nnimap-request-expire-articles-progress)))
+ (and oldarts
+ (imap-message-flags-add
+ (nnimap-range-to-string
+ (gnus-compress-sequence oldarts))
+ "\\Deleted")
+ (setq articles (gnus-set-difference
+ articles oldarts)))))))))))
+ ;; return articles not deleted
+ articles)
+
+(deffoo nnimap-request-move-article (article group server
+ accept-form &optional last)
+ (when (nnimap-possibly-change-server server)
+ (save-excursion
+ (let ((buf (get-buffer-create " *nnimap move*"))
+ (nnimap-current-move-article article)
+ (nnimap-current-move-group group)
+ (nnimap-current-move-server nnimap-current-server)
+ result)
+ (and (nnimap-request-article article group server)
+ (save-excursion
+ (set-buffer buf)
+ (buffer-disable-undo (current-buffer))
+ (insert-buffer-substring nntp-server-buffer)
+ (setq result (eval accept-form))
+ (kill-buffer buf)
+ result)
+ (nnimap-request-expire-articles (list article) group server t))
+ result))))
+
+(deffoo nnimap-request-accept-article (group &optional server last)
+ (when (nnimap-possibly-change-server server)
+ (let (uid)
+ (if (setq uid
+ (if (string= nnimap-current-server nnimap-current-move-server)
+ ;; moving article within same server, speed it up...
+ (and (nnimap-possibly-change-group
+ nnimap-current-move-group)
+ (imap-message-copy (number-to-string
+ nnimap-current-move-article)
+ group 'dontcreate nil
+ nnimap-server-buffer))
+ ;; turn into rfc822 format (\r\n eol's)
+ (with-current-buffer (current-buffer)
+ (goto-char (point-min))
+ (while (search-forward "\n" nil t)
+ (replace-match "\r\n")))
+ ;; next line for Cyrus server bug
+ (imap-mailbox-unselect nnimap-server-buffer)
+ (imap-message-append group (current-buffer) nil nil
+ nnimap-server-buffer)))
+ (cons group (nth 1 uid))
+ (nnheader-report 'nnimap (imap-error-text nnimap-server-buffer))))))
+
+(deffoo nnimap-request-delete-group (group force &optional server)
+ (when (nnimap-possibly-change-server server)
+ (with-current-buffer nnimap-server-buffer
+ (if force
+ (or (null (imap-mailbox-status group 'uidvalidity))
+ (imap-mailbox-delete group))
+ ;; UNSUBSCRIBE?
+ t))))
+
+(deffoo nnimap-request-rename-group (group new-name &optional server)
+ (when (nnimap-possibly-change-server server)
+ (imap-mailbox-rename group new-name nnimap-server-buffer)))
+
+(defun nnimap-expunge (mailbox server)
+ (when (nnimap-possibly-change-group mailbox server)
+ (imap-mailbox-expunge nnimap-server-buffer)))
+
+(defun nnimap-acl-get (mailbox server)
+ (when (nnimap-possibly-change-server server)
+ (imap-mailbox-acl-get mailbox nnimap-server-buffer)))
+
+(defun nnimap-acl-edit (mailbox method old-acls new-acls)
+ (when (nnimap-possibly-change-server (cadr method))
+ (unless (imap-capability 'ACL nnimap-server-buffer)
+ (error "Your server does not support ACL editing"))
+ (with-current-buffer nnimap-server-buffer
+ ;; delete all removed identifiers
+ (mapcar (lambda (old-acl)
+ (unless (assoc (car old-acl) new-acls)
+ (or (imap-mailbox-acl-delete (car old-acl) mailbox)
+ (error "Can't delete ACL for %s" (car old-acl)))))
+ old-acls)
+ ;; set all changed acl's
+ (mapcar (lambda (new-acl)
+ (let ((new-rights (cdr new-acl))
+ (old-rights (cdr (assoc (car new-acl) old-acls))))
+ (unless (and old-rights new-rights
+ (string= old-rights new-rights))
+ (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox)
+ (error "Can't set ACL for %s to %s" (car new-acl)
+ new-rights)))))
+ new-acls)
+ t)))
+
+\f
+;;; Internal functions
+
+;;
+;; This is confusing.
+;;
+;; mark => read, tick, draft, reply etc
+;; flag => "\\Seen", "\\Flagged", "\\Draft", "gnus-expire" etc
+;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc
+;;
+;; Mark should not really contain 'read since it's not a "mark" in the Gnus
+;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read).
+;;
+
+(defconst nnimap-mark-to-predicate-alist
+ (mapcar
+ (lambda (pair) ; cdr is the mark
+ (or (assoc (cdr pair)
+ '((read . "SEEN")
+ (tick . "FLAGGED")
+ (draft . "DRAFT")
+ (reply . "ANSWERED")))
+ (cons (cdr pair)
+ (format "KEYWORD gnus-%s" (symbol-name (cdr pair))))))
+ (cons '(read . read) gnus-article-mark-lists)))
+
+(defun nnimap-mark-to-predicate (pred)
+ "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP
+predicate (a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD
+gnus-expire\") to be used within a IMAP SEARCH query."
+ (cdr (assq pred nnimap-mark-to-predicate-alist)))
+
+(defconst nnimap-mark-to-flag-alist
+ (mapcar
+ (lambda (pair)
+ (or (assoc (cdr pair)
+ '((read . "\\Seen")
+ (tick . "\\Flagged")
+ (draft . "\\Draft")
+ (reply . "\\Answered")))
+ (cons (cdr pair)
+ (format "gnus-%s" (symbol-name (cdr pair))))))
+ (cons '(read . read) gnus-article-mark-lists)))
+
+(defun nnimap-mark-to-flag-1 (preds)
+ (if (and (not (null preds)) (listp preds))
+ (cons (nnimap-mark-to-flag (car preds))
+ (nnimap-mark-to-flag (cdr preds)))
+ (cdr (assoc preds nnimap-mark-to-flag-alist))))
+
+(defun nnimap-mark-to-flag (preds &optional always-list make-string)
+ "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP
+flag (a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\") to
+be used in a STORE FLAGS command."
+ (let ((result (nnimap-mark-to-flag-1 preds)))
+ (setq result (if (and (or make-string always-list)
+ (not (listp result)))
+ (list result)
+ result))
+ (if make-string
+ (mapconcat (lambda (flag)
+ (if (listp flag)
+ (mapconcat 'identity flag " ")
+ flag))
+ result " ")
+ result)))
+
+(defun nnimap-mark-permanent-p (mark &optional group)
+ "Return t iff MARK can be permanently (between IMAP sessions) saved
+on articles, in GROUP."
+ (imap-message-flag-permanent-p (nnimap-mark-to-flag mark)))
+
+(defun nnimap-remassoc (key alist)
+ "Delete by side effect any elements of LIST whose car is
+`equal' to KEY. The modified LIST is returned. If the first member
+of LIST has a car that is `equal' to KEY, there is no way to remove it
+by side effect; therefore, write `(setq foo (remassoc key foo))' to be
+sure of changing the value of `foo'."
+ (when alist
+ (if (equal key (caar alist))
+ (cdr alist)
+ (setcdr alist (nnimap-remassoc key (cdr alist)))
+ alist)))
+
+(defun nnimap-update-alist-soft (key value alist)
+ (if value
+ (cons (cons key value) (nnimap-remassoc key alist))
+ (nnimap-remassoc key alist)))
+
+(defun nnimap-range-to-string (range)
+ (mapconcat
+ (lambda (item)
+ (if (consp item)
+ (format "%d:%d"
+ (car item) (cdr item))
+ (format "%d" item)))
+ (if (and (listp range) (not (listp (cdr range))))
+ (list range) ;; make (1 . 2) into ((1 . 2))
+ range)
+ ","))
+
+(when nnimap-debug
+ (require 'trace)
+ (buffer-disable-undo (get-buffer-create nnimap-debug))
+ (mapc (lambda (f) (trace-function-background f nnimap-debug))
+ '(
+nnimap-replace-in-string
+nnimap-possibly-change-server
+nnimap-verify-uidvalidity
+nnimap-find-minmax-uid
+nnimap-possibly-change-group
+;nnimap-replace-whitespace
+nnimap-retrieve-headers-progress
+nnimap-retrieve-which-headers
+nnimap-group-overview-filename
+nnimap-retrieve-headers-from-file
+nnimap-retrieve-headers-from-server
+nnimap-retrieve-headers
+nnimap-open-connection
+nnimap-open-server
+nnimap-server-opened
+nnimap-close-server
+nnimap-request-close
+nnimap-status-message
+;nnimap-demule
+nnimap-request-article-part
+nnimap-request-article
+nnimap-request-head
+nnimap-request-body
+nnimap-request-group
+nnimap-close-group
+nnimap-pattern-to-list-arguments
+nnimap-request-list
+nnimap-request-post
+nnimap-retrieve-groups
+nnimap-request-update-info-internal
+nnimap-request-type
+nnimap-request-set-mark
+nnimap-split-to-groups
+nnimap-split-find-rule
+nnimap-split-find-inbox
+nnimap-split-articles
+nnimap-request-scan
+nnimap-request-newgroups
+nnimap-request-create-group
+nnimap-time-substract
+nnimap-date-days-ago
+nnimap-request-expire-articles-progress
+nnimap-request-expire-articles
+nnimap-request-move-article
+nnimap-request-accept-article
+nnimap-request-delete-group
+nnimap-request-rename-group
+gnus-group-nnimap-expunge
+gnus-group-nnimap-edit-acl
+gnus-group-nnimap-edit-acl-done
+nnimap-group-mode-hook
+nnimap-mark-to-predicate
+nnimap-mark-to-flag-1
+nnimap-mark-to-flag
+nnimap-mark-permanent-p
+nnimap-remassoc
+nnimap-update-alist-soft
+nnimap-range-to-string
+ )))
+
+(provide 'nnimap)
+
+;;; nnimap.el ends here
(let (lines chars)
(save-excursion
(goto-char (point-min))
- (when (search-forward "\n\n" nil t)
- (setq chars (- (point-max) (point)))
- (setq lines (count-lines (point) (point-max)))
- (forward-char -1)
- (save-excursion
- (when (re-search-backward "^Lines: " nil t)
- (delete-region (point) (progn (forward-line 1) (point)))))
- (beginning-of-line)
- (insert (format "Lines: %d\n" (max lines 0)))
- chars))))
+ (unless (search-forward "\n\n" nil t)
+ (goto-char (point-max))
+ (insert "\n"))
+ (setq chars (- (point-max) (point)))
+ (setq lines (count-lines (point) (point-max)))
+ (forward-char -1)
+ (save-excursion
+ (when (re-search-backward "^Lines: " nil t)
+ (delete-region (point) (progn (forward-line 1) (point)))))
+ (beginning-of-line)
+ (insert (format "Lines: %d\n" (max lines 0)))
+ chars)))
(defun nnmail-insert-xref (group-alist)
"Insert an Xref line based on the (group . article) alist."
(save-excursion
(goto-char (point-min))
- (when (search-forward "\n\n" nil t)
- (forward-char -1)
- (when (re-search-backward "^Xref: " nil t)
- (delete-region (match-beginning 0)
- (progn (forward-line 1) (point))))
- (insert (format "Xref: %s" (system-name)))
- (while group-alist
- (insert (format " %s:%d"
- (mm-encode-coding-string
- (caar group-alist)
- nnmail-pathname-coding-system)
- (cdar group-alist)))
- (setq group-alist (cdr group-alist)))
- (insert "\n"))))
+ (unless (search-forward "\n\n" nil t)
+ (goto-char (point-max))
+ (insert "\n"))
+ (forward-char -1)
+ (when (re-search-backward "^Xref: " nil t)
+ (delete-region (match-beginning 0)
+ (progn (forward-line 1) (point))))
+ (insert (format "Xref: %s" (system-name)))
+ (while group-alist
+ (insert (format " %s:%d"
+ (mm-encode-coding-string
+ (caar group-alist)
+ nnmail-pathname-coding-system)
+ (cdar group-alist)))
+ (setq group-alist (cdr group-alist)))
+ (insert "\n")))
;;; Message washing functions
((numberp nntp-nov-gap)
(let ((count 0)
(received 0)
- (last-point (point-min))
+ last-point
+ in-process-buffer-p
(buf nntp-server-buffer)
- ;;(process-buffer (nntp-find-connection (current-buffer))))
+ (process-buffer (nntp-find-connection-buffer nntp-server-buffer))
first)
;; We have to check `nntp-server-xover'. If it gets set to nil,
;; that means that the server does not understand XOVER, but we
(< (- (nth 1 articles) (car articles)) nntp-nov-gap))
(setq articles (cdr articles)))
- (when (nntp-send-xover-command first (car articles))
- (setq articles (cdr articles)
- count (1+ count))
-
+ (setq in-process-buffer-p (stringp nntp-server-xover))
+ (nntp-send-xover-command first (car articles))
+ (setq articles (cdr articles))
+
+ (when (and nntp-server-xover in-process-buffer-p)
+ ;; Don't count tried request.
+ (setq count (1+ count))
+
;; Every 400 requests we have to read the stream in
;; order to avoid deadlocks.
(when (or (null articles) ;All requests have been sent.
(zerop (% count nntp-maximum-request)))
- (accept-process-output)
+
+ (nntp-accept-response)
;; On some Emacs versions the preceding function has
;; a tendency to change the buffer. Perhaps. It's
;; quite difficult to reproduce, because it only
;; seems to happen once in a blue moon.
- (set-buffer buf)
+ (set-buffer process-buffer)
(while (progn
- (goto-char last-point)
+ (goto-char (or last-point (point-min)))
;; Count replies.
(while (re-search-forward "^[0-9][0-9][0-9] " nil t)
(setq received (1+ received)))
(setq last-point (point))
(< received count))
- (accept-process-output)
- (set-buffer buf)))))
+ (nntp-accept-response)
+ (set-buffer process-buffer))
+ (set-buffer buf))))
(when nntp-server-xover
- ;; Wait for the reply from the final command.
- (goto-char (point-max))
- (re-search-backward "^[0-9][0-9][0-9] " nil t)
- (when (looking-at "^[23]")
- (while (progn
- (goto-char (point-max))
- (forward-line -1)
- (not (looking-at "^\\.\r?\n")))
- (nntp-accept-response)))
+ (when in-process-buffer-p
+ (set-buffer process-buffer)
+ ;; Wait for the reply from the final command.
+ (goto-char (point-max))
+ (re-search-backward "^[0-9][0-9][0-9] " nil t)
+ (when (looking-at "^[23]")
+ (while (progn
+ (goto-char (point-max))
+ (forward-line -1)
+ (not (looking-at "^\\.\r?\n")))
+ (nntp-accept-response)
+ (set-buffer process-buffer)))
+ (set-buffer buf)
+ (goto-char (point-max))
+ (insert-buffer-substring process-buffer)
+ (set-buffer process-buffer)
+ (erase-buffer)
+ (set-buffer buf))
;; We remove any "." lines and status lines.
(goto-char (point-min))
(nntp-send-command-nodelete
"\r?\n\\.\r?\n" nntp-server-xover range)
;; We do not wait for the reply.
- (nntp-send-command-nodelete "\r?\n\\.\r?\n" nntp-server-xover range))
+ (nntp-send-command-nodelete nil nntp-server-xover range))
(let ((commands nntp-xover-commands))
;; `nntp-xover-commands' is a list of possible XOVER commands.
;; We try them all until we get at positive response.
(end-of-line)
(while (> (current-column) 72)
(beginning-of-line)
- (forward-char 72)
+ (forward-char 71) ;; 71 char plus an "="
(search-backward "=" (- (point) 2) t)
(insert "=\n")
(end-of-line))
- (forward-line))))))
+ (unless (eobp)
+ (forward-line)))))))
(defun quoted-printable-encode-string (string)
"QP-encode STRING and return the results."
;;; rfc1843.el --- HZ (rfc1843) decoding
-;; Copyright (c) 1998 by Shenghuo Zhu <zsh@cs.rochester.edu>
+;; Copyright (c) 1998,1999 by Shenghuo Zhu <zsh@cs.rochester.edu>
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
-;; $Revision: 1.1.1.3 $
;; Keywords: news HZ
-;; Time-stamp: <Tue Oct 6 23:48:49 EDT 1998 zsh>
-;; This file is not part of GNU Emacs, but the same permissions
-;; apply.
+;; This file is a part of GNU Emacs, but the same permissions apply.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
(save-excursion
(save-restriction
(message-narrow-to-head)
- (goto-char (point-max))
- (widen)
- (rfc1843-decode-region (point) (point-max))))))
+ (let* ((inhibit-point-motion-hooks t)
+ (case-fold-search t)
+ (ct (message-fetch-field "Content-Type" t))
+ (ctl (and ct (ignore-errors
+ (mail-header-parse-content-type ct)))))
+ (if (and ctl (not (string-match "/" (car ctl))))
+ (setq ctl nil))
+ (goto-char (point-max))
+ (widen)
+ (forward-line 1)
+ (narrow-to-region (point) (point-max))
+ (when (or (not ctl)
+ (equal (car ctl) "text/plain"))
+ (rfc1843-decode-region (point) (point-max))))))))
(defvar rfc1843-old-gnus-decode-header-function nil)
(defvar gnus-decode-header-methods)
--- /dev/null
+;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes
+;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <jas@pdc.kth.se>
+;; Keywords: mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; This is a quick'n'dirty, low performance, implementation of RFC2104.
+;;;
+;;; Example:
+;;;
+;;; (require 'md5)
+;;; (rfc2104-hash 'md5 64 16 "Jefe" "what do ya want for nothing?")
+;;; "750c783e6ab0b503eaa86e310a5db738"
+;;;
+;;; 64 is block length of hash function (64 for MD5 and SHA), 16 is
+;;; resulting hash length (16 for MD5, 20 for SHA).
+;;;
+;;; Tested with Emacs 20.2 and XEmacs 20.3.
+
+;;; Release history:
+;;;
+;;; 1998-08-16 initial release posted to gnu.emacs.sources
+;;; 1998-08-17 use append instead of char-list-to-string
+;;; 1998-08-26 don't require hexl
+;;; 1998-09-25 renamed from hmac.el to rfc2104.el, also renamed functions
+;;; 1999-10-23 included in pgnus
+
+(require 'cl)
+
+;; Magic character for inner HMAC round. 0x36 == 54 == '6'
+(defconst rfc2104-ipad ?\x36)
+
+;; Magic character for outer HMAC round. 0x5C == 92 == '\'
+(defconst rfc2104-opad ?\x5C)
+
+;; Not so magic character for padding the key. 0x00
+(defconst rfc2104-zero ?\x00)
+
+;; Alist for converting hex to decimal.
+(defconst rfc2104-hex-alist
+ '((?0 . 0) (?a . 10) (?A . 10)
+ (?1 . 1) (?b . 11) (?B . 11)
+ (?2 . 2) (?c . 12) (?C . 12)
+ (?3 . 3) (?d . 13) (?D . 13)
+ (?4 . 4) (?e . 14) (?E . 14)
+ (?5 . 5) (?f . 15) (?F . 15)
+ (?6 . 6)
+ (?7 . 7)
+ (?8 . 8)
+ (?9 . 9)))
+
+(defun rfc2104-hex-to-int (str)
+ (if str
+ (if (listp str)
+ (+ (* 16 (rfc2104-hex-to-int (cdr str)))
+ (cdr (assoc (car str) rfc2104-hex-alist)))
+ (rfc2104-hex-to-int (reverse (append str nil))))
+ 0))
+
+(defun rfc2104-hash (hash block-length hash-length key text)
+ (let* (;; if key is longer than B, reset it to HASH(key)
+ (key (if (> (length key) block-length)
+ (funcall hash key) key))
+ (k_ipad (append key nil))
+ (k_opad (append key nil)))
+ ;; zero pad k_ipad/k_opad
+ (while (< (length k_ipad) block-length)
+ (setq k_ipad (append k_ipad (list rfc2104-zero))))
+ (while (< (length k_opad) block-length)
+ (setq k_opad (append k_opad (list rfc2104-zero))))
+ ;; XOR key with ipad/opad into k_ipad/k_opad
+ (setq k_ipad (mapcar (lambda (c) (logxor c rfc2104-ipad)) k_ipad))
+ (setq k_opad (mapcar (lambda (c) (logxor c rfc2104-opad)) k_opad))
+ ;; perform inner hash
+ (let ((first-round (funcall hash (concat k_ipad text)))
+ de-hexed)
+ (while (< 0 (length first-round))
+ (push (rfc2104-hex-to-int (substring first-round -2)) de-hexed)
+ (setq first-round (substring first-round 0 -2)))
+ ;; perform outer hash
+ (funcall hash (concat k_opad de-hexed)))))
+
+(provide 'rfc2104)
+
+;;; rfc2104.el ends here
+1999-10-23 Simon Josefsson <jas@pdc.kth.se>
+
+ * gnus.texi (Mail Source Specifiers): Add imap mail-source.
+ (IMAP): New subsection.
+ (SOUP): Typo.
+
+1999-09-27 16:07:31 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * emacs-mime.texi (New Viewers): Fix.
+
1999-09-25 10:58:17 Lars Magne Ingebrigtsen <larsi@gnus.org>
* message.texi (Forwarding): Updated.
@c \input texinfo @c -*-texinfo-*-
@setfilename gnus
-@settitle Pterodactyl Gnus 0.97 Manual
+@settitle Pterodactyl Gnus Manual
@synindex fn cp
@synindex vr cp
@synindex pg cp
@tex
@titlepage
-@title Pterodactyl Gnus 0.97 Manual
+@title Pterodactyl Gnus Manual
@author by Lars Magne Ingebrigtsen
@page
spool or your mbox file. All at the same time, if you want to push your
luck.
-This manual corresponds to Pterodactyl Gnus 0.97.
+This manual corresponds to Pterodactyl Gnus .
@end ifinfo
(maildir :path "/home/user-name/Maildir/cur")
@end lisp
+@item imap
+Get mail from a IMAP server. If you don't want to use IMAP as intended,
+as a network mail reading protocol, for some reason or other Gnus let
+you treat it similar to a POP server and fetches articles from a given
+IMAP mailbox.
+
+Keywords:
+
+@table @code
+@item :server
+The name of the IMAP server. The default is taken from the
+@code{MAILHOST} environment variable.
+
+@item :port
+The port number of the IMAP server. The default is @samp{143}, or
+@samp{993} for SSL connections.
+
+@item :user
+The user name to give to the IMAP server. The default is the login
+name.
+
+@item :password
+The password to give to the IMAP server. If not specified, the user is
+prompted.
+
+@item :stream
+What stream to use for connecting to the server, this is one of the
+symbols in @code{imap-stream-alist}. Right now, this means
+@samp{kerberos4}, @samp{ssl} or the default @samp{network}.
+
+@item :authenticator
+Which authenticator to use for authenticating to the server, this is one
+of the symbols in @code{imap-authenticator-alist}. Right now, this means
+@samp{kerberos4}, @samp{cram-md5}, @samp{anonymous} or the default
+@samp{login}.
+
+@item :mailbox
+The name of the mailbox to get mail from. The default is @samp{INBOX}
+which normally is the mailbox which receive incoming mail.
+
+@item :predicate
+The predicate used to find articles to fetch. The default,
+@samp{UNSEEN UNDELETED}, is probably the best choice for most people,
+but if you sometimes peek in your mailbox with a IMAP client and mark
+some articles as read (or; SEEN) you might want to set this to
+@samp{nil}. Then all articles in the mailbox is fetched, no matter
+what. For a complete list of predicates, see RFC2060 §6.4.4.
+
+@end table
+
+An example IMAP mail source:
+
+@lisp
+(imap :server "mail.mycorp.com" :stream kerberos4)
+@end lisp
+
@end table
* SOUP:: Reading @sc{SOUP} packets ``offline''.
* Web Searches:: Creating groups from articles that match a string.
* Mail-To-News Gateways:: Posting articles via mail-to-news gateways.
+* IMAP:: Using Gnus as a IMAP client.
@end menu
transport things like Ghod intended. And then we just use normal
newsreaders.
-However, it can sometimes be convenient to do something a that's a bit
+However, it can sometimes be convenient to do something that's a bit
easier on the brain if you have a very slow modem, and you're not really
that interested in doing things properly.
@end lisp
+
+@node IMAP
+@subsection IMAP
+@cindex nnimap
+@cindex IMAP
+
+IMAP is a network protocol for reading mail (or news, or ...), think of
+it as a modernized NNTP. Connecting to a IMAP server is much similar to
+connecting to a news server, you just specify the network address of the
+server.
+
+The following variables can be used to create a virtual @code{nnimap}
+server:
+
+@table @code
+
+@item nnimap-address
+@vindex nnimap-address
+
+The address of the remote IMAP server. Defaults to the virtual server
+name if not specified.
+
+@item nnimap-server-port
+@vindex nnimap-server-port
+Port on server to contact. Defaults to port 143, or 993 for SSL.
+
+@item nnimap-list-pattern
+@vindex nnimap-list-pattern
+String or list of strings of mailboxes to limit available groups
+to. This is used when the server has very many mailboxes and you're only
+interested in a few -- some servers export your home directory via IMAP,
+you'll probably want to limit the mailboxes to those in @file{~/Mail/*}
+then.
+
+The string can also be a cons of REFERENCE and the string as above, what
+REFERENCE is used for is server specific, but on the University of
+Washington server it's a directory that will be concatenated with the
+mailbox.
+
+Example:
+
+@lisp
+("INBOX" "Mail/*" "alt.sex.*" ("~friend/Mail/" . "list/*"))
+@end lisp
+
+@item nnimap-stream
+@vindex nnimap-stream
+The type of stream used to connect to your server. By default, nnimap
+will use the most secure stream your server is capable of.
+
+@itemize @bullet
+@item
+@dfn{kerberos4:} Uses the `imtest' program.
+@item
+@dfn{ssl:} Uses OpenSSL or SSLeay.
+@item
+@dfn{network:} Plain, TCP/IP network connection.
+@end itemize
+
+@item nnimap-authenticator
+@vindex nnimap-authenticator
+
+The authenticator used to connect to the server. By default, nnimap will
+use the most secure authenticator your server is capable of.
+
+@itemize @bullet
+@item
+@dfn{kerberos4:} Kerberos authentication.
+@item
+@dfn{cram-md5:} Encrypted username/password via CRAM-MD5.
+@item
+@dfn{login:} Plain-text username/password via LOGIN.
+@item
+@dfn{anonymous:} Login as `anonymous', supplying your emailadress as password.
+@end itemize
+
+@item nnimap-expunge-on-close
+@cindex Expunging
+@vindex nnimap-expunge-on-close
+Unlike Parmenides the IMAP designers has decided that things that
+doesn't exist actually does exist. More specifically, IMAP has this
+concept of marking articles @code{Deleted} which doesn't actually delete
+them, and this (marking them @code{Deleted}, that is) is what nnimap
+does when you delete a article in Gnus (with @kbd{G DEL} or similair).
+
+Since the articles aren't really removed when we mark them with the
+@code{Deleted} flag we'll need a way to actually delete them. Feel like
+running in circles yet?
+
+Traditionally, nnimap has removed all articles marked as @code{Deleted}
+when closing a mailbox but this is now configurable by this server
+variable.
+
+The possible options are:
+
+@table @code
+
+@item always
+The default behaviour, delete all articles marked as "Deleted" when
+closing a mailbox.
+@item never
+Never actually delete articles. Currently there is no way of showing the
+articles marked for deletion in nnimap, but other IMAP clients may allow
+you to do this. If you ever want to run the EXPUNGE command manually,
+@xref{Expunging mailboxes}.
+@item ask
+When closing mailboxes, nnimap will ask if you wish to expunge deleted
+articles or not.
+@end table
+
+@end table
+
+@menu
+* Splitting in IMAP:: Splitting mail with nnimap.
+* Editing IMAP ACLs:: Limiting/enabling other users access to a mailbox.
+* Expunging mailboxes:: Equivalent of a "compress mailbox" button.
+@end menu
+
+
+
+@node Splitting in IMAP
+@subsubsection Splitting in IMAP
+@cindex splitting imap mail
+
+Splitting is something Gnus users has loved and used for years, and now
+the rest of the world is catching up. Yeah, dream on, not many IMAP
+server has server side splitting and those that have splitting seem to
+use some non-standard protocol. This means that IMAP support for Gnus
+has to do it's own splitting.
+
+And it does.
+
+There are three variables of interest:
+
+@table @code
+
+@item nnimap-split-crosspost
+@cindex splitting, crosspost
+@cindex crosspost
+@vindex nnimap-split-crosspost
+
+If non-nil, do crossposting if several split methods match the mail. If
+nil, the first match in @code{nnimap-split-rule} found will be used.
+
+Nnmail equivalent: @code{nnmail-crosspost}.
+
+@item nnimap-split-inbox
+@cindex splitting, inbox
+@cindex inbox
+@vindex nnimap-split-inbox
+
+A string or a list of strings that gives the name(s) of IMAP mailboxes
+to split from. Defaults to nil, which means that splitting is disabled!
+
+@lisp
+(setq nnimap-split-inbox '("INBOX" ("~/friend/Mail" . "lists/*") "lists.imap"))
+@end lisp
+
+No nnmail equivalent.
+
+@item nnimap-split-rule
+@cindex Splitting, rules
+@vindex nnimap-split-rule
+
+New mail found in @code{nnimap-split-inbox} will be split according to
+this variable.
+
+This variable contains a list of lists, where the first element in the
+sublist gives the name of the IMAP mailbox to move articles matching the
+regexp in the second element in the sublist. Got that? Neither did I, we
+need examples.
+
+@lisp
+(setq nnimap-split-rule
+ '(("INBOX.nnimap" "^Sender: owner-nnimap@@vic20.globalcom.se")
+ ("INBOX.junk" "^Subject:.*MAKE MONEY")
+ ("INBOX.private" "")))
+@end lisp
+
+This will put all articles from the nnimap mailing list into mailbox
+INBOX.nnimap, all articles containing MAKE MONEY in the Subject: line
+into INBOX.spam and everything else in INBOX.private.
+
+The first string may contain `\\1' forms, like the ones used by
+replace-match to insert sub-expressions from the matched text. For
+instance:
+
+@lisp
+ ("INBOX.lists.\\1" "^Sender: owner-\\([a-z-]+\\)@")
+@end lisp
+
+The second element can also be a function. In that case, it will be
+called with the first element of the rule as the argument, in a buffer
+containing the headers of the article. It should return a non-nil value
+if it thinks that the mail belongs in that group.
+
+Nnmail users might recollect that the last regexp had to be empty to
+match all articles (like in the example above). This is not required in
+nnimap. Articles not matching any of the regexps will not be moved out
+of your inbox. (This might might affect performance if you keep lots of
+unread articles in your inbox, since the splitting code would go over
+them every time you fetch new mail.)
+
+These rules are processed from the beginning of the alist toward the
+end. The first rule to make a match will "win", unless you have
+crossposting enabled. In that case, all matching rules will "win".
+
+The splitting code tries to create mailboxes if it need too.
+
+Nnmail equivalent: @code{nnmail-split-methods}.
+
+@end table
+
+@node Editing IMAP ACLs
+@subsubsection Editing IMAP ACLs
+@cindex editing imap acls
+@cindex Access Control Lists
+@cindex Editing IMAP ACLs
+@kindex G l
+@findex gnus-group-nnimap-edit-acl
+
+ACL stands for Access Control List. ACLs are used in IMAP for limiting
+(or enabling) other users access to your mail boxes. Not all IMAP
+servers support this, this function will give an error if it doesn't.
+
+To edit a ACL for a mailbox, type @kbd{G l}
+(@code{gnus-group-edit-nnimap-acl}) and you'll be presented with a ACL
+editing window with detailed instructions.
+
+Some possible uses:
+
+@itemize @bullet
+@item
+Giving "anyone" the "lrs" rights (lookup, read, keep seen/unseen flags)
+on your mailing list mailboxes enables other users on the same server to
+follow the list without subscribing to it.
+@item
+At least with the Cyrus server, you are required to give the user
+"anyone" posting ("p") capabilities to have "plussing" work (that is,
+mail sent to user+mailbox@@domain ending up in the IMAP mailbox
+INBOX.mailbox).
+@end itemize
+
+@node Expunging mailboxes
+@subsubsection Expunging mailboxes
+@cindex expunging
+
+@cindex Expunge
+@cindex Manual expunging
+@kindex G x
+@findex gnus-group-nnimap-expunge
+
+If you're using the @code{never} setting of @code{nnimap-expunge-close},
+you may want the option of expunging all deleted articles in a mailbox
+manually. This is exactly what @kbd{G x} does.
+
+Currently there is no way of showing deleted articles, you can just
+delete them.
+
+
+
@node Combined Groups
@section Combined Groups
\input texinfo @c -*-texinfo-*-
@setfilename message
-@settitle Pterodactyl Message 0.97 Manual
+@settitle Pterodactyl Message 0.98 Manual
@synindex fn cp
@synindex vr cp
@synindex pg cp
@tex
@titlepage
-@title Pterodactyl Message 0.97 Manual
+@title Pterodactyl Message 0.98 Manual
@author by Lars Magne Ingebrigtsen
@page
* Key Index:: List of Message mode keys.
@end menu
-This manual corresponds to Pterodactyl Message 0.97. Message is
+This manual corresponds to Pterodactyl Message 0.98. Message is
distributed with the Gnus distribution bearing the same version number
as this manual.
projects / elisp / gnus.git- / commitdiff