;;; 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 <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
(require 'mm-uu)
)
+(autoload 'gnus-msg-mail "gnus-msg" nil t)
+(autoload 'gnus-button-mailto "gnus-msg")
+(autoload 'gnus-button-reply "gnus-msg" nil t)
+
(defgroup gnus-article nil
"Article display."
:link '(custom-manual "(gnus)The Article Buffer")
(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)
:type 'sexp
:group 'gnus-article-hiding)
+;; Fixme: This isn't the right thing for mixed graphical and and
+;; non-graphical frames in a session.
+;; gnus-xmas.el overrides this for XEmacs.
(defcustom gnus-article-x-face-command
(cond
- ;; Fixme: This isn't the right thing for mixed graphical and and
- ;; non-graphical frames in a session.
- ;; gnus-xmas.el overrides this for XEmacs.
+ ((and (fboundp 'image-type-available-p)
+ (module-installed-p 'x-face-e21))
+ 'x-face-decode-message-header)
((and (fboundp 'image-type-available-p)
(image-type-available-p 'xbm))
- (if (module-installed-p 'x-face-e21)
- 'x-face-decode-message-header
- 'gnus-article-display-xface))
+ 'gnus-article-display-xface)
((and (not (featurep 'xemacs))
window-system
(module-installed-p 'x-face-mule))
(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
(defcustom gnus-article-banner-alist nil
"Banner alist for stripping.
-For example,
- ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
+For example,
+ ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
:version "21.1"
:type '(repeat (cons symbol regexp))
:group 'gnus-article-washing)
-(gnus-define-group-parameter
+(gnus-define-group-parameter
banner
:variable-document
"Alist of regexps (to match group names) and banner."
:variable-group gnus-article-washing
- :parameter-type
+ :parameter-type
'(choice :tag "Banner"
:value nil
(const :tag "Remove signature" signature)
(symbol :tag "Item in `gnus-article-banner-alist'" none)
regexp
(const :tag "None" nil))
- :parameter-document
+ :parameter-document
"If non-nil, specify how to remove `banners' from articles.
Symbol `signature' means to remove signatures delimited by
:type 'hook
:group 'gnus-article-various)
+(when (featurep 'xemacs)
+ ;; Extracted from gnus-xmas-define in order to preserve user settings
+ (when (fboundp 'turn-off-scroll-in-place)
+ (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
+ ;; Extracted from gnus-xmas-redefine in order to preserve user settings
+ (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
+
(defcustom gnus-article-menu-hook nil
"*Hook run after the creation of the article mode menu."
:type 'hook
(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
"Function called with a MIME handle as the argument.
This is meant for people who want to view first matched part.
-For `undisplayed-alternative' (default), the first undisplayed
-part or alternative part is used. For `undisplayed', the first
-undisplayed part is used. For a function, the first part which
+For `undisplayed-alternative' (default), the first undisplayed
+part or alternative part is used. For `undisplayed', the first
+undisplayed part is used. For a function, the first part which
the function return `t' is used. For `nil', the first part is
used."
:version "21.1"
:group 'gnus-article-mime
- :type '(choice
+ :type '(choice
(item :tag "first" :value nil)
(item :tag "undisplayed" :value undisplayed)
- (item :tag "undisplayed or alternative"
+ (item :tag "undisplayed or alternative"
:value undisplayed-alternative)
(function)))
: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.
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)
(image-type-available-p 'pbm))
(and (not (featurep 'xemacs))
window-system
- (module-installed-p 'gnus-bitmap)))
+ (module-installed-p 'smiley-mule)))
t
nil)
"Display smileys.
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)
(defvar gnus-article-mime-handle-alist-1 nil)
(defvar gnus-treatment-function-alist
- '((gnus-treat-decode-article-as-default-mime-charset
+ `((gnus-treat-decode-article-as-default-mime-charset
gnus-article-decode-article-as-default-mime-charset)
(gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
(gnus-treat-strip-banner gnus-article-strip-banner)
(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)
gnus-article-strip-multiple-blank-lines)
(gnus-treat-overstrike gnus-article-treat-overstrike)
(gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
- (gnus-treat-display-smileys gnus-article-smiley-display)
+ (gnus-treat-display-smileys ,(if (or (featurep 'xemacs)
+ (>= emacs-major-version 21))
+ 'gnus-smiley-display
+ 'gnus-article-smiley-display))
(gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
(gnus-treat-display-picons gnus-article-display-picons)
(gnus-treat-play-sounds gnus-earcon-display)))
(defvar gnus-article-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
;; This causes the citation match run O(2^n).
- ;; (modify-syntax-entry ?- "w" table)
+ ;; (modify-syntax-entry ?- "w" table)
(modify-syntax-entry ?> ")" table)
(modify-syntax-entry ?< "(" table)
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)
'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"))
(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")))
(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
(when (process-status "article-x-face")
(delete-process "article-x-face"))
(let ((inhibit-point-motion-hooks t)
+ x-faces
(case-fold-search t)
from last)
(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"))
(goto-char (point-min))
(not (string-match gnus-article-x-face-too-ugly
from))))
;; Has to be present.
- (re-search-forward "^X-Face:[ \t]*" nil t))
+ (re-search-forward "^X-Face:[\t ]*" 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
(let ((inhibit-point-motion-hooks t)
buffer-read-only
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (set-buffer gnus-summary-buffer)
gnus-newsgroup-ignored-charsets)))
(mail-decode-encoded-word-region (point-min) (point-max)))))
(let ((inhibit-point-motion-hooks t) (case-fold-search t)
buffer-read-only
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (condition-case nil
(set-buffer gnus-summary-buffer)
(error))
format (and ctl (mail-content-type-get ctl 'format)))
(when cte
(setq cte (mail-header-strip cte)))
- (if (and ctl (not (string-match "/" (car ctl))))
+ (if (and ctl (not (string-match "/" (car ctl))))
(setq ctl nil))
(goto-char (point-max)))
(forward-line 1)
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
+ (ctl (and ct
(ignore-errors
(mail-header-parse-content-type ct)))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
- (unless charset
+ (unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(and type (let ((case-fold-search t))
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
+ (ctl (and ct
(ignore-errors
(mail-header-parse-content-type ct)))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
- (unless charset
+ (unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(and type (let ((case-fold-search t))
(if (gnus-buffer-live-p gnus-original-article-buffer)
(with-current-buffer gnus-original-article-buffer
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
+ (ctl (and ct
(ignore-errors
(mail-header-parse-content-type ct)))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
- (unless charset
+ (unless charset
(setq charset gnus-newsgroup-charset))
(article-goto-body)
(save-window-excursion
"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."
Originally it is hide instead of DUMMY."
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t))
- (gnus-remove-text-properties-when
+ (gnus-remove-text-properties-when
'article-type type
- (point-min) (point-max)
+ (point-min) (point-max)
(cons 'article-type (cons type
gnus-hidden-properties)))))
(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
- ((= 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."
(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))
(unless (gnus-article-check-hidden-text 'emphasis arg)
(save-excursion
- (let ((alist (or
+ (let ((alist (or
(condition-case nil
- (with-current-buffer gnus-summary-buffer
- gnus-article-emphasis-alist)
+ (with-current-buffer gnus-summary-buffer
+ gnus-article-emphasis-alist)
(error))
gnus-emphasis-alist))
(buffer-read-only nil)
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.
(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: "
"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)
(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)
(let ((sig (with-current-buffer gnus-original-article-buffer
(gnus-fetch-field "X-PGP-Sig")))
items info headers)
- (when (and sig
+ (when (and sig
mml2015-use
(mml2015-clear-verify-function))
(with-temp-buffer
(case-fold-search t))
;; Don't verify multiple headers.
(setq headers (mapconcat (lambda (header)
- (concat header ": "
+ (concat header ": "
(mail-fetch-field header) "\n"))
(split-string (nth 1 items) ",") "")))
(delete-region (point-min) (point-max))
(let ((coding-system-for-write (or gnus-newsgroup-charset
'iso-8859-1)))
(funcall (mml2015-clear-verify-function)))
- (setq info
- (or (mm-handle-multipart-ctl-parameter
+ (setq info
+ (or (mm-handle-multipart-ctl-parameter
mm-security-handle 'gnus-details)
- (mm-handle-multipart-ctl-parameter
+ (mm-handle-multipart-ctl-parameter
mm-security-handle 'gnus-info)))))
(when info
(let (buffer-read-only bface eface)
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
"\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
["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.
\\[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)
(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)
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)
;;;###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
(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
(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
(set-buffer gnus-article-buffer)
(let ((handles (or handles gnus-article-mime-handles))
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(with-current-buffer gnus-summary-buffer
gnus-newsgroup-ignored-charsets)))
(when handles
"Save the MIME part under point then replace it with an external body."
(interactive)
(gnus-article-check-buffer)
- (let* ((data (get-text-property (point) 'gnus-data))
- (file (and data (mm-save-part data)))
- param)
+ (let* ((data (get-text-property (point) 'gnus-data))
+ 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)
(insert "Content-Transfer-Encoding: binary\n")
(insert "\n"))
(setcdr data
- (cdr (mm-make-handle nil
+ (cdr (mm-make-handle nil
`("message/external-body"
(access-type . "LOCAL-FILE")
(name . ,file)))))
(set-buffer gnus-summary-buffer)
(gnus-article-edit-article
- `(lambda ()
+ `(lambda ()
(erase-buffer)
- (let ((mail-parse-charset (or gnus-article-charset
+ (let ((mail-parse-charset (or gnus-article-charset
',gnus-newsgroup-charset))
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(or gnus-article-ignored-charsets
',gnus-newsgroup-ignored-charsets))
(mbl mml-buffer-list))
',gnus-newsgroup-charset))
(message-options message-options)
(message-options-set-recipient)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(or gnus-article-ignored-charsets
',gnus-newsgroup-ignored-charsets)))
(mml-to-mime)
(mml-destroy-buffers)
- (remove-hook 'kill-buffer-hook
+ (remove-hook 'kill-buffer-hook
'mml-destroy-buffers t)
(kill-local-variable 'mml-buffer-list))
(gnus-summary-edit-article-done
,(or (mail-header-references gnus-current-headers) "")
- ,(gnus-group-read-only-p)
+ ,(gnus-group-read-only-p)
,gnus-summary-buffer no-highlight))))))
(defun gnus-mime-save-part ()
(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 ()
(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)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(contents (and handle (mm-get-part handle)))
- (base (and handle
+ (base (and handle
(file-name-nondirectory
(or
(mail-content-type-get (mm-handle-type handle) 'name)
(if (mm-handle-undisplayer handle)
(mm-remove-part handle))
(setq charset
- (or (cdr (assq arg
+ (or (cdr (assq arg
gnus-summary-show-article-charset-alist))
(read-coding-system "Charset: ")))))
(forward-line 2)
(mm-insert-inline handle
- (if (and charset
- (setq charset (mm-charset-to-coding-system
+ (if (and charset
+ (setq charset (mm-charset-to-coding-system
charset))
(not (eq charset 'ascii)))
(mm-decode-coding-string contents charset)
(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)))
(if (mm-handle-undisplayer handle)
(mm-remove-part handle))
(let ((gnus-newsgroup-charset
- (or (cdr (assq arg
+ (or (cdr (assq arg
gnus-summary-show-article-charset-alist))
(read-coding-system "Charset: ")))
(gnus-newsgroup-ignored-charsets 'gnus-all))
(mm-user-display-methods nil)
(mm-inlined-types nil)
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (set-buffer gnus-summary-buffer)
gnus-newsgroup-ignored-charsets)))
(when handle
(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)))
(mm-inlined-types '(".*"))
(mm-inline-large-images t)
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (set-buffer gnus-summary-buffer)
gnus-newsgroup-ignored-charsets)))
(when handle
(if condition
(let ((alist gnus-article-mime-handle-alist) ihandle n)
(while (setq ihandle (pop alist))
- (if (and (cond
+ (if (and (cond
((functionp condition)
(funcall condition (cdr ihandle)))
- ((eq condition 'undisplayed)
+ ((eq condition 'undisplayed)
(not (or (mm-handle-undisplayer (cdr ihandle))
(equal (mm-handle-media-type (cdr ihandle))
"multipart/alternative"))))
(interactive "P")
(save-current-buffer
(set-buffer gnus-article-buffer)
- (or (numberp n) (setq n (gnus-article-mime-match-handle-first
+ (or (numberp n) (setq n (gnus-article-mime-match-handle-first
gnus-article-mime-match-handle-function)))
(when (> n (length gnus-article-mime-handle-alist))
(error "No such part"))
(prog1
(let ((window (selected-window))
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (set-buffer gnus-summary-buffer)
gnus-newsgroup-ignored-charsets)))
(save-excursion
gnus-mime-button-line-format gnus-mime-button-line-format-alist
`(keymap ,gnus-mime-button-map
,@(if (>= (string-to-number emacs-version) 21)
- nil
+ nil
(list 'local-map gnus-mime-button-map))
gnus-callback gnus-mm-display-part
gnus-part ,gnus-tmp-id
(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
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))
;;;!!! Most multipart/related is an HTML message plus images.
- ;;;!!! Unfortunately we are unable to let W3 display those
+ ;;;!!! Unfortunately we are unable to let W3 display those
;;;!!! included images, so we just display it as a mixed multipart.
;;(gnus-mime-display-mixed (cdr handle))
;;;!!! No, w3 can display everything just fine.
;(gnus-article-insert-newline)
(gnus-insert-mime-button
handle id (list (or display (and not-attachment text))))
- (gnus-article-insert-newline)
- ;(gnus-article-insert-newline)
+ (gnus-article-insert-newline)
+ ;(gnus-article-insert-newline)
;; Remember modify the number of forward lines.
(setq move t))
(setq beg (point))
(forward-line -1)
(setq beg (point)))
(let ((mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (condition-case ()
(set-buffer gnus-summary-buffer)
(error))
(save-restriction
(narrow-to-region beg (point))
(gnus-treat-article
- nil id
+ nil id
(gnus-article-mime-total-parts)
(mm-handle-media-type handle)))))))))
(if (stringp (car preferred))
(gnus-display-mime preferred)
(let ((mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (set-buffer gnus-summary-buffer)
gnus-newsgroup-ignored-charsets)))
(mm-display-part preferred)
(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)))
(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)))
((or (stringp article)
(numberp article))
(let ((gnus-override-method gnus-override-method)
- (methods (and (stringp article)
+ (methods (and (stringp article)
gnus-refer-article-method))
result
(buffer-read-only nil))
(gnus-check-group-server))
(when (gnus-request-article article group (current-buffer))
(when (numberp article)
- (gnus-async-prefetch-next group article
+ (gnus-async-prefetch-next group article
gnus-summary-buffer)
(when gnus-keep-backlog
(gnus-backlog-enter-article
(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."
(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))
(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."
(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
(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)
(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
: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)
("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
t gnus-button-message-id 3)
("\\(<URL: *\\)mailto: *\\([^> \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...
("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
(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
(setq to (gnus-url-unhex-string url)))
(setq args (cons (list "to" to) args)
subject (cdr-safe (assoc "subject" args)))
- (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))
-
-(defalias 'gnus-button-reply 'message-reply)
+ (gnus-msg-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-embedded-url (address)
"Activate ADDRESS with `browse-url'."
(browse-url (gnus-strip-whitespace address)))
+(eval-when-compile
+ ;; Silence the byte-compiler.
+ (autoload 'smiley-toggle-buffer "gnus-bitmap"))
(defun gnus-article-smiley-display ()
"Display \"smileys\" as small graphical icons."
(smiley-toggle-buffer 1 (current-buffer) (point-min) (point-max)))
(defun gnus-article-encrypt-body (protocol &optional n)
"Encrypt the article body."
- (interactive
+ (interactive
(list
(or gnus-article-encrypt-protocol
(completing-read "Encrypt protocol: "
- gnus-article-encrypt-protocol-alist
+ gnus-article-encrypt-protocol-alist
nil t))
current-prefix-arg))
(let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
(let* ((buffer-read-only nil)
(headers
(mapcar (lambda (field)
- (and (save-restriction
+ (and (save-restriction
(message-narrow-to-head)
(goto-char (point-min))
(search-forward field nil t))
(mm-remove-parts (cdr handle))
(let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
buffer-read-only)
- (when region
+ (when region
(delete-region (car region) (cdr region))
(set-marker (car region) nil)
(set-marker (cdr region) nil)))
(if details
(if gnus-mime-security-show-details-inline
(let ((gnus-mime-security-button-pressed t)
- (gnus-mime-security-button-line-format
+ (gnus-mime-security-button-line-format
(get-text-property (point) 'gnus-line-format))
buffer-read-only)
(forward-char -1)
(forward-char -1))
(forward-char)
(delete-region (point)
- (or (text-property-not-all
+ (or (text-property-not-all
(point) (point-max)
- 'gnus-line-format
+ 'gnus-line-format
gnus-mime-security-button-line-format)
(point-max)))
(gnus-insert-mime-security-button handle))
(defun gnus-insert-mime-security-button (handle &optional displayed)
(let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
(gnus-tmp-type
- (concat
+ (concat
(or (nth 2 (assoc protocol mm-verify-function-alist))
(nth 2 (assoc protocol mm-decrypt-function-alist))
"Unknown")
(setq gnus-tmp-details
(if gnus-tmp-details
(concat "\n" gnus-tmp-details) ""))
- (setq gnus-tmp-pressed-details
+ (setq gnus-tmp-pressed-details
(if gnus-mime-security-button-pressed gnus-tmp-details ""))
(unless (bolp)
(insert "\n"))
(setq b (point))
(gnus-eval-format
- gnus-mime-security-button-line-format
+ gnus-mime-security-button-line-format
gnus-mime-security-button-line-format-alist
`(keymap ,gnus-mime-security-button-map
,@(if (>= (string-to-number emacs-version) 21)
nil ;; XEmacs doesn't care
(list 'local-map gnus-mime-security-button-map))
gnus-callback gnus-mime-security-press-button
- gnus-line-format ,gnus-mime-security-button-line-format
+ gnus-line-format ,gnus-mime-security-button-line-format
article-type annotation
gnus-data ,handle))
(setq e (point))
(gnus-mime-display-mixed (cdr handle))
(unless (bolp)
(insert "\n"))
- (let ((gnus-mime-security-button-line-format
+ (let ((gnus-mime-security-button-line-format
gnus-mime-security-button-end-line-format))
(gnus-insert-mime-security-button handle))
(mm-set-handle-multipart-parameter
- handle 'gnus-region
+ handle 'gnus-region
(cons (set-marker (make-marker) (point-min))
(set-marker (make-marker) (point-max))))))
projects / elisp / gnus.git- / blobdiff