From: yamaoka Date: Mon, 8 Nov 1999 23:15:08 +0000 (+0000) Subject: Importing Pterodactyl Gnus v0.98. X-Git-Tag: pgnus-0_98~1 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=22d67eb69d38558636bccda449388713db84b44d;p=elisp%2Fgnus.git- Importing Pterodactyl Gnus v0.98. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 14ba45e..885e63a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,193 @@ +Fri Nov 5 19:10:02 1999 Lars Magne Ingebrigtsen + + * gnus.el: Pterodactyl Gnus v0.98 is released. + +1999-11-05 01:27:49 Shenghuo ZHU + + * gnus-agent.el (gnus-agent-expire): Remove bad line in NOV. + +1999-11-04 22:20:35 Shenghuo ZHU + + * mml.el (mml-generate-mime-1): Read attached binary file in + binary mode. + +1999-11-03 16:08:56 Shenghuo ZHU + + * gnus-sum.el (gnus-summary-toggle-header): Fix arg bug. + +1999-11-03 15:27:38 Shenghuo ZHU + + * mailcap.el (mailcap-viewer-lessp): Fix bug. + +1999-11-02 17:28:33 Shenghuo ZHU + + * gnus-sum.el (gnus-summary-search-article): Fix loop search bug. + +1999-10-31 21:24:59 Shenghuo ZHU + + * 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 + + * gnus-sum.el (gnus-article-get-xrefs): Test eobp. + +1999-09-27 Hrvoje Niksic + + * mm-decode.el (mm-attachment-override-types): Exclude text/plain. + +1999-10-26 23:27:44 Shenghuo ZHU + + * mm-decode.el (mm-dissect-buffer): CTE may come without CTL. + +1999-10-26 21:44:05 Shenghuo ZHU + + * gnus-srvr.el (gnus-browse-foreign-server): Use + `buffer-substring' instead of `read'. + +1999-10-23 Simon Josefsson + + * 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 + + * 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 + + * gnus-art.el (gnus-article-setup-buffer): Fix buffer leak. + +1999-10-13 12:52:18 Shenghuo ZHU + + * mm-view.el (mm-inline-message): Fix leaving group bug. + +1999-10-07 17:59:49 Shenghuo ZHU + + * gnus-msg.el (gnus-post-method): Use normal method if current is + not available. + +1999-10-07 17:09:34 Shenghuo ZHU + + * nnmail.el (nnmail-insert-xref): Dealing with empty articles. + (nnmail-insert-lines): Ditto. + +1999-10-07 Shenghuo ZHU + + * nnfolder.el (nnfolder-insert-newsgroup-line): Insert a blank + line. + + * message.el (message-unsent-separator): One more separator. + +1999-10-06 Shenghuo ZHU + + * 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 + + * qp.el (quoted-printable-encode-region): Check eobp. + +1999-10-03 Shenghuo ZHU + + * nntp.el (nntp-retrieve-headers-with-xover): Fix hanging problem. + +1999-10-02 Shenghuo ZHU + + * nntp.el (nntp-send-xover-command): Wait for nothing if not + wait-for-reply. + +1999-09-29 Shenghuo ZHU + + * mm-uu.el (mm-uu-forward-begin-line): Change the regexp. + (mm-uu-forward-end-line): Ditto. + +1999-09-29 Didier Verna + + * 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 + + * mm-util.el (mm-binary-coding-system): Try binary first. + +1999-09-14 Shenghuo ZHU + + * rfc1843.el (rfc1843-decode-article-body): Don't decode twice. + +1999-09-10 Shenghuo ZHU + + * 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 + + * mm-uu.el (mm-uu-dissect): Do not dissect quoted-printable + forwarded message. + +1999-09-27 20:33:41 Lars Magne Ingebrigtsen + + * 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 + + * message.el (message-newline-and-reformat): Work for SC. + +1999-09-27 19:38:33 Lars Magne Ingebrigtsen + + * 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 * gnus.el: Pterodactyl Gnus v0.97 is released. @@ -133,7 +323,7 @@ Mon Sep 27 15:18:05 1999 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treat-predicate): Work for (not 5). -1999-08-27 Peter von der Ahé +1999-08-27 Peter von der Ah-Aé $)A * message.el (message-send): More helpful error message if sending fails @@ -335,7 +525,7 @@ Fri Aug 27 13:17:48 1999 Lars Magne Ingebrigtsen * 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é +Tue Jul 20 02:39:56 1999 Peter von der Ah-Aé $)A * gnus-sum.el (gnus-summary-exit): Allow gnus-use-adaptive-scoring to have buffer local values. @@ -2887,7 +3077,7 @@ Mon Nov 30 23:38:02 1998 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Use mm-make-handle. -1998-12-01 01:53:49 François Pinard +1998-12-01 01:53:49 Fran-Açois Pinard $)A * nndoc.el (nndoc-mime-parts-type-p): Do related. @@ -4633,7 +4823,7 @@ Mon Sep 14 18:55:38 1998 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-q-encode-region): Would bug out. -1998-09-13 François Pinard +1998-09-13 Fran-Açois Pinard $)A * nndoc.el: Make nndoc-dissection-alist simpler for MIME, adjust all related functions. Handle message/rfc822 parts. Display subject on diff --git a/lisp/binhex.el b/lisp/binhex.el index ddad17e..e6ce6ca 100644 --- a/lisp/binhex.el +++ b/lisp/binhex.el @@ -3,7 +3,7 @@ ;; Author: Shenghuo Zhu ;; Create Date: Oct 1, 1998 -;; $Revision: 1.1.1.10 $ +;; $Revision: 1.1.1.11 $ ;; Time-stamp: ;; Keywords: binhex @@ -199,12 +199,12 @@ If HEADER-ONLY is non-nil only decode header and return filename." (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) diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index d2ed36b..76dfca3 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -227,6 +227,7 @@ If nil, only read articles will be expired." "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) @@ -418,6 +419,27 @@ be a select method." (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 ;;; @@ -955,6 +977,8 @@ the actual number of articles toggled is returned." 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)) @@ -1447,9 +1471,10 @@ The following commands are available: (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)) diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index e084612..4bde941 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -616,6 +616,22 @@ be added below it (otherwise)." :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 ;;; @@ -1086,6 +1102,7 @@ Initialized from `text-mode-syntax-table.") (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)))))))) @@ -1494,9 +1511,9 @@ header in the current article." (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) @@ -1824,7 +1841,7 @@ should replace the \"Date:\" one, or should be added below it." (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 @@ -1842,16 +1859,17 @@ should replace the \"Date:\" one, or should be added below it." (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. @@ -1905,9 +1923,13 @@ should replace the \"Date:\" one, or should be added below it." (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 @@ -2043,6 +2065,7 @@ This format is defined by the `gnus-article-time-format' variable." 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 @@ -2547,6 +2570,8 @@ commands: (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) @@ -2914,11 +2939,33 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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)))) diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index cbc6735..52e1d5f 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -514,6 +514,7 @@ ticked: The number of ticked articles." "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 @@ -525,6 +526,7 @@ ticked: The number of ticked articles." "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) @@ -2215,6 +2217,62 @@ score file entries for articles to include in the 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 . diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index fa842b4..74a02f2 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -103,6 +103,7 @@ the second with the current group name.") (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." @@ -555,6 +556,7 @@ If SILENT, don't prompt the user." ;; 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 diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el index 50048bc..1cc975a 100644 --- a/lisp/gnus-srvr.el +++ b/lisp/gnus-srvr.el @@ -594,7 +594,9 @@ The following commands are available: (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)))) diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index ef27428..7ba223c 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -2547,8 +2547,9 @@ If FORCE is non-nil, the .newsrc file is read." (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 diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 8ff0671..ac5d927 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -822,7 +822,7 @@ which it may alter in any way.") (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." @@ -4823,7 +4823,8 @@ This is meant to be called in `gnus-article-internal-prepare-hook'." (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))) @@ -6920,6 +6921,7 @@ Optional argument BACKWARD means do search for backward. (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. @@ -6946,6 +6948,9 @@ Optional argument BACKWARD means do search for backward. (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. @@ -7147,9 +7152,12 @@ If ARG is a negative number, hide the unwanted header lines." (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)))) @@ -7162,8 +7170,7 @@ If ARG is a negative number, hide the unwanted header lines." (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)) diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index 97da766..b8235cf 100644 --- a/lisp/gnus-topic.el +++ b/lisp/gnus-topic.el @@ -212,11 +212,12 @@ If TOPIC, start with that topic." (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 @@ -981,6 +982,7 @@ articles in the topic and its subtopics." ["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])))) @@ -1119,23 +1121,25 @@ If COPYP, copy the groups instead." (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." @@ -1475,6 +1479,55 @@ If REVERSE, sort in reverse order." (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 diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 532429b..5cacabb 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -950,7 +950,8 @@ ARG is passed to the first function." (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))) diff --git a/lisp/gnus.el b/lisp/gnus.el index 4c3c359..3644883 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -260,7 +260,7 @@ is restarted, and sometimes reloaded." :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) @@ -1234,7 +1234,8 @@ slower." ("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 diff --git a/lisp/imap.el b/lisp/imap.el new file mode 100644 index 0000000..661dd0a --- /dev/null +++ b/lisp/imap.el @@ -0,0 +1,2280 @@ +;;; imap.el --- imap library +;; Copyright (C) 1998,1999 Free Software Foundation, Inc. + +;; Author: Simon Josefsson +;; 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: ^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.") + + +;; 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)))) + + +;; 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)) + + +;; 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 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)))))) + + +;; 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) ">")))) + + +;; 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)))))))) + + +;; 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 = / +;; "\" quoted-specials +;; +;; quoted-specials = DQUOTE / "\" +;; +;; TEXT-CHAR = + +(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 = +;; +;; 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 = + +(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*] +;; +;; 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* + +(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 = / +;; "\" 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 diff --git a/lisp/lpath.el b/lisp/lpath.el index 8a0ec4d..43b4383 100644 --- a/lisp/lpath.el +++ b/lisp/lpath.el @@ -48,7 +48,7 @@ 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 diff --git a/lisp/mail-source.el b/lisp/mail-source.el index cc58f6f..0758c9a 100644 --- a/lisp/mail-source.el +++ b/lisp/mail-source.el @@ -89,7 +89,16 @@ This variable is a list of mail source specifiers." (: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.")) @@ -97,7 +106,8 @@ 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) @@ -419,6 +429,46 @@ If ARGS, PROMPT is used as an argument to `format'." (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 diff --git a/lisp/mailcap.el b/lisp/mailcap.el index 7a1c05b..74d2771 100644 --- a/lisp/mailcap.el +++ b/lisp/mailcap.el @@ -623,12 +623,12 @@ If TEST is not given, it defaults to t." (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) diff --git a/lisp/message.el b/lisp/message.el index 822a349..c3350a8 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -953,6 +953,7 @@ The cdr of ech entry is a function for applying the face to a region.") "^ *---+ +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.") @@ -1617,10 +1618,12 @@ With the prefix argument FORCE, insert the header anyway." 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))) @@ -3831,7 +3834,11 @@ Optional NEWS will use news to forward instead of mail." ;;;###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)) diff --git a/lisp/mm-bodies.el b/lisp/mm-bodies.el index 3ced083..a448b0b 100644 --- a/lisp/mm-bodies.el +++ b/lisp/mm-bodies.el @@ -209,7 +209,7 @@ The characters in CHARSET should then be decoded." ;; 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)))))) @@ -225,7 +225,7 @@ The characters in CHARSET should then be decoded." (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)))) diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 693c60e..98a167c 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -139,7 +139,7 @@ "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 @@ -190,7 +190,11 @@ to: (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) "/")) diff --git a/lisp/mm-util.el b/lisp/mm-util.el index 43c94f2..5a4d8c3 100644 --- a/lisp/mm-util.el +++ b/lisp/mm-util.el @@ -112,8 +112,8 @@ (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.") @@ -235,15 +235,17 @@ used as the line break code type of the 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) @@ -267,8 +269,7 @@ See also `with-temp-file' and `with-output-to-string'." (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)) diff --git a/lisp/mm-uu.el b/lisp/mm-uu.el index 6262930..c08d009 100644 --- a/lisp/mm-uu.el +++ b/lisp/mm-uu.el @@ -81,8 +81,8 @@ decoder, such as hexbin." ;;; Thanks to Edward J. Sabol and ;;; Peter von der Ah\'e -(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) @@ -147,7 +147,7 @@ To disable dissecting shar codes, for instance, add (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))) diff --git a/lisp/mm-view.el b/lisp/mm-view.el index 4d00c52..5b53685 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -185,7 +185,9 @@ (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 () diff --git a/lisp/mml.el b/lisp/mml.el index 771487d..1aa55ac 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -242,7 +242,8 @@ contents of this part.") (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) diff --git a/lisp/nnagent.el b/lisp/nnagent.el index 9d94eb8..ed62850 100644 --- a/lisp/nnagent.el +++ b/lisp/nnagent.el @@ -114,7 +114,12 @@ (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 diff --git a/lisp/nnfolder.el b/lisp/nnfolder.el index a45f4f7..e989080 100644 --- a/lisp/nnfolder.el +++ b/lisp/nnfolder.el @@ -119,8 +119,9 @@ If NIL, NNFOLDER-FILE-CODING-SYSTEM is used.") (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) @@ -368,7 +369,8 @@ If NIL, NNFOLDER-FILE-CODING-SYSTEM is used.") (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)) @@ -400,8 +402,9 @@ If NIL, NNFOLDER-FILE-CODING-SYSTEM is used.") (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 @@ -647,8 +650,9 @@ deleted. Point is left where the deleted region was." (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)))) @@ -677,10 +681,12 @@ deleted. Point is left where the deleted region was." (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. diff --git a/lisp/nnimap.el b/lisp/nnimap.el new file mode 100644 index 0000000..c8c57f9 --- /dev/null +++ b/lisp/nnimap.el @@ -0,0 +1,1273 @@ +;;; nnimap.el --- imap backend for Gnus +;; Copyright (C) 1998,1999 Free Software Foundation, Inc. + +;; Author: Simon Josefsson +;; Jim Radford +;; 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. + + +;; 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))) + + +;;; 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 diff --git a/lisp/nnmail.el b/lisp/nnmail.el index aa1ce27..73057c2 100644 --- a/lisp/nnmail.el +++ b/lisp/nnmail.el @@ -999,35 +999,39 @@ Return the number of characters in the body." (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 diff --git a/lisp/nntp.el b/lisp/nntp.el index 507733a..3e4322b 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -1118,9 +1118,10 @@ password contained in '~/.nntp-authinfo'." ((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 @@ -1133,40 +1134,55 @@ password contained in '~/.nntp-authinfo'." (< (- (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)) @@ -1189,7 +1205,7 @@ password contained in '~/.nntp-authinfo'." (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. diff --git a/lisp/qp.el b/lisp/qp.el index 18c66b7..56203e9 100644 --- a/lisp/qp.el +++ b/lisp/qp.el @@ -99,11 +99,12 @@ matched by that regexp." (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." diff --git a/lisp/rfc1843.el b/lisp/rfc1843.el index f16cfcb..254dd65 100644 --- a/lisp/rfc1843.el +++ b/lisp/rfc1843.el @@ -1,13 +1,10 @@ ;;; rfc1843.el --- HZ (rfc1843) decoding -;; Copyright (c) 1998 by Shenghuo Zhu +;; Copyright (c) 1998,1999 by Shenghuo Zhu ;; Author: Shenghuo Zhu -;; $Revision: 1.1.1.3 $ ;; Keywords: news HZ -;; Time-stamp: -;; 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 @@ -139,9 +136,20 @@ ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc" (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) diff --git a/lisp/rfc2104.el b/lisp/rfc2104.el new file mode 100644 index 0000000..dd4d5ac --- /dev/null +++ b/lisp/rfc2104.el @@ -0,0 +1,104 @@ +;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes +;; Copyright (C) 1998,1999 Free Software Foundation, Inc. + +;; Author: Simon Josefsson +;; 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 diff --git a/texi/ChangeLog b/texi/ChangeLog index 0667c43..42cd590 100644 --- a/texi/ChangeLog +++ b/texi/ChangeLog @@ -1,3 +1,13 @@ +1999-10-23 Simon Josefsson + + * gnus.texi (Mail Source Specifiers): Add imap mail-source. + (IMAP): New subsection. + (SOUP): Typo. + +1999-09-27 16:07:31 Lars Magne Ingebrigtsen + + * emacs-mime.texi (New Viewers): Fix. + 1999-09-25 10:58:17 Lars Magne Ingebrigtsen * message.texi (Forwarding): Updated. diff --git a/texi/gnus.texi b/texi/gnus.texi index 5b4ff1c..6c8c1c3 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -1,7 +1,7 @@ @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 @@ -319,7 +319,7 @@ into another language, under the above conditions for modified versions. @tex @titlepage -@title Pterodactyl Gnus 0.97 Manual +@title Pterodactyl Gnus Manual @author by Lars Magne Ingebrigtsen @page @@ -355,7 +355,7 @@ can be gotten by any nefarious means you can think of---@sc{nntp}, local 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 @@ -10374,6 +10374,62 @@ An example maildir mail source: (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 @@ -11511,6 +11567,7 @@ newsgroups. * 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 @@ -11833,7 +11890,7 @@ Of course, us Unix Weenie types of human beans use things like 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. @@ -12270,6 +12327,267 @@ So, to use this, simply say something like: @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 diff --git a/texi/message.texi b/texi/message.texi index 2b6cc14..2391c1b 100644 --- a/texi/message.texi +++ b/texi/message.texi @@ -1,7 +1,7 @@ \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 @@ -42,7 +42,7 @@ into another language, under the above conditions for modified versions. @tex @titlepage -@title Pterodactyl Message 0.97 Manual +@title Pterodactyl Message 0.98 Manual @author by Lars Magne Ingebrigtsen @page @@ -83,7 +83,7 @@ Message mode buffers. * 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.