X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fnnimap.el;h=44776044e9845aef922289b0002a31da9c089f6c;hb=e2696774a2e225ea60d46cc665d4232c80412731;hp=306f54e67baa635a2a5045194c571faaf58d3bb6;hpb=49d38b41c190eaab2cb34294fac7302a9c9ea353;p=elisp%2Fgnus.git- diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 306f54e..4477604 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -61,7 +61,6 @@ ;;; Code: (eval-when-compile (require 'cl)) -(eval-when-compile (require 'gnus-clfns)) (require 'imap) (require 'nnoo) @@ -72,6 +71,8 @@ (require 'gnus-start) (require 'gnus-int) +(eval-when-compile (require 'cl)) + (nnoo-declare nnimap) (defconst nnimap-version "nnimap 1.0") @@ -402,6 +403,43 @@ just like \"ticked\" articles, in other IMAP clients.") If this is 'imap-mailbox-lsub, then use a server-side subscription list to restrict visible folders.") +(defcustom nnimap-id nil + "Plist with client identity to send to server upon login. +Nil means no information is sent, symbol `no' to disable ID query +alltogheter, or plist with identifier-value pairs to send to +server. RFC 2971 describes the list as follows: + + Any string may be sent as a field, but the following are defined to + describe certain values that might be sent. Implementations are free + to send none, any, or all of these. Strings are not case-sensitive. + Field strings MUST NOT be longer than 30 octets. Value strings MUST + NOT be longer than 1024 octets. Implementations MUST NOT send more + than 30 field-value pairs. + + name Name of the program + version Version number of the program + os Name of the operating system + os-version Version of the operating system + vendor Vendor of the client/server + support-url URL to contact for support + address Postal address of contact/vendor + date Date program was released, specified as a date-time + in IMAP4rev1 + command Command used to start the program + arguments Arguments supplied on the command line, if any + if any + environment Description of environment, i.e., UNIX environment + variables or Windows registry settings + + Implementations MUST NOT send the same field name more than once. + +An example plist would be '(\"name\" \"Gnus\" \"version\" gnus-version-number +\"os\" system-configuration \"vendor\" \"GNU\")." + :group 'nnimap + :type '(choice (const :tag "No information" nil) + (const :tag "Disable ID query" no) + (plist :key-type string :value-type string))) + (defcustom nnimap-debug nil "If non-nil, random debug spews are placed in *nnimap-debug* buffer." :group 'nnimap @@ -550,7 +588,7 @@ If EXAMINE is non-nil the group is selected read-only." (with-temp-buffer (buffer-disable-undo) (insert headers) - (let ((head (nnheader-parse-naked-head))) + (let ((head (nnheader-parse-naked-head uid))) (mail-header-set-number head uid) (mail-header-set-chars head chars) (mail-header-set-lines head lines) @@ -716,19 +754,22 @@ If EXAMINE is non-nil the group is selected read-only." (imap-capability 'IMAP4rev1 nnimap-server-buffer)) (imap-close nnimap-server-buffer) (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server)) - (let* ((list (gnus-parse-netrc nnimap-authinfo-file)) + (let* ((list (netrc-parse nnimap-authinfo-file)) (port (if nnimap-server-port (int-to-string nnimap-server-port) "imap")) - (alist (gnus-netrc-machine list (or nnimap-server-address - nnimap-address server) - port "imap")) - (user (gnus-netrc-get alist "login")) - (passwd (gnus-netrc-get alist "password"))) + (alist (or (netrc-machine list server port "imap") + (netrc-machine list + (or nnimap-server-address + nnimap-address) + port "imap"))) + (user (netrc-get alist "login")) + (passwd (netrc-get alist "password"))) (if (imap-authenticate user passwd nnimap-server-buffer) (prog1 (push (list server nnimap-server-buffer) nnimap-server-buffer-alist) + (imap-id nnimap-id nnimap-server-buffer) (nnimap-possibly-change-server server)) (imap-close nnimap-server-buffer) (kill-buffer nnimap-server-buffer) @@ -790,8 +831,8 @@ Return nil if the server couldn't be closed for some reason." 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) + (mapc (lambda (server) (nnimap-close-server (car server))) + nnimap-server-buffer-alist) (setq nnimap-server-buffer-alist nil)) (deffoo nnimap-status-message (&optional server) @@ -1177,11 +1218,11 @@ function is generally only called when Gnus is shutting down." (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) + (mapc (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 @@ -1272,7 +1313,7 @@ function is generally only called when Gnus is shutting down." nnimap-split-download-body-default nnimap-split-download-body) (and (nnimap-request-article article) - (mail-narrow-to-head)) + (with-current-buffer nntp-server-buffer (mail-narrow-to-head))) (nnimap-request-head article)) ;; copy article to right group(s) (setq removeorig nil) @@ -1291,7 +1332,9 @@ function is generally only called when Gnus is shutting down." (let (msgid) (and (setq msgid (nnmail-fetch-field "message-id")) - (nnmail-cache-insert msgid to-group))))) + (nnmail-cache-insert msgid + to-group + (nnmail-fetch-field "subject")))))) ;; Add the group-art list to the history list. (push (list (cons to-group 0)) nnmail-split-history)) (t @@ -1325,7 +1368,7 @@ function is generally only called when Gnus is shutting down." (nnimap-before-find-minmax-bugworkaround) (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) - (dolist (mbx (imap-mailbox-lsub "*" (car pattern) nil + (dolist (mbx (imap-mailbox-lsub (cdr pattern) (car pattern) nil nnimap-server-buffer)) (or (catch 'found (dolist (mailbox (imap-mailbox-get 'list-flags mbx @@ -1468,7 +1511,8 @@ function is generally only called when Gnus is shutting down." (replace-match "\r\n")) (when nnmail-cache-accepted-message-ids (nnmail-cache-insert (nnmail-fetch-field "message-id") - group))) + group + (nnmail-fetch-field "subject")))) (when (and last nnmail-cache-accepted-message-ids) (nnmail-cache-close)) ;; this 'or' is for Cyrus server bug @@ -1507,21 +1551,21 @@ function is generally only called when Gnus is shutting down." (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) + (mapc (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) + (mapc (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)))