X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=bc784f7eabb2fdd8878fd1afbc84aa7659fa4dd8;hb=e5bec5d05f433a43fa2d14cdb7bebeeefab8835f;hp=2872d701f9c9787f2df8df59fc65fdc24ad4eb56;hpb=a6240bd7dbf5d29a3a38d33dec311ff1a9fbfb94;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 2872d70..bc784f7 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,5 +1,6 @@ ;;; gnus-art.el --- article mode commands for Semi-gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -178,9 +179,10 @@ this list." (defcustom gnus-boring-article-headers '(empty followup-to reply-to) "Headers that are only to be displayed if they have interesting data. Possible values in this list are `empty', `newsgroups', `followup-to', -`reply-to', `date', `long-to', and `many-to'." +`to-address', `reply-to', `date', `long-to', and `many-to'." :type '(set (const :tag "Headers with no content." empty) (const :tag "Newsgroups with only one group." newsgroups) + (const :tag "To identical to to-address." to-address) (const :tag "Followup-to identical to newsgroups." followup-to) (const :tag "Reply-to identical to from." reply-to) (const :tag "Date less than four days old." date) @@ -245,6 +247,7 @@ asynchronously. The compressed face will be piped to this command." (function-item gnus-article-display-xface) (function-item x-face-mule-gnus-article-display-x-face) function) + ;;:version "21.1" :group 'gnus-article-washing) (defcustom gnus-article-x-face-too-ugly nil @@ -255,7 +258,7 @@ asynchronously. The compressed face will be piped to this command." (defcustom gnus-article-banner-alist nil "Banner alist for stripping. For example, - ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" + ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" :version "21.1" :type '(repeat (cons symbol regexp)) :group 'gnus-article-washing) @@ -839,6 +842,13 @@ See the manual for details." :group 'gnus-article-treat :type gnus-article-treat-custom) +(defcustom gnus-treat-leading-whitespace nil + "Remove leading whitespace in headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + (defcustom gnus-treat-hide-headers 'head "Hide headers. Valid values are nil, t, `head', `last', an integer or a predicate. @@ -1034,6 +1044,7 @@ See the manual for details." Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." :group 'gnus-article-treat + ;;:version "21.1" :type gnus-article-treat-head-custom) (put 'gnus-treat-display-xface 'highlight t) @@ -1051,6 +1062,7 @@ See the manual for details." Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." :group 'gnus-article-treat + ;;:version "21.1" :type gnus-article-treat-custom) (put 'gnus-treat-display-smileys 'highlight t) @@ -1158,6 +1170,7 @@ It is a string, such as \"PGP\". If nil, ask user." (gnus-treat-hide-citation gnus-article-hide-citation) (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) + (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace) (gnus-treat-strip-pgp gnus-article-hide-pgp) (gnus-treat-strip-pem gnus-article-hide-pem) (gnus-treat-highlight-headers gnus-article-highlight-headers) @@ -1290,8 +1303,7 @@ Initialized from `text-mode-syntax-table.") (unless gnus-inhibit-hiding (save-excursion (save-restriction - (let ((buffer-read-only nil) - (inhibit-read-only t) + (let ((inhibit-read-only t) (case-fold-search t) (max (1+ (length gnus-sorted-header-list))) (ignored (when (not gnus-visible-headers) @@ -1381,15 +1393,30 @@ always hide." 'boring-headers))) ;; Hide boring Newsgroups header. ((eq elem 'newsgroups) - (when (equal (gnus-fetch-field "newsgroups") - (gnus-group-real-name - (if (boundp 'gnus-newsgroup-name) - gnus-newsgroup-name - ""))) + (when (gnus-string-equal + (gnus-fetch-field "newsgroups") + (gnus-group-real-name + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name + ""))) (gnus-article-hide-header "newsgroups"))) + ((eq elem 'to-address) + (let ((to (message-fetch-field "to")) + (to-address + (gnus-parameter-to-address + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name "")))) + (when (and to to-address + (ignore-errors + (gnus-string-equal + ;; only one address in To + (nth 1 (mail-extract-address-components to)) + to-address))) + (gnus-article-hide-header "to")))) ((eq elem 'followup-to) - (when (equal (message-fetch-field "followup-to") - (message-fetch-field "newsgroups")) + (when (gnus-string-equal + (message-fetch-field "followup-to") + (message-fetch-field "newsgroups")) (gnus-article-hide-header "followup-to"))) ((eq elem 'reply-to) (let ((from (message-fetch-field "from")) @@ -1397,9 +1424,9 @@ always hide." (when (and from reply-to (ignore-errors - (equal - (nth 1 (funcall gnus-extract-address-components from)) - (nth 1 (funcall gnus-extract-address-components reply-to))))) + (gnus-string-equal + (nth 1 (mail-extract-address-components from)) + (nth 1 (mail-extract-address-components reply-to))))) (gnus-article-hide-header "reply-to")))) ((eq elem 'date) (let ((date (message-fetch-field "date"))) @@ -1466,8 +1493,7 @@ if given a positive prefix, always hide." (header-end (point-min)) header-start field-end field-start (inhibit-point-motion-hooks t) - (inhibit-read-only t) - buffer-read-only) + (inhibit-read-only t)) (save-restriction (widen) (while (and (setq header-start @@ -1706,27 +1732,48 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (when (process-status "article-x-face") (delete-process "article-x-face")) (let ((inhibit-point-motion-hooks t) + x-faces (case-fold-search t) - (x-faces "") from last) - (when (gnus-buffer-live-p gnus-original-article-buffer) - (with-current-buffer gnus-original-article-buffer - (save-restriction - (article-narrow-to-head) - (while (re-search-forward "^X-Face:" nil t) - (setq x-faces - (concat - x-faces - (buffer-substring (match-beginning 0) - (1- (re-search-forward - "^\\($\\|[^ \t]\\)" nil t))))))))) (save-restriction (article-narrow-to-head) + (when (and buffer-read-only ;; When type `W f' + (progn + (goto-char (point-min)) + (not (re-search-forward "^X-Face:[\t ]*" nil t))) + (gnus-buffer-live-p gnus-original-article-buffer)) + (with-current-buffer gnus-original-article-buffer + (save-restriction + (article-narrow-to-head) + (while (re-search-forward "^X-Face:" nil t) + (setq x-faces + (concat + (or x-faces "") + (buffer-substring + (match-beginning 0) + (1- (re-search-forward + "^\\($\\|[^ \t]\\)" nil t)))))))) + (if x-faces + (let (point start bface eface buffer-read-only) + (goto-char (point-max)) + (forward-line -1) + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) 'face)) + (goto-char (point-max)) + (setq point (point)) + (insert x-faces) + (goto-char point) + (while (looking-at "\\([^:]+\\): *") + (put-text-property (match-beginning 1) (1+ (match-end 1)) + 'face bface) + (setq start (match-end 0)) + (forward-line 1) + (while (looking-at "[\t ]") + (forward-line 1)) + (put-text-property start (point) + 'face eface))))) + (goto-char (point-min)) (setq from (message-fetch-field "from")) - (when (gnus-buffer-live-p gnus-original-article-buffer) - (message-remove-header "X-Face") - (goto-char (point-min)) - (insert x-faces)) (goto-char (point-min)) (while (and gnus-article-x-face-command (not last) @@ -1934,24 +1981,24 @@ If FORCE, decode the article whether it is marked as base64 not." "Remove list identifies from the Subject header. The `gnus-list-identifiers' variable specifies what to do." (interactive) - (save-excursion - (save-restriction - (let ((inhibit-point-motion-hooks t) - buffer-read-only) - (article-narrow-to-head) - (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers - (mapconcat 'identity gnus-list-identifiers " *\\|")))) - (when regexp - (goto-char (point-min)) - (when (re-search-forward - (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp - " *\\)\\)+\\(Re: +\\)?\\)") - nil t) - (let ((s (or (match-string 3) (match-string 5)))) - (delete-region (match-beginning 1) (match-end 1)) - (when s - (goto-char (match-beginning 1)) - (insert s)))))))))) + (let ((inhibit-point-motion-hooks t) + (regexp (if (consp gnus-list-identifiers) + (mapconcat 'identity gnus-list-identifiers " *\\|") + gnus-list-identifiers)) + buffer-read-only) + (when regexp + (save-excursion + (save-restriction + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward + (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)") + nil t) + (delete-region (match-beginning 2) (match-end 0)) + (beginning-of-line)) + (when (re-search-forward + "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t) + (delete-region (match-beginning 1) (match-end 1)))))))) (defun article-hide-pgp () "Remove any PGP headers and signatures in the current article." @@ -2367,118 +2414,116 @@ should replace the \"Date:\" one, or should be added below it." (defun article-make-date-line (date type) "Return a DATE line of TYPE." - (let ((time (condition-case () - (date-to-time date) - (error '(0 0))))) - (cond - ;; Convert to the local timezone. We have to slap a - ;; `condition-case' round the calls to the timezone - ;; functions since they aren't particularly resistant to - ;; buggy dates. - ((eq type 'local) - (let ((tz (car (current-time-zone time)))) - (format "Date: %s %s%02d%02d" (current-time-string time) - (if (> tz 0) "+" "-") (/ (abs tz) 3600) - (/ (% (abs tz) 3600) 60)))) - ;; Convert to Universal Time. - ((eq type 'ut) - (concat "Date: " - (current-time-string - (let* ((e (parse-time-string date)) - (tm (apply 'encode-time e)) - (ms (car tm)) - (ls (- (cadr tm) (car (current-time-zone time))))) - (cond ((< ls 0) (list (1- ms) (+ ls 65536))) - ((> ls 65535) (list (1+ ms) (- ls 65536))) - (t (list ms ls))))) - " UT")) - ;; Get the original date from the article. - ((eq type 'original) - (concat "Date: " (if (string-match "\n+$" date) - (substring date 0 (match-beginning 0)) - date))) - ;; Let the user define the format. - ((eq type 'user) - (if (gnus-functionp gnus-article-time-format) - (funcall gnus-article-time-format time) - (concat - "Date: " - (format-time-string gnus-article-time-format time)))) - ;; ISO 8601. - ((eq type 'iso8601) - (let ((tz (car (current-time-zone time)))) - (concat - "Date: " - (format-time-string "%Y%m%dT%H%M%S" time) - (format "%s%02d%02d" - (if (> tz 0) "+" "-") (/ (abs tz) 3600) - (/ (% (abs tz) 3600) 60))))) - ;; Do an X-Sent lapsed format. - ((eq type 'lapsed) - ;; If the date is seriously mangled, the timezone functions are - ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time (subtract-time now time)) - (real-sec (and real-time - (+ (* (float (car real-time)) 65536) - (cadr real-time)))) - (sec (and real-time (abs real-sec))) - num prev) + (unless (memq type '(local ut original user iso8601 lapsed english)) + (error "Unknown conversion type: %s" type)) + (condition-case () + (let ((time (date-to-time date))) (cond - ((null real-time) - "X-Sent: Unknown") - ((zerop sec) - "X-Sent: Now") - (t - (concat - "X-Sent: " - ;; This is a bit convoluted, but basically we go - ;; through the time units for years, weeks, etc, - ;; and divide things to see whether that results - ;; in positive answers. - (mapconcat - (lambda (unit) - (if (zerop (setq num (ffloor (/ sec (cdr unit))))) - ;; The (remaining) seconds are too few to - ;; be divided into this time unit. - "" - ;; It's big enough, so we output it. - (setq sec (- sec (* num (cdr unit)))) - (prog1 - (concat (if prev ", " "") (int-to-string - (floor num)) - " " (symbol-name (car unit)) - (if (> num 1) "s" "")) - (setq prev t)))) - article-time-units "") - ;; If dates are odd, then it might appear like the - ;; article was sent in the future. - (if (> real-sec 0) - " ago" - " in the future")))))) - ;; Display the date in proper English - ((eq type 'english) - (let ((dtime (decode-time time))) - (concat - "Date: the " - (number-to-string (nth 3 dtime)) - (let ((digit (% (nth 3 dtime) 10))) - (cond - ((memq (nth 3 dtime) '(11 12 13)) "th") - ((= digit 1) "st") - ((= digit 2) "nd") - ((= digit 3) "rd") - (t "th"))) - " of " - (nth (1- (nth 4 dtime)) gnus-english-month-names) - " " - (number-to-string (nth 5 dtime)) - " at " - (format "%02d" (nth 2 dtime)) - ":" - (format "%02d" (nth 1 dtime))))) - (t - (error "Unknown conversion type: %s" type))))) + ;; Convert to the local timezone. + ((eq type 'local) + (let ((tz (car (current-time-zone time)))) + (format "Date: %s %s%02d%02d" (current-time-string time) + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60)))) + ;; Convert to Universal Time. + ((eq type 'ut) + (concat "Date: " + (current-time-string + (let* ((e (parse-time-string date)) + (tm (apply 'encode-time e)) + (ms (car tm)) + (ls (- (cadr tm) (car (current-time-zone time))))) + (cond ((< ls 0) (list (1- ms) (+ ls 65536))) + ((> ls 65535) (list (1+ ms) (- ls 65536))) + (t (list ms ls))))) + " UT")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " (if (string-match "\n+$" date) + (substring date 0 (match-beginning 0)) + date))) + ;; Let the user define the format. + ((eq type 'user) + (if (gnus-functionp gnus-article-time-format) + (funcall gnus-article-time-format time) + (concat + "Date: " + (format-time-string gnus-article-time-format time)))) + ;; ISO 8601. + ((eq type 'iso8601) + (let ((tz (car (current-time-zone time)))) + (concat + "Date: " + (format-time-string "%Y%m%dT%H%M%S" time) + (format "%s%02d%02d" + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60))))) + ;; Do an X-Sent lapsed format. + ((eq type 'lapsed) + ;; If the date is seriously mangled, the timezone functions are + ;; liable to bug out, so we ignore all errors. + (let* ((now (current-time)) + (real-time (subtract-time now time)) + (real-sec (and real-time + (+ (* (float (car real-time)) 65536) + (cadr real-time)))) + (sec (and real-time (abs real-sec))) + num prev) + (cond + ((null real-time) + "X-Sent: Unknown") + ((zerop sec) + "X-Sent: Now") + (t + (concat + "X-Sent: " + ;; This is a bit convoluted, but basically we go + ;; through the time units for years, weeks, etc, + ;; and divide things to see whether that results + ;; in positive answers. + (mapconcat + (lambda (unit) + (if (zerop (setq num (ffloor (/ sec (cdr unit))))) + ;; The (remaining) seconds are too few to + ;; be divided into this time unit. + "" + ;; It's big enough, so we output it. + (setq sec (- sec (* num (cdr unit)))) + (prog1 + (concat (if prev ", " "") (int-to-string + (floor num)) + " " (symbol-name (car unit)) + (if (> num 1) "s" "")) + (setq prev t)))) + article-time-units "") + ;; If dates are odd, then it might appear like the + ;; article was sent in the future. + (if (> real-sec 0) + " ago" + " in the future")))))) + ;; Display the date in proper English + ((eq type 'english) + (let ((dtime (decode-time time))) + (concat + "Date: the " + (number-to-string (nth 3 dtime)) + (let ((digit (% (nth 3 dtime) 10))) + (cond + ((memq (nth 3 dtime) '(11 12 13)) "th") + ((= digit 1) "st") + ((= digit 2) "nd") + ((= digit 3) "rd") + (t "th"))) + " of " + (nth (1- (nth 4 dtime)) gnus-english-month-names) + " " + (number-to-string (nth 5 dtime)) + " at " + (format "%02d" (nth 2 dtime)) + ":" + (format "%02d" (nth 1 dtime))))))) + (error + (format "Date: %s (from Oort)" date)))) (defun article-date-local (&optional highlight) "Convert the current article date to the local timezone." @@ -2565,6 +2610,17 @@ This format is defined by the `gnus-article-time-format' variable." (let ((buffer-read-only nil)) (gnus-article-unhide-text (point-min) (point-max)))))) +(defun article-remove-leading-whitespace () + "Remove excessive whitespace from all headers." + (interactive) + (save-excursion + (save-restriction + (let ((buffer-read-only nil)) + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t) + (delete-region (match-beginning 1) (match-end 1))))))) + (defun article-emphasize (&optional arg) "Emphasize text according to `gnus-emphasis-alist'." (interactive (gnus-article-hidden-arg)) @@ -2619,8 +2675,9 @@ This format is defined by the `gnus-article-time-format' variable." gnus-newsgroup-name 'highlight-words t))) gnus-emphasis-alist))))) -(defvar gnus-summary-article-menu) -(defvar gnus-summary-post-menu) +(eval-when-compile + (defvar gnus-summary-article-menu) + (defvar gnus-summary-post-menu)) ;;; Saving functions. @@ -2825,7 +2882,8 @@ The directory to save in defaults to `gnus-article-save-directory'." (cond ((and (eq command 'default) gnus-last-shell-command) gnus-last-shell-command) - (command command) + ((stringp command) + command) (t (read-string (format "Shell command on %s: " @@ -2836,7 +2894,9 @@ The directory to save in defaults to `gnus-article-save-directory'." "this article")) gnus-last-shell-command)))) (when (string-equal command "") - (setq command gnus-last-shell-command)) + (if gnus-last-shell-command + (setq command gnus-last-shell-command) + (error "A command is required."))) (gnus-eval-in-buffer-window gnus-article-buffer (save-restriction (widen) @@ -2898,6 +2958,15 @@ If variable `gnus-use-long-file-name' is non-nil, it is (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))) gnus-article-save-directory))) +(defun gnus-sender-save-name (newsgroup headers &optional last-file) + "Generate file name from sender." + (let ((from (mail-header-from headers))) + (expand-file-name + (if (and from (string-match "\\([^ <]+\\)@" from)) + (match-string 1 from) + "nobody") + gnus-article-save-directory))) + (defun article-verify-x-pgp-sig () "Verify X-PGP-Sig." (interactive) @@ -2998,6 +3067,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-fill-long-lines article-capitalize-sentences article-remove-cr + article-remove-leading-whitespace article-display-x-face article-de-quoted-unreadable article-de-base64-unreadable @@ -3064,32 +3134,24 @@ If variable `gnus-use-long-file-name' is non-nil, it is "\M-g" gnus-article-read-summary-keys) ;; 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)))) - -(eval-when-compile - (defvar gnus-article-commands-menu)) +(let (keys) + (let ((key 32)) + (while (<= key 127) + (push (char-to-string key) keys) + (incf key)) + (dolist (elem (accessible-keymaps gnus-summary-mode-map)) + (setq key (car elem)) + (when (and (> (length key) 0) + (not (eq 'menu-bar (aref key 0))) + (symbolp (lookup-key gnus-summary-mode-map key))) + (push key keys)))) + (dolist (key keys) + (unless (lookup-key gnus-article-mode-map key) + (define-key gnus-article-mode-map key 'gnus-article-read-summary-keys)))) (defun gnus-article-make-menu-bar () + (unless (boundp 'gnus-article-commands-menu) + (gnus-summary-make-menu-bar)) (gnus-turn-off-edit-menu 'article) (unless (boundp 'gnus-article-article-menu) (easy-menu-define @@ -3111,20 +3173,14 @@ 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 leading whitespace" gnus-article-remove-leading-whitespace t] ["Decode HZ" gnus-article-decode-HZ t])) ;; 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))) + ;; Note "Post" menu is defined in gnus-sum.el for consistency - (gnus-run-hooks 'gnus-article-menu-hook)) - ;; Add the menu. - (when (boundp 'gnus-article-commands-menu) - (easy-menu-add gnus-article-commands-menu gnus-article-mode-map)) - (when (boundp 'gnus-summary-post-menu) - (easy-menu-add gnus-summary-post-menu gnus-article-mode-map))) + (gnus-run-hooks 'gnus-article-menu-hook))) ;; Fixme: do something for the Emacs tool bar in Article mode a la ;; Summary. @@ -3145,8 +3201,6 @@ commands: \\[gnus-article-describe-briefly]\t Describe the current mode briefly \\[gnus-info-find-node]\t Go to the Gnus info node" (interactive) - (when (gnus-visual-p 'article-menu 'menu) - (gnus-article-make-menu-bar)) (gnus-simplify-mode-line) (setq mode-name "Article") (setq major-mode 'gnus-article-mode) @@ -3154,6 +3208,8 @@ commands: (unless (assq 'gnus-show-mime minor-mode-alist) (push (list 'gnus-show-mime " MIME") minor-mode-alist)) (use-local-map gnus-article-mode-map) + (when (gnus-visual-p 'article-menu 'menu) + (gnus-article-make-menu-bar)) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) (make-local-variable 'gnus-page-broken) @@ -3303,7 +3359,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." result) (save-excursion (gnus-article-setup-buffer) - (set-buffer gnus-original-article-buffer) + (set-buffer gnus-article-buffer) ;; Deactivate active regions. (when (and (boundp 'transient-mark-mode) transient-mark-mode) @@ -3465,29 +3521,36 @@ If ALL-HEADERS is non-nil, no headers are hidden." ;;;###autoload (defun gnus-article-prepare-display () "Make the current buffer look like a nice article." - (setq gnus-article-wash-types nil) - (gnus-run-hooks 'gnus-tmp-internal-hook) - (gnus-run-hooks 'gnus-article-prepare-hook) + (let ((gnus-article-buffer (current-buffer)) + buffer-read-only) + (unless (eq major-mode 'gnus-article-mode) + (gnus-article-mode)) + (setq buffer-read-only nil + gnus-button-marker-list nil + gnus-article-wash-types nil) + (save-restriction + (widen) + (static-if (featurep 'xemacs) + (map-extents (lambda (extent maparg) (delete-extent extent))) + (let ((lists (overlay-lists))) + (dolist (overlay (nconc (car lists) (cdr lists))) + (delete-overlay overlay))))) + (gnus-run-hooks 'gnus-tmp-internal-hook)) + (set-buffer gnus-original-article-buffer) ;; Display message. - (let (mime-display-header-hook mime-display-text/plain-hook) - (funcall (if gnus-show-mime - (progn - (setq mime-message-structure gnus-current-headers) - (mime-buffer-entity-set-buffer-internal - mime-message-structure - gnus-original-article-buffer) - (mime-entity-set-representation-type-internal - mime-message-structure 'mime-buffer-entity) - (luna-send mime-message-structure - 'initialize-instance - mime-message-structure) - gnus-article-display-method-for-mime) - gnus-article-display-method-for-traditional))) - ;; Associate this article with the current summary buffer. - (setq gnus-article-current-summary gnus-summary-buffer) + (setq mime-message-structure gnus-current-headers) + (mime-buffer-entity-set-buffer-internal mime-message-structure + gnus-original-article-buffer) + (mime-entity-set-representation-type-internal mime-message-structure + 'mime-buffer-entity) + (luna-send mime-message-structure 'initialize-instance + mime-message-structure) + (if gnus-show-mime + (let (mime-display-header-hook mime-display-text/plain-hook) + (funcall gnus-article-display-method-for-mime)) + (funcall gnus-article-display-method-for-traditional)) ;; Call the treatment functions. - (let ((inhibit-read-only t) - buffer-read-only) + (let ((inhibit-read-only t)) (save-restriction (widen) (if gnus-show-mime @@ -3503,17 +3566,17 @@ If ALL-HEADERS is non-nil, no headers are hidden." (narrow-to-region (point) (point-max)) (gnus-treat-article nil)) (put-text-property (point-min) (point-max) 'read-only nil))) - ;; Perform the article display hooks. Incidentally, this hook is - ;; an obsolete variable by now. - (gnus-run-hooks 'gnus-article-display-hook)) + (gnus-run-hooks 'gnus-article-prepare-hook)) (defun gnus-article-decode-article-as-default-mime-charset () "Decode an article as `default-mime-charset'. It won't work if the value of the variable `gnus-show-mime' is non-nil." (unless gnus-show-mime + (set (make-local-variable 'default-mime-charset) + (with-current-buffer gnus-summary-buffer + default-mime-charset)) (decode-mime-charset-region (point-min) (point-max) - (with-current-buffer gnus-summary-buffer - default-mime-charset)))) + default-mime-charset))) ;;; ;;; Gnus MIME viewing functions @@ -3554,9 +3617,14 @@ value of the variable `gnus-show-mime' is non-nil." (defun gnus-article-mime-part-status () (with-current-buffer gnus-article-buffer - (let ((entity (get-text-property (point-min) 'mime-view-entity))) - (if (and entity (mime-entity-children entity)) - (format " (%d parts)" (length (mime-entity-children entity))) + (let ((entity (get-text-property (point-min) 'mime-view-entity)) + children) + (if (and entity + (setq children (mime-entity-children entity)) + (setq children (length children))) + (if (eq 1 children) + " (1 part)" + (format " (%d parts)" children)) "")))) (defvar gnus-mime-button-map @@ -3609,8 +3677,10 @@ value of the variable `gnus-show-mime' is non-nil." (interactive) (gnus-article-check-buffer) (let* ((data (get-text-property (point) 'gnus-data)) - (file (and data (mm-save-part data))) - param) + file param) + (if (mm-multiple-handles gnus-article-mime-handles) + (error "This function is not implemented.")) + (setq file (and data (mm-save-part data))) (when file (with-current-buffer (mm-handle-buffer data) (erase-buffer) @@ -3685,7 +3755,9 @@ value of the variable `gnus-show-mime' is non-nil." (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) (when data - (push (setq data (copy-sequence data)) gnus-article-mime-handles) + (setq gnus-article-mime-handles + (mm-merge-handles + gnus-article-mime-handles (setq data (copy-sequence data)))) (mm-interactively-view-part data)))) (defun gnus-mime-view-part-as-type-internal () @@ -3717,7 +3789,8 @@ value of the variable `gnus-show-mime' is non-nil." (mm-handle-description handle) (mm-handle-cache handle) (mm-handle-id handle))) - (push handle gnus-article-mime-handles) + (setq gnus-article-mime-handles + (mm-merge-handles gnus-article-mime-handles handle)) (gnus-mm-display-part handle)))) (defun gnus-mime-copy-part (&optional handle) @@ -3780,7 +3853,8 @@ value of the variable `gnus-show-mime' is non-nil." (goto-char b))))) (defun gnus-mime-view-part-as-charset (&optional handle arg) - "Insert the MIME part under point into the current buffer." + "Insert the MIME part under point into the current buffer using the +specified charset." (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) @@ -3815,7 +3889,7 @@ value of the variable `gnus-show-mime' is non-nil." (defun gnus-mime-internalize-part (&optional handle) "View the MIME part under point with an internal viewer. -In no internal viewer is available, use an external viewer." +If no internal viewer is available, use an external viewer." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) @@ -4092,6 +4166,8 @@ In no internal viewer is available, use an external viewer." (gnus-treat-article 'head)))))))) (defvar gnus-mime-display-multipart-as-mixed nil) +(defvar gnus-mime-display-multipart-alternative-as-mixed nil) +(defvar gnus-mime-display-multipart-related-as-mixed nil) (defun gnus-mime-display-part (handle) (cond @@ -4104,13 +4180,15 @@ In no internal viewer is available, use an external viewer." handle)) ;; multipart/alternative ((and (equal (car handle) "multipart/alternative") - (not gnus-mime-display-multipart-as-mixed)) + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-alternative-as-mixed))) (let ((id (1+ (length gnus-article-mime-handle-alist)))) (push (cons id handle) gnus-article-mime-handle-alist) (gnus-mime-display-alternative (cdr handle) nil nil id))) ;; multipart/related ((and (equal (car handle) "multipart/related") - (not gnus-mime-display-multipart-as-mixed)) + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-related-as-mixed))) ;;;!!!We should find the start part, but we just default ;;;!!!to the first part. ;;(gnus-mime-display-part (cadr handle)) @@ -4609,10 +4687,16 @@ Argument LINES specifies lines to be scrolled down." (save-excursion (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (elt key 0) unread-command-events) - (setq key (if (featurep 'xemacs) - (events-to-keys (read-key-sequence "Describe key: ")) - (read-key-sequence "Describe key: ")))) + (if (featurep 'xemacs) + (progn + (push (elt key 0) unread-command-events) + (setq key (events-to-keys + (read-key-sequence "Describe key: ")))) + (setq unread-command-events + (mapcar + (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) + key)) + (setq key (read-key-sequence "Describe key: ")))) (describe-key key)) (describe-key key))) @@ -4624,10 +4708,16 @@ Argument LINES specifies lines to be scrolled down." (save-excursion (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (elt key 0) unread-command-events) - (setq key (if (featurep 'xemacs) - (events-to-keys (read-key-sequence "Describe key: ")) - (read-key-sequence "Describe key: ")))) + (if (featurep 'xemacs) + (progn + (push (elt key 0) unread-command-events) + (setq key (events-to-keys + (read-key-sequence "Describe key: ")))) + (setq unread-command-events + (mapcar + (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) + key)) + (setq key (read-key-sequence "Describe key: ")))) (describe-key-briefly key insert)) (describe-key-briefly key insert))) @@ -4887,12 +4977,13 @@ groups." (set-buffer gnus-article-buffer) (gnus-article-edit-mode) (funcall start-func) + (set-buffer-modified-p 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"))) + (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit"))) (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." @@ -4902,7 +4993,20 @@ groups." (start (window-start))) (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind) - (gnus-article-edit-exit) + ;; We remove all text props from the article buffer. + (let ((content + (buffer-substring-no-properties (point-min) (point-max))) + (p (point))) + (erase-buffer) + (insert content) + (let ((winconf gnus-prev-winconf)) + (gnus-article-mode) + (set-window-configuration winconf) + ;; Tippy-toe some to make sure that point remains where it was. + (save-current-buffer + (set-buffer buf) + (set-window-start (get-buffer-window (current-buffer)) start) + (goto-char p)))) (save-excursion (set-buffer buf) (let ((buffer-read-only nil)) @@ -4926,21 +5030,22 @@ groups." (defun gnus-article-edit-exit () "Exit the article editing without updating." (interactive) - ;; We remove all text props from the article buffer. - (let ((buf (buffer-substring-no-properties (point-min) (point-max))) - (curbuf (current-buffer)) - (p (point)) - (window-start (window-start))) - (erase-buffer) - (insert buf) - (let ((winconf gnus-prev-winconf)) - (gnus-article-mode) - (set-window-configuration winconf) - ;; Tippy-toe some to make sure that point remains where it was. - (save-current-buffer - (set-buffer curbuf) - (set-window-start (get-buffer-window (current-buffer)) window-start) - (goto-char p))))) + (when (or (not (buffer-modified-p)) + (yes-or-no-p "Article modified; kill anyway? ")) + (let ((curbuf (current-buffer)) + (p (point)) + (window-start (window-start))) + (erase-buffer) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (insert-buffer gnus-original-article-buffer)) + (let ((winconf gnus-prev-winconf)) + (gnus-article-mode) + (set-window-configuration winconf) + ;; Tippy-toe some to make sure that point remains where it was. + (save-current-buffer + (set-buffer curbuf) + (set-window-start (get-buffer-window (current-buffer)) window-start) + (goto-char p)))))) (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." @@ -4963,12 +5068,12 @@ groups." (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))) + (font-lock-mode -1)) + (when mime-edit-mode-flag + (mime-edit-exit 'nomime 'no-error) + (message ""))) (defun gnus-article-mime-edit-article-setup () "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode @@ -4977,7 +5082,8 @@ after replacing with the original article." (setq gnus-article-edit-done-function `(lambda (&rest args) (when mime-edit-mode-flag - (mime-edit-exit) + (let (mime-edit-insert-user-agent-field) + (mime-edit-exit)) (message "")) (goto-char (point-min)) (let (case-fold-search) @@ -4985,53 +5091,79 @@ after replacing with the original article." (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) + (insert + (prog1 + (buffer-substring-no-properties (point-min) (point-max)) + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (erase-buffer))) (setq gnus-current-headers (gnus-article-make-full-mail-header)) + (set-buffer gnus-article-buffer) (gnus-article-prepare-display))) - (substitute-key-definition - 'gnus-article-edit-exit 'gnus-article-mime-edit-exit - gnus-article-edit-mode-map) + (substitute-key-definition 'gnus-article-edit-done + 'gnus-article-mime-edit-done + gnus-article-edit-mode-map) + (substitute-key-definition 'gnus-article-edit-exit + 'gnus-article-mime-edit-exit + gnus-article-edit-mode-map) (erase-buffer) (insert-buffer gnus-original-article-buffer) - (mime-edit-again) + (let ((ofn (symbol-function 'mime-edit-decode-single-part-in-buffer))) + (fset 'mime-edit-decode-single-part-in-buffer + (lambda (&rest args) + (if (let ((content-type (car args))) + (and (eq 'message (mime-content-type-primary-type + content-type)) + (eq 'rfc822 (mime-content-type-subtype content-type)))) + (setcar (cdr args) 'not-decode-text)) + (apply ofn args))) + (unwind-protect + (mime-edit-again) + (fset 'mime-edit-decode-single-part-in-buffer ofn))) (when (featurep 'font-lock) (set (make-local-variable 'font-lock-defaults) '(message-font-lock-keywords t)) (font-lock-set-defaults) (turn-on-font-lock)) + (set-buffer-modified-p nil) + (delete-other-windows) (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-done (&optional arg) + "Update the article MIME edits and exit." + (interactive "P") + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode -1)) + (gnus-article-edit-done arg)) + (defun gnus-article-mime-edit-exit () "Exit the article MIME editing without updating." (interactive) - (let ((winconf gnus-prev-winconf) - buf) + (when (or (not (buffer-modified-p)) + (yes-or-no-p "Article modified; kill anyway? ")) + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode -1)) (when mime-edit-mode-flag - (mime-edit-exit) + (let (mime-edit-insert-user-agent-field) + (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))) + (let ((winconf gnus-prev-winconf)) + (insert (prog1 + (buffer-substring-no-properties (point-min) (point-max)) + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (erase-buffer))) + (setq gnus-current-headers (gnus-article-make-full-mail-header)) + (set-buffer gnus-article-buffer) + (gnus-article-prepare-display) + (set-window-configuration winconf)))) ;;; ;;; Article highlights @@ -5047,9 +5179,10 @@ after replacing with the original article." :type 'regexp) (defcustom gnus-button-alist - `(("<\\(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) + `(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" + 0 t gnus-button-handle-news 3) + ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t + gnus-button-handle-news 2) ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t gnus-button-fetch-group 4) @@ -5057,7 +5190,7 @@ after replacing with the original article." ("\\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) + ("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) @@ -5435,6 +5568,45 @@ specified by `gnus-button-alist'." (gnus-message 1 "You must define `%S' to use this button" (cons fun args))))))) +(defun gnus-parse-news-url (url) + (let (scheme server group message-id articles) + (with-temp-buffer + (insert url) + (goto-char (point-min)) + (when (looking-at "\\([A-Za-z]+\\):") + (setq scheme (match-string 1)) + (goto-char (match-end 0))) + (when (looking-at "//\\([^/]+\\)/") + (setq server (match-string 1)) + (goto-char (match-end 0))) + + (cond + ((looking-at "\\(.*@.*\\)") + (setq message-id (match-string 1))) + ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)") + (setq group (match-string 1) + articles (split-string (match-string 2) "-"))) + ((looking-at "\\([^/]+\\)/?") + (setq group (match-string 1))) + (t + (error "Unknown news URL syntax")))) + (list scheme server group message-id articles))) + +(defun gnus-button-handle-news (url) + "Fetch a news URL." + (destructuring-bind (scheme server group message-id articles) + (gnus-parse-news-url url) + (cond + (message-id + (save-excursion + (set-buffer gnus-summary-buffer) + (if server + (let ((gnus-refer-article-method (list (list 'nntp server)))) + (gnus-summary-refer-article message-id)) + (gnus-summary-refer-article message-id)))) + (group + (gnus-button-fetch-group url))))) + (defun gnus-button-message-id (message-id) "Fetch MESSAGE-ID." (save-excursion