X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fgnus-art.el;h=595c6f714e79850d96476510aebc25694873ef81;hb=fc45c122f629ca33c51860601e86df8faf00a0c2;hp=f1b4b6d682cde747cdaaff6f9516751bd9b82beb;hpb=097cf341cfee92e9d5d30de9bdbc14a50ddfe414;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index f1b4b6d..595c6f7 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,8 +1,10 @@ -;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;;; gnus-art.el --- article mode commands for Semi-gnus +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen -;; Keywords: news +;; Author: Lars Magne Ingebrigtsen +;; MORIOKA Tomohiko +;; Katsumi Yamaoka +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -33,6 +35,8 @@ (require 'gnus-spec) (require 'gnus-int) (require 'browse-url) +(require 'alist) +(require 'mime-view) (defgroup gnus-article nil "Article display." @@ -91,11 +95,26 @@ :group 'gnus-article) (defcustom gnus-ignored-headers - '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:" - "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:" - "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:" - "^Approved:" "^Sender:" "^Received:" "^Mail-from:") - "All headers that start with this regexp will be hidden. + '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:" + "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:" + "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:" + "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:" + "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:" + "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:" + "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:" + "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:" + "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:" + "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:" + "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:" + "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" + "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" + "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" + "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:" + "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:" + "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" + "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" + "^Status:") + "*All headers that start with this regexp will be hidden. This variable can also be a list of regexps of headers to be ignored. If `gnus-visible-headers' is non-nil, this variable will be ignored." :type '(choice :custom-show nil @@ -104,8 +123,8 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :group 'gnus-article-hiding) (defcustom gnus-visible-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:" - "All headers that do not match this regexp will be hidden. + "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:" + "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." :type '(repeat :value-to-internal (lambda (widget value) @@ -119,7 +138,7 @@ If this variable is non-nil, `gnus-ignored-headers' will be ignored." (defcustom gnus-sorted-header-list '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:") - "This variable is a list of regular expressions. + "*This variable is a list of regular expressions. If it is non-nil, headers that match the regular expressions will be placed first in the article buffer in the sequence specified by this list." @@ -168,7 +187,7 @@ regexp. If it matches, the text in question is not a signature." (defcustom gnus-article-x-face-command "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" - "String or function to be executed to display an X-Face header. + "*String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." :type 'string ;Leave function case to Lisp. @@ -196,9 +215,9 @@ asynchronously. The compressed face will be piped to this command." (lambda (spec) (list (format format (car spec) (cadr spec)) - 2 3 (intern (format "gnus-emphasis-%s" (caddr spec))))) + 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) types))) - "Alist that says how to fontify certain phrases. + "*Alist that says how to fontify certain phrases. Each item looks like this: (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) @@ -247,8 +266,12 @@ Esample: (_/*word*/_)." (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" "Format for display of Date headers in article bodies. -See `format-time-string' for the possible values." - :type 'string +See `format-time-string' for the possible values. + +The variable can also be function, which should return a complete Date +header. The function is called with one argument, the time, which can +be fed to `format-time-string'." + :type '(choice string symbol) :link '(custom-manual "(gnus)Article Date") :group 'gnus-article-washing) @@ -332,7 +355,7 @@ LAST-FILE." (defcustom gnus-split-methods '((gnus-article-archive-name) (gnus-article-nndoc-name)) - "Variable used to suggest where articles are to be saved. + "*Variable used to suggest where articles are to be saved. For instance, if you would like to save articles related to Gnus in the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", you could set this variable to something like: @@ -357,18 +380,20 @@ be used as possible file names." (sexp :value nil)))) (defcustom gnus-strict-mime t - "*If nil, MIME-decode even if there is no Mime-Version header." + "*If nil, MIME-decode even if there is no MIME-Version header." :group 'gnus-article-mime :type 'boolean) -(defcustom gnus-show-mime-method 'metamail-buffer - "Function to process a MIME message. +(defcustom gnus-article-display-method-for-mime + 'gnus-article-display-mime-message + "Function to display a MIME message. The function is called from the article buffer." :group 'gnus-article-mime :type 'function) -(defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable - "*Function to decode MIME encoded words. +(defcustom gnus-article-display-method-for-traditional + 'gnus-article-display-traditional-message + "*Function to display a traditional message. The function is called from the article buffer." :group 'gnus-article-mime :type 'function) @@ -440,12 +465,12 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." (defface gnus-header-from-face '((((class color) (background dark)) - (:foreground "spring green" :bold t)) + (:foreground "spring green")) (((class color) (background light)) - (:foreground "red3" :bold t)) + (:foreground "red3")) (t - (:bold t :italic t))) + (:italic t))) "Face used for displaying from headers." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -453,10 +478,10 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." (defface gnus-header-subject-face '((((class color) (background dark)) - (:foreground "SeaGreen3" :bold t)) + (:foreground "SeaGreen3")) (((class color) (background light)) - (:foreground "red4" :bold t)) + (:foreground "red4")) (t (:bold t :italic t))) "Face used for displaying subject headers." @@ -466,12 +491,12 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." (defface gnus-header-newsgroups-face '((((class color) (background dark)) - (:foreground "yellow" :bold t :italic t)) + (:foreground "yellow" :italic t)) (((class color) (background light)) - (:foreground "MidnightBlue" :bold t :italic t)) + (:foreground "MidnightBlue" :italic t)) (t - (:bold t :italic t))) + (:italic t))) "Face used for displaying newsgroups headers." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -506,7 +531,7 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." ("Subject" nil gnus-header-subject-face) ("Newsgroups:.*," nil gnus-header-newsgroups-face) ("" gnus-header-name-face gnus-header-content-face)) - "Controls highlighting of article header. + "*Controls highlighting of article header. An alist of the form (HEADER NAME CONTENT). @@ -530,6 +555,7 @@ displayed by the first non-nil matching CONTENT face." ;;; Internal variables (defvar article-lapsed-timer nil) +(defvar gnus-article-current-summary nil) (defvar gnus-article-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) @@ -543,8 +569,8 @@ Initialized from `text-mode-syntax-table.") (defvar gnus-save-article-buffer nil) (defvar gnus-article-mode-line-format-alist - (nconc '((?w (gnus-article-wash-status) ?s)) - gnus-summary-mode-line-format-alist)) + (nconc '((?w (gnus-article-wash-status) ?s)) + gnus-summary-mode-line-format-alist)) (defvar gnus-number-of-articles-to-be-saved nil) @@ -571,7 +597,7 @@ Initialized from `text-mode-syntax-table.") b e (cons 'article-type (cons type gnus-hidden-properties)))) (defun gnus-article-unhide-text-type (b e type) - "Hide text of TYPE between B and E." + "Unhide text of TYPE between B and E." (remove-text-properties b e (cons 'article-type (cons type gnus-hidden-properties))) (when (memq 'intangible gnus-hidden-properties) @@ -633,6 +659,7 @@ always hide." (save-excursion (save-restriction (let ((buffer-read-only nil) + (case-fold-search t) (props (nconc (list 'article-type 'headers) gnus-hidden-properties)) (max (1+ (length gnus-sorted-header-list))) @@ -649,7 +676,7 @@ always hide." (listp gnus-visible-headers)) (mapconcat 'identity gnus-visible-headers "\\|")))) (inhibit-point-motion-hooks t) - want-list beg) + beg) ;; First we narrow to just the headers. (widen) (goto-char (point-min)) @@ -742,8 +769,8 @@ always hide." from reply-to (ignore-errors (equal - (nth 1 (mail-extract-address-components from)) - (nth 1 (mail-extract-address-components reply-to))))) + (nth 1 (funcall gnus-extract-address-components from)) + (nth 1 (funcall gnus-extract-address-components reply-to))))) (gnus-article-hide-header "reply-to")))) ((eq elem 'date) (let ((date (message-fetch-field "date"))) @@ -814,7 +841,7 @@ characters to translate to." (when (search-forward "\n\n" nil t) (let ((buffer-read-only nil)) (while (search-forward "\b" nil t) - (let ((next (following-char)) + (let ((next (char-after)) (previous (char-after (- (point) 2)))) ;; We do the boldification/underlining by hiding the ;; overstrikes and putting the proper text property @@ -847,7 +874,7 @@ characters to translate to." (adaptive-fill-mode t)) (while (not (eobp)) (and (>= (current-column) (min fill-column (window-width))) - (/= (preceding-char) ?:) + (not (eq (char-before) ?:)) (fill-paragraph nil)) (end-of-line 2)))))) @@ -884,12 +911,13 @@ characters to translate to." (delete-process "article-x-face")) (let ((inhibit-point-motion-hooks t) (case-fold-search t) - from) + from last) (save-restriction (nnheader-narrow-to-headers) (setq from (message-fetch-field "from")) (goto-char (point-min)) (while (and gnus-article-x-face-command + (not last) (or force ;; Check whether this face is censored. (not gnus-article-x-face-too-ugly) @@ -898,6 +926,12 @@ characters to translate to." from)))) ;; Has to be present. (re-search-forward "^X-Face: " nil t)) + ;; This used to try to do multiple faces (`while' instead of + ;; `when' above), but (a) sending multiple EOFs to xv doesn't + ;; work (b) it can crash some versions of Emacs (c) are + ;; multiple faces really something to encourage? + (when (stringp gnus-article-x-face-command) + (setq last t)) ;; We now have the area of the buffer where the X-Face is stored. (save-excursion (let ((beg (point)) @@ -918,84 +952,14 @@ characters to translate to." (process-send-region "article-x-face" beg end) (process-send-eof "article-x-face")))))))))) -(defun gnus-hack-decode-rfc1522 () - "Emergency hack function for avoiding problems when decoding." - (let ((buffer-read-only nil)) - (goto-char (point-min)) - ;; Remove encoded TABs. - (while (search-forward "=09" nil t) - (replace-match " " t t)) - ;; Remove encoded newlines. - (goto-char (point-min)) - (while (search-forward "=10" nil t) - (replace-match " " t t)))) - -(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) -(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) -(defun article-decode-rfc1522 () - "Hack to remove QP encoding from headers." - (let ((case-fold-search t) - (inhibit-point-motion-hooks t) - (buffer-read-only nil) - string) - (save-restriction - (narrow-to-region - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point-max))) - (goto-char (point-min)) - (while (re-search-forward - "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) - (setq string (match-string 1)) - (save-restriction - (narrow-to-region (match-beginning 0) (match-end 0)) - (delete-region (point-min) (point-max)) - (insert string) - (article-mime-decode-quoted-printable - (goto-char (point-min)) (point-max)) - (subst-char-in-region (point-min) (point-max) ?_ ? ) - (goto-char (point-max))) - (goto-char (point-min)))))) - -(defun article-de-quoted-unreadable (&optional force) - "Do a naive translation of a quoted-printable-encoded article. -This is in no way, shape or form meant as a replacement for real MIME -processing, but is simply a stop-gap measure until MIME support is -written. -If FORCE, decode the article whether it is marked as quoted-printable -or not." - (interactive (list 'force)) - (save-excursion - (let ((case-fold-search t) - (buffer-read-only nil) - (type (gnus-fetch-field "content-transfer-encoding"))) - (gnus-article-decode-rfc1522) - (when (or force - (and type (string-match "quoted-printable" (downcase type)))) - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (article-mime-decode-quoted-printable (point) (point-max)))))) - -(defun article-mime-decode-quoted-printable-buffer () - "Decode Quoted-Printable in the current buffer." - (article-mime-decode-quoted-printable (point-min) (point-max))) - -(defun article-mime-decode-quoted-printable (from to) - "Decode Quoted-Printable in the region between FROM and TO." - (interactive "r") - (goto-char from) - (while (search-forward "=" to t) - (cond ((eq (following-char) ?\n) - (delete-char -1) - (delete-char 1)) - ((looking-at "[0-9A-F][0-9A-F]") - (subst-char-in-region - (1- (point)) (point) ?= - (hexl-hex-string-to-integer - (buffer-substring (point) (+ 2 (point))))) - (delete-char 2)) - ((looking-at "=") - (delete-char 1)) - ((gnus-message 3 "Malformed MIME quoted-printable message"))))) +(defun gnus-article-decode-rfc1522 () + "Decode MIME encoded-words in header fields." + (let (buffer-read-only) + (let ((charset (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset))) + (mime-decode-header-in-buffer charset) + ))) (defun article-hide-pgp (&optional arg) "Toggle hiding of any PGP headers and signatures in the current article. @@ -1010,29 +974,27 @@ always hide." (goto-char (point-min)) ;; Hide the "header". (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) - (gnus-article-hide-text-type (1+ (match-beginning 0)) - (match-end 0) 'pgp) + (delete-region (1+ (match-beginning 0)) (match-end 0)) (setq beg (point)) ;; Hide the actual signature. (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) (setq end (1+ (match-beginning 0))) - (gnus-article-hide-text-type + (delete-region end (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) (match-end 0) ;; Perhaps we shouldn't hide to the end of the buffer ;; if there is no end to the signature? - (point-max)) - 'pgp)) + (point-max)))) ;; Hide "- " PGP quotation markers. (when (and beg end) (narrow-to-region beg end) (goto-char (point-min)) (while (re-search-forward "^- " nil t) - (gnus-article-hide-text-type - (match-beginning 0) (match-end 0) 'pgp)) + (delete-region + (match-beginning 0) (match-end 0))) (widen)) - (run-hooks 'gnus-article-hide-pgp-hook)))))) + (gnus-run-hooks 'gnus-article-hide-pgp-hook)))))) (defun article-hide-pem (&optional arg) "Toggle hiding of any PEM headers and signatures in the current article. @@ -1122,42 +1084,43 @@ always hide." (article-remove-trailing-blank-lines) (article-strip-multiple-blank-lines)) -(defvar mime::preview/content-list) -(defvar mime::preview-content-info/point-min) +(defun article-strip-all-blank-lines () + "Strip all blank lines." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "^[ \t]*\n" nil t) + (replace-match "" t t))))) + (defun gnus-article-narrow-to-signature () "Narrow to the signature; return t if a signature is found, else nil." (widen) - (when (and (boundp 'mime::preview/content-list) - mime::preview/content-list) - ;; We have a MIMEish article, so we use the MIME data to narrow. - (let ((pcinfo (car (last mime::preview/content-list)))) - (ignore-errors - (narrow-to-region - (funcall (intern "mime::preview-content-info/point-min") pcinfo) - (point-max))))) - - (when (gnus-article-search-signature) - (forward-line 1) - ;; Check whether we have some limits to what we consider - ;; to be a signature. - (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit - (list gnus-signature-limit))) - limit limited) - (while (setq limit (pop limits)) - (if (or (and (integerp limit) - (< (- (point-max) (point)) limit)) - (and (floatp limit) - (< (count-lines (point) (point-max)) limit)) - (and (gnus-functionp limit) - (funcall limit)) - (and (stringp limit) - (not (re-search-forward limit nil t)))) - () ; This limit did not succeed. - (setq limited t - limits nil))) - (unless limited - (narrow-to-region (point) (point-max)) - t)))) + (let ((inhibit-point-motion-hooks t)) + (when (gnus-article-search-signature) + (forward-line 1) + ;; Check whether we have some limits to what we consider + ;; to be a signature. + (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit + (list gnus-signature-limit))) + limit limited) + (while (setq limit (pop limits)) + (if (or (and (integerp limit) + (< (- (point-max) (point)) limit)) + (and (floatp limit) + (< (count-lines (point) (point-max)) limit)) + (and (gnus-functionp limit) + (funcall limit)) + (and (stringp limit) + (not (re-search-forward limit nil t)))) + () ; This limit did not succeed. + (setq limited t + limits nil))) + (unless limited + (narrow-to-region (point) (point-max)) + t))))) (defun gnus-article-search-signature () "Search the current buffer for the signature separator. @@ -1234,8 +1197,7 @@ means show, 0 means toggle." (defun gnus-article-hidden-text-p (type) "Say whether the current buffer contains hidden text of type TYPE." - (let ((start (point-min)) - (pos (text-property-any (point-min) (point-max) 'article-type type))) + (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) (while (and pos (not (get-text-property pos 'invisible))) (setq pos @@ -1336,9 +1298,25 @@ how much time has lapsed since DATE." (concat "Date: " date)) ;; Let the user define the format. ((eq type 'user) + (if (gnus-functionp gnus-article-time-format) + (funcall + gnus-article-time-format + (ignore-errors + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT")))) + (concat + "Date: " + (format-time-string gnus-article-time-format + (ignore-errors + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT"))))))) + ;; ISO 8601. + ((eq type 'iso8601) (concat "Date: " - (format-time-string gnus-article-time-format + (format-time-string "%Y%M%DT%h%m%s" (ignore-errors (gnus-encode-date (timezone-make-date-arpa-standard @@ -1417,13 +1395,14 @@ function and want to see what the date was before converting." (defun article-update-date-lapsed () "Function to be run from a timer to update the lapsed time line." - (save-excursion - (ignore-errors - (when (gnus-buffer-live-p gnus-article-buffer) - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (when (re-search-forward "^X-Sent:" nil t) - (article-date-lapsed t)))))) + (let (deactivate-mark) + (save-excursion + (ignore-errors + (when (gnus-buffer-live-p gnus-article-buffer) + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + (when (re-search-forward "^X-Sent:" nil t) + (article-date-lapsed t))))))) (defun gnus-start-date-timer (&optional n) "Start a timer to update the X-Sent header in the article buffers. @@ -1433,7 +1412,7 @@ is to run." (unless n (setq n 1)) (gnus-stop-date-timer) - (setq article-lapsed-timer + (setq article-lapsed-timer (nnheader-run-at-time 1 n 'article-update-date-lapsed))) (defun gnus-stop-date-timer () @@ -1449,6 +1428,11 @@ This format is defined by the `gnus-article-time-format' variable." (interactive (list t)) (article-date-ut 'user highlight)) +(defun article-date-iso8601 (&optional highlight) + "Convert the current article date to ISO8601." + (interactive (list t)) + (article-date-ut 'iso8601 highlight)) + (defun article-show-all () "Show all hidden text in the article buffer." (interactive) @@ -1516,7 +1500,7 @@ This format is defined by the `gnus-article-time-format' variable." (gnus-number-of-articles-to-be-saved (when (eq gnus-prompt-before-saving t) num))) ; Magic - (set-buffer gnus-summary-buffer) + (set-buffer gnus-article-current-summary) (funcall gnus-default-article-saver filename))))) (defun gnus-read-save-file-name (prompt &optional filename @@ -1613,7 +1597,6 @@ This format is defined by the `gnus-article-time-format' variable." "Append this article to Rmail file. Optional argument FILENAME specifies file name. Directory to save to is default to `gnus-article-save-directory'." - (interactive) (setq filename (gnus-read-save-file-name "Save %s in rmail file:" filename gnus-rmail-save-name gnus-newsgroup-name @@ -1629,7 +1612,6 @@ Directory to save to is default to `gnus-article-save-directory'." "Append this article to Unix mail file. Optional argument FILENAME specifies file name. Directory to save to is default to `gnus-article-save-directory'." - (interactive) (setq filename (gnus-read-save-file-name "Save %s in Unix mail file:" filename gnus-mail-save-name gnus-newsgroup-name @@ -1648,7 +1630,6 @@ Directory to save to is default to `gnus-article-save-directory'." "Append this article to file. Optional argument FILENAME specifies file name. Directory to save to is default to `gnus-article-save-directory'." - (interactive) (setq filename (gnus-read-save-file-name "Save %s in file:" filename gnus-file-save-name gnus-newsgroup-name @@ -1667,14 +1648,12 @@ Directory to save to is default to `gnus-article-save-directory'." "Write this article to a file. Optional argument FILENAME specifies file name. The directory to save in defaults to `gnus-article-save-directory'." - (interactive) (gnus-summary-save-in-file nil t)) (defun gnus-summary-save-body-in-file (&optional filename) "Append this article body to a file. Optional argument FILENAME specifies file name. The directory to save in defaults to `gnus-article-save-directory'." - (interactive) (setq filename (gnus-read-save-file-name "Save %s body in file:" filename gnus-file-save-name gnus-newsgroup-name @@ -1691,7 +1670,6 @@ The directory to save in defaults to `gnus-article-save-directory'." (defun gnus-summary-save-in-pipe (&optional command) "Pipe this article to subprocess." - (interactive) (setq command (cond ((eq command 'default) gnus-last-shell-command) @@ -1805,8 +1783,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is (article-fill . gnus-article-word-wrap) article-remove-cr article-display-x-face - article-de-quoted-unreadable - article-mime-decode-quoted-printable article-hide-pgp article-hide-pem article-hide-signature @@ -1815,7 +1791,9 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-strip-multiple-blank-lines article-strip-leading-space article-strip-blank-lines + article-strip-all-blank-lines article-date-local + article-date-iso8601 article-date-original article-date-ut article-date-user @@ -1855,8 +1833,28 @@ If variable `gnus-use-long-file-name' is non-nil, it is "\M-^" gnus-article-read-summary-keys "\M-g" gnus-article-read-summary-keys) -(substitute-key-definition - 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) +;; Define almost undefined keys to `gnus-article-read-summary-keys'. +(mapcar + (lambda (key) + (unless (lookup-key gnus-article-mode-map key) + (define-key gnus-article-mode-map key + 'gnus-article-read-summary-keys))) + (delq nil + (append + (mapcar + (lambda (elt) + (let ((key (car elt))) + (and (> (length key) 0) + (not (eq 'menu-bar (aref key 0))) + (symbolp (lookup-key gnus-summary-mode-map key)) + key))) + (accessible-keymaps gnus-summary-mode-map)) + (let ((c 127) + keys) + (while (>= c 32) + (push (char-to-string c) keys) + (decf c)) + keys)))) (defun gnus-article-make-menu-bar () (gnus-turn-off-edit-menu 'article) @@ -1868,7 +1866,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Scroll backwards" gnus-article-goto-prev-page t] ["Show summary" gnus-article-show-summary t] ["Fetch Message-ID at point" gnus-article-refer-article t] - ["Mail to address at point" gnus-article-mail t])) + ["Mail to address at point" gnus-article-mail t] + ["Send a bug report" gnus-bug t])) (easy-menu-define gnus-article-treatment-menu gnus-article-mode-map "" @@ -1878,18 +1877,15 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] ["Remove carriage return" gnus-article-remove-cr t] - ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) + )) - (when nil - (when (boundp 'gnus-summary-article-menu) - (define-key gnus-article-mode-map [menu-bar commands] - (cons "Commands" gnus-summary-article-menu)))) + ;; Note "Commands" menu is defined in gnus-sum.el for consistency (when (boundp 'gnus-summary-post-menu) (define-key gnus-article-mode-map [menu-bar post] (cons "Post" gnus-summary-post-menu))) - (run-hooks 'gnus-article-menu-hook))) + (gnus-run-hooks 'gnus-article-menu-hook))) (defun gnus-article-mode () "Major mode for displaying an article. @@ -1909,7 +1905,6 @@ commands: (interactive) (when (gnus-visual-p 'article-menu 'menu) (gnus-article-make-menu-bar)) - (kill-all-local-variables) (gnus-simplify-mode-line) (setq mode-name "Article") (setq major-mode 'gnus-article-mode) @@ -1919,13 +1914,14 @@ commands: (use-local-map gnus-article-mode-map) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) - (set (make-local-variable 'gnus-page-broken) nil) - (set (make-local-variable 'gnus-button-marker-list) nil) + (make-local-variable 'gnus-page-broken) + (make-local-variable 'gnus-button-marker-list) + (make-local-variable 'gnus-article-current-summary) (gnus-set-default-directory) (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) (set-syntax-table gnus-article-mode-syntax-table) - (run-hooks 'gnus-article-mode-hook)) + (gnus-run-hooks 'gnus-article-mode-hook)) (defun gnus-article-setup-buffer () "Initialize the article buffer." @@ -1946,23 +1942,20 @@ commands: (gnus-set-global-variables))) ;; Init original article buffer. (save-excursion - (set-buffer (get-buffer-create gnus-original-article-buffer)) + (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) (buffer-disable-undo (current-buffer)) (setq major-mode 'gnus-original-article-mode) - (gnus-add-current-to-buffer-list) (make-local-variable 'gnus-original-article)) (if (get-buffer name) (save-excursion (set-buffer name) (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) - (gnus-add-current-to-buffer-list) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) (current-buffer)) (save-excursion - (set-buffer (get-buffer-create name)) - (gnus-add-current-to-buffer-list) + (set-buffer (gnus-get-buffer-create name)) (gnus-article-mode) (make-local-variable 'gnus-summary-buffer) (current-buffer))))) @@ -1982,6 +1975,70 @@ commands: (forward-line line) (point))))) +;;; @@ article filters +;;; + +(defun gnus-article-display-mime-message () + "Article display method for MIME message." + ;; called from `gnus-original-article-buffer'. + (let (charset all-headers) + (with-current-buffer gnus-summary-buffer + (setq charset default-mime-charset + all-headers gnus-have-all-headers)) + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + (mime-display-message mime-message-structure + gnus-article-buffer nil gnus-article-mode-map) + (when all-headers + (gnus-article-hide-headers nil -1)) + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + ) + ;; `mime-display-message' changes current buffer to `gnus-article-buffer'. + (make-local-variable 'mime-button-mother-dispatcher) + (setq mime-button-mother-dispatcher + (function gnus-article-push-button)) + (run-hooks 'gnus-mime-article-prepare-hook)) + +(defun gnus-article-display-traditional-message () + "Article display method for traditional message." + (set-buffer gnus-article-buffer) + (let (buffer-read-only) + (erase-buffer) + (insert-buffer-substring gnus-original-article-buffer))) + +(defun gnus-article-make-full-mail-header (&optional number charset) + "Create a new mail header structure in a raw article buffer." + (unless (and number charset) + (save-current-buffer + (set-buffer gnus-summary-buffer) + (unless number + (setq number (or (cdr gnus-article-current) 0))) + (unless charset + (setq charset (or default-mime-charset 'x-ctext))))) + (goto-char (point-min)) + (let ((header-end (if (search-forward "\n\n" nil t) + (1- (point)) + (goto-char (point-max)))) + (chars (- (point-max) (point))) + (lines (count-lines (point) (point-max))) + (default-mime-charset charset) + xref) + (narrow-to-region (point-min) header-end) + (setq xref (std11-fetch-field "xref")) + (prog1 + (make-full-mail-header + number + (std11-fetch-field "subject") + (std11-fetch-field "from") + (std11-fetch-field "date") + (std11-fetch-field "message-id") + (std11-fetch-field "references") + chars + lines + (when xref (concat "Xref: " xref))) + (widen)))) + (defun gnus-article-prepare (article &optional all-headers header) "Prepare ARTICLE in article mode buffer. ARTICLE should either be an article number or a Message-ID. @@ -1992,19 +2049,14 @@ If ALL-HEADERS is non-nil, no headers are hidden." (unless (eq major-mode 'gnus-summary-mode) (set-buffer gnus-summary-buffer)) (setq gnus-summary-buffer (current-buffer)) - ;; Make sure the connection to the server is alive. - (unless (gnus-server-opened - (gnus-find-method-for-group gnus-newsgroup-name)) - (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) - (gnus-request-group gnus-newsgroup-name t)) (let* ((gnus-article (if header (mail-header-number header) article)) (summary-buffer (current-buffer)) - (internal-hook gnus-article-internal-prepare-hook) + (gnus-tmp-internal-hook gnus-article-internal-prepare-hook) (group gnus-newsgroup-name) result) (save-excursion (gnus-article-setup-buffer) - (set-buffer gnus-article-buffer) + (set-buffer gnus-original-article-buffer) ;; Deactivate active regions. (when (and (boundp 'transient-mark-mode) transient-mark-mode) @@ -2020,11 +2072,16 @@ If ALL-HEADERS is non-nil, no headers are hidden." (cons gnus-newsgroup-name article)) (set-buffer gnus-summary-buffer) (setq gnus-current-article article) - (gnus-summary-mark-article article gnus-canceled-mark)) - (unless (memq article gnus-newsgroup-sparse) - (gnus-error - 1 "No such article (may have expired or been canceled)"))) - (if (or (eq result 'pseudo) (eq result 'nneething)) + (if (eq (gnus-article-mark article) gnus-undownloaded-mark) + (progn + (gnus-summary-set-agent-mark article) + (message "Message marked for downloading")) + (gnus-summary-mark-article article gnus-canceled-mark) + (unless (memq article gnus-newsgroup-sparse) + (gnus-error 1 + "No such article (may have expired or been canceled)"))))) + (if (or (eq result 'pseudo) + (eq result 'nneething)) (progn (save-excursion (set-buffer summary-buffer) @@ -2057,40 +2114,25 @@ If ALL-HEADERS is non-nil, no headers are hidden." (unless (vectorp gnus-current-headers) (setq gnus-current-headers nil)) (gnus-summary-goto-subject gnus-current-article) - (gnus-summary-show-thread) - (run-hooks 'gnus-mark-article-hook) + (when (gnus-summary-show-thread) + ;; If the summary buffer really was folded, the + ;; previous goto may not actually have gone to + ;; the right article, but the thread root instead. + ;; So we go again. + (gnus-summary-goto-subject gnus-current-article)) + (gnus-run-hooks 'gnus-mark-article-hook) (gnus-set-mode-line 'summary) (when (gnus-visual-p 'article-highlight 'highlight) - (run-hooks 'gnus-visual-mark-article-hook)) + (gnus-run-hooks 'gnus-visual-mark-article-hook)) ;; Set the global newsgroup variables here. ;; Suggested by Jim Sisolak ;; . (gnus-set-global-variables) (setq gnus-have-all-headers - (or all-headers gnus-show-all-headers)) - (and gnus-use-cache - (vectorp (gnus-summary-article-header article)) - (gnus-cache-possibly-enter-article - group article - (gnus-summary-article-header article) - (memq article gnus-newsgroup-marked) - (memq article gnus-newsgroup-dormant) - (memq article gnus-newsgroup-unreads))))) + (or all-headers gnus-show-all-headers)))) (when (or (numberp article) (stringp article)) - ;; Hooks for getting information from the article. - ;; This hook must be called before being narrowed. - (let (buffer-read-only) - (run-hooks 'internal-hook) - (run-hooks 'gnus-article-prepare-hook) - ;; Decode MIME message. - (when gnus-show-mime - (if (or (not gnus-strict-mime) - (gnus-fetch-field "Mime-Version")) - (funcall gnus-show-mime-method) - (funcall gnus-decode-encoded-word-method))) - ;; Perform the article display hooks. - (run-hooks 'gnus-article-display-hook)) + (gnus-article-prepare-display) ;; Do page break. (goto-char (point-min)) (setq gnus-page-broken @@ -2100,8 +2142,27 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-set-mode-line 'article) (gnus-configure-windows 'article) (goto-char (point-min)) + (search-forward "\n\n" nil t) + (set-window-point (get-buffer-window (current-buffer)) (point)) t)))))) +(defun gnus-article-prepare-display () + "Make the current buffer look like a nice article." + (let ((method + (if gnus-show-mime + (progn + (setq mime-message-structure gnus-current-headers) + gnus-article-display-method-for-mime) + gnus-article-display-method-for-traditional))) + (gnus-run-hooks 'gnus-tmp-internal-hook) + (gnus-run-hooks 'gnus-article-prepare-hook) + ;; Display message. + (funcall method) + ;; Associate this article with the current summary buffer. + (setq gnus-article-current-summary gnus-summary-buffer) + ;; Perform the article display hooks. + (gnus-run-hooks 'gnus-article-display-hook))) + (defun gnus-article-wash-status () "Return a string which display status of article washing." (save-excursion @@ -2124,7 +2185,9 @@ If ALL-HEADERS is non-nil, no headers are hidden." (if mime ?m ? ) (if emphasis ?e ? ))))) -(defun gnus-article-hide-headers-if-wanted () +(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) + +(defun gnus-article-maybe-hide-headers () "Hide unwanted headers if `gnus-have-all-headers' is nil. Provided for backwards compatibility." (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) @@ -2264,7 +2327,8 @@ Argument LINES specifies lines to be scrolled down." (error "There is no summary buffer for this article buffer") (gnus-article-set-globals) (gnus-configure-windows 'article) - (gnus-summary-goto-subject gnus-current-article))) + (gnus-summary-goto-subject gnus-current-article) + (gnus-summary-position-point))) (defun gnus-article-describe-briefly () "Describe article mode commands briefly." @@ -2278,7 +2342,7 @@ Argument LINES specifies lines to be scrolled down." (let ((obuf (current-buffer)) (owin (current-window-configuration)) func) - (switch-to-buffer gnus-summary-buffer 'norecord) + (switch-to-buffer gnus-article-current-summary 'norecord) (setq func (lookup-key (current-local-map) (this-command-keys))) (call-interactively func) (set-buffer obuf) @@ -2289,7 +2353,7 @@ Argument LINES specifies lines to be scrolled down." "Execute the last keystroke in the summary buffer." (interactive) (let (func) - (pop-to-buffer gnus-summary-buffer 'norecord) + (pop-to-buffer gnus-article-current-summary 'norecord) (setq func (lookup-key (current-local-map) (this-command-keys))) (call-interactively func))) @@ -2297,85 +2361,101 @@ Argument LINES specifies lines to be scrolled down." "Read a summary buffer key sequence and execute it from the article buffer." (interactive "P") (let ((nosaves - '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" - "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" - "=" "^" "\M-^" "|")) - (nosave-but-article - '("A\r")) - (nosave-in-article - '("\C-d")) - keys) + '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" + "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" + "=" "^" "\M-^" "|")) + (nosave-but-article + '("A\r")) + (nosave-in-article + '("\C-d")) + (up-to-top + '("n" "Gn" "p" "Gp")) + keys new-sum-point) (save-excursion - (set-buffer gnus-summary-buffer) + (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (or key last-command-event) unread-command-events) - (setq keys (read-key-sequence nil)))) + (push (or key last-command-event) unread-command-events) + (setq keys (read-key-sequence nil)))) (message "") (if (or (member keys nosaves) - (member keys nosave-but-article) - (member keys nosave-in-article)) - (let (func) - (save-window-excursion - (pop-to-buffer gnus-summary-buffer 'norecord) - ;; We disable the pick minor mode commands. - (let (gnus-pick-mode) - (setq func (lookup-key (current-local-map) keys)))) - (if (not func) - (ding) - (unless (member keys nosave-in-article) - (set-buffer gnus-summary-buffer)) - (call-interactively func)) - (when (member keys nosave-but-article) - (pop-to-buffer gnus-article-buffer 'norecord))) + (member keys nosave-but-article) + (member keys nosave-in-article)) + (let (func) + (save-window-excursion + (pop-to-buffer gnus-article-current-summary 'norecord) + ;; We disable the pick minor mode commands. + (let (gnus-pick-mode) + (setq func (lookup-key (current-local-map) keys)))) + (if (not func) + (ding) + (unless (member keys nosave-in-article) + (set-buffer gnus-article-current-summary)) + (call-interactively func) + (setq new-sum-point (point))) + (when (member keys nosave-but-article) + (pop-to-buffer gnus-article-buffer 'norecord))) ;; These commands should restore window configuration. (let ((obuf (current-buffer)) - (owin (current-window-configuration)) - (opoint (point)) - func in-buffer) - (if not-restore-window - (pop-to-buffer gnus-summary-buffer 'norecord) - (switch-to-buffer gnus-summary-buffer 'norecord)) - (setq in-buffer (current-buffer)) - ;; We disable the pick minor mode commands. - (if (setq func (let (gnus-pick-mode) - (lookup-key (current-local-map) keys))) - (call-interactively func) - (ding)) - (when (eq in-buffer (current-buffer)) - (set-buffer obuf) - (unless not-restore-window - (set-window-configuration owin)) - (set-window-point (get-buffer-window (current-buffer)) opoint)))))) + (owin (current-window-configuration)) + (opoint (point)) + (summary gnus-article-current-summary) + func in-buffer selected) + (if not-restore-window + (pop-to-buffer summary 'norecord) + (switch-to-buffer summary 'norecord)) + (setq in-buffer (current-buffer)) + ;; We disable the pick minor mode commands. + (if (setq func (let (gnus-pick-mode) + (lookup-key (current-local-map) keys))) + (progn + (call-interactively func) + (setq new-sum-point (point))) + (ding)) + (when (eq in-buffer (current-buffer)) + (setq selected (gnus-summary-select-article)) + (set-buffer obuf) + (unless not-restore-window + (set-window-configuration owin)) + (unless (or (not (eq selected 'old)) (member keys up-to-top)) + (set-window-point (get-buffer-window (current-buffer)) + opoint)) + (let ((win (get-buffer-window gnus-article-current-summary))) + (when win + (set-window-point win new-sum-point)))))))) (defun gnus-article-hide (&optional arg force) "Hide all the gruft in the current article. This means that PGP stuff, signatures, cited text and (some) headers will be hidden. If given a prefix, show the hidden text instead." - (interactive (list current-prefix-arg 'force)) + (interactive (append (gnus-article-hidden-arg) (list 'force))) (gnus-article-hide-headers arg) (gnus-article-hide-pgp arg) (gnus-article-hide-citation-maybe arg force) (gnus-article-hide-signature arg)) (defun gnus-article-maybe-highlight () - "Do some article highlighting if `article-visual' is non-nil." + "Do some article highlighting if article highlighting is requested." (when (gnus-visual-p 'article-highlight 'highlight) (gnus-article-highlight-some))) +(defun gnus-check-group-server () + ;; Make sure the connection to the server is alive. + (unless (gnus-server-opened + (gnus-find-method-for-group gnus-newsgroup-name)) + (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) + (gnus-request-group gnus-newsgroup-name t))) + (defun gnus-request-article-this-buffer (article group) "Get an article and insert it into this buffer." - (let (do-update-line) + (let (do-update-line sparse-header) (prog1 (save-excursion (erase-buffer) (gnus-kill-all-overlays) (setq group (or group gnus-newsgroup-name)) - ;; Open server if it has closed. - (gnus-check-server (gnus-find-method-for-group group)) - ;; Using `gnus-request-article' directly will insert the article into ;; `nntp-server-buffer' - so we'll save some time by not having to ;; copy it from the server buffer into the article buffer. @@ -2392,7 +2472,7 @@ If given a prefix, show the hidden text instead." (when (and (numberp article) gnus-summary-buffer (get-buffer gnus-summary-buffer) - (buffer-name (get-buffer gnus-summary-buffer))) + (gnus-buffer-exists-p gnus-summary-buffer)) (save-excursion (set-buffer gnus-summary-buffer) (let ((header (gnus-summary-article-header article))) @@ -2403,7 +2483,7 @@ If given a prefix, show the hidden text instead." (setq do-update-line article) (setq article (mail-header-id header)) (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article)) + (setq sparse-header (gnus-read-header article))) (setq gnus-newsgroup-sparse (delq article gnus-newsgroup-sparse))) ((vectorp header) @@ -2416,10 +2496,13 @@ If given a prefix, show the hidden text instead." (let ((method (gnus-find-method-for-group gnus-newsgroup-name))) - (if (not (eq (car method) 'nneething)) - () - (let ((dir (concat (file-name-as-directory (nth 1 method)) - (mail-header-subject header)))) + (when (and (eq (car method) 'nneething) + (vectorp header)) + (let ((dir (concat + (file-name-as-directory + (or (cadr (assq 'nneething-address method)) + (nth 1 method))) + (mail-header-subject header)))) (when (file-directory-p dir) (setq article 'nneething) (gnus-group-enter-directory dir)))))))) @@ -2429,21 +2512,12 @@ If given a prefix, show the hidden text instead." ((and (numberp article) gnus-summary-buffer (get-buffer gnus-summary-buffer) - (buffer-name (get-buffer gnus-summary-buffer)) + (gnus-buffer-exists-p gnus-summary-buffer) (eq (cdr (save-excursion (set-buffer gnus-summary-buffer) (assq article gnus-newsgroup-reads))) gnus-canceled-mark)) nil) - ;; We first check `gnus-original-article-buffer'. - ((and (get-buffer gnus-original-article-buffer) - (numberp article) - (save-excursion - (set-buffer gnus-original-article-buffer) - (and (equal (car gnus-original-article) group) - (eq (cdr gnus-original-article) article)))) - (insert-buffer-substring gnus-original-article-buffer) - 'article) ;; Check the backlog. ((and gnus-keep-backlog (gnus-backlog-request-article group article (current-buffer))) @@ -2451,6 +2525,8 @@ If given a prefix, show the hidden text instead." ;; Check asynchronous pre-fetch. ((gnus-async-request-fetched-article group article (current-buffer)) (gnus-async-prefetch-next group article gnus-summary-buffer) + (when (and (numberp article) gnus-keep-backlog) + (gnus-backlog-enter-article group article (current-buffer))) 'article) ;; Check the cache. ((and gnus-use-cache @@ -2464,6 +2540,7 @@ If given a prefix, show the hidden text instead." (buffer-read-only nil)) (erase-buffer) (gnus-kill-all-overlays) + (gnus-check-group-server) (when (gnus-request-article article group (current-buffer)) (when (numberp article) (gnus-async-prefetch-next group article gnus-summary-buffer) @@ -2474,20 +2551,21 @@ If given a prefix, show the hidden text instead." ;; It was a pseudo. (t article))) + ;; Associate this article with the current summary buffer. + (setq gnus-article-current-summary gnus-summary-buffer) + ;; Take the article from the original article buffer ;; and place it in the buffer it's supposed to be in. (when (and (get-buffer gnus-article-buffer) - ;;(numberp article) (equal (buffer-name (current-buffer)) (buffer-name (get-buffer gnus-article-buffer)))) (save-excursion (if (get-buffer gnus-original-article-buffer) - (set-buffer (get-buffer gnus-original-article-buffer)) - (set-buffer (get-buffer-create gnus-original-article-buffer)) + (set-buffer gnus-original-article-buffer) + (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) (buffer-disable-undo (current-buffer)) (setq major-mode 'gnus-original-article-mode) - (setq buffer-read-only t) - (gnus-add-current-to-buffer-list)) + (setq buffer-read-only t)) (let (buffer-read-only) (erase-buffer) (insert-buffer-substring gnus-article-buffer)) @@ -2499,7 +2577,7 @@ If given a prefix, show the hidden text instead." (stringp article))) (let ((buf (current-buffer))) (set-buffer gnus-summary-buffer) - (gnus-summary-update-article do-update-line) + (gnus-summary-update-article do-update-line sparse-header) (gnus-summary-goto-subject do-update-line nil t) (set-window-point (get-buffer-window (current-buffer) t) (point)) @@ -2514,6 +2592,12 @@ If given a prefix, show the hidden text instead." :group 'gnus-article-various :type 'hook) +(defcustom gnus-article-edit-article-setup-function + 'gnus-article-mime-edit-article-setup + "Function called to setup an editing article buffer." + :group 'gnus-article-various + :type 'function) + (defvar gnus-article-edit-done-function nil) (defvar gnus-article-edit-mode-map nil) @@ -2535,7 +2619,6 @@ This is an extended text-mode. \\{gnus-article-edit-mode-map}" (interactive) - (kill-all-local-variables) (setq major-mode 'gnus-article-edit-mode) (setq mode-name "Article Edit") (use-local-map gnus-article-edit-mode-map) @@ -2544,7 +2627,7 @@ This is an extended text-mode. (setq buffer-read-only nil) (buffer-enable-undo) (widen) - (run-hooks 'text-mode 'gnus-article-edit-mode-hook)) + (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook)) (defun gnus-article-edit (&optional force) "Edit the current article. @@ -2555,6 +2638,7 @@ groups." (when (and (not force) (gnus-group-read-only-p)) (error "The current newsgroup does not support article editing")) + (gnus-article-date-original) (gnus-article-edit-article `(lambda (no-highlight) (gnus-summary-edit-article-done @@ -2566,10 +2650,13 @@ groups." (let ((winconf (current-window-configuration))) (set-buffer gnus-article-buffer) (gnus-article-edit-mode) + (gnus-article-delete-text-of-type 'annotation) (gnus-set-text-properties (point-min) (point-max) nil) (gnus-configure-windows 'edit-article) (setq gnus-article-edit-done-function exit-func) (setq gnus-prev-winconf winconf) + (when gnus-article-edit-article-setup-function + (funcall gnus-article-edit-article-setup-function)) (gnus-message 6 "C-c C-c to end edits"))) (defun gnus-article-edit-done (&optional arg) @@ -2600,6 +2687,8 @@ groups." (let ((func gnus-article-edit-done-function) (buf (current-buffer)) (start (window-start))) + (remove-hook 'gnus-article-mode-hook + 'gnus-article-mime-edit-article-unwind) (gnus-article-edit-exit) (save-excursion (set-buffer buf) @@ -2651,6 +2740,86 @@ groups." (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2")))) ;;; +;;; Article editing with MIME-Edit +;;; + +(defcustom gnus-article-mime-edit-article-setup-hook nil + "Hook run after setting up a MIME editing article buffer." + :group 'gnus-article-various + :type 'hook) + +(defun gnus-article-mime-edit-article-unwind () + "Unwind `gnus-article-buffer' if article editing was given up." + (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind) + (when mime-edit-mode-flag + (mime-edit-exit 'nomime 'no-error) + (message "")) + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode 0))) + +(defun gnus-article-mime-edit-article-setup () + "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode +after replacing with the original article." + (setq gnus-show-mime t) + (setq gnus-article-edit-done-function + `(lambda (&rest args) + (when mime-edit-mode-flag + (mime-edit-exit) + (message "")) + (goto-char (point-min)) + (let (case-fold-search) + (when (re-search-forward + (format "^%s$" (regexp-quote mail-header-separator)) + nil t) + (replace-match ""))) + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode 0)) + (apply ,gnus-article-edit-done-function args) + (set-buffer gnus-original-article-buffer) + (erase-buffer) + (insert-buffer gnus-article-buffer) + (setq gnus-current-headers (gnus-article-make-full-mail-header)) + (gnus-article-prepare-display))) + (define-key (current-local-map) "\C-c\C-k" 'gnus-article-mime-edit-exit) + (erase-buffer) + (insert-buffer gnus-original-article-buffer) + (mime-edit-again) + (when (featurep 'font-lock) + (set (make-local-variable 'font-lock-defaults) + '(message-font-lock-keywords t)) + (font-lock-set-defaults) + (turn-on-font-lock)) + (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind) + (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook)) + +(defun gnus-article-mime-edit-exit () + "Exit the article MIME editing without updating." + (interactive) + (let ((winconf gnus-prev-winconf) + buf) + (when mime-edit-mode-flag + (mime-edit-exit) + (message "")) + (goto-char (point-min)) + (let (case-fold-search) + (when (re-search-forward + (format "^%s$" (regexp-quote mail-header-separator)) nil t) + (replace-match ""))) + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode 0)) + ;; We remove all text props from the article buffer. + (setq buf (format "%s" (buffer-string))) + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (erase-buffer) + (insert buf) + (setq gnus-current-headers (gnus-article-make-full-mail-header)) + (gnus-article-prepare-display) + (set-window-configuration winconf))) + +;;; ;;; Article highlights ;;; @@ -2664,21 +2833,23 @@ groups." :type 'regexp) (defcustom gnus-button-alist - `(("<\\(url: ?\\)?news:\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t + `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t gnus-button-message-id 2) ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1) - ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t + ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" + 1 t gnus-button-fetch-group 4) ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2) ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 2) + ("mailto:\\([a-zA-Z.-@_+0-9%]+\\)" 0 t gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) ;; This is how URLs _should_ be embedded in text... ("]*\\)>" 0 t gnus-button-embedded-url 1) ;; Raw URLs. (,gnus-button-url-regexp 0 t gnus-button-url 0)) - "Alist of regexps matching buttons in article bodies. + "*Alist of regexps matching buttons in article bodies. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where REGEXP: is the string matching text around the button, @@ -2710,7 +2881,7 @@ variable it the real callback function." ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t gnus-button-message-id 3)) - "Alist of headers and regexps to match buttons in article heads. + "*Alist of headers and regexps to match buttons in article heads. This alist is very similar to `gnus-button-alist', except that each alist has an additional HEADER element first in each entry: @@ -2748,6 +2919,7 @@ call it with the value of the `gnus-data' text property." (let* ((pos (posn-point (event-start event))) (data (get-text-property pos 'gnus-data)) (fun (get-text-property pos 'gnus-callback))) + (goto-char pos) (when fun (funcall fun data)))) @@ -3052,14 +3224,6 @@ specified by `gnus-button-alist'." (match-string 3 address) "nntp"))))))) -(defun gnus-split-string (string pattern) - "Return a list of substrings of STRING which are separated by PATTERN." - (let (parts (start 0)) - (while (string-match pattern string start) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0))) - (nreverse (cons (substring string start) parts)))) - (defun gnus-url-parse-query-string (query &optional downcase) (let (retval pairs cur key val) (setq pairs (gnus-split-string query "&")) @@ -3114,7 +3278,7 @@ forbidden in URL encoding." ;; Send mail to someone (when (string-match "mailto:/*\\(.*\\)" url) (setq url (substring url (match-beginning 1) nil))) - (let (to args source-url subject func) + (let (to args subject func) (if (string-match (regexp-quote "?") url) (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) args (gnus-url-parse-query-string @@ -3122,34 +3286,43 @@ forbidden in URL encoding." (setq to (gnus-url-unhex-string url))) (setq args (cons (list "to" to) args) subject (cdr-safe (assoc "subject" args))) - (message-mail) - (while args - (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) - (if (fboundp func) - (funcall func) - (message-position-on-field (caar args))) - (insert (mapconcat 'identity (cdar args) ", ")) - (setq args (cdr args))) - (if subject - (message-goto-body) - (message-goto-subject)))) + (gnus-setup-message 'reply + (message-mail) + (while args + (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) + (if (fboundp func) + (funcall func) + (message-position-on-field (caar args))) + (insert (mapconcat 'identity (cdar args) ", ")) + (setq args (cdr args))) + (if subject + (message-goto-body) + (message-goto-subject))))) (defun gnus-button-mailto (address) ;; Mail to ADDRESS. (set-buffer (gnus-copy-article-buffer)) - (message-reply address)) + (gnus-setup-message 'reply + (message-reply address))) (defun gnus-button-reply (address) ;; Reply to ADDRESS. - (message-reply address)) + (gnus-setup-message 'reply + (message-reply address))) (defun gnus-button-url (address) "Browse ADDRESS." - (funcall browse-url-browser-function address)) + ;; In Emacs 20, `browse-url-browser-function' may be an alist. + (if (listp browse-url-browser-function) + (browse-url address) + (funcall browse-url-browser-function address))) (defun gnus-button-embedded-url (address) "Browse ADDRESS." - (funcall browse-url-browser-function (gnus-strip-whitespace address))) + ;; In Emacs 20, `browse-url-browser-function' may be an alist. + (if (listp browse-url-browser-function) + (browse-url (gnus-strip-whitespace address)) + (funcall browse-url-browser-function (gnus-strip-whitespace address)))) ;;; Next/prev buttons in the article buffer. @@ -3167,7 +3340,8 @@ forbidden in URL encoding." (gnus-eval-format gnus-prev-page-line-format nil `(gnus-prev t local-map ,gnus-prev-page-map - gnus-callback gnus-article-button-prev-page)))) + gnus-callback gnus-article-button-prev-page + gnus-type annotation)))) (defvar gnus-next-page-map nil) (unless gnus-next-page-map @@ -3195,9 +3369,10 @@ forbidden in URL encoding." (defun gnus-insert-next-page-button () (let ((buffer-read-only nil)) (gnus-eval-format gnus-next-page-line-format nil - `(gnus-next t local-map ,gnus-next-page-map - gnus-callback - gnus-article-button-next-page)))) + `(gnus-next + t local-map ,gnus-next-page-map + gnus-callback gnus-article-button-next-page + gnus-type annotation)))) (defun gnus-article-button-next-page (arg) "Go to the next page." @@ -3215,6 +3390,54 @@ forbidden in URL encoding." (gnus-article-prev-page) (select-window win))) + +;;; @ for mime-view +;;; + +(defun gnus-article-header-presentation-method (entity situation) + (mime-insert-header entity) + ) + +(set-alist 'mime-header-presentation-method-alist + 'gnus-original-article-mode + #'gnus-article-header-presentation-method) + +(defun gnus-mime-preview-quitting-method () + (mime-preview-kill-buffer) + (delete-other-windows) + (gnus-article-show-summary) + (gnus-summary-select-article gnus-show-all-headers t)) + +(set-alist 'mime-preview-quitting-method-alist + 'gnus-original-article-mode #'gnus-mime-preview-quitting-method) + +(defun gnus-following-method (buf) + (set-buffer buf) + (message-followup) + (message-yank-original) + (kill-buffer buf) + (goto-char (point-min)) + ) + +(set-alist 'mime-preview-following-method-alist + 'gnus-original-article-mode #'gnus-following-method) + +(set-alist 'mime-preview-over-to-previous-method-alist + 'gnus-original-article-mode + (lambda () + (gnus-article-read-summary-keys + nil (gnus-character-to-event ?P)))) + +(set-alist 'mime-preview-over-to-next-method-alist + 'gnus-original-article-mode' + (lambda () + (gnus-article-read-summary-keys + nil (gnus-character-to-event ?N)))) + + +;;; @ end +;;; + (gnus-ems-redefine) (provide 'gnus-art)