From: yamaoka Date: Mon, 2 Oct 2000 00:50:45 +0000 (+0000) Subject: Synch with Gnus. X-Git-Tag: t-gnus-6_14-quimby-before-installer-changed-~76 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=5e782cd9e8310aa2266ce68e15215155018d482e;p=elisp%2Fgnus.git- Synch with Gnus. ;; gnus-ja.texi: The node `Agent and IMAP' has not been translated yet. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ede82a7..90b5562 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,120 @@ +2000-10-01 17:08:50 ShengHuo ZHU + + * mailcap.el (mailcap-mime-types): Use mailcap-mime-data. + * mml.el (mml-minibuffer-read-type): Use mailcap-mime-types. + +2000-10-01 13:07:21 ShengHuo ZHU + + * webmail.el (webmail-netscape-open, webmail-hotmail-article, + webmail-hotmail-list): Update. + +2000-10-01 08:36:09 ShengHuo ZHU + + * mail-source.el (mail-source-report-new-mail): Use + nnheader-cancel-timer. + +2000-10-01 08:35:38 ShengHuo ZHU + + * lpath.el (overlay-*): Shut up. + * dgnushack.el: Two implementations of smiley. + +2000-10-01 08:32:42 ShengHuo ZHU + + * gnus-ml.el: Usage. + (gnus-mailing-list-archive, gnus-mailing-list-owner, + gnus-mailing-list-post, gnus-mailing-list-unsubscribe, + gnus-mailing-list-subscribe, gnus-mailing-list-help): Bind list-*. + (gnus-mailing-list-menu): Define it. + (turn-on-gnus-mailing-list-mode, gnus-mailing-list-mode): Autoload. + + * gnus-xmas.el (gnus-xmas-mailing-list-menu-add): Move here. + +2000-09-30 18:52:51 ShengHuo ZHU + + * webmail.el (webmail-my-deja-*): Rewrite. + +2000-09-30 Simon Josefsson + + * nnimap.el (nnimap-request-accept-article): Remove \n's from + From_ lines. + +2000-08-05 Simon Josefsson + + Make GCC to remote groups work when unplugged + (postpone GCC until message is actually sent). + + * gnus-draft.el (gnus-draft-send): Call `gnus-agent-restore-gcc'. + + * gnus-agent.el (gnus-agent-possibly-do-gcc): + (gnus-agent-restore-gcc): + (gnus-agent-possibly-save-gcc): New functions. + + * gnus-msg.el (gnus-inews-add-send-actions): Use + `gnus-agent-possibly-do-gcc' if Agentized. + (gnus-inews-add-send-actions): Add `gnus-agent-possibly-save-gcc' + to `message-header-hook'. + + * gnus.el (gnus-agent-gcc-header): New variable. + +2000-07-13 Simon Josefsson + + Asks the user to synch flags with server when you plug in. + + * gnus-agent.el (gnus-agent-synchronize-flags): New variable. + (gnus-agent-possibly-synchronize-flags-server): New function, use it. + (gnus-agent-toggle-plugged): Call it. + (gnus-agent-synchronize-flags): Renamed from `gnus-agent-synchronize'. + (gnus-agent-group-mode-map): `g-a-s' -> `g-a-s-flags'. + (gnus-agent-possibly-synchronize-flags): New function. + (gnus-agent-possibly-synchronize-flags-server): New function. + +2000-09-30 Simon Josefsson + + * starttls.el: New file, by Daiki Ueno. + +2000-08-02 Stanislav Shalunov + + * message.el (message-make-in-reply-to): In-Reply-To is message-id + (see DRUMS). + +2000-09-29 Simon Josefsson + + * nntp.el (nntp-async-trigger): Fix authinfo in asynchronous + prefetch. + +2000-08-09 10:21:20 Katsumi Yamaoka + + * nntp.el (nntp-open-telnet): Wait for the telnet prompt before + sending a command; allow the rtelnet prompt as well. + +2000-09-29 Simon Josefsson + + * message.el (message-send): Make sure error is signalled if no + send method is specified. + +2000-09-29 Florian Weimer + + * qp.el (quoted-printable-encode-region): Wrap with + `mm-with-unibyte-current-buffer'. + +2000-09-29 12:12:49 ShengHuo ZHU + + * gnus-agent.el (gnus-agent-fetch-group-1): Reimplement Mike + McEwan's proposal. + +2000-09-29 12:06:40 ShengHuo ZHU + + * gnus-agent.el: Revoke Mike McEwan's 1998-09-05 patch due to + the GNU assignment issue. + +2000-09-29 09:56:34 ShengHuo ZHU + + * nndoc.el (nndoc-dissect-mime-parts-sub): Correctly mark body-begin. + +2000-09-29 09:14:08 ShengHuo ZHU + + * gnus-sum.el (gnus-summary-enter-digest-group): Decode to-address. + 2000-09-28 Kai Gro,A_(Bjohann * gnus-art.el (article-strip-banner): elkin@tverd.astro.spbu.ru: diff --git a/lisp/dgnushack.el b/lisp/dgnushack.el index 175239d..5c9f0d5 100644 --- a/lisp/dgnushack.el +++ b/lisp/dgnushack.el @@ -38,14 +38,15 @@ (cond ((and (featurep 'xemacs) (featurep 'mule)) (if (memq 'shift-jis (coding-priority-list)) (set-coding-priority-list - (nconc (delq 'shift-jis (coding-priority-list)) '(shift-jis))))) + (append (delq 'shift-jis (coding-priority-list)) '(shift-jis))))) ((boundp 'MULE) (put '*coding-category-sjis* 'priority (length *predefined-category*))) ((featurep 'mule) (if (memq 'coding-category-sjis coding-category-list) (set-coding-priority - (nconc (delq 'coding-category-sjis coding-category-list) - '(coding-category-sjis)))))) + (append (delq 'coding-category-sjis + (copy-sequence coding-category-list)) + '(coding-category-sjis)))))) (fset 'facep 'ignore) @@ -205,7 +206,7 @@ Modify to suit your needs.")) file elc) (mapcar (lambda (el) (setq files (delete el files))) - (nconc + (append dgnushack-tool-files (condition-case nil (progn (require 'w3-forms) nil) @@ -214,9 +215,10 @@ Modify to suit your needs.")) (condition-case nil (progn (require 'bbdb) nil) (error '("gnus-bbdb.el"))) - (unless (featurep 'xemacs) + (if (featurep 'xemacs) + '("smiley-ems.el") '("gnus-xmas.el" "gnus-picon.el" "messagexmas.el" - "nnheaderxm.el" "gnus-ml.el")) + "nnheaderxm.el" "smiley.el")) (when (and (fboundp 'md5) (subrp (symbol-function 'md5))) '("md5.el")))) (while (setq file (pop files)) diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 4924a29..2ac606d 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -31,11 +31,11 @@ (require 'gnus-cache) (require 'nnvirtual) (require 'gnus-sum) +(require 'gnus-score) (eval-when-compile (if (featurep 'xemacs) (require 'itimer) (require 'timer)) - (require 'gnus-score) (require 'gnus-group)) (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") @@ -97,6 +97,14 @@ fetched will be limited to it. If not a positive integer, never consider it." :type '(choice (const nil) (integer :tag "Number"))) +(defcustom gnus-agent-synchronize-flags 'ask + "Indicate if flags are synchronized when you plug in. +If this is `ask' the hook will query the user." + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Ask" ask)) + :group 'gnus-agent) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) @@ -114,10 +122,6 @@ fetched will be limited to it. If not a positive integer, never consider it." (defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) -(defconst gnus-agent-scoreable-headers - '("subject" "from" "date" "message-id" "references" "chars" "lines" "xref") - "Headers that are considered when scoring articles for download via the Agent.") - ;; Dynamic variables (defvar gnus-headers) (defvar gnus-score) @@ -247,7 +251,7 @@ fetched will be limited to it. If not a positive integer, never consider it." "Jc" gnus-enter-category-buffer "Jj" gnus-agent-toggle-plugged "Js" gnus-agent-fetch-session - "JY" gnus-agent-synchronize + "JY" gnus-agent-synchronize-flags "JS" gnus-group-send-drafts "Ja" gnus-agent-add-group "Jr" gnus-agent-remove-group) @@ -304,6 +308,7 @@ fetched will be limited to it. If not a positive integer, never consider it." (if plugged (progn (setq gnus-plugged plugged) + (gnus-agent-possibly-synchronize-flags) (gnus-run-hooks 'gnus-agent-plugged-hook) (setcar (cdr gnus-agent-mode-status) " Plugged")) (gnus-agent-close-connections) @@ -385,6 +390,27 @@ be a select method." (while (search-backward "\n" nil t) (replace-match "\\n" t t)))) +(defun gnus-agent-restore-gcc () + "Restore GCC field from saved header." + (save-excursion + (goto-char (point-min)) + (while (re-search-forward (concat gnus-agent-gcc-header ":") nil t) + (replace-match "Gcc:" 'fixedcase)))) + +(defun gnus-agent-possibly-save-gcc () + "Save GCC if Gnus is unplugged." + (unless gnus-plugged + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (re-search-forward "^gcc:" nil t) + (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase)))))) + +(defun gnus-agent-possibly-do-gcc () + "Do GCC if Gnus is plugged." + (when gnus-plugged + (gnus-inews-do-gcc))) + ;;; ;;; Group mode commands ;;; @@ -439,27 +465,49 @@ 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." +(defun gnus-agent-synchronize-flags () + "Synchronize unplugged flags with servers." (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) - (nnheader-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"))) - (kill-buffer nil))))) + (gnus-agent-synchronize-flags-server gnus-command-method))))) + +(defun gnus-agent-possibly-synchronize-flags () + "Synchronize flags according to `gnus-agent-synchronize-flags'." + (interactive) + (save-excursion + (dolist (gnus-command-method gnus-agent-covered-methods) + (when (file-exists-p (gnus-agent-lib-file "flags")) + (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) + +(defun gnus-agent-synchronize-flags-server (method) + "Synchronize flags set when unplugged for server." + (let ((gnus-command-method method)) + (when (file-exists-p (gnus-agent-lib-file "flags")) + (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) + (erase-buffer) + (nnheader-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")))) + (delete-file (gnus-agent-lib-file "flags"))) + (kill-buffer nil)))) + +(defun gnus-agent-possibly-synchronize-flags-server (method) + "Synchronize flags for server according to `gnus-agent-synchronize-flags'." + (when (or (and gnus-agent-synchronize-flags + (not (eq gnus-agent-synchronize-flags 'ask))) + (and (eq gnus-agent-synchronize-flags 'ask) + (gnus-y-or-n-p (format "Synchronize flags on server `%s'? " + (cadr method))))) + (gnus-agent-synchronize-flags-server method))) ;;; ;;; Server mode commands @@ -677,7 +725,7 @@ the actual number of articles toggled is returned." (nnheader-translate-file-chars (nnheader-replace-chars-in-string (nnheader-replace-duplicate-chars-in-string - (nnheader-replace-chars-in-string + (nnheader-replace-chars-in-string (gnus-group-real-name group) ?/ ?_) ?. ?_) @@ -793,8 +841,8 @@ the actual number of articles toggled is returned." (with-temp-buffer (let (article) (while (setq article (pop articles)) - (when (or - (gnus-backlog-request-article group article + (when (or + (gnus-backlog-request-article group article nntp-server-buffer) (gnus-request-article article group)) (goto-char (point-max)) @@ -1047,7 +1095,7 @@ the actual number of articles toggled is returned." (while (setq group (pop groups)) (when (<= (gnus-group-level group) gnus-agent-handle-level) (gnus-agent-fetch-group-1 group gnus-command-method)))))) - (error + (error (unless (funcall gnus-agent-confirmation-function (format "Error (%s). Continue? " err)) (error "Cannot fetch articles into the Gnus agent.")))) @@ -1073,17 +1121,13 @@ the actual number of articles toggled is returned." ;; Fetch headers. (when (and (or (gnus-active group) (gnus-activate-group group)) (setq articles (gnus-agent-fetch-headers group)) - (progn + (let ((nntp-server-buffer gnus-agent-overview-buffer)) ;; Parse them and see which articles we want to fetch. (setq gnus-newsgroup-dependencies (make-vector (length articles) 0)) - ;; No need to call `gnus-get-newsgroup-headers-xover' with - ;; the entire .overview for group as we still have the just - ;; downloaded headers in `gnus-agent-overview-buffer'. - (let ((nntp-server-buffer gnus-agent-overview-buffer)) - (setq gnus-newsgroup-headers - (gnus-get-newsgroup-headers-xover articles nil nil - group))) + (setq gnus-newsgroup-headers + (gnus-get-newsgroup-headers-xover articles nil nil + group)) ;; `gnus-agent-overview-buffer' may be killed for ;; timeout reason. If so, recreate it. (gnus-agent-create-buffer))) @@ -1092,45 +1136,23 @@ the actual number of articles toggled is returned." (gnus-get-predicate (or (gnus-group-find-parameter group 'agent-predicate t) (cadr category)))) - ;; Do we want to download everything, or nothing? - (if (or (eq (caaddr predicate) 'gnus-agent-true) - (eq (caaddr predicate) 'gnus-agent-false)) - ;; Yes. - (setq arts (symbol-value - (cadr (assoc (caaddr predicate) - '((gnus-agent-true articles) - (gnus-agent-false nil)))))) - ;; No, we need to decide what we want. + (if (memq (caaddr predicate) '(gnus-agent-true gnus-agent-false)) + ;; Simple implementation + (setq arts + (and (eq (caaddr predicate) 'gnus-agent-true) articles)) + (setq arts nil) (setq score-param - (let ((score-method - (or - (gnus-group-find-parameter group 'agent-score t) - (caddr category)))) - (when score-method - (require 'gnus-score) - (if (eq score-method 'file) - (let ((entries - (gnus-score-load-files - (gnus-all-score-files group))) - list score-file) - (while (setq list (car entries)) - (push (car list) score-file) - (setq list (cdr list)) - (while list - (when (member (caar list) - gnus-agent-scoreable-headers) - (push (car list) score-file)) - (setq list (cdr list))) - (setq score-param - (append score-param (list (nreverse score-file))) - score-file nil entries (cdr entries))) - (list score-param)) - (if (stringp (car score-method)) - score-method - (list (list score-method))))))) + (or (gnus-group-get-parameter group 'agent-score t) + (caddr category))) + ;; Translate score-param into real one + (cond + ((eq score-param 'file) + (setq score-param (gnus-all-score-files group))) + ((stringp (car score-param))) + (t + (setq score-param (list (list score-param))))) (when score-param (gnus-score-headers score-param)) - (setq arts nil) (while (setq gnus-headers (pop gnus-newsgroup-headers)) (setq gnus-score (or (cdr (assq (mail-header-number gnus-headers) diff --git a/lisp/gnus-draft.el b/lisp/gnus-draft.el index 293209c..366f867 100644 --- a/lisp/gnus-draft.el +++ b/lisp/gnus-draft.el @@ -33,6 +33,7 @@ (require 'message) (require 'gnus-msg) (require 'nndraft) +(require 'gnus-agent) (eval-when-compile (require 'cl)) ;;; Draft minor mode @@ -142,6 +143,8 @@ (setq type (ignore-errors (read (current-buffer))) method (ignore-errors (read (current-buffer)))) (message-remove-header gnus-agent-meta-information-header))) + ;; Let Agent restore any GCC lines and have message.el perform them. + (gnus-agent-restore-gcc) ;; Then we send it. If we have no meta-information, we just send ;; it and let Message figure out how. (when (let ((mail-header-separator "")) diff --git a/lisp/gnus-mailcap.el b/lisp/gnus-mailcap.el index 1c72d9f..b48fc26 100644 --- a/lisp/gnus-mailcap.el +++ b/lisp/gnus-mailcap.el @@ -937,7 +937,23 @@ The path of COMMAND will be returned iff COMMAND is a command." (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) - (mm-delete-duplicates (mapcar 'cdr mailcap-mime-extensions))) + (mm-delete-duplicates + (nconc + (mapcar 'cdr mailcap-mime-extensions) + (apply + 'nconc + (mapcar + (lambda (l) + (delq nil + (mapcar + (lambda (m) + (let ((type (cdr (assq 'type (cdr m))))) + (if (equal (cadr (split-string type "/")) + "*") + nil + type))) + (cdr l)))) + mailcap-mime-data))))) (provide 'gnus-mailcap) diff --git a/lisp/gnus-ml.el b/lisp/gnus-ml.el index 64f587a..6dbcfa2 100644 --- a/lisp/gnus-ml.el +++ b/lisp/gnus-ml.el @@ -23,19 +23,16 @@ ;; implement (small subset of) RFC 2369 +;;; Usage: + +;; (add-hook 'gnus-summary-mode-hook 'turn-on-gnus-mailing-list-mode) + ;;; Code: (require 'gnus) +(require 'gnus-msg) (eval-when-compile (require 'cl)) -(defvar group) -(defvar list-help) -(defvar list-subscribe) -(defvar list-unsubscribe) -(defvar list-post) -(defvar list-owner) -(defvar list-archive) - ;;; Mailing list minor mode (defvar gnus-mailing-list-mode nil @@ -43,6 +40,8 @@ (defvar gnus-mailing-list-mode-map nil) +(defvar gnus-mailing-list-menu) + (unless gnus-mailing-list-mode-map (setq gnus-mailing-list-mode-map (make-sparse-keymap)) @@ -67,10 +66,12 @@ ["Mail to owner" gnus-mailing-list-owner t] ["Browse archive" gnus-mailing-list-archive t])))) +;;;###autoload (defun turn-on-gnus-mailing-list-mode () - (when (gnus-group-get-parameter group 'to-list) + (when (gnus-group-get-parameter gnus-newsgroup-name 'to-list) (gnus-mailing-list-mode 1))) +;;;###autoload (defun gnus-mailing-list-mode (&optional arg) "Minor mode for providing mailing-list commands. @@ -91,51 +92,59 @@ (defun gnus-mailing-list-help () "Get help from mailing list server." (interactive) - (cond (list-help (gnus-mailing-list-message list-help)) - (t (display-message 'no-log "no list-help in this group")))) + (let ((list-help + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "list-help")))) + (cond (list-help (gnus-mailing-list-message list-help)) + (t (gnus-message 1 "no list-help in this group"))))) (defun gnus-mailing-list-subscribe () "Subscribe" (interactive) - (cond (list-subscribe (gnus-mailing-list-message list-subscribe)) - (t (display-message 'no-log "no list-subscribe in this group")))) - + (let ((list-subscribe + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "list-subscribe")))) + (cond (list-subscribe (gnus-mailing-list-message list-subscribe)) + (t (gnus-message 1 "no list-subscribe in this group"))))) (defun gnus-mailing-list-unsubscribe () "Unsubscribe" (interactive) - (cond (list-unsubscribe (gnus-mailing-list-message list-unsubscribe)) - (t (display-message 'no-log "no list-unsubscribe in this group")))) + (let ((list-unsubscribe + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "list-unsubscribe")))) + (cond (list-unsubscribe (gnus-mailing-list-message list-unsubscribe)) + (t (gnus-message 1 "no list-unsubscribe in this group"))))) (defun gnus-mailing-list-post () "Post message (really useful ?)" (interactive) - (cond (list-post (gnus-mailing-list-message list-post)) - (t (display-message 'no-log "no list-post in this group"))) - ) + (let ((list-post + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "list-post")))) + (cond (list-post (gnus-mailing-list-message list-post)) + (t (gnus-message 1 "no list-post in this group"))))) (defun gnus-mailing-list-owner () "Mail to the owner" (interactive) - (cond (list-owner (gnus-mailing-list-message list-owner)) - (t (display-message 'no-log "no list-owner in this group"))) - ) + (let ((list-owner + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "list-owner")))) + (cond (list-owner (gnus-mailing-list-message list-owner)) + (t (gnus-message 1 "no list-owner in this group"))))) (defun gnus-mailing-list-archive () "Browse archive" (interactive) - (cond (list-archive (gnus-mailing-list-message list-archive)) - (t (display-message 'no-log "no list-owner in this group"))) - ) + (let ((list-archive + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "list-archive")))) + (cond (list-archive (gnus-mailing-list-message list-archive)) + (t (gnus-message 1 "no list-owner in this group"))))) ;;; Utility functions -(defun gnus-xmas-mailing-list-menu-add () - (gnus-xmas-menu-add mailing-list - gnus-mailing-list-menu)) - -(add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add) - (defun gnus-mailing-list-message (address) "" (let ((mailto "") diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 84a89a6..5abdd23 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -283,7 +283,11 @@ the Gcc: header for archiving purposes." (defun gnus-inews-add-send-actions (winconf buffer article) (make-local-hook 'message-sent-hook) - (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) + (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc + 'gnus-inews-do-gcc) nil t) + (when gnus-agent + (make-local-hook 'message-header-hook) + (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t)) (setq message-post-method `(lambda (arg) (gnus-post-method arg ,gnus-newsgroup-name))) diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 62ed97a..2d1ed3d 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -6970,7 +6970,10 @@ to guess what the document format is." ;; the parent article. (when (setq to-address (or (message-fetch-field "reply-to") (message-fetch-field "from"))) - (setq params (append (list (cons 'to-address to-address))))) + (setq params (append + (list (cons 'to-address + (funcall gnus-decode-encoded-word-function + to-address)))))) (setq dig (nnheader-set-temp-buffer " *gnus digest buffer*")) (insert-buffer-substring gnus-original-article-buffer) ;; Remove lines that may lead nndoc to misinterpret the diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index d2cab8e..4cb948d 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -961,6 +961,12 @@ XEmacs compatibility workaround." (set-glyph-face glyph 'default) glyph))) +(defun gnus-xmas-mailing-list-menu-add () + (gnus-xmas-menu-add mailing-list + gnus-mailing-list-menu)) + +(add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add) + (provide 'gnus-xmas) ;;; gnus-xmas.el ends here diff --git a/lisp/gnus.el b/lisp/gnus.el index 02e7e43..9914f81 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -1528,6 +1528,7 @@ If nil, no default charset is assumed when posting." ;;; Internal variables +(defvar gnus-agent-gcc-header "X-Gnus-Agent-Gcc") (defvar gnus-agent-meta-information-header "X-Gnus-Agent-Meta-Information") (defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) (defvar gnus-original-article-buffer " *Original Article*") diff --git a/lisp/lpath.el b/lisp/lpath.el index d258187..8091555 100644 --- a/lisp/lpath.el +++ b/lisp/lpath.el @@ -17,7 +17,7 @@ (defun maybe-bind (args) (mapcar (lambda (var) (unless (boundp var) (set var nil))) args)) -(if (string-match "XEmacs" emacs-version) +(if (featurep 'xemacs) (progn (defvar track-mouse nil) (maybe-fbind '(posn-point @@ -50,7 +50,8 @@ vcard-pretty-print image-type-available-p put-image create-image display-graphic-p find-image insert-image image-size - make-overlay overlay-put make-symbolic-link)) + make-overlay overlay-put overlay-buffer overlay-start + overlay-get overlay-end make-symbolic-link)) (maybe-bind '(global-face-data mark-active transient-mark-mode mouse-selection-click-count mouse-selection-click-count-buffer buffer-display-table diff --git a/lisp/mail-source.el b/lisp/mail-source.el index 70c3ff7..58a1804 100644 --- a/lisp/mail-source.el +++ b/lisp/mail-source.el @@ -730,9 +730,9 @@ This only works when `display-time' is enabled." (> (prefix-numeric-value arg) 0)))) (setq mail-source-report-new-mail on) (and mail-source-report-new-mail-timer - (cancel-timer mail-source-report-new-mail-timer)) + (nnheader-cancel-timer mail-source-report-new-mail-timer)) (and mail-source-report-new-mail-idle-timer - (cancel-timer mail-source-report-new-mail-idle-timer)) + (nnheader-cancel-timer mail-source-report-new-mail-idle-timer)) (setq mail-source-report-new-mail-timer nil) (setq mail-source-report-new-mail-idle-timer nil) (if on diff --git a/lisp/message.el b/lisp/message.el index d1923fe..b17e411 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -847,13 +847,13 @@ Valid valued are `unique' and `unsent'." :type '(choice (const :tag "unique" unique) (const :tag "unsent" unsent))) -(defcustom message-default-charset +(defcustom message-default-charset (and (featurep 'xemacs) (not (featurep 'mule)) 'iso-8859-1) "Default charset used in non-MULE XEmacsen." :group 'message :type 'symbol) -(defcustom message-dont-reply-to-names +(defcustom message-dont-reply-to-names (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) "*A regexp specifying names to prune when doing wide replies. A value of nil means exclude your own name only." @@ -1249,7 +1249,7 @@ The cdr of ech entry is a function for applying the face to a region.") (defcustom message-send-mail-partially-limit 1000000 "The limitation of messages sent as message/partial. -The lower bound of message size in characters, beyond which the message +The lower bound of message size in characters, beyond which the message should be sent in several parts. If it is nil, the size is unlimited." :group 'message-buffers :type '(choice (const :tag "unlimited" nil) @@ -1406,7 +1406,7 @@ should be sent in several parts. If it is nil, the size is unlimited." "Remove double quotes (\") from strings in list." (mapcar (lambda (item) (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) - (setq item (concat (match-string 1 item) + (setq item (concat (match-string 1 item) (match-string 2 item)))) item) elems)) @@ -1524,7 +1524,7 @@ is used by default." (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers (mapconcat 'identity gnus-list-identifiers " *\\|")))) - (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp + (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp " *\\)\\)+\\(Re: +\\)?\\)") subject) (concat (substring subject 0 (match-beginning 1)) (or (match-string 3 subject) @@ -2658,15 +2658,15 @@ It should typically alter the sending method in some way or other." (funcall message-encode-function) (while (and success (setq elem (pop alist))) - (when (or (not (funcall (cadr elem))) - (and (or (not (memq (car elem) - message-sent-message-via)) - (y-or-n-p - (format - "Already sent message via %s; resend? " - (car elem)))) - (setq success (funcall (caddr elem) arg)))) - (setq sent t)))) + (when (funcall (cadr elem)) + (when (and (or (not (memq (car elem) + message-sent-message-via)) + (y-or-n-p + (format + "Already sent message via %s; resend? " + (car elem)))) + (setq success (funcall (caddr elem) arg))) + (setq sent t))))) (unless (or sent (not success)) (error "No methods specified to send by")) (prog1 diff --git a/lisp/mml.el b/lisp/mml.el index 1d71f4b..f588060 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -704,25 +704,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." "application/octet-stream")) (string (completing-read (format "Content type (default %s): " default) - (mapcar - 'list - (mm-delete-duplicates - (nconc - (mapcar 'cdr mailcap-mime-extensions) - (apply - 'nconc - (mapcar - (lambda (l) - (delq nil - (mapcar - (lambda (m) - (let ((type (cdr (assq 'type (cdr m))))) - (if (equal (cadr (split-string type "/")) - "*") - nil - type))) - (cdr l)))) - mailcap-mime-data)))))))) + (mapcar 'list (mailcap-mime-types))))) (if (not (equal string "")) string default))) diff --git a/lisp/nndoc.el b/lisp/nndoc.el index e59b22c..3833395 100644 --- a/lisp/nndoc.el +++ b/lisp/nndoc.el @@ -701,7 +701,8 @@ PARENT is the message-ID of the parent summary line, or nil for none." subject content-type type subtype boundary-regexp) ;; Gracefully handle a missing body. (goto-char head-begin) - (if (search-forward "\n\n" body-end t) + (if (or (and (eq (char-after) ?\n) (or (forward-char 1) t)) + (search-forward "\n\n" body-end t)) (setq head-end (1- (point)) body-begin (point)) (setq head-end body-end diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 396f5a8..c0d3302 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -1124,7 +1124,7 @@ function is generally only called when Gnus is shutting down." ;; remove any 'From blabla' lines, some IMAP servers ;; reject the entire message otherwise. (when (looking-at "^From[^:]") - (kill-region (gnus-point-at-bol) (gnus-point-at-eol))) + (kill-region (point) (progn (forward-line) (point)))) ;; turn into rfc822 format (\r\n eol's) (while (search-forward "\n" nil t) (replace-match "\r\n"))) diff --git a/lisp/nntp.el b/lisp/nntp.el index 046c785..2a93db7 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -1068,7 +1068,7 @@ password contained in '~/.nntp-authinfo'." (if (memq (following-char) '(?4 ?5)) ;; wants credentials? (if (looking-at "480") - (nntp-handle-authinfo nntp-process-to-buffer) + (nntp-handle-authinfo process) ;; report error message. (nntp-snarf-error-message) (nntp-do-callback nil)) diff --git a/lisp/qp.el b/lisp/qp.el index 5979006..c55cb9e 100644 --- a/lisp/qp.el +++ b/lisp/qp.el @@ -92,49 +92,50 @@ If `mm-use-ultra-safe-encoding' is set, fold unconditionally and encode lines starting with \"From\"." (interactive "r") (save-excursion - (save-restriction - (narrow-to-region from to) - ;; (mm-encode-body) - ;; Encode all the non-ascii and control characters. - (goto-char (point-min)) - (while (and (skip-chars-forward - ;; Avoid using 8bit characters. = is \075. - ;; Equivalent to "^\000-\007\013\015-\037\200-\377=" - (or class "\010-\012\014\040-\074\076-\177")) - (not (eobp))) - (insert - (prog1 - (upcase (format "=%02x" (char-after))) - (delete-char 1)))) - ;; Encode white space at the end of lines. - (goto-char (point-min)) - (while (re-search-forward "[ \t]+$" nil t) - (goto-char (match-beginning 0)) - (while (not (eolp)) + (mm-with-unibyte-current-buffer + (save-restriction + (narrow-to-region from to) + ;; (mm-encode-body) + ;; Encode all the non-ascii and control characters. + (goto-char (point-min)) + (while (and (skip-chars-forward + ;; Avoid using 8bit characters. = is \075. + ;; Equivalent to "^\000-\007\013\015-\037\200-\377=" + (or class "\010-\012\014\040-\074\076-\177")) + (not (eobp))) (insert (prog1 (upcase (format "=%02x" (char-after))) - (delete-char 1))))) - (when (or fold mm-use-ultra-safe-encoding) - ;; Fold long lines. - (let ((tab-width 1)) ;; HTAB is one character. - (goto-char (point-min)) - (while (not (eobp)) - ;; In ultra-safe mode, encode "From " at the beginning of a - ;; line. - (when mm-use-ultra-safe-encoding - (beginning-of-line) - (when (looking-at "From ") - (replace-match "From=20" nil t))) - (end-of-line) - (while (> (current-column) 76) ;; tab-width must be 1. - (beginning-of-line) - (forward-char 75);; 75 chars plus an "=" - (search-backward "=" (- (point) 2) t) - (insert "=\n") - (end-of-line)) - (unless (eobp) - (forward-line)))))))) + (delete-char 1)))) + ;; Encode white space at the end of lines. + (goto-char (point-min)) + (while (re-search-forward "[ \t]+$" nil t) + (goto-char (match-beginning 0)) + (while (not (eolp)) + (insert + (prog1 + (upcase (format "=%02x" (char-after))) + (delete-char 1))))) + (when (or fold mm-use-ultra-safe-encoding) + ;; Fold long lines. + (let ((tab-width 1));; HTAB is one character. + (goto-char (point-min)) + (while (not (eobp)) + ;; In ultra-safe mode, encode "From " at the beginning of a + ;; line. + (when mm-use-ultra-safe-encoding + (beginning-of-line) + (when (looking-at "From ") + (replace-match "From=20" nil t))) + (end-of-line) + (while (> (current-column) 76);; tab-width must be 1. + (beginning-of-line) + (forward-char 75);; 75 chars plus an "=" + (search-backward "=" (- (point) 2) t) + (insert "=\n") + (end-of-line)) + (unless (eobp) + (forward-line))))))))) (defun quoted-printable-encode-string (string) "QP-encode STRING and return the results." diff --git a/lisp/starttls.el b/lisp/starttls.el new file mode 100644 index 0000000..8d5600e --- /dev/null +++ b/lisp/starttls.el @@ -0,0 +1,79 @@ +;;; starttls.el --- TLSv1 functions + +;; Copyright (C) 1999 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/11/20 +;; Keywords: TLS, SSL, OpenSSL + +;; This file is not part of any package. + +;; This program 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. + +;; This program 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 module defines some utility functions for TLSv1 functions. + +;; [RFC 2246] "The TLS Protocol Version 1.0" +;; by Christopher Allen and +;; Tim Dierks (1999/01) + +;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" +;; by Chris Newman (1999/06) + +;;; Code: + +(defgroup starttls nil + "Support for `Transport Layer Security' protocol." + :group 'ssl) + +(defcustom starttls-program "starttls" + "The program to run in a subprocess to open an TLSv1 connection." + :group 'starttls) + +(defcustom starttls-extra-args nil + "Extra arguments to `starttls-program'" + :group 'starttls) + +(defun starttls-negotiate (process) + (signal-process (process-id process) 'SIGALRM)) + +(defun starttls-open-stream (name buffer host service) + "Open a TLS connection for a service to a host. +Returns a subprocess-object to represent the connection. +Input and output work as for subprocesses; `delete-process' closes it. +Args are NAME BUFFER HOST SERVICE. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer (or `buffer-name') to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer +Third arg is name of the host to connect to, or its IP address. +Fourth arg SERVICE is name of the service desired, or an integer +specifying a port number to connect to." + + (let* ((process-connection-type nil) + (process (apply #'start-process + name buffer starttls-program + host (format "%s" service) + starttls-extra-args))) + (process-kill-without-query process) + process)) + +(provide 'starttls) + +;;; starttls.el ends here diff --git a/lisp/webmail.el b/lisp/webmail.el index 38638ef..00506b8 100644 --- a/lisp/webmail.el +++ b/lisp/webmail.el @@ -129,8 +129,8 @@ (login-url content ("http://ureg.netscape.com/iiop/UReg2/login/loginform") - "%s&U2_USERNAME=%s&U2_PASSWORD=%s" - webmail-aux user password) + "U2_USERNAME=%s&U2_PASSWORD=%s%s" + user password webmail-aux) (login-snarf . webmail-netaddress-login) (list-url "http://webmail.netscape.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True" @@ -154,9 +154,7 @@ (list-url "http://www.deja.com/rg_gotomail.xp") (list-snarf . webmail-my-deja-list) (article-snarf . webmail-my-deja-article) - (trash-url - "%s/gmm_multiplex.femail?%%2Fgmm_domovemesg_top.femail=Move+to%%3A&folder_top=%s%%3Azzz%%3A%%7E6trash%%3AF%%3A0&docid=%s" - webmail-aux user id)))) + (trash-url webmail-aux id)))) (defvar webmail-variables '(address article-snarf article-url list-snarf list-url @@ -215,9 +213,9 @@ (defun webmail-error (str) (if webmail-error-function (funcall webmail-error-function str)) - (message "%s HTML has changed; please get a new version of webmail (%s)" + (message "%s HTML has changed or your w3 package is too old.(%s)" webmail-type str) - (error "%s HTML has changed; please get a new version of webmail (%s)" + (error "%s HTML has changed or your w3 package is too old.(%s)" webmail-type str)) (defun webmail-setdefault (type) @@ -412,62 +410,71 @@ (webmail-error "login@2")))) (defun webmail-hotmail-list () - (let (site url newp) - (goto-char (point-min)) - (if (re-search-forward "[0-9]+ new" nil t) - (message "Found %s" (match-string 0)) - (webmail-error "maybe your w3 version is too old")) - (goto-char (point-min)) - (if (re-search-forward + (goto-char (point-min)) + (skip-chars-forward " \t\n\r") + (let (site url newp (total "0")) + (if (eobp) + (setq total "0")) + (if (re-search-forward "\\([0-9]+\\) *(\\([0-9]+\\) new)" nil t) + (message "Found %s (%s new)" (setq total (match-string 1)) + (match-string 2)) + (if (re-search-forward "\\([0-9]+\\) new" nil t) + (message "Found %s new" (setq total (match-string 1))) + (webmail-error "list@0"))) + (unless (equal total "0") + (goto-char (point-min)) + (if (re-search-forward "https?://\\([^/]+hotmail\\.msn\\.com\\)/cgi-bin/" nil t) - (setq site (match-string 1)) - (webmail-error "list@1")) - (goto-char (point-min)) - (if (re-search-forward "disk=\\([^&]+\\)&" nil t) - (setq webmail-aux - (concat "http://" site "/cgi-bin/HoTMaiL?disk=" - (match-string 1))) - (webmail-error "list@2")) - (goto-char (point-max)) - (while (re-search-backward - "newmail\\.gif\\|href=\"\\(/cgi-bin/getmsg\\?[^\"]+\\)\"" - nil t) - (if (setq url (match-string 1)) - (progn - (if (or newp (not webmail-newmail-only)) - (let (id) - (if (string-match "msg=\\([^&]+\\)" url) - (setq id (match-string 1 url))) - (push (cons id (concat "http://" site url "&raw=0")) - webmail-articles))) - (setq newp nil)) - (setq newp t))))) + (setq site (match-string 1)) + (webmail-error "list@1")) + (goto-char (point-min)) + (if (re-search-forward "disk=\\([^&]+\\)&" nil t) + (setq webmail-aux + (concat "http://" site "/cgi-bin/HoTMaiL?disk=" + (match-string 1))) + (webmail-error "list@2")) + (goto-char (point-max)) + (while (re-search-backward + "newmail\\.gif\\|href=\"\\(/cgi-bin/getmsg\\?[^\"]+\\)\"" + nil t) + (if (setq url (match-string 1)) + (progn + (if (or newp (not webmail-newmail-only)) + (let (id) + (if (string-match "msg=\\([^&]+\\)" url) + (setq id (match-string 1 url))) + (push (cons id (concat "http://" site url "&raw=0")) + webmail-articles))) + (setq newp nil)) + (setq newp t)))))) ;; Thank victor@idaccr.org (Victor S. Miller) for raw=0 (defun webmail-hotmail-article (file id) (goto-char (point-min)) - (if (not (search-forward "
" nil t))
-      (webmail-error "article@3"))
-  (skip-chars-forward "\n\r\t ")
-  (delete-region (point-min) (point))
-  (if (not (search-forward "
" nil t)) - (webmail-error "article@3.1")) - (delete-region (match-beginning 0) (point-max)) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) - (goto-char (point-min)) - (while (re-search-forward "\r\n?" nil t) - (replace-match "\n")) - (goto-char (point-min)) - (insert "\n\n") - (if (not (looking-at "\n*From ")) - (insert "From nobody " (current-time-string) "\n") - (forward-line)) - (insert "X-Gnus-Webmail: " (symbol-value 'user) - "@" (symbol-name webmail-type) "\n") - (mm-append-to-file (point-min) (point-max) file)) + (skip-chars-forward " \t\n\r") + (unless (eobp) + (if (not (search-forward "
" nil t))
+	(webmail-error "article@3"))
+    (skip-chars-forward "\n\r\t ")
+    (delete-region (point-min) (point))
+    (if (not (search-forward "
" nil t)) + (webmail-error "article@3.1")) + (delete-region (match-beginning 0) (point-max)) + (nnweb-remove-markup) + (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) + (nnweb-decode-entities)) + (goto-char (point-min)) + (while (re-search-forward "\r\n?" nil t) + (replace-match "\n")) + (goto-char (point-min)) + (insert "\n\n") + (if (not (looking-at "\n*From ")) + (insert "From nobody " (current-time-string) "\n") + (forward-line)) + (insert "X-Gnus-Webmail: " (symbol-value 'user) + "@" (symbol-name webmail-type) "\n") + (mm-append-to-file (point-min) (point-max) file))) (defun webmail-hotmail-article-old (file id) (let (p attachment count mime hotmail-direct) @@ -716,9 +723,12 @@ (defun webmail-netscape-open () (goto-char (point-min)) - (if (re-search-forward "login/hint\\?\\([^\"]+\\)\"" nil t) - (setq webmail-aux (match-string 1)) - (webmail-error "open@1"))) + (setq webmail-aux "") + (while (re-search-forward + "TYPE=hidden *NAME=\\([^ ]+\\) *VALUE=\"\\([^\"]+\\)" + nil t) + (setq webmail-aux (concat webmail-aux "&" (match-string 1) "=" + (match-string 2))))) (defun webmail-netaddress-open () (goto-char (point-min)) @@ -1041,44 +1051,142 @@ (webmail-error "open@1"))) (defun webmail-my-deja-list () - (let (item id newp) + (let (item id newp base) + (goto-char (point-min)) + (when (re-search-forward "href=\"\\(\\([^\"]*\\)/mailnf\\.[^\"]*\\)\"" + nil t) + (let ((url (match-string 1))) + (setq base (match-string 2)) + (erase-buffer) + (nnweb-insert url))) (goto-char (point-min)) (when (re-search-forward - "(\\([0-9]+\\) message(s), \\([0-9]+\\) new, \\([0-9]+\\) k )" + "(\\([0-9]+\\) Message.?-[^>]*\\([0-9]+\\) New" nil t) - (message "Found %s mail(s), %s unread, total size %s K" - (match-string 1) (match-string 2) (match-string 3))) + (message "Found %s mail(s), %s unread" + (match-string 1) (match-string 2))) (goto-char (point-min)) (while (re-search-forward - "•   \\|\\(http:[^\"]+\\)/display_seemesg\\.femail\\?docid=\\([^&\"]+\\)" + "newmail\\.gif\\|href=\"[^\"]*\\(mailnf\\.[^\"]+act=view[^\"]+mid=\\([^\"&]+\\)[^\"]+\\)\"" nil t) (if (setq id (match-string 2)) - (when (or newp (not webmail-newmail-only)) - (push - (cons id (format "%s/gmm_multiplex.femail?docid=%s&femail_page_name=display_page&bool_next_on_disp_pg=true&bool_prev_on_disp_pg=false&display_all_headers=false&%%2Fgmm_save.femail=Download&femail_page_name=display_page&bool_next_on_disp_pg=true&bool_prev_on_disp_pg=false&display_all_headers=false" - (match-string 1) id)) - webmail-articles) - (setq webmail-aux (match-string 1)) + (when (and (or newp (not webmail-newmail-only)) + (not (assoc id webmail-articles))) + (push (cons id (setq webmail-aux + (concat base "/" (match-string 1)))) + webmail-articles) (setq newp nil)) (setq newp t))) (setq webmail-articles (nreverse webmail-articles)))) +(defun webmail-my-deja-article-part (base) + (let (p) + (cond + ((looking-at "[\t\040\r\n]*