From: ShengHuo ZHU Date: Thu, 7 Feb 2002 15:28:34 +0000 (+0000) Subject: 2002-02-03 ShengHuo ZHU X-Git-Tag: emacs-21.2~106 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=71b51fc098090133c0878b54dc7ccf6b627b07be;p=emacs.git 2002-02-03 ShengHuo ZHU * message.el (message-forward-rmail-make-body): Directly use rmail-msg-restore-non-pruned-header to avoid calling vertical-motion. 2002-01-03 ShengHuo ZHU * mm-util.el (mm-charset-to-coding-system): Don't setq charset. * mm-util.el (mm-use-find-coding-systems-region): New variable. (mm-find-mime-charset-region): Use it. * nntp.el (nntp-send-buffer): Use mm-with-unibyte-current-buffer. * nnspool.el (nnspool-request-post): Ditto. 2002-01-01 ShengHuo ZHU * message.el, gnus-art.el, gnus.el, gnus-cite.el: Adapt face definitions to use :weight and :slant. 2001-12-12 Pavel Jan,Am(Bk * gnus-mlspl.el (gnus-group-split-fancy): Doc fix (add reference to variable, follow doc-string conventions). 2001-12-05 ShengHuo ZHU * mm-view.el (mm-inline-text): w3-coding-system-for-mime-charset may not defined. From: Raja R Harinath . * mm-view.el (mm-inline-message): Insert a newline unless bolp. * gnus-sum.el (gnus-summary-save-article): Nix gnus-display-mime-function and gnus-article-prepare-hook. 2001-12-01 ShengHuo ZHU * message.el (message-mail): Add send-actions. 2001-11-28 ShengHuo ZHU * gnus-sum.el (gnus-summary-limit-to-author): Fix the number of arguments. 2001-11-25 Stefan Monnier * imap.el (imap-interactive-login, imap-open, imap-authenticate): Use make-local-variable rather than make-variable-buffer-local. 2001-11-25 ShengHuo ZHU * message.el (message-forward-rmail-make-body): Use save-window-excursion. (message-encode-message-body): Use noerror when search. (message-setup-1): Convert compose-mail send-actions to message-send-actions. * message.el (message-forward-subject-author-subject): Don't use message-news-p, which widens the buffer. (message-forward-make-body): New function. (message-forward): Use it. (message-insinuate-rmail): New function. (message-forward-rmail-make-body): New function. * gnus-util.el (gnus-directory-sep-char-regexp): New variable. * gnus-score.el (gnus-score-find-bnews): Use it. * mm-util.el (mm-iso-8859-x-to-15-region): Use insert-before-markers. From Jesper Harder * mm-util.el (mm-coding-system-priorities): Add backslash in the doc. * mm-util.el (mm-coding-system-priorities): New variable. (mm-sort-coding-systems-predicate): New function. (mm-find-mime-charset-region): Resort coding systems if needed. Suggested by Katsumi Yamaoka . * mm-util.el (mm-iso-8859-15-compatible): Fix doc. (mm-hack-charsets): Fix doc. * mm-util.el (mm-iso-8859-15-compatible): Add inconvertible chars. (mm-iso-8859-x-to-15-table): Ditto. (mm-iso-8859-x-to-15-region): Ditto. (mm-find-mime-charset-region): Ditto. * gnus-sum.el (gnus-summary-limit-to-subject): An exclusion version. (gnus-summary-limit-to-author): Ditto. (gnus-summary-limit-to-extra): Ditto. (gnus-summary-find-matching): Support not-matching argument. * message.el (message-wash-subject): Use `insert' rather than `insert-string', which is deprecated. From Kai Gro,A_(Bjohann 2001-11-14 Sam Steingold * gnus-score.el: Fixed some doc strings to properly quote symbols. 2001-11-10 Pavel Jan,Al(Bk * gnus.el (gnus-local-domain): Reformat the doc-string to refer to function `system-name' instead of both function and variable. 2001-11-07 ShengHuo ZHU * mml.el (mml-preview): Bind mail-header-separator. 2001-11-05 ShengHuo ZHU * mml.el (mml-generate-mime-1): Use mm-with-unibyte-current-buffer. Suggested by Dave Love . 2001-11-01 ShengHuo ZHU * mm-util.el (mm-charset-synonym-alist): Revert (some). 2001-10-30 ShengHuo ZHU * mm-util.el (mm-iso-8859-x-to-15-region): New function. (mm-hack-charsets): New variable. (mm-iso-8859-15-compatible): New variable. (mm-iso-8859-x-to-15-table): New variable. (mm-find-mime-charset-region): Add parameter hack-charsets. * mm-util.el (mm-charset-to-coding-system): Return nil, if charset is nil. * nnultimate.el, nnweb.el, nnslashdot.el: Update, because the web pages are changed. * mm-util.el (mm-mime-mule-charset-alist): Move down and call mm-coding-system-p. Don't correct it only in XEmacs. (mm-charset-to-coding-system): Use mm-coding-system-p and mm-get-coding-system-list. (mm-emacs-mule, mm-mule4-p): New. (mm-enable-multibyte, mm-disable-multibyte, mm-enable-multibyte-mule4, mm-disable-multibyte-mule4, mm-with-unibyte-current-buffer, mm-with-unibyte-current-buffer-mule4): Use them. (mm-find-mime-charset-region): Treat iso-2022-jp. From Dave Love : * mm-util.el (mm-mime-mule-charset-alist): Make it correct by construction. (mm-charset-synonym-alist): Remove windows-125[02]. Make other entries conditional on not having a coding system defined for them. (mm-mule-charset-to-mime-charset): Use find-coding-systems-for-charsets if defined. (mm-charset-to-coding-system): Don't use mm-get-coding-system-list. Look in mm-charset-synonym-alist later. Add last resort search of coding systems. (mm-enable-multibyte-mule4, mm-disable-multibyte-mule4) (mm-with-unibyte-current-buffer-mule4): Just treat Mule 5 like Mule 4. (mm-find-mime-charset-region): Re-write. (mm-with-unibyte-current-buffer): Restore buffer as well as multibyteness. 2001-10-27 Stefan Monnier * gnus-msg.el (gnus-setup-message): Setup reaper for MML buffers. --- diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 5b3776c0329..f88703239bb 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,9 @@ +2002-02-03 ShengHuo ZHU + + * message.el (message-forward-rmail-make-body): Directly use + rmail-msg-restore-non-pruned-header to avoid calling + vertical-motion. + 2002-01-03 Lars Magne Ingebrigtsen * gnus-start.el (gnus-read-init-file): Cleaned up. @@ -12,10 +18,165 @@ * gnus-start.el (gnus-read-init-file): Don't force coding system for ~/.gnus. From Dave Love . +2002-01-03 ShengHuo ZHU + + * mm-util.el (mm-charset-to-coding-system): Don't setq charset. + * mm-util.el (mm-use-find-coding-systems-region): New variable. + (mm-find-mime-charset-region): Use it. + * nntp.el (nntp-send-buffer): Use mm-with-unibyte-current-buffer. + * nnspool.el (nnspool-request-post): Ditto. + +2002-01-01 ShengHuo ZHU + + * message.el, gnus-art.el, gnus.el, gnus-cite.el: + Adapt face definitions to use :weight and :slant. + +2001-12-12 Pavel Jan,Am(Bk + + * gnus-mlspl.el (gnus-group-split-fancy): Doc fix (add reference + to variable, follow doc-string conventions). + +2001-12-05 ShengHuo ZHU + + * mm-view.el (mm-inline-text): w3-coding-system-for-mime-charset + may not defined. From: Raja R Harinath . + + * mm-view.el (mm-inline-message): Insert a newline unless bolp. + + * gnus-sum.el (gnus-summary-save-article): Nix + gnus-display-mime-function and gnus-article-prepare-hook. + +2001-12-01 ShengHuo ZHU + + * message.el (message-mail): Add send-actions. + +2001-11-28 ShengHuo ZHU + + * gnus-sum.el (gnus-summary-limit-to-author): Fix the number of + arguments. + +2001-11-25 Stefan Monnier + + * imap.el (imap-interactive-login, imap-open, imap-authenticate): + Use make-local-variable rather than make-variable-buffer-local. + +2001-11-25 ShengHuo ZHU + + * message.el (message-forward-rmail-make-body): Use + save-window-excursion. + (message-encode-message-body): Use noerror when search. + (message-setup-1): Convert compose-mail send-actions to + message-send-actions. + + * message.el (message-forward-subject-author-subject): Don't use + message-news-p, which widens the buffer. + (message-forward-make-body): New function. + (message-forward): Use it. + (message-insinuate-rmail): New function. + (message-forward-rmail-make-body): New function. + + * gnus-util.el (gnus-directory-sep-char-regexp): New variable. + * gnus-score.el (gnus-score-find-bnews): Use it. + * mm-util.el (mm-iso-8859-x-to-15-region): Use + insert-before-markers. + From Jesper Harder + * mm-util.el (mm-coding-system-priorities): Add backslash in the doc. + * mm-util.el (mm-coding-system-priorities): New variable. + (mm-sort-coding-systems-predicate): New function. + (mm-find-mime-charset-region): Resort coding systems if needed. + Suggested by Katsumi Yamaoka . + + * mm-util.el (mm-iso-8859-15-compatible): Fix doc. + (mm-hack-charsets): Fix doc. + + * mm-util.el (mm-iso-8859-15-compatible): Add inconvertible chars. + (mm-iso-8859-x-to-15-table): Ditto. + (mm-iso-8859-x-to-15-region): Ditto. + (mm-find-mime-charset-region): Ditto. + + * gnus-sum.el (gnus-summary-limit-to-subject): An exclusion version. + (gnus-summary-limit-to-author): Ditto. + (gnus-summary-limit-to-extra): Ditto. + (gnus-summary-find-matching): Support not-matching argument. + + * message.el (message-wash-subject): Use `insert' rather than + `insert-string', which is deprecated. + From Kai Gro,A_(Bjohann + +2001-11-14 Sam Steingold + + * gnus-score.el: Fixed some doc strings to properly quote symbols. + +2001-11-10 Pavel Jan,Al(Bk + + * gnus.el (gnus-local-domain): Reformat the doc-string to refer to + function `system-name' instead of both function and variable. + +2001-11-07 ShengHuo ZHU + + * mml.el (mml-preview): Bind mail-header-separator. + +2001-11-05 ShengHuo ZHU + + * mml.el (mml-generate-mime-1): Use mm-with-unibyte-current-buffer. + Suggested by Dave Love . + +2001-11-01 ShengHuo ZHU + + * mm-util.el (mm-charset-synonym-alist): Revert (some). + +2001-10-30 ShengHuo ZHU + + * mm-util.el (mm-iso-8859-x-to-15-region): New function. + (mm-hack-charsets): New variable. + (mm-iso-8859-15-compatible): New variable. + (mm-iso-8859-x-to-15-table): New variable. + (mm-find-mime-charset-region): Add parameter hack-charsets. + + * mm-util.el (mm-charset-to-coding-system): Return nil, if charset + is nil. + + * nnultimate.el, nnweb.el, nnslashdot.el: Update, because the web + pages are changed. + + * mm-util.el (mm-mime-mule-charset-alist): Move down and call + mm-coding-system-p. Don't correct it only in XEmacs. + (mm-charset-to-coding-system): Use mm-coding-system-p and + mm-get-coding-system-list. + (mm-emacs-mule, mm-mule4-p): New. + (mm-enable-multibyte, mm-disable-multibyte, + mm-enable-multibyte-mule4, mm-disable-multibyte-mule4, + mm-with-unibyte-current-buffer, + mm-with-unibyte-current-buffer-mule4): Use them. + (mm-find-mime-charset-region): Treat iso-2022-jp. + + From Dave Love : + + * mm-util.el (mm-mime-mule-charset-alist): Make it correct by + construction. + (mm-charset-synonym-alist): Remove windows-125[02]. Make other + entries conditional on not having a coding system defined for + them. + (mm-mule-charset-to-mime-charset): Use + find-coding-systems-for-charsets if defined. + (mm-charset-to-coding-system): Don't use + mm-get-coding-system-list. Look in mm-charset-synonym-alist + later. Add last resort search of coding systems. + (mm-enable-multibyte-mule4, mm-disable-multibyte-mule4) + (mm-with-unibyte-current-buffer-mule4): Just treat Mule 5 like + Mule 4. + (mm-find-mime-charset-region): Re-write. + (mm-with-unibyte-current-buffer): Restore buffer as well as + multibyteness. + 2001-10-30 Simon Josefsson * nnimap.el (nnimap-date-days-ago): Defeat locale. +2001-10-27 Stefan Monnier + + * gnus-msg.el (gnus-setup-message): Setup reaper for MML buffers. + 2001-09-27 Gerd Moellmann * gnus-ems.el (gnus-article-display-xface): Skip over previously @@ -23,8 +184,8 @@ 2001-09-19 Sam Steingold - * gnus-win.el (gnus-buffer-configuration): Respect - `gnus-bug-create-help-buffer'. + * gnus-win.el (gnus-buffer-configuration): + Respect `gnus-bug-create-help-buffer'. 2001-09-18 Pavel Jan,Am(Bk @@ -34,8 +195,8 @@ 2001-09-18 Gerd Moellmann - * gnus-sum.el (gnus-select-newsgroup): Make - `gnus-current-select-method' buffer-local. + * gnus-sum.el (gnus-select-newsgroup): + Make `gnus-current-select-method' buffer-local. From TSUCHIYA Masatoshi . * gnus-art.el (gnus-request-article-this-buffer): Refer to @@ -2840,7 +3001,7 @@ * gnus-draft.el (gnus-draft-send): Move gnus-draft-setup inside of let. -2000-04-26 Pavel Janik ml. +2000-04-26 Pavel Jan,Al(Bk * gnus-draft.el (gnus-draft-setup): Fix comments. @@ -5663,9 +5824,9 @@ * pop3.el: New version. -1999-07-05 Simon Josefsson +1999-07-05 Simon Josefsson - * gnus-srvr.el (gnus-browse-foreign-server): Use read. + * gnus-srvr.el (gnus-browse-foreign-server): Use read. 1999-07-07 Lars Magne Ingebrigtsen diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 225ef3572b4..e86c0d38f56 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -1,6 +1,6 @@ ;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -1963,7 +1963,7 @@ Put point at the beginning of the signature separator." (defun gnus-article-check-hidden-text (type arg) "Return nil if hiding is necessary. -Arg can be nil or a number. Nil and positive means hide, negative +Arg can be nil or a number. nil and positive means hide, negative means show, 0 means toggle." (save-excursion (save-restriction diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 43358ad53f9..b1473692e4a 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -3462,7 +3462,7 @@ group." (defun gnus-group-find-new-groups (&optional arg) "Search for new groups and add them. -Each new group will be treated with `gnus-subscribe-newsgroup-method.' +Each new group will be treated with `gnus-subscribe-newsgroup-method'. With 1 C-u, use the `ask-server' method to query the server for new groups. With 2 C-u's, use most complete method possible to query the server diff --git a/lisp/gnus/gnus-mlspl.el b/lisp/gnus/gnus-mlspl.el index 70619b5044e..40f53a83cfa 100644 --- a/lisp/gnus/gnus-mlspl.el +++ b/lisp/gnus/gnus-mlspl.el @@ -98,8 +98,8 @@ gnus-group-split is a valid value for nnmail-split-methods." ;;;###autoload (defun gnus-group-split-fancy (&optional groups no-crosspost catch-all) - "Uses information from group parameters in order to split mail. It -can be embedded into nnmail-split-fancy lists with the SPLIT + "Uses information from group parameters in order to split mail. +It can be embedded into `nnmail-split-fancy' lists with the SPLIT \(: gnus-group-split-fancy GROUPS NO-CROSSPOST CATCH-ALL\) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index ef5875b36c2..6ff82265910 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -233,6 +233,7 @@ Thank you for your help in stamping out bugs. (let ((mbl1 mml-buffer-list)) (setq mml-buffer-list mbl) ;; Global value (set (make-local-variable 'mml-buffer-list) mbl1);; Local value + (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t) (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)) (mml-destroy-buffers) (setq mml-buffer-list mbl))) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 0cfc079a214..1de3b48e5f5 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -59,10 +59,10 @@ Each element of this alist should be of the form If the name of a group is matched by REGEXP, the corresponding scorefiles will be used for that group. The first match found is used, subsequent matching entries are ignored (to -use multiple matches, see gnus-score-file-multiple-match-alist). +use multiple matches, see `gnus-score-file-multiple-match-alist'). These score files are loaded in addition to any files returned by -gnus-score-find-score-files-function (which see)." +`gnus-score-find-score-files-function'." :group 'gnus-score-files :type '(repeat (cons regexp (repeat file)))) @@ -75,10 +75,10 @@ If the name of a group is matched by REGEXP, the corresponding scorefiles will be used for that group. If multiple REGEXPs match a group, the score files corresponding to each match will be used (for only one match to be used, see -gnus-score-file-single-match-alist). +`gnus-score-file-single-match-alist'). These score files are loaded in addition to any files returned by -gnus-score-find-score-files-function (which see)." +`gnus-score-find-score-files-function'." :group 'gnus-score-files :type '(repeat (cons regexp (repeat file)))) @@ -101,9 +101,9 @@ files do not actually have to exist. Predefined values are: -gnus-score-find-single: Only apply the group's own score file. -gnus-score-find-hierarchical: Also apply score files from parent groups. -gnus-score-find-bnews: Apply score files whose names matches. +`gnus-score-find-single': Only apply the group's own score file. +`gnus-score-find-hierarchical': Also apply score files from parent groups. +`gnus-score-find-bnews': Apply score files whose names matches. See the documentation to these functions for more information. @@ -1497,7 +1497,7 @@ THREAD is expected to contain a list of the form `(PARENT [CHILD1 CHILD2 ...])' where PARENT is a header array and each CHILD is a list of the same form as THREAD. The empty list `nil' is valid. For each article in the tree, the score of the corresponding entry in -GNUS-NEWSGROUP-SCORED is adjusted by SCORE-ADJUST." +`gnus-newsgroup-scored' is adjusted by SCORE-ADJUST." (while thread (let ((head (car thread))) (if (listp head) @@ -1515,7 +1515,7 @@ GNUS-NEWSGROUP-SCORED is adjusted by SCORE-ADJUST." A root is an article with no references. An orphan is an article which has references, but is not connected via its references to a root article. This function finds all the orphans, and adjusts their -score in GNUS-NEWSGROUP-SCORED by SCORE." +score in `gnus-newsgroup-scored' by SCORE." (let ((threads (gnus-make-threads))) ;; gnus-make-threads produces a list, where each entry is a "thread" ;; as described in the gnus-score-lower-thread docs. This function @@ -2560,8 +2560,10 @@ GROUP using BNews sys file syntax." ;; too much. (delete-char (min (1- (point-max)) klen)) (goto-char (point-max)) - (search-backward (string directory-sep-char)) - (delete-region (1+ (point)) (point-min))) + (if (re-search-backward gnus-directory-sep-char-regexp nil t) + (delete-region (1+ (point)) (point-min)) + (gnus-message 1 "Can't find directory separator in %s" + (car sfiles)))) ;; If short file names were used, we have to translate slashes. (goto-char (point-min)) (let ((regexp (concat @@ -2595,10 +2597,10 @@ GROUP using BNews sys file syntax." ;; we add this score file to the list of score files ;; applicable to this group. (when (or (and not-match - (ignore-errors + (ignore-errors (not (string-match regexp group-trans)))) - (and (not not-match) - (ignore-errors (string-match regexp group-trans)))) + (and (not not-match) + (ignore-errors (string-match regexp group-trans)))) (push (car sfiles) ofiles))) (setq sfiles (cdr sfiles))) (kill-buffer (current-buffer)) @@ -2678,7 +2680,7 @@ Destroys the current buffer." (defun gnus-score-find-alist (group) "Return list of score files for GROUP. -The list is determined from the variable gnus-score-file-alist." +The list is determined from the variable `gnus-score-file-alist'." (let ((alist gnus-score-file-multiple-match-alist) score-files) ;; if this group has been seen before, return the cached entry diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 36fff90ef88..bc172f4b509 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -5972,7 +5972,7 @@ be displayed." (unless (eq major-mode 'gnus-summary-mode) (set-buffer gnus-summary-buffer)) (let ((article (or article (gnus-summary-article-number))) - (all-headers (not (not all-headers))) ;Must be T or NIL. + (all-headers (not (not all-headers))) ;Must be t or nil. gnus-summary-display-article-function) (and (not pseudo) (gnus-summary-article-pseudo-p article) @@ -6393,24 +6393,35 @@ If given a prefix, remove all limits." (gnus-summary-limit nil 'pop) (gnus-summary-position-point))) -(defun gnus-summary-limit-to-subject (subject &optional header) - "Limit the summary buffer to articles that have subjects that match a regexp." - (interactive "sLimit to subject (regexp): ") +(defun gnus-summary-limit-to-subject (subject &optional header not-matching) + "Limit the summary buffer to articles that have subjects that match a regexp. +If NOT-MATCHING, excluding articles that have subjects that match a regexp." + (interactive + (list (read-string (if current-prefix-arg + "Exclude subject (regexp): " + "Limit to subject (regexp): ")) + nil current-prefix-arg)) (unless header (setq header "subject")) (when (not (equal "" subject)) (prog1 (let ((articles (gnus-summary-find-matching - (or header "subject") subject 'all))) + (or header "subject") subject 'all nil nil + not-matching))) (unless articles (error "Found no matches for \"%s\"" subject)) (gnus-summary-limit articles)) (gnus-summary-position-point)))) -(defun gnus-summary-limit-to-author (from) - "Limit the summary buffer to articles that have authors that match a regexp." - (interactive "sLimit to author (regexp): ") - (gnus-summary-limit-to-subject from "from")) +(defun gnus-summary-limit-to-author (from &optional not-matching) + "Limit the summary buffer to articles that have authors that match a regexp. +If NOT-MATCHING, excluding articles that have authors that match a regexp." + (interactive + (list (read-string (if current-prefix-arg + "Exclude author (regexp): " + "Limit to author (regexp): ")) + current-prefix-arg)) + (gnus-summary-limit-to-subject from "from" not-matching)) (defun gnus-summary-limit-to-age (age &optional younger-p) "Limit the summary buffer to articles that are older than (or equal) AGE days. @@ -6450,25 +6461,31 @@ articles that are younger than AGE days." (gnus-summary-limit (nreverse articles))) (gnus-summary-position-point))) -(defun gnus-summary-limit-to-extra (header regexp) +(defun gnus-summary-limit-to-extra (header regexp &optional not-matching) "Limit the summary buffer to articles that match an 'extra' header." (interactive (let ((header (intern (gnus-completing-read (symbol-name (car gnus-extra-headers)) - "Limit extra header:" + (if current-prefix-arg + "Exclude extra header:" + "Limit extra header:") (mapcar (lambda (x) (cons (symbol-name x) x)) gnus-extra-headers) nil t)))) (list header - (read-string (format "Limit to header %s (regexp): " header))))) + (read-string (format "%s header %s (regexp): " + (if current-prefix-arg "Exclude" "Limit to") + header)) + current-prefix-arg))) (when (not (equal "" regexp)) (prog1 (let ((articles (gnus-summary-find-matching - (cons 'extra header) regexp 'all))) + (cons 'extra header) regexp 'all nil nil + not-matching))) (unless articles (error "Found no matches for \"%s\"" regexp)) (gnus-summary-limit articles)) @@ -7215,17 +7232,15 @@ Optional argument BACKWARD means do search for backward. t))) (defun gnus-summary-find-matching (header regexp &optional backward unread - not-case-fold) + not-case-fold not-matching) "Return a list of all articles that match REGEXP on HEADER. The search stars on the current article and goes forwards unless BACKWARD is non-nil. If BACKWARD is `all', do all articles. If UNREAD is non-nil, only unread articles will be taken into consideration. If NOT-CASE-FOLD, case won't be folded -in the comparisons." - (let ((data (if (eq backward 'all) gnus-newsgroup-data - (gnus-data-find-list - (gnus-summary-article-number) (gnus-data-list backward)))) - (case-fold-search (not not-case-fold)) +in the comparisons. If NOT-MATCHING, return a list of all articles that +not match REGEXP on HEADER." + (let ((case-fold-search (not not-case-fold)) articles d func) (if (consp header) (if (eq (car header) 'extra) @@ -7237,14 +7252,21 @@ in the comparisons." (unless (fboundp (intern (concat "mail-header-" header))) (error "%s is not a valid header" header)) (setq func `(lambda (h) (,(intern (concat "mail-header-" header)) h)))) - (while data - (setq d (car data)) - (and (or (not unread) ; We want all articles... - (gnus-data-unread-p d)) ; Or just unreads. - (vectorp (gnus-data-header d)) ; It's not a pseudo. - (string-match regexp (funcall func (gnus-data-header d))) ; Match. - (push (gnus-data-number d) articles)) ; Success! - (setq data (cdr data))) + (dolist (d (if (eq backward 'all) + gnus-newsgroup-data + (gnus-data-find-list + (gnus-summary-article-number) + (gnus-data-list backward)))) + (when (and (or (not unread) ; We want all articles... + (gnus-data-unread-p d)) ; Or just unreads. + (vectorp (gnus-data-header d)) ; It's not a pseudo. + (if not-matching + (not (string-match + regexp + (funcall func (gnus-data-header d)))) + (string-match regexp + (funcall func (gnus-data-header d))))) + (push (gnus-data-number d) articles))) ; Success! (nreverse articles))) (defun gnus-summary-execute-command (header regexp command &optional backward) @@ -9126,7 +9148,9 @@ The variable `gnus-default-article-saver' specifies the saver function." (gnus-message 1 "Article %d is unsaveable" article)) ;; This is a real article. (save-window-excursion - (gnus-summary-select-article t nil nil article)) + (let ((gnus-display-mime-function nil) + (gnus-article-prepare-hook nil)) + (gnus-summary-select-article t nil nil article))) (save-excursion (set-buffer save-buffer) (erase-buffer) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 7417543278c..329d81a2a33 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1003,6 +1003,11 @@ Entries without port tokens default to DEFAULTPORT." (remove-text-properties start end properties object)) t)) +(defvar gnus-directory-sep-char-regexp "/" + "The regexp of directory separator character. +If you find some problem with the directory separator character, try +\"[/\\\\\]\" for some systems.") + (provide 'gnus-util) ;;; gnus-util.el ends here diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index d0729dcefbd..98f17f34be9 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1,6 +1,6 @@ ;;; gnus.el --- a newsreader for GNU Emacs -;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996, -;; 1997, 1998, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997, +;; 1998, 2000, 2001, 2002 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -1024,7 +1024,7 @@ Should be set in paths.el, and shouldn't be touched by the user.") (defcustom gnus-local-domain nil "Local domain name without a host name. The DOMAINNAME environment variable is used instead if it is defined. -If the `system-name' function returns the full Internet name, there is +If the function `system-name' returns the full Internet name, there is no need to set this variable." :group 'gnus-message :type '(choice (const :tag "default" nil) diff --git a/lisp/gnus/imap.el b/lisp/gnus/imap.el index c2808a72430..d46a92a0b28 100644 --- a/lisp/gnus/imap.el +++ b/lisp/gnus/imap.el @@ -719,8 +719,8 @@ 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) + (make-local-variable 'imap-username) + (make-local-variable 'imap-password) (let (user passwd ret) ;; (condition-case () (while (or (not user) (not passwd)) @@ -887,7 +887,7 @@ necessery. If nil, the buffer name is generated." (with-current-buffer (get-buffer-create buffer) (if (imap-opened buffer) (imap-close buffer)) - (mapcar 'make-variable-buffer-local imap-local-variables) + (mapcar 'make-local-variable imap-local-variables) (imap-disable-multibyte) (buffer-disable-undo) (setq imap-server (or server imap-server)) @@ -957,8 +957,8 @@ password is remembered in the buffer." (or (eq imap-state 'auth) (eq imap-state 'select) (eq imap-state 'examine)) - (make-variable-buffer-local 'imap-username) - (make-variable-buffer-local 'imap-password) + (make-local-variable 'imap-username) + (make-local-variable '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) @@ -1751,21 +1751,21 @@ Return nil if no complete line has arrived." ;; ;; addr-adl = nstring ;; ; Holds route from [RFC-822] route-addr if -;; ; non-NIL +;; ; non-nil ;; ;; addr-host = nstring -;; ; NIL indicates [RFC-822] group syntax. +;; ; 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 +;; ; 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] +;; ; If non-nil, holds phrase from [RFC-822] ;; ; mailbox after removing [RFC-822] quoting ;; @@ -2455,7 +2455,7 @@ Return nil if no complete line has arrived." (push (imap-parse-nstring) body);; body-fld-desc (imap-forward) ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a - ;; nstring and return NIL instead of defaulting back to 7BIT + ;; nstring and return nil instead of defaulting back to 7BIT ;; as the standard says. (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc (imap-forward) diff --git a/lisp/gnus/mailcap.el b/lisp/gnus/mailcap.el index 3d0d599b2fa..89a643fa57b 100644 --- a/lisp/gnus/mailcap.el +++ b/lisp/gnus/mailcap.el @@ -274,7 +274,7 @@ to return a true or false shell value for the validity.") (defcustom mailcap-download-directory nil "*Directory to which `mailcap-save-binary-file' downloads files by default. -Nil means your home directory." +nil means your home directory." :type '(choice (const :tag "Home directory" nil) directory) :group 'mailcap) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index dcc265dcf0b..cca933cb5cc 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -1,5 +1,5 @@ ;;; message.el --- composing mail and news messages -*- coding: iso-latin-1 -*- -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -3635,8 +3635,10 @@ than 988 characters long, and if they are not, trim them until they are." (push '(message-mode (encrypt . mc-encrypt-message) (sign . mc-sign-message)) mc-modes-alist)) - (when actions - (setq message-send-actions actions)) + (dolist (action actions) + (condition-case nil + (add-to-list 'message-send-actions + `(apply ',(car action) ',(cdr action))))) (setq message-reply-buffer replybuffer) (goto-char (point-min)) ;; Insert all the headers. @@ -3753,7 +3755,7 @@ OTHER-HEADERS is an alist of header/value pairs." (nconc `((To . ,(or to "")) (Subject . ,(or subject ""))) (when other-headers other-headers)) - replybuffer) + replybuffer send-actions) ;; FIXME: Should return nil if failure. t)) @@ -4116,7 +4118,7 @@ header line with the old Message-ID." "Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT. Previous forwarders, replyers, etc. may add it." (with-temp-buffer - (insert-string subject) + (insert subject) (goto-char (point-min)) ;; strip Re/Fwd stuff off the beginning (while (re-search-forward @@ -4155,8 +4157,8 @@ Source is the sender, and if the original message was news, Source is the list of newsgroups is was posted to." (concat "[" (let ((prefix - (or (message-fetch-field - (if (message-news-p) "newsgroups" "from")) + (or (message-fetch-field "newsgroups") + (message-fetch-field "from") "(nowhere)"))) (if message-forward-decoded-p prefix @@ -4199,6 +4201,7 @@ the message." (eval-when-compile (defvar gnus-article-decoded-p)) + ;;;###autoload (defun message-forward (&optional news digest) "Forward the current message via mail. @@ -4206,39 +4209,42 @@ Optional NEWS will use news to forward instead of mail. Optional DIGEST will use digest to forward." (interactive "P") (let* ((cur (current-buffer)) - (message-forward-decoded-p + (message-forward-decoded-p (if (local-variable-p 'gnus-article-decoded-p (current-buffer)) - gnus-article-decoded-p ;; In an article buffer. + gnus-article-decoded-p ;; In an article buffer. message-forward-decoded-p)) - (subject (message-make-forward-subject)) - art-beg) + (subject (message-make-forward-subject))) (if news (message-news nil subject) (message-mail nil subject)) - ;; Put point where we want it before inserting the forwarded - ;; message. - (if message-forward-before-signature - (message-goto-body) - (goto-char (point-max))) - (if message-forward-as-mime - (if digest - (insert "\n<#multipart type=digest>\n") - (if message-forward-show-mml - (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") - (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n"))) - (insert "\n-------------------- Start of forwarded message --------------------\n")) - (let ((b (point)) e) + (message-forward-make-body cur digest))) + +;;;###autoload +(defun message-forward-make-body (forward-buffer &optional digest) + ;; Put point where we want it before inserting the forwarded + ;; message. + (if message-forward-before-signature + (message-goto-body) + (goto-char (point-max))) + (if message-forward-as-mime (if digest - (if message-forward-as-mime - (insert-buffer-substring cur) - (mml-insert-buffer cur)) - (if (and message-forward-show-mml - (not message-forward-decoded-p)) - (insert - (with-temp-buffer - (mm-disable-multibyte-mule4) ;; Must copy buffer in unibyte mode + (insert "\n<#multipart type=digest>\n") + (if message-forward-show-mml + (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") + (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n"))) + (insert "\n-------------------- Start of forwarded message --------------------\n")) + (let ((b (point)) e) + (if digest + (if message-forward-as-mime + (insert-buffer-substring forward-buffer) + (mml-insert-buffer forward-buffer)) + (if (and message-forward-show-mml + (not message-forward-decoded-p)) + (insert + (with-temp-buffer + (mm-disable-multibyte-mule4) ;; Must copy buffer in unibyte mode (insert - (with-current-buffer cur + (with-current-buffer forward-buffer (mm-string-as-unibyte (buffer-string)))) (mm-enable-multibyte-mule4) (mime-to-mml) @@ -4246,37 +4252,53 @@ Optional DIGEST will use digest to forward." (when (looking-at "From ") (replace-match "X-From-Line: ")) (buffer-string))) - (save-restriction - (narrow-to-region (point) (point)) - (mml-insert-buffer cur) - (goto-char (point-min)) - (when (looking-at "From ") - (replace-match "X-From-Line: ")) - (goto-char (point-max))))) - (setq e (point)) - (if message-forward-as-mime - (if digest - (insert "<#/multipart>\n") - (if message-forward-show-mml - (insert "<#/mml>\n") - (insert "<#/part>\n"))) - (insert "\n-------------------- End of forwarded message --------------------\n")) - (if (and digest message-forward-as-mime) - (save-restriction - (narrow-to-region b e) - (goto-char b) - (narrow-to-region (point) - (or (search-forward "\n\n" nil t) (point))) - (delete-region (point-min) (point-max))) - (when (and (not current-prefix-arg) - message-forward-ignored-headers) - (save-restriction - (narrow-to-region b e) - (goto-char b) - (narrow-to-region (point) - (or (search-forward "\n\n" nil t) (point))) - (message-remove-header message-forward-ignored-headers t))))) - (message-position-point))) + (save-restriction + (narrow-to-region (point) (point)) + (mml-insert-buffer forward-buffer) + (goto-char (point-min)) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + (goto-char (point-max))))) + (setq e (point)) + (if message-forward-as-mime + (if digest + (insert "<#/multipart>\n") + (if message-forward-show-mml + (insert "<#/mml>\n") + (insert "<#/part>\n"))) + (insert "\n-------------------- End of forwarded message --------------------\n")) + (if (and digest message-forward-as-mime) + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (delete-region (point-min) (point-max))) + (when (and (not current-prefix-arg) + message-forward-ignored-headers) + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (message-remove-header message-forward-ignored-headers t))))) + (message-position-point)) + +;;;###autoload +(defun message-forward-rmail-make-body (forward-buffer) + (save-window-excursion + (set-buffer forward-buffer) + (if (rmail-msg-is-pruned) + (rmail-msg-restore-non-pruned-header))) + (message-forward-make-body forward-buffer)) + +;;;###autoload +(defun message-insinuate-rmail () + "Let RMAIL uses message to forward." + (interactive) + (setq rmail-enable-mime-composing t) + (setq rmail-insert-mime-forwarded-message-function + 'message-forward-rmail-make-body)) ;;;###autoload (defun message-resend (address) @@ -4648,9 +4670,10 @@ regexp varstr." ;; /usr/bin/mail. (unless content-type-p (goto-char (point-min)) - (re-search-forward "^MIME-Version:") - (forward-line 1) - (insert "Content-Type: text/plain; charset=us-ascii\n"))))) + ;; For unknown reason, MIME-Version doesn't exist. + (when (re-search-forward "^MIME-Version:" nil t) + (forward-line 1) + (insert "Content-Type: text/plain; charset=us-ascii\n")))))) (defun message-read-from-minibuffer (prompt) "Read from the minibuffer while providing abbrev expansion." diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 95ab4f6291f..bbc16c04879 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -1,5 +1,5 @@ -;;; mm-util.el --- utility functions for MIME things -;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +;;; mm-util.el --- Utility functions for Mule and low level things +;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -27,63 +27,6 @@ (eval-when-compile (require 'cl)) (require 'mail-prsvr) -(defun mm-coding-system-p (sym) - "Return non-nil if SYM is a coding system." - (or (and (fboundp 'coding-system-p) (coding-system-p sym)) - (memq sym (mm-get-coding-system-list)))) - -(defvar mm-mime-mule-charset-alist - `((us-ascii ascii) - (iso-8859-1 latin-iso8859-1) - (iso-8859-2 latin-iso8859-2) - (iso-8859-3 latin-iso8859-3) - (iso-8859-4 latin-iso8859-4) - (iso-8859-5 cyrillic-iso8859-5) - ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters. - ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default - ;; charset is koi8-r, not iso-8859-5. - (koi8-r cyrillic-iso8859-5 gnus-koi8-r) - (iso-8859-6 arabic-iso8859-6) - (iso-8859-7 greek-iso8859-7) - (iso-8859-8 hebrew-iso8859-8) - (iso-8859-9 latin-iso8859-9) - (iso-8859-14 latin-iso8859-14) - (iso-8859-15 latin-iso8859-15) - (viscii vietnamese-viscii-lower) - (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978) - (euc-kr korean-ksc5601) - (gb2312 chinese-gb2312) - (big5 chinese-big5-1 chinese-big5-2) - (tibetan tibetan) - (thai-tis620 thai-tis620) - (iso-2022-7bit ethiopic arabic-1-column arabic-2-column) - (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212 - katakana-jisx0201) - (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212 - chinese-cns11643-1 chinese-cns11643-2) - (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2 - cyrillic-iso8859-5 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212 - chinese-cns11643-1 chinese-cns11643-2 - chinese-cns11643-3 chinese-cns11643-4 - chinese-cns11643-5 chinese-cns11643-6 - chinese-cns11643-7) - ;; utf-8 comes either from Mule-UCS or Mule 5+. - ,@(if (mm-coding-system-p 'utf-8) - (list (cons 'utf-8 (delete 'ascii - (coding-system-get - 'mule-utf-8 - 'safe-charsets)))))) - "Alist of MIME-charset/MULE-charsets.") - (eval-and-compile (mapcar (lambda (elem) @@ -104,12 +47,6 @@ (make-char . (lambda (charset int) (int-to-char int))) - (read-coding-system - . (lambda (prompt) - "Prompt the user for a coding system." - (completing-read - prompt (mapcar (lambda (s) (list (symbol-name (car s)))) - mm-mime-mule-charset-alist)))) (read-charset . (lambda (prompt) "Return a charset." @@ -119,40 +56,86 @@ (mapcar (lambda (e) (list (symbol-name (car e)))) mm-mime-mule-charset-alist) nil t)))) + (subst-char-in-string + . (lambda (from to string) ;; stolen (and renamed) from nnheader.el + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurrences of FROM with TO. + (while (< idx len) + (when (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string))) (string-as-unibyte . identity) - (multibyte-string-p . ignore) - ))) + (string-as-multibyte . identity) + (multibyte-string-p . ignore)))) (eval-and-compile (defalias 'mm-char-or-char-int-p - (cond + (cond ((fboundp 'char-or-char-int-p) 'char-or-char-int-p) - ((fboundp 'char-valid-p) 'char-valid-p) + ((fboundp 'char-valid-p) 'char-valid-p) (t 'identity)))) +(eval-and-compile + (defalias 'mm-read-coding-system + (cond + ((fboundp 'read-coding-system) + (if (and (featurep 'xemacs) + (<= (string-to-number emacs-version) 21.1)) + (lambda (prompt &optional default-coding-system) + (read-coding-system prompt)) + 'read-coding-system)) + (t (lambda (prompt &optional default-coding-system) + "Prompt the user for a coding system." + (completing-read + prompt (mapcar (lambda (s) (list (symbol-name (car s)))) + mm-mime-mule-charset-alist))))))) + (defvar mm-coding-system-list nil) (defun mm-get-coding-system-list () "Get the coding system list." (or mm-coding-system-list (setq mm-coding-system-list (mm-coding-system-list)))) +(defun mm-coding-system-p (sym) + "Return non-nil if SYM is a coding system." + (or (and (fboundp 'coding-system-p) (coding-system-p sym)) + (memq sym (mm-get-coding-system-list)))) + (defvar mm-charset-synonym-alist - `((big5 . cn-big5) - (gb2312 . cn-gb-2312) + `( + ;; Perfectly fine? A valid MIME name, anyhow. + ,@(unless (mm-coding-system-p 'big5) + '((big5 . cn-big5))) + ;; Not in XEmacs, but it's not a proper MIME charset anyhow. + ,@(unless (mm-coding-system-p 'x-ctext) + '((x-ctext . ctext))) + ;; Apparently not defined in Emacs 20, but is a valid MIME name. + ,@(unless (mm-coding-system-p 'gb2312) + '((gb2312 . cn-gb-2312))) + ;; ISO-8859-15 is very similar to ISO-8859-1. + ,@(unless (mm-coding-system-p 'iso-8859-15) ; Emacs 21 defines it. + '((iso-8859-15 . iso-8859-1))) ;; Windows-1252 is actually a superset of Latin-1. See also ;; `gnus-article-dumbquotes-map'. - ,(unless (mm-coding-system-p 'windows-1252) ; should be defined eventually - '(windows-1252 . iso-8859-1)) + ,@(unless (mm-coding-system-p 'windows-1252) + (if (mm-coding-system-p 'cp1252) + '((windows-1252 . cp1252)) + '((windows-1252 . iso-8859-1)))) ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft ;; Outlook users in Czech republic. Use this to allow reading of their ;; e-mails. cp1250 should be defined by M-x codepage-setup. - ,(unless (mm-coding-system-p 'windows-1250) ; should be defined eventually - '(windows-1250 . cp1250)) - (x-ctext . ctext)) + ,@(if (and (not (mm-coding-system-p 'windows-1250)) + (mm-coding-system-p 'cp1250)) + '((windows-1250 . cp1250))) + ) "A mapping from invalid charset names to the real charset names.") (defvar mm-binary-coding-system - (cond + (cond ((mm-coding-system-p 'binary) 'binary) ((mm-coding-system-p 'no-conversion) 'no-conversion) (t nil)) @@ -169,30 +152,160 @@ "Text coding system for write.") (defvar mm-auto-save-coding-system - (cond + (cond ((mm-coding-system-p 'emacs-mule) (if (memq system-type '(windows-nt ms-dos ms-windows)) - (if (mm-coding-system-p 'emacs-mule-dos) + (if (mm-coding-system-p 'emacs-mule-dos) 'emacs-mule-dos mm-binary-coding-system) 'emacs-mule)) ((mm-coding-system-p 'escape-quoted) 'escape-quoted) (t mm-binary-coding-system)) "Coding system of auto save file.") +(defvar mm-universal-coding-system mm-auto-save-coding-system + "The universal coding system.") + +;; Fixme: some of the cars here aren't valid MIME charsets. That +;; should only matter with XEmacs, though. +(defvar mm-mime-mule-charset-alist + `((us-ascii ascii) + (iso-8859-1 latin-iso8859-1) + (iso-8859-2 latin-iso8859-2) + (iso-8859-3 latin-iso8859-3) + (iso-8859-4 latin-iso8859-4) + (iso-8859-5 cyrillic-iso8859-5) + ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters. + ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default + ;; charset is koi8-r, not iso-8859-5. + (koi8-r cyrillic-iso8859-5 gnus-koi8-r) + (iso-8859-6 arabic-iso8859-6) + (iso-8859-7 greek-iso8859-7) + (iso-8859-8 hebrew-iso8859-8) + (iso-8859-9 latin-iso8859-9) + (iso-8859-14 latin-iso8859-14) + (iso-8859-15 latin-iso8859-15) + (viscii vietnamese-viscii-lower) + (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978) + (euc-kr korean-ksc5601) + (gb2312 chinese-gb2312) + (big5 chinese-big5-1 chinese-big5-2) + (tibetan tibetan) + (thai-tis620 thai-tis620) + (iso-2022-7bit ethiopic arabic-1-column arabic-2-column) + (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7 + latin-jisx0201 japanese-jisx0208-1978 + chinese-gb2312 japanese-jisx0208 + korean-ksc5601 japanese-jisx0212 + katakana-jisx0201) + (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7 + latin-jisx0201 japanese-jisx0208-1978 + chinese-gb2312 japanese-jisx0208 + korean-ksc5601 japanese-jisx0212 + chinese-cns11643-1 chinese-cns11643-2) + (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2 + cyrillic-iso8859-5 greek-iso8859-7 + latin-jisx0201 japanese-jisx0208-1978 + chinese-gb2312 japanese-jisx0208 + korean-ksc5601 japanese-jisx0212 + chinese-cns11643-1 chinese-cns11643-2 + chinese-cns11643-3 chinese-cns11643-4 + chinese-cns11643-5 chinese-cns11643-6 + chinese-cns11643-7) + ,(if (or (not (fboundp 'charsetp)) ;; non-Mule case + (charsetp 'unicode-a) + (not (mm-coding-system-p 'mule-utf-8))) + '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e) + ;; If we have utf-8 we're in Mule 5+. + (append '(utf-8) + (delete 'ascii + (coding-system-get 'mule-utf-8 'safe-charsets))))) + "Alist of MIME-charset/MULE-charsets.") + +;; Correct by construction, but should be unnecessary: +;; XEmacs hates it. +(when (and (not (featurep 'xemacs)) + (fboundp 'coding-system-list) + (fboundp 'sort-coding-systems)) + (setq mm-mime-mule-charset-alist + (apply + 'nconc + (mapcar + (lambda (cs) + (when (and (coding-system-get cs 'mime-charset) + (not (eq t (coding-system-get cs 'safe-charsets)))) + (list (cons (coding-system-get cs 'mime-charset) + (delq 'ascii + (coding-system-get cs 'safe-charsets)))))) + (sort-coding-systems (coding-system-list 'base-only)))))) + +(defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2) + "A list of special charsets. +Valid elements include: +`iso-8859-15' convert ISO-8859-1, -9 to ISO-8859-15 if ISO-8859-15 exists. +`iso-2022-jp-2' convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists." +) + +(defvar mm-iso-8859-15-compatible + '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE") + (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE")) + "ISO-8859-15 exchangeable coding systems and inconvertible characters.") + +(defvar mm-iso-8859-x-to-15-table + (and (fboundp 'coding-system-p) + (mm-coding-system-p 'iso-8859-15) + (mapcar + (lambda (cs) + (if (mm-coding-system-p (car cs)) + (let ((c (string-to-char + (decode-coding-string "\341" (car cs))))) + (cons (char-charset c) + (cons + (- (string-to-char + (decode-coding-string "\341" 'iso-8859-15)) c) + (string-to-list (decode-coding-string (car (cdr cs)) + (car cs)))))) + '(gnus-charset 0))) + mm-iso-8859-15-compatible)) + "A table of the difference character between ISO-8859-X and ISO-8859-15.") + +(defvar mm-coding-system-priorities nil + "Preferred coding systems for encoding outgoing mails. + +More than one suitable coding systems may be found for some texts. By +default, a coding system with the highest priority is used to encode +outgoing mails (see `sort-coding-systems'). If this variable is set, +it overrides the default priority. For example, Japanese users may +prefer iso-2022-jp to japanese-shift-jis: + +\(setq mm-coding-system-priorities + '(iso-2022-jp iso-2022-jp-2 japanese-shift-jis utf-8)) +") + +(defvar mm-use-find-coding-systems-region + (fboundp 'find-coding-systems-region) + "Use `find-coding-systems-region' to find proper coding systems.") + ;;; Internal variables: ;;; Functions: (defun mm-mule-charset-to-mime-charset (charset) "Return the MIME charset corresponding to the given Mule CHARSET." - (let ((alist mm-mime-mule-charset-alist) - out) - (while alist - (when (memq charset (cdar alist)) - (setq out (caar alist) - alist nil)) - (pop alist)) - out)) + (if (fboundp 'find-coding-systems-for-charsets) + (let (mime) + (dolist (cs (find-coding-systems-for-charsets (list charset))) + (unless mime + (when cs + (setq mime (coding-system-get cs 'mime-charset))))) + mime) + (let ((alist mm-mime-mule-charset-alist) + out) + (while alist + (when (memq charset (cdar alist)) + (setq out (caar alist) + alist nil)) + (pop alist)) + out))) (defun mm-charset-to-coding-system (charset &optional lbt) "Return coding-system corresponding to CHARSET. @@ -201,12 +314,11 @@ If optional argument LBT (`unix', `dos' or `mac') is specified, it is used as the line break code type of the coding system." (when (stringp charset) (setq charset (intern (downcase charset)))) - (setq charset - (or (cdr (assq charset mm-charset-synonym-alist)) - charset)) (when lbt (setq charset (intern (format "%s-%s" charset lbt)))) (cond + ((null charset) + charset) ;; Running in a non-MULE environment. ((null (mm-get-coding-system-list)) charset) @@ -215,63 +327,76 @@ used as the line break code type of the coding system." 'ascii) ;; Check to see whether we can handle this charset. (This depends ;; on there being some coding system matching each `mime-charset' - ;; coding sysytem property defined, as there should be.) - ((memq charset (mm-get-coding-system-list)) + ;; property defined, as there should be.) + ((and (mm-coding-system-p charset) +;;; Doing this would potentially weed out incorrect charsets. +;;; charset +;;; (eq charset (coding-system-get charset 'mime-charset)) + ) charset) - ;; Nope. - (t - nil))) - -(if (fboundp 'subst-char-in-string) - (defsubst mm-replace-chars-in-string (string from to) - (subst-char-in-string from to string)) - (defun mm-replace-chars-in-string (string from to) - "Replace characters in STRING from FROM to TO." - (let ((string (substring string 0)) ;Copy string. - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (when (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string))) - -(defsubst mm-enable-multibyte () - "Set the multibyte flag of the current buffer. + ;; Translate invalid charsets. + ((let ((cs (cdr (assq charset mm-charset-synonym-alist)))) + (and cs (mm-coding-system-p charset) cs))) + ;; Last resort: search the coding system list for entries which + ;; have the right mime-charset in case the canonical name isn't + ;; defined (though it should be). + ((let (cs) + ;; mm-get-coding-system-list returns a list of cs without lbt. + ;; Do we need -lbt? + (dolist (c (mm-get-coding-system-list)) + (if (and (null cs) + (eq charset (coding-system-get c 'mime-charset))) + (setq cs c))) + cs)))) + +(defsubst mm-replace-chars-in-string (string from to) + (mm-subst-char-in-string from to string)) + +(eval-and-compile + (defvar mm-emacs-mule (and (not (featurep 'xemacs)) + (boundp 'default-enable-multibyte-characters) + default-enable-multibyte-characters + (fboundp 'set-buffer-multibyte)) + "Emacs mule.") + + (defvar mm-mule4-p (and mm-emacs-mule + (fboundp 'charsetp) + (not (charsetp 'eight-bit-control))) + "Mule version 4.") + + (if mm-emacs-mule + (defun mm-enable-multibyte () + "Set the multibyte flag of the current buffer. Only do this if the default value of `enable-multibyte-characters' is non-nil. This is a no-op in XEmacs." - (when (and (fboundp 'set-buffer-multibyte) - (boundp 'enable-multibyte-characters) - (default-value 'enable-multibyte-characters)) - (set-buffer-multibyte t))) + (set-buffer-multibyte t)) + (defalias 'mm-enable-multibyte 'ignore)) -(defsubst mm-disable-multibyte () - "Unset the multibyte flag of in the current buffer. + (if mm-emacs-mule + (defun mm-disable-multibyte () + "Unset the multibyte flag of in the current buffer. This is a no-op in XEmacs." - (when (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil))) + (set-buffer-multibyte nil)) + (defalias 'mm-disable-multibyte 'ignore)) -(defsubst mm-enable-multibyte-mule4 () - "Enable multibyte in the current buffer. + (if mm-mule4-p + (defun mm-enable-multibyte-mule4 () + "Enable multibyte in the current buffer. Only used in Emacs Mule 4." - (when (and (fboundp 'set-buffer-multibyte) - (boundp 'enable-multibyte-characters) - (default-value 'enable-multibyte-characters) - (not (charsetp 'eight-bit-control))) - (set-buffer-multibyte t))) - -(defsubst mm-disable-multibyte-mule4 () - "Disable multibyte in the current buffer. + (set-buffer-multibyte t)) + (defalias 'mm-enable-multibyte-mule4 'ignore)) + + (if mm-mule4-p + (defun mm-disable-multibyte-mule4 () + "Disable multibyte in the current buffer. Only used in Emacs Mule 4." - (when (and (fboundp 'set-buffer-multibyte) - (not (charsetp 'eight-bit-control))) - (set-buffer-multibyte nil))) + (set-buffer-multibyte nil)) + (defalias 'mm-disable-multibyte-mule4 'ignore))) (defun mm-preferred-coding-system (charset) ;; A typo in some Emacs versions. - (or (get-charset-property charset 'prefered-coding-system) - (get-charset-property charset 'preferred-coding-system))) + (or (get-charset-property charset 'preferred-coding-system) + (get-charset-property charset 'prefered-coding-system))) (defun mm-charset-after (&optional pos) "Return charset of a character in current buffer at position POS. @@ -294,10 +419,10 @@ If the charset is `composition', return the actual one." (progn (setq mail-parse-mule-charset (and (boundp 'current-language-environment) - (car (last - (assq 'charset - (assoc current-language-environment - language-info-alist)))))) + (car (last + (assq 'charset + (assoc current-language-environment + language-info-alist)))))) (if (or (not mail-parse-mule-charset) (eq mail-parse-mule-charset 'ascii)) (setq mail-parse-mule-charset @@ -309,6 +434,8 @@ If the charset is `composition', return the actual one." (defun mm-mime-charset (charset) "Return the MIME charset corresponding to the given Mule CHARSET." + (if (eq charset 'unknown) + (error "The message contains non-printable characters, please use attachment")) (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property)) ;; This exists in Emacs 20. (or @@ -317,6 +444,7 @@ If the charset is `composition', return the actual one." (mm-preferred-coding-system charset) 'mime-charset)) (and (eq charset 'ascii) 'us-ascii) + (mm-preferred-coding-system charset) (mm-mule-charset-to-mime-charset charset)) ;; This is for XEmacs. (mm-mule-charset-to-mime-charset charset))) @@ -330,21 +458,8 @@ If the charset is `composition', return the actual one." (setq result (cons head result))) (nreverse result))) -(defun mm-find-mime-charset-region (b e) - "Return the MIME charsets needed to encode the region between B and E." - (let ((charsets (mapcar 'mm-mime-charset - (delq 'ascii - (mm-find-charset-region b e))))) - (when (memq 'iso-2022-jp-2 charsets) - (setq charsets (delq 'iso-2022-jp charsets))) - (setq charsets (mm-delete-duplicates charsets)) - (if (and (> (length charsets) 1) - (fboundp 'find-coding-systems-region) - (let ((cs (find-coding-systems-region b e))) - (or (memq 'utf-8 cs) (memq 'mule-utf-8 cs)))) - '(utf-8) - charsets))) - +;; It's not clear whether this is supposed to mean the global or local +;; setting. I think it's used inconsistently. -- fx (defsubst mm-multibyte-p () "Say whether multibyte is enabled." (if (and (not (featurep 'xemacs)) @@ -352,6 +467,71 @@ If the charset is `composition', return the actual one." enable-multibyte-characters (featurep 'mule))) +(defun mm-iso-8859-x-to-15-region (&optional b e) + (if (fboundp 'char-charset) + (let (charset item c inconvertible) + (save-restriction + (if e (narrow-to-region b e)) + (goto-char (point-min)) + (skip-chars-forward "\0-\177") + (while (not (eobp)) + (cond + ((not (setq item (assq (char-charset (setq c (char-after))) + mm-iso-8859-x-to-15-table))) + (forward-char)) + ((memq c (cdr (cdr item))) + (setq inconvertible t) + (forward-char)) + (t + (insert (prog1 (+ c (car (cdr item))) (delete-char 1)))) + (skip-chars-forward "\0-\177")))) + (not inconvertible)))) + +(defun mm-sort-coding-systems-predicate (a b) + (> (length (memq a mm-coding-system-priorities)) + (length (memq b mm-coding-system-priorities)))) + +(defun mm-find-mime-charset-region (b e &optional hack-charsets) + "Return the MIME charsets needed to encode the region between B and E. +nil means ASCII, a single-element list represents an appropriate MIME +charset, and a longer list means no appropriate charset." + (let (charsets) + ;; The return possibilities of this function are a mess... + (or (and (mm-multibyte-p) + mm-use-find-coding-systems-region + ;; Find the mime-charset of the most preferred coding + ;; system that has one. + (let ((systems (find-coding-systems-region b e))) + (when mm-coding-system-priorities + (setq systems + (sort systems 'mm-sort-coding-systems-predicate))) + ;; Fixme: The `mime-charset' (`x-ctext') of `compound-text' + ;; is not in the IANA list. + (setq systems (delq 'compound-text systems)) + (unless (equal systems '(undecided)) + (while systems + (let ((cs (coding-system-get (pop systems) 'mime-charset))) + (if cs + (setq systems nil + charsets (list cs)))))) + charsets)) + ;; Otherwise we're not multibyte, XEmacs or a single coding + ;; system won't cover it. + (setq charsets + (mm-delete-duplicates + (mapcar 'mm-mime-charset + (delq 'ascii + (mm-find-charset-region b e)))))) + (if (and (memq 'iso-8859-15 charsets) + (memq 'iso-8859-15 hack-charsets) + (save-excursion (mm-iso-8859-x-to-15-region b e))) + (mapcar (lambda (x) (setq charsets (delq (car x) charsets))) + mm-iso-8859-15-compatible)) + (if (and (memq 'iso-2022-jp-2 charsets) + (memq 'iso-2022-jp-2 hack-charsets)) + (setq charsets (delq 'iso-2022-jp charsets))) + charsets)) + (defmacro mm-with-unibyte-buffer (&rest forms) "Create a temporary buffer, and evaluate FORMS there like `progn'. Use unibyte mode for this." @@ -364,15 +544,18 @@ Use unibyte mode for this." "Evaluate FORMS with current current buffer temporarily made unibyte. Also bind `default-enable-multibyte-characters' to nil. Equivalent to `progn' in XEmacs" - (let ((multibyte (make-symbol "multibyte"))) - `(if (fboundp 'set-buffer-multibyte) - (let ((,multibyte enable-multibyte-characters)) + (let ((multibyte (make-symbol "multibyte")) + (buffer (make-symbol "buffer"))) + `(if mm-emacs-mule + (let ((,multibyte enable-multibyte-characters) + (,buffer (current-buffer))) (unwind-protect (let (default-enable-multibyte-characters) (set-buffer-multibyte nil) ,@forms) + (set-buffer ,buffer) (set-buffer-multibyte ,multibyte))) - (progn + (let (default-enable-multibyte-characters) ,@forms)))) (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0) (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body)) @@ -380,22 +563,19 @@ Equivalent to `progn' in XEmacs" (defmacro mm-with-unibyte-current-buffer-mule4 (&rest forms) "Evaluate FORMS there like `progn' in current buffer. Mule4 only." - (let ((multibyte (make-symbol "multibyte"))) - `(if (or (featurep 'xemacs) - (not (fboundp 'set-buffer-multibyte)) - (charsetp 'eight-bit-control)) ;; For Emacs Mule 4 only. - (progn - ,@forms) - (let ((,multibyte (default-value 'enable-multibyte-characters))) - (unwind-protect - (let ((buffer-file-coding-system mm-binary-coding-system) - (coding-system-for-read mm-binary-coding-system) - (coding-system-for-write mm-binary-coding-system)) - (set-buffer-multibyte nil) - (setq-default enable-multibyte-characters nil) - ,@forms) - (setq-default enable-multibyte-characters ,multibyte) - (set-buffer-multibyte ,multibyte)))))) + (let ((multibyte (make-symbol "multibyte")) + (buffer (make-symbol "buffer"))) + `(if mm-mule4-p + (let ((,multibyte enable-multibyte-characters) + (,buffer (current-buffer))) + (unwind-protect + (let (default-enable-multibyte-characters) + (set-buffer-multibyte nil) + ,@forms) + (set-buffer ,buffer) + (set-buffer-multibyte ,multibyte))) + (let (default-enable-multibyte-characters) + ,@forms)))) (put 'mm-with-unibyte-current-buffer-mule4 'lisp-indent-function 0) (put 'mm-with-unibyte-current-buffer-mule4 'edebug-form-spec '(body)) @@ -410,9 +590,14 @@ Mule4 only." "Return a list of Emacs charsets in the region B to E." (cond ((and (mm-multibyte-p) - (fboundp 'find-charset-region)) + (fboundp 'find-charset-region)) ;; Remove composition since the base charsets have been included. - (delq 'composition (find-charset-region b e))) + ;; Remove eight-bit-*, treat them as ascii. + (let ((css (find-charset-region b e))) + (mapcar (lambda (cs) (setq css (delq cs css))) + '(composition eight-bit-control eight-bit-graphic + control-1)) + css)) (t ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit. (save-excursion @@ -425,8 +610,8 @@ Mule4 only." (let (charset) (setq charset (and (boundp 'current-language-environment) - (car (last (assq 'charset - (assoc current-language-environment + (car (last (assq 'charset + (assoc current-language-environment language-info-alist)))))) (if (eq charset 'ascii) (setq charset nil)) (or charset @@ -476,15 +661,15 @@ If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers. (auto-mode-alist (if inhibit nil (mm-auto-mode-alist))) (default-major-mode 'fundamental-mode) (enable-local-variables nil) - (after-insert-file-functions nil) + (after-insert-file-functions nil) (enable-local-eval nil) (find-file-hooks nil) - (inhibit-file-name-operation (if inhibit + (inhibit-file-name-operation (if inhibit 'insert-file-contents inhibit-file-name-operation)) (inhibit-file-name-handlers (if inhibit - (append mm-inhibit-file-name-handlers + (append mm-inhibit-file-name-handlers inhibit-file-name-handlers) inhibit-file-name-handlers))) (insert-file-contents filename visit beg end replace))) @@ -497,37 +682,47 @@ saying what text to write. Optional fourth argument specifies the coding system to use when encoding the file. If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers." - (let ((coding-system-for-write - (or codesys mm-text-coding-system-for-write + (let ((coding-system-for-write + (or codesys mm-text-coding-system-for-write mm-text-coding-system)) - (inhibit-file-name-operation (if inhibit + (inhibit-file-name-operation (if inhibit 'append-to-file inhibit-file-name-operation)) (inhibit-file-name-handlers (if inhibit - (append mm-inhibit-file-name-handlers + (append mm-inhibit-file-name-handlers inhibit-file-name-handlers) inhibit-file-name-handlers))) (append-to-file start end filename))) -(defun mm-write-region (start end filename &optional append visit lockname +(defun mm-write-region (start end filename &optional append visit lockname coding-system inhibit) "Like `write-region'. If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers." - (let ((coding-system-for-write - (or coding-system mm-text-coding-system-for-write + (let ((coding-system-for-write + (or coding-system mm-text-coding-system-for-write mm-text-coding-system)) - (inhibit-file-name-operation (if inhibit + (inhibit-file-name-operation (if inhibit 'write-region inhibit-file-name-operation)) (inhibit-file-name-handlers (if inhibit - (append mm-inhibit-file-name-handlers + (append mm-inhibit-file-name-handlers inhibit-file-name-handlers) inhibit-file-name-handlers))) (write-region start end filename append visit lockname))) +(defun mm-image-load-path (&optional package) + (let (dir result) + (dolist (path load-path (nreverse result)) + (if (file-directory-p + (setq dir (concat (file-name-directory + (directory-file-name path)) + "etc/" (or package "gnus/")))) + (push dir result)) + (push path result)))) + (provide 'mm-util) ;;; mm-util.el ends here diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 89b0e5e458c..2fa24a72855 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -50,10 +50,11 @@ `(lambda () (remove-images ,b (1+ ,b)))))) (defun mm-inline-image-xemacs (handle) + (insert "\n") + (forward-char -1) (let ((b (point)) (annot (make-annotation (mm-get-image handle) nil 'text)) buffer-read-only) - (insert "\n") (mm-handle-set-undisplayer handle `(lambda () @@ -104,11 +105,14 @@ (and (boundp 'w3-meta-charset-content-type-regexp) (re-search-forward w3-meta-charset-content-type-regexp nil t))) - (setq charset (or (w3-coding-system-for-mime-charset - (buffer-substring-no-properties - (match-beginning 2) - (match-end 2))) - charset))) + (setq charset + (or (let ((bsubstr (buffer-substring-no-properties + (match-beginning 2) + (match-end 2)))) + (if (fboundp 'w3-coding-system-for-mime-charset) + (w3-coding-system-for-mime-charset bsubstr) + (mm-charset-to-coding-system bsubstr))) + charset))) (delete-region (point-min) (point-max)) (insert (mm-decode-string text charset)) (save-window-excursion @@ -120,7 +124,21 @@ (url-standalone-mode t)) (condition-case var (w3-region (point-min) (point-max)) - (error))))) + (error + (delete-region (point-min) (point-max)) + (let ((b (point)) + (charset (mail-content-type-get + (mm-handle-type handle) 'charset))) + (if (or (eq charset 'gnus-decoded) + (eq mail-parse-charset 'gnus-decoded)) + (save-restriction + (narrow-to-region (point) (point)) + (mm-insert-part handle) + (goto-char (point-max))) + (insert (mm-decode-string (mm-get-part handle) + charset)))) + (message + "Error while rendering html; showing as text/plain")))))) (mm-handle-set-undisplayer handle `(lambda () @@ -133,33 +151,28 @@ '(background background-pixmap foreground))) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) - ((or (equal type "enriched") - (equal type "richtext")) - (save-excursion - (mm-with-unibyte-buffer - (mm-insert-part handle) - (save-window-excursion - (enriched-decode (point-min) (point-max)) - (setq text (buffer-string))))) - (mm-insert-inline handle text)) ((equal type "x-vcard") (mm-insert-inline handle (concat "\n-- \n" - (if (fboundp 'vcard-pretty-print) - (vcard-pretty-print (mm-get-part handle)) - (vcard-format-string - (vcard-parse-string (mm-get-part handle) - 'vcard-standard-filter)))))) + (ignore-errors + (if (fboundp 'vcard-pretty-print) + (vcard-pretty-print (mm-get-part handle)) + (vcard-format-string + (vcard-parse-string (mm-get-part handle) + 'vcard-standard-filter))))))) (t (let ((b (point)) (charset (mail-content-type-get (mm-handle-type handle) 'charset))) (if (or (eq charset 'gnus-decoded) ;; This is probably not entirely correct, but - ;; makes rfc822 parts with embedded multiparts work. + ;; makes rfc822 parts with embedded multiparts work. (eq mail-parse-charset 'gnus-decoded)) - (mm-insert-part handle) + (save-restriction + (narrow-to-region (point) (point)) + (mm-insert-part handle) + (goto-char (point-max))) (insert (mm-decode-string (mm-get-part handle) charset))) (when (and (equal type "plain") (equal (cdr (assoc 'format (mm-handle-type handle))) @@ -172,6 +185,9 @@ (save-restriction (narrow-to-region b (point)) (set-text-properties (point-min) (point-max) nil) + (when (or (equal type "enriched") + (equal type "richtext")) + (enriched-decode (point-min) (point-max))) (mm-handle-set-undisplayer handle `(lambda () @@ -219,6 +235,7 @@ (defun mm-inline-message (handle) (let ((b (point)) + (bolp (bolp)) (charset (mail-content-type-get (mm-handle-type handle) 'charset)) gnus-displaying-mime handles) @@ -232,13 +249,16 @@ (narrow-to-region b b) (mm-insert-part handle) (let (gnus-article-mime-handles - ;; disable prepare hook - gnus-article-prepare-hook + ;; disable prepare hook + gnus-article-prepare-hook (gnus-newsgroup-charset (or charset gnus-newsgroup-charset))) (run-hooks 'gnus-article-decode-hook) (gnus-article-prepare-display) (setq handles gnus-article-mime-handles)) + (goto-char (point-min)) + (unless bolp + (insert "\n")) (goto-char (point-max)) (unless (bolp) (insert "\n")) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 87aff3e125c..d2beef9fa50 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -133,7 +133,7 @@ The function is called with one parameter, which is the generated part.") (when (and (not raw) (memq nil charsets)) (if (or (memq 'unknown-encoding mml-confirmation-set) (prog1 (y-or-n-p - "\ + "\ Message contains characters with unknown encoding. Really send?") (set (make-local-variable 'mml-confirmation-set) (push 'unknown-encoding mml-confirmation-set)))) @@ -252,7 +252,7 @@ A message part needs to be split into %d charset parts. Really send? " "Return the buffer up till the next part, multipart or closing part or multipart. If MML is non-nil, return the buffer up till the correspondent mml tag." (let ((beg (point)) (count 1)) - ;; If the tag ended at the end of the line, we go to the next line. + ;; If the tag ended at the end of the line, we go to the next line. (when (looking-at "[ \t]*\n") (forward-line 1)) (if mml @@ -305,43 +305,47 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (setq type (or (cdr (assq 'type cont)) "text/plain")) (if (and (not raw) (member (car (split-string type "/")) '("text" "message"))) - (with-temp-buffer - (cond - ((cdr (assq 'buffer cont)) - (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)) - ((eq 'mml (car cont)) - (insert (cdr (assq 'contents cont)))) - (t - (save-restriction - (narrow-to-region (point) (point)) - (insert (cdr (assq 'contents cont))) - ;; Remove quotes from quoted tags. - (goto-char (point-min)) - (while (re-search-forward - "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t) - (delete-region (+ (match-beginning 0) 2) - (+ (match-beginning 0) 3)))))) - (cond - ((eq (car cont) 'mml) - (let ((mml-boundary (funcall mml-boundary-function - (incf mml-multipart-number))) - (mml-generate-default-type "text/plain")) - (mml-to-mime)) - (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) - ;; ignore 0x1b, it is part of iso-2022-jp - (setq encoding (mm-body-7-or-8)))) - ((string= (car (split-string type "/")) "message") - (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) - ;; ignore 0x1b, it is part of iso-2022-jp - (setq encoding (mm-body-7-or-8)))) - (t - (setq charset (mm-encode-body)) - (setq encoding (mm-body-encoding - charset (cdr (assq 'encoding cont)))))) - (setq coded (buffer-string))) + (progn + (with-temp-buffer + (cond + ((cdr (assq 'buffer cont)) + (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)) + ((eq 'mml (car cont)) + (insert (cdr (assq 'contents cont)))) + (t + (save-restriction + (narrow-to-region (point) (point)) + (insert (cdr (assq 'contents cont))) + ;; Remove quotes from quoted tags. + (goto-char (point-min)) + (while (re-search-forward + "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t) + (delete-region (+ (match-beginning 0) 2) + (+ (match-beginning 0) 3)))))) + (cond + ((eq (car cont) 'mml) + (let ((mml-boundary (funcall mml-boundary-function + (incf mml-multipart-number))) + (mml-generate-default-type "text/plain")) + (mml-to-mime)) + (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) + ;; ignore 0x1b, it is part of iso-2022-jp + (setq encoding (mm-body-7-or-8)))) + ((string= (car (split-string type "/")) "message") + (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) + ;; ignore 0x1b, it is part of iso-2022-jp + (setq encoding (mm-body-7-or-8)))) + (t + (setq charset (mm-encode-body)) + (setq encoding (mm-body-encoding + charset (cdr (assq 'encoding cont)))))) + (setq coded (buffer-string))) + (mml-insert-mime-headers cont type charset encoding) + (insert "\n") + (insert coded)) (mm-with-unibyte-buffer (cond ((cdr (assq 'buffer cont)) @@ -353,10 +357,11 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (t (insert (cdr (assq 'contents cont))))) (setq encoding (mm-encode-buffer type) - coded (buffer-string)))) - (mml-insert-mime-headers cont type charset encoding) - (insert "\n") - (insert coded))) + coded (buffer-string))) + (mml-insert-mime-headers cont type charset encoding) + (insert "\n") + (mm-with-unibyte-current-buffer + (insert coded))))) ((eq (car cont) 'external) (insert "Content-Type: message/external-body") (let ((parameters (mml-parameter-string @@ -378,7 +383,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (concat "access-type=" (if (member (nth 0 name) '("ftp@" "anonymous@")) "anon-ftp" - "ftp"))))) + "ftp"))))) (when parameters (mml-insert-parameter-string cont '(expiration size permission)))) @@ -651,19 +656,19 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." main)) (easy-menu-define - mml-menu mml-mode-map "" - '("MML" - ("Attach" - ["File" mml-attach-file t] - ["Buffer" mml-attach-buffer t] - ["External" mml-attach-external t]) - ("Insert" - ["Multipart" mml-insert-multipart t] - ["Part" mml-insert-part t]) - ;;["Narrow" mml-narrow-to-part t] - ["Quote" mml-quote-region t] - ["Validate" mml-validate t] - ["Preview" mml-preview t])) + mml-menu mml-mode-map "" + '("MML" + ("Attach" + ["File" mml-attach-file t] + ["Buffer" mml-attach-buffer t] + ["External" mml-attach-external t]) + ("Insert" + ["Multipart" mml-insert-multipart t] + ["Part" mml-insert-part t]) + ;;["Narrow" mml-narrow-to-part t] + ["Quote" mml-quote-region t] + ["Validate" mml-validate t] + ["Preview" mml-preview t])) (defvar mml-mode nil "Minor mode for editing MML.") @@ -692,7 +697,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (defun mml-minibuffer-read-file (prompt) (let ((file (read-file-name prompt nil nil t))) - ;; Prevent some common errors. This is inspired by similar code in + ;; Prevent some common errors. This is inspired by similar code in ;; VM. (when (file-directory-p file) (error "%s is a directory, cannot attach" file)) @@ -836,7 +841,8 @@ If RAW, don't highlight the article." (if (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n") nil t) (replace-match "\n")) - (mml-to-mime) + (let ((mail-header-separator "")) ;; mail-header-separator is removed. + (mml-to-mime)) (if raw (when (fboundp 'set-buffer-multibyte) (let ((s (buffer-string))) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 8ed7a4a5973..8ba41d95072 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -99,7 +99,7 @@ message, a huge time saver for large mailboxes.") (defvoo nnfolder-file-coding-system mm-text-coding-system) (defvoo nnfolder-file-coding-system-for-write nnheader-file-coding-system "Coding system for save nnfolder file. -If NIL, NNFOLDER-FILE-CODING-SYSTEM is used.") +If nil, `nnfolder-file-coding-system' is used.") diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 9234325eac0..ad28361ebd8 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -318,7 +318,7 @@ GROUP: Mail will be stored in GROUP (a string). \(FIELD VALUE [- RESTRICT [- RESTRICT [...]]] SPLIT): If the message field FIELD (a regexp) contains VALUE (a regexp), store the messages as specified by SPLIT. If RESTRICT (a regexp) matches some string - after FIELD and before the end of the matched VALUE, return NIL, + after FIELD and before the end of the matched VALUE, return nil, otherwise process SPLIT. Multiple RESTRICTs add up, further restricting the possibility of processing SPLIT. diff --git a/lisp/gnus/nnslashdot.el b/lisp/gnus/nnslashdot.el index 246a3613a81..8290b2c73b1 100644 --- a/lisp/gnus/nnslashdot.el +++ b/lisp/gnus/nnslashdot.el @@ -1,5 +1,5 @@ ;;; nnslashdot.el --- interfacing with Slashdot -;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -57,6 +57,9 @@ "http://slashdot.org/article.pl?sid=%s&mode=nocomment" "Where nnslashdot will fetch the article from.") +(defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml" + "Where nnslashdot will fetch the stories from.") + (defvoo nnslashdot-threshold -1 "The article threshold.") @@ -86,19 +89,17 @@ (nnslashdot-possibly-change-server group server) (condition-case why (unless gnus-nov-is-evil - (if nnslashdot-threaded - (nnslashdot-threaded-retrieve-headers articles group) - (nnslashdot-sane-retrieve-headers articles group))) + (nnslashdot-retrieve-headers-1 articles group)) (search-failed (nnslashdot-lose why)))) -(deffoo nnslashdot-threaded-retrieve-headers (articles group) - (let ((last (car (last articles))) - (did nil) - (start 1) - (sid (caddr (assoc group nnslashdot-groups))) - (first-comments t) - (startats '(1)) - headers article subject score from date lines parent point s) +(deffoo nnslashdot-retrieve-headers-1 (articles group) + (let* ((last (car (last articles))) + (start (if nnslashdot-threaded 1 (pop articles))) + (entry (assoc group nnslashdot-groups)) + (sid (nth 2 entry)) + (first-comments t) + headers article subject score from date lines parent point cid + s startats changed) (save-excursion (set-buffer nnslashdot-buffer) (let ((case-fold-search t)) @@ -107,10 +108,10 @@ (nnweb-insert (format nnslashdot-article-url (nnslashdot-sid-strip sid)) t) (goto-char (point-min)) - (search-forward "Posted by ") - (when (looking-at "]+>\\([^<]+\\)") - (setq from (nnweb-decode-entities-string (match-string 1)))) - (search-forward " on ") + (re-search-forward "Posted by[ \t\r\n]+") + (when (looking-at "\\(]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)") + (setq from (nnweb-decode-entities-string (match-string 2)))) + (search-forward "on ") (setq date (nnslashdot-date-to-date (buffer-substring (point) (1- (search-forward "<"))))) (setq lines (/ (- (point) @@ -123,16 +124,16 @@ 1 group from date (concat "<" (nnslashdot-sid-strip sid) "%1@slashdot>") "" 0 lines nil nil)) - headers)) - (while (and (setq start (pop startats)) - (< start last)) + headers) + (setq start (if nnslashdot-threaded 2 (pop articles)))) + (while (and start (<= start last)) (setq point (goto-char (point-max))) (nnweb-insert (format nnslashdot-comments-url (nnslashdot-sid-strip sid) - nnslashdot-threshold 0 start) + nnslashdot-threshold 0 (- start 2)) t) - (when first-comments + (when (and nnslashdot-threaded first-comments) (setq first-comments nil) (goto-char (point-max)) (while (re-search-backward "startat=\\([0-9]+\\)" nil t) @@ -140,58 +141,68 @@ (unless (memq s startats) (push s startats))) (setq startats (sort startats '<))) + (setq article (if (and article (< start article)) article start)) (goto-char point) (while (re-search-forward "<\\(b\\|H4\\)>\\([^<]+\\).*score:\\([^)]+\\))" nil t) - (setq article (string-to-number (match-string 1)) + (setq cid (match-string 1) subject (match-string 3) score (match-string 5)) + (unless (assq article (nth 4 entry)) + (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry))) + (setq changed t)) (when (string-match "^Re: *" subject) (setq subject (concat "Re: " (substring subject (match-end 0))))) - (setq subject (nnweb-decode-entities-string subject)) - (forward-line 1) + (setq subject (nnweb-decode-entities-string subject)) + (search-forward "
") (if (looking-at - "by ]+>\\([^<]+\\)[ \t\n]*.*(\\([^)]+\\))") + "by[ \t\n]+]+>\\([^<]+\\)[ \t\n]*(\\(<[^>]+>\\)*\\([^<>)]+\\))") (progn (goto-char (- (match-end 0) 5)) - (setq from (concat + (setq from (concat (nnweb-decode-entities-string (match-string 1)) - " <" (match-string 2) ">"))) + " <" (match-string 3) ">"))) (setq from "") - (when (looking-at "by \\(.+\\) on ") + (when (looking-at "by \\([^<>]*\\) on ") (goto-char (- (match-end 0) 5)) (setq from (nnweb-decode-entities-string (match-string 1))))) (search-forward " on ") (setq date (nnslashdot-date-to-date - (buffer-substring (point) (progn (end-of-line) (point))))) - (setq lines (/ (abs (- (search-forward "\n\r") (point))))) + (setq lines (/ (abs (- (search-forward ""))) 70)) - (forward-line 4) - (setq parent - (if (looking-at ".*cid=\\([0-9]+\\)") - (match-string 1) - nil)) - (setq did t) + (if (not + (re-search-forward ".*cid=\\([0-9]+\\)\">Parent" nil t)) + (setq parent nil) + (setq parent (match-string 1)) + (when (string= parent "0") + (setq parent nil))) (push (cons - (1+ article) + article (make-full-mail-header - (1+ article) + article (concat subject " (" score ")") from date - (concat "<" (nnslashdot-sid-strip sid) "%" - (number-to-string (1+ article)) - "@slashdot>") + (concat "<" (nnslashdot-sid-strip sid) "%" cid "@slashdot>") (if parent - (concat "<" (nnslashdot-sid-strip sid) "%" - (number-to-string (1+ (string-to-number parent))) - "@slashdot>") + (concat "<" (nnslashdot-sid-strip sid) "%" + parent "@slashdot>") "") 0 lines nil nil)) - headers))))) + headers) + (while (and articles (<= (car articles) article)) + (pop articles)) + (setq article (1+ article))) + (if nnslashdot-threaded + (progn + (setq start (pop startats)) + (if start (setq start (+ start 2)))) + (setq start (pop articles)))))) + (if changed (nnslashdot-write-groups)) (setq nnslashdot-headers (sort headers 'car-less-than-car)) (save-excursion (set-buffer nntp-server-buffer) @@ -201,108 +212,6 @@ (nnheader-insert-nov (cdr header))))) 'nov)) -(deffoo nnslashdot-sane-retrieve-headers (articles group) - (let ((last (car (last articles))) - (did nil) - (start (max (1- (car articles)) 1)) - (sid (caddr (assoc group nnslashdot-groups))) - headers article subject score from date lines parent point) - (save-excursion - (set-buffer nnslashdot-buffer) - (erase-buffer) - (when (= start 1) - (nnweb-insert (format nnslashdot-article-url - (nnslashdot-sid-strip sid)) t) - (goto-char (point-min)) - (search-forward "Posted by ") - (when (looking-at "]+>\\([^<]+\\)") - (setq from (nnweb-decode-entities-string (match-string 1)))) - (search-forward " on ") - (setq date (nnslashdot-date-to-date - (buffer-substring (point) (1- (search-forward "<"))))) - (forward-line 2) - (setq lines (count-lines (point) - (re-search-forward - "A href=\"\\(http://slashdot.org\\)?/article"))) - (push - (cons - 1 - (make-full-mail-header - 1 group from date (concat "<" (nnslashdot-sid-strip sid) - "%1@slashdot>") - "" 0 lines nil nil)) - headers)) - (while (or (not article) - (and did - (< article last))) - (when article - (setq start (1+ article))) - (setq point (goto-char (point-max))) - (nnweb-insert - (format nnslashdot-comments-url (nnslashdot-sid-strip sid) - nnslashdot-threshold 4 start) - t) - (goto-char point) - (while (re-search-forward - "<\\(b\\|H4\\)>\\([^<]+\\).*score:\\([^)]+\\))" - nil t) - (setq article (string-to-number (match-string 1)) - subject (match-string 3) - score (match-string 5)) - (when (string-match "^Re: *" subject) - (setq subject (concat "Re: " (substring subject (match-end 0))))) - (setq subject (nnweb-decode-entities-string subject)) - (forward-line 1) - (if (looking-at - "by ]+>\\([^<]+\\)[ \t\n]*.*(\\([^)]+\\))") - (progn - (goto-char (- (match-end 0) 5)) - (setq from (concat - (nnweb-decode-entities-string (match-string 1)) - " <" (match-string 2) ">"))) - (setq from "") - (when (looking-at "by \\(.+\\) on ") - (goto-char (- (match-end 0) 5)) - (setq from (nnweb-decode-entities-string (match-string 1))))) - (search-forward " on ") - (setq date - (nnslashdot-date-to-date - (buffer-substring (point) (progn (end-of-line) (point))))) - (setq lines (/ (abs (- (search-forward ""))) - 70)) - (forward-line 2) - (setq parent - (if (looking-at ".*cid=\\([0-9]+\\)") - (match-string 1) - nil)) - (setq did t) - (push - (cons - (1+ article) - (make-full-mail-header - (1+ article) (concat subject " (" score ")") - from date - (concat "<" (nnslashdot-sid-strip sid) "%" - (number-to-string (1+ article)) - "@slashdot>") - (if parent - (concat "<" (nnslashdot-sid-strip sid) "%" - (number-to-string (1+ (string-to-number parent))) - "@slashdot>") - "") - 0 lines nil nil)) - headers)))) - (setq nnslashdot-headers - (sort headers (lambda (s1 s2) (< (car s1) (car s2))))) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (mm-with-unibyte-current-buffer - (dolist (header nnslashdot-headers) - (nnheader-insert-nov (cdr header))))) - 'nov)) - (deffoo nnslashdot-request-group (group &optional server dont-check) (nnslashdot-possibly-change-server nil server) (let ((elem (assoc group nnslashdot-groups))) @@ -325,7 +234,7 @@ (deffoo nnslashdot-request-article (article &optional group server buffer) (nnslashdot-possibly-change-server group server) - (let (contents) + (let (contents cid) (condition-case why (save-excursion (set-buffer nnslashdot-buffer) @@ -333,23 +242,32 @@ (goto-char (point-min)) (when (and (stringp article) (string-match "%\\([0-9]+\\)@" article)) - (setq article (string-to-number (match-string 1 article)))) + (setq cid (match-string 1 article)) + (let ((map (nth 4 (assoc group nnslashdot-groups)))) + (while map + (if (equal (cdar map) cid) + (setq article (caar map) + map nil) + (setq map (cdr map)))))) (when (numberp article) (if (= article 1) (progn - (re-search-forward "Posted by *<[^>]+>[^>]*<[^>]+> *on ") + (re-search-forward + "Posted by") (search-forward "
") (setq contents (buffer-substring (point) (progn (re-search-forward - "

.*A href=\"\\(http://slashdot.org\\)?/article") + "< [ \t\r\n]*" (1- article))) + (setq cid (cdr (assq article + (nth 4 (assoc group nnslashdot-groups))))) + (search-forward (format "" cid)) (setq contents (buffer-substring - (re-search-forward "]+>") + (re-search-forward "]*>") (search-forward ""))))))) (search-failed (nnslashdot-lose why))) @@ -384,10 +302,10 @@ (let ((number 0) sid elem description articles gname) (condition-case why - ;; First we do the Ultramode to get info on all the latest groups. - (progn + ;; First we do the Ultramode to get info on all the latest groups. + (progn (mm-with-unibyte-buffer - (nnweb-insert "http://slashdot.org/slashdot.xml" t) + (nnweb-insert nnslashdot-backslash-url t) (goto-char (point-min)) (while (search-forward "" nil t) (narrow-to-region (point) (search-forward "")) @@ -404,7 +322,8 @@ (setq gname (concat description " (" sid ")")) (if (setq elem (assoc gname nnslashdot-groups)) (setcar (cdr elem) articles) - (push (list gname articles sid) nnslashdot-groups)) + (push (list gname articles sid (current-time) nil) + nnslashdot-groups)) (goto-char (point-max)) (widen))) ;; Then do the older groups. @@ -425,13 +344,14 @@ (setq gname (concat description " (" sid ")")) (if (setq elem (assoc gname nnslashdot-groups)) (setcar (cdr elem) articles) - (push (list gname articles sid) nnslashdot-groups))))) + (push (list gname articles sid (current-time) nil) + nnslashdot-groups))))) (incf number 30))) (search-failed (nnslashdot-lose why))) (nnslashdot-write-groups) (nnslashdot-generate-active) t)) - + (deffoo nnslashdot-request-newgroups (date &optional server) (nnslashdot-possibly-change-server nil server) (nnslashdot-generate-active) @@ -496,6 +416,24 @@ (setq nnslashdot-headers nil nnslashdot-groups nil)) +(deffoo nnslashdot-request-expire-articles + (articles group &optional server force) + (nnslashdot-possibly-change-server group server) + (let ((item (assoc group nnslashdot-groups))) + (when item + (if (fourth item) + (when (and (>= (length articles) (cadr item)) ;; All are expirable. + (nnmail-expired-article-p + group + (fourth item) + force)) + (setq nnslashdot-groups (delq item nnslashdot-groups)) + (nnslashdot-write-groups) + (setq articles nil)) ;; all expired. + (setcdr (cddr item) (list (current-time))) + (nnslashdot-write-groups)))) + articles) + (nnoo-define-skeleton nnslashdot) ;;; Internal functions @@ -508,18 +446,32 @@ (unless nnslashdot-groups (nnslashdot-read-groups))) +(defun nnslashdot-make-tuple (tuple n) + (prog1 + tuple + (while (> n 1) + (unless (cdr tuple) + (setcdr tuple (list nil))) + (setq tuple (cdr tuple) + n (1- n))))) + (defun nnslashdot-read-groups () (let ((file (expand-file-name "groups" nnslashdot-directory))) (when (file-exists-p file) (mm-with-unibyte-buffer (insert-file-contents file) (goto-char (point-min)) - (setq nnslashdot-groups (read (current-buffer))))))) + (setq nnslashdot-groups (read (current-buffer)))) + (if (and nnslashdot-groups (< (length (car nnslashdot-groups)) 5)) + (let ((groups nnslashdot-groups)) + (while groups + (nnslashdot-make-tuple (car groups) 5) + (setq groups (cdr groups)))))))) (defun nnslashdot-write-groups () (with-temp-file (expand-file-name "groups" nnslashdot-directory) - (prin1 nnslashdot-groups (current-buffer)))) - + (gnus-prin1 nnslashdot-groups))) + (defun nnslashdot-init (server) "Initialize buffers and such." (unless (file-exists-p nnslashdot-directory) @@ -528,7 +480,8 @@ (setq nnslashdot-buffer (save-excursion (nnheader-set-temp-buffer - (format " *nnslashdot %s*" server)))))) + (format " *nnslashdot %s*" server)))) + (push nnslashdot-buffer gnus-buffers))) (defun nnslashdot-date-to-date (sdate) (condition-case err @@ -552,11 +505,6 @@ (defun nnslashdot-lose (why) (error "Slashdot HTML has changed; please get a new version of nnslashdot")) -;(defun nnslashdot-sid-strip (sid) -; (if (string-match "^00/" sid) -; (substring sid (match-end 0)) -; sid)) - (defalias 'nnslashdot-sid-strip 'identity) (provide 'nnslashdot) diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index b33a2dbb50e..ffc0532446a 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -1,7 +1,8 @@ ;;; nnspool.el --- spool access for GNU Emacs ;; Copyright (C) 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997, 1998, -;; 2000 Free Software Foundation, Inc. +;; 2000, 2002 +;; Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -327,7 +328,8 @@ there.") () (nnheader-report 'nnspool "") (set-process-sentinel proc 'nnspool-inews-sentinel) - (process-send-region proc (point-min) (point-max)) + (mm-with-unibyte-current-buffer + (process-send-region proc (point-min) (point-max))) ;; We slap a condition-case around this, because the process may ;; have exited already... (ignore-errors diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 803fd975e5e..ad3ed90cc2c 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -1,6 +1,6 @@ ;;; nntp.el --- nntp access for Gnus ;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, 1994, 1995, 1996, -;; 1997, 1998, 2000, 2001 +;; 1997, 1998, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -397,8 +397,10 @@ noticing asynchronous data.") (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) (erase-buffer))) (nntp-encode-text) - (process-send-region (nntp-find-connection nntp-server-buffer) - (point-min) (point-max)) + (mm-with-unibyte-current-buffer + ;; Some encoded unicode text contains character 0x80-0x9f e.g. Euro. + (process-send-region (nntp-find-connection nntp-server-buffer) + (point-min) (point-max))) (nntp-retrieve-data nil nntp-address nntp-port-number nntp-server-buffer wait-for nnheader-callback-function)) diff --git a/lisp/gnus/nnultimate.el b/lisp/gnus/nnultimate.el index 6ccb0a2aec8..5ce8446da11 100644 --- a/lisp/gnus/nnultimate.el +++ b/lisp/gnus/nnultimate.el @@ -56,6 +56,8 @@ (defvoo nnultimate-groups nil) (defvoo nnultimate-headers nil) (defvoo nnultimate-articles nil) +(defvar nnultimate-table-regexp + "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") ;;; Interface functions @@ -74,13 +76,17 @@ (old-total (or (nth 6 entry) 1)) (furl "forumdisplay.cgi?action=topics&number=%d&DaysPrune=1000") (furls (list (concat nnultimate-address (format furl sid)))) + (nnultimate-table-regexp + "postings.*editpost\\|forumdisplay\\|getbio") headers article subject score from date lines parent point contents tinfo fetchers map elem a href garticles topic old-max - inc datel table string current-page total-contents pages + inc datel table current-page total-contents pages farticles forum-contents parse furl-fetched mmap farticle) (setq map mapping) (while (and (setq article (car articles)) map) + ;; Skip past the articles in the map until we reach the + ;; article we're looking for. (while (and map (or (> article (caar map)) (< (cadar map) (caar map)))) @@ -101,7 +107,7 @@ fetchers)) (pop articles) (setq article (car articles))))) - ;; Now we have the mapping from/to Gnus/nnultimate article numbers, + ;; Now we have the mapping from/to Gnus/nnultimate article numbers, ;; so we start fetching the topics that we need to satisfy the ;; request. (if (not fetchers) @@ -128,22 +134,27 @@ (setq contents (ignore-errors (w3-parse-buffer (current-buffer)))) (setq table (nnultimate-find-forum-table contents)) - (setq string (mapconcat 'identity (nnweb-text table) "")) - (when (string-match "topic is \\([0-9]\\) pages" string) - (setq pages (string-to-number (match-string 1 string))) - (setcdr table nil) - (setq table (nnultimate-find-forum-table contents))) + (goto-char (point-min)) + (when (re-search-forward "topic is \\([0-9]+\\) pages" nil t) + (setq pages (string-to-number (match-string 1)))) (setq contents (cdr (nth 2 (car (nth 2 table))))) (setq total-contents (nconc total-contents contents)) (incf current-page)) - ;;(setq total-contents (nreverse total-contents)) - (dolist (art (cdr elem)) - (if (not (nth (1- (cdr art)) total-contents)) - () ;(debug) - (push (list (car art) - (nth (1- (cdr art)) total-contents) - subject) - nnultimate-articles))))) + (when t + (let ((i 0)) + (dolist (co total-contents) + (push (list (or (nnultimate-topic-article-to-article + group (car elem) (incf i)) + 1) + co subject) + nnultimate-articles)))) + (when nil + (dolist (art (cdr elem)) + (when (nth (1- (cdr art)) total-contents) + (push (list (car art) + (nth (1- (cdr art)) total-contents) + subject) + nnultimate-articles)))))) (setq nnultimate-articles (sort nnultimate-articles 'car-less-than-car)) ;; Now we have all the articles, conveniently in an alist @@ -161,17 +172,26 @@ (setq date (substring (car datel) (match-end 0)) datel nil)) (pop datel)) - (setq date (delete "" (split-string date "[- \n\t\r    ]"))) - (if (or (member "AM" date) - (member "PM" date)) + (when date + (setq date (delete "" (split-string + date "[-, \n\t\r    ]"))) + (if (or (member "AM" date) + (member "PM" date)) + (setq date (format + "%s %s %s %s" + (nth 1 date) + (if (and (>= (length (nth 0 date)) 3) + (assoc (downcase + (substring (nth 0 date) 0 3)) + parse-time-months)) + (substring (nth 0 date) 0 3) + (car (rassq (string-to-number (nth 0 date)) + parse-time-months))) + (nth 2 date) (nth 3 date))) (setq date (format "%s %s %s %s" - (car (rassq (string-to-number (nth 0 date)) + (car (rassq (string-to-number (nth 1 date)) parse-time-months)) - (nth 1 date) (nth 2 date) (nth 3 date))) - (setq date (format "%s %s %s %s" - (car (rassq (string-to-number (nth 1 date)) - parse-time-months)) - (nth 0 date) (nth 2 date) (nth 3 date)))) + (nth 0 date) (nth 2 date) (nth 3 date))))) (push (cons article @@ -180,7 +200,7 @@ from (or date "") (concat "<" (number-to-string sid) "%" (number-to-string article) - "@ultimate>") + "@ultimate." server ">") "" 0 (/ (length (mapconcat 'identity @@ -199,6 +219,16 @@ (nnheader-insert-nov (cdr header)))))) 'nov))) +(defun nnultimate-topic-article-to-article (group topic article) + (catch 'found + (dolist (elem (nth 5 (assoc group nnultimate-groups))) + (when (and (= topic (nth 2 elem)) + (>= article (nth 3 elem)) + (< article (+ (- (nth 1 elem) (nth 0 elem)) 1 + (nth 3 elem)))) + (throw 'found + (+ (nth 0 elem) (- article (nth 3 elem)))))))) + (deffoo nnultimate-request-group (group &optional server dont-check) (nnultimate-possibly-change-server nil server) (when (not nnultimate-groups) @@ -330,7 +360,7 @@ ;; the group is entered, there's 2 new articles in topic one ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 ;; in topic one and 10 will be the 2 in topic three. - (dolist (row (reverse forum-contents)) + (dolist (row (nreverse forum-contents)) (setq row (nth 2 row)) (when (setq a (nnweb-parse-find 'a row)) (setq subject (car (last (nnweb-text a))) @@ -403,7 +433,7 @@ nnultimate-groups-alist) (with-temp-file (expand-file-name "groups" nnultimate-directory) (prin1 nnultimate-groups-alist (current-buffer)))) - + (defun nnultimate-init (server) "Initialize buffers and such." (unless (file-exists-p nnultimate-directory) @@ -438,9 +468,7 @@ (nth 2 parse)))) (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) case-fold-search) - (when (and href (string-match - "postings\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio" - href)) + (when (and href (string-match nnultimate-table-regexp href)) t)))) (provide 'nnultimate) diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index c4ff7248e6b..740b182639f 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -1,5 +1,5 @@ ;;; nnweb.el --- retrieving articles via web search engines -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -55,25 +55,48 @@ (defvoo nnweb-directory (nnheader-concat gnus-directory "nnweb/") "Where nnweb will save its files.") -(defvoo nnweb-type 'dejanews +(defvoo nnweb-type 'google "What search engine type is being used. -Valid types include `dejanews', `dejanewsold', `reference', +Valid types include `google', `dejanews', `dejanewsold', `reference', and `altavista'.") (defvar nnweb-type-definition - '((dejanews + '( + (google + ;;(article . nnweb-google-wash-article) + ;;(id . "http://groups.google.com/groups?as_umsgid=%s") (article . ignore) - (id . "http://search.dejanews.com/msgid.xp?MID=%s&fmt=text") - (map . nnweb-dejanews-create-mapping) - (search . nnweb-dejanews-search) - (address . "http://www.deja.com/=dnc/qs.xp") - (identifier . nnweb-dejanews-identity)) - (dejanewsold + (id . "http://groups.google.com/groups?selm=%s&output=gplain") + ;;(reference . nnweb-google-reference) + (reference . identity) + (map . nnweb-google-create-mapping) + (search . nnweb-google-search) + (address . "http://groups.google.com/groups") + (identifier . nnweb-google-identity)) + (dejanews ;; alias of google + ;;(article . nnweb-google-wash-article) + ;;(id . "http://groups.google.com/groups?as_umsgid=%s") (article . ignore) - (map . nnweb-dejanews-create-mapping) - (search . nnweb-dejanewsold-search) - (address . "http://www.deja.com/dnquery.xp") - (identifier . nnweb-dejanews-identity)) + (id . "http://groups.google.com/groups?selm=%s&output=gplain") + ;;(reference . nnweb-google-reference) + (reference . identity) + (map . nnweb-google-create-mapping) + (search . nnweb-google-search) + (address . "http://groups.google.com/groups") + (identifier . nnweb-google-identity)) +;;; (dejanews +;;; (article . ignore) +;;; (id . "http://search.dejanews.com/msgid.xp?MID=%s&fmt=text") +;;; (map . nnweb-dejanews-create-mapping) +;;; (search . nnweb-dejanews-search) +;;; (address . "http://www.deja.com/=dnc/qs.xp") +;;; (identifier . nnweb-dejanews-identity)) +;;; (dejanewsold +;;; (article . ignore) +;;; (map . nnweb-dejanews-create-mapping) +;;; (search . nnweb-dejanewsold-search) +;;; (address . "http://www.deja.com/dnquery.xp") +;;; (identifier . nnweb-dejanews-identity)) (reference (article . nnweb-reference-wash-article) (map . nnweb-reference-create-mapping) @@ -124,6 +147,8 @@ and `altavista'.") (deffoo nnweb-request-scan (&optional group server) (nnweb-possibly-change-server group server) + (if nnweb-ephemeral-p + (setq nnweb-hashtb (gnus-make-hashtable 4095))) (funcall (nnweb-definition 'map)) (unless nnweb-ephemeral-p (nnweb-write-active) @@ -134,9 +159,10 @@ and `altavista'.") (when (and group (not (equal group nnweb-group)) (not nnweb-ephemeral-p)) + (setq nnweb-group group + nnweb-articles nil) (let ((info (assoc group nnweb-group-alist))) (when info - (setq nnweb-group group) (setq nnweb-type (nth 2 info)) (setq nnweb-search (nth 3 info)) (unless dont-check @@ -175,17 +201,19 @@ and `altavista'.") (and (stringp article) (nnweb-definition 'id t) (let ((fetch (nnweb-definition 'id)) - art) + art active) (when (string-match "^<\\(.*\\)>$" article) (setq art (match-string 1 article))) - (and fetch - art - (mm-with-unibyte-current-buffer - (nnweb-fetch-url - (format fetch article))))))) + (when (and fetch art) + (setq url (format fetch art)) + (mm-with-unibyte-current-buffer + (nnweb-fetch-url url)) + (if (nnweb-definition 'reference t) + (setq article + (funcall (nnweb-definition + 'reference) article))))))) (unless nnheader-callback-function - (funcall (nnweb-definition 'article)) - (nnweb-decode-entities)) + (funcall (nnweb-definition 'article))) (nnheader-report 'nnweb "Fetched article %s" article) (cons group (and (numberp article) article)))))) @@ -290,10 +318,11 @@ and `altavista'.") (nnweb-open-server server))) (unless nnweb-group-alist (nnweb-read-active)) + (unless nnweb-hashtb + (setq nnweb-hashtb (gnus-make-hashtable 4095))) (when group (when (and (not nnweb-ephemeral-p) - (not (equal group nnweb-group))) - (setq nnweb-hashtb (gnus-make-hashtable 4095)) + (equal group nnweb-group)) (nnweb-request-group group nil t)))) (defun nnweb-init (server) @@ -393,7 +422,7 @@ and `altavista'.") (car (rassq (string-to-number (match-string 2 date)) parse-time-months)) - (match-string 3 date) + (match-string 3 date) (match-string 1 date))) (setq date "Jan 1 00:00:00 0000")) (incf i) @@ -559,6 +588,7 @@ and `altavista'.") (while (search-forward "," nil t) (replace-match " " t t))) (widen) + (nnweb-decode-entities) (set-marker body nil)))) (defun nnweb-reference-search (search) @@ -663,7 +693,8 @@ and `altavista'.") (while (re-search-forward "[0-9]+" nil t) (replace-match "<\\1> " t))) (widen) - (nnweb-remove-markup))) + (nnweb-remove-markup) + (nnweb-decode-entities))) (defun nnweb-altavista-search (search &optional part) (url-insert-file-contents @@ -682,6 +713,140 @@ and `altavista'.") (setq buffer-file-name nil) t) +;;; +;;; Deja bought by google.com +;;; + +(defun nnweb-google-wash-article () + (let ((case-fold-search t) url) + (goto-char (point-min)) + (re-search-forward "^

" nil t)
+    (narrow-to-region (point-min) (point))
+    (search-backward "" nil t)
+      (replace-match "\n"))
+    (nnweb-remove-markup)
+    (goto-char (point-min))
+    (while (re-search-forward "^[ \t]*\n" nil t)
+      (replace-match ""))
+    (goto-char (point-max))
+    (insert "\n")
+    (widen)
+    (narrow-to-region (point) (point-max))
+    (search-forward "" nil t)
+    (delete-region (point) (point-max))
+    (nnweb-remove-markup)
+    (widen)))
+
+(defun nnweb-google-parse-1 (&optional Message-ID)
+  (let ((i 0)
+	(case-fold-search t)
+	(active (cadr (assoc nnweb-group nnweb-group-alist)))
+	Subject Score Date Newsgroups From
+	map url mid)
+    (unless active
+      (push (list nnweb-group (setq active (cons 1 0))
+		  nnweb-type nnweb-search)
+	    nnweb-group-alist))
+    ;; Go through all the article hits on this page.
+    (goto-char (point-min))
+    (while (re-search-forward
+	    "a href=/groups\\(\\?[^ \">]*selm=\\([^ &\">]+\\)\\)" nil t)
+      (setq mid (match-string 2)
+	    url (format 
+		 "http://groups.google.com/groups?selm=%s&output=gplain" mid))
+      (narrow-to-region (search-forward ">" nil t)
+			(search-forward "" nil t))
+      (nnweb-remove-markup)
+      (nnweb-decode-entities)
+      (setq Subject (buffer-string))
+      (goto-char (point-max))
+      (widen)
+      (forward-line 1)
+      (when (looking-at "
]+>")
+	(goto-char (match-end 0)))
+      (if (not (looking-at "]+>"))
+	  (skip-chars-forward " \t")
+	(narrow-to-region (point)
+			  (search-forward "" nil t))
+	(nnweb-remove-markup)
+	(nnweb-decode-entities)
+	(setq Newsgroups (buffer-string))
+	(goto-char (point-max))
+	(widen)
+	(skip-chars-forward "- \t"))
+      (when (looking-at
+	     "\\([0-9]+[/ ][A-Za-z]+[/ ][0-9]+\\)[ \t]*by[ \t]*\\([^<]*\\) - ]+\\)" url)
+      (match-string 1 url)
+    url))
+
 ;;;
 ;;; General web/w3 interface utility functions
 ;;;
@@ -689,7 +854,7 @@ and `altavista'.")
 (defun nnweb-insert-html (parse)
   "Insert HTML based on a w3 parse tree."
   (if (stringp parse)
-      (insert parse)
+      (insert (nnheader-string-as-multibyte parse))
     (insert "<" (symbol-name (car parse)) " ")
     (insert (mapconcat
 	     (lambda (param)
@@ -729,7 +894,7 @@ and `altavista'.")
   (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+\\);" nil t)
     (let ((elem (if (eq (aref (match-string 1) 0) ?\#)
 			(let ((c
-			       (string-to-number (substring 
+			       (string-to-number (substring
 						  (match-string 1) 1))))
 			  (if (mm-char-or-char-int-p c) c 32))
 		      (or (cdr (assq (intern (match-string 1))
@@ -739,9 +904,9 @@ and `altavista'.")
 	(setq elem (char-to-string elem)))
       (replace-match elem t t))))
 
-(defun nnweb-decode-entities-string (str)
+(defun nnweb-decode-entities-string (string)
   (with-temp-buffer
-    (insert str)
+    (insert string)
     (nnweb-decode-entities)
     (buffer-substring (point-min) (point-max))))
 
@@ -760,12 +925,12 @@ and `altavista'.")
   "Insert the contents from an URL in the current buffer.
 If FOLLOW-REFRESH is non-nil, redirect refresh url in META."
   (let ((name buffer-file-name))
-    (if follow-refresh
+    (if follow-refresh 
 	(save-restriction
 	  (narrow-to-region (point) (point))
 	  (url-insert-file-contents url)
 	  (goto-char (point-min))
-	  (when (re-search-forward 
+	  (when (re-search-forward
 		 "]*URL=\\([^\"]+\\)\"" nil t)
 	    (let ((url (match-string 1)))
 	      (delete-region (point-min) (point-max))
@@ -822,6 +987,11 @@ If FOLLOW-REFRESH is non-nil, redirect refresh url in META."
 		 (listp (cdr element)))
 	(nnweb-text-1 element)))))
 
+(defun nnweb-replace-in-string (string match newtext)
+  (while (string-match match string)
+    (setq string (replace-match newtext t t string)))
+  string)
+
 (provide 'nnweb)
 
 ;;; nnweb.el ends here