-;;; gnus-art.el --- article mode commands for Gnus
+;;; gnus-art.el --- article mode commands for Semi-gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
(require 'gnus-spec)
(require 'gnus-int)
(require 'browse-url)
+(require 'alist)
+(require 'mime-view)
(defgroup gnus-article nil
"Article display."
(defcustom gnus-ignored-headers
'("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
- "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
+ "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
"^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
"^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
"^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
"^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"
"^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
- "^NNTP-[-A-Za-z]*:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
+ "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
"^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
"^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"
"^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"
- "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
- "^X-Admin:" "^X-UID:")
+ "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
+ "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
+ "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
+ "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:"
+ "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
+ "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
+ "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
+ "^Status:")
"*All headers that start with this regexp will be hidden.
This variable can also be a list of regexps of headers to be ignored.
If `gnus-visible-headers' is non-nil, this variable will be ignored."
:group 'gnus-article-hiding)
(defcustom gnus-visible-headers
- "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:"
+ "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:"
"*All headers that do not match this regexp will be hidden.
This variable can also be a list of regexp of headers to remain visible.
If this variable is non-nil, `gnus-ignored-headers' will be ignored."
:group 'gnus-article-washing)
(eval-and-compile
- (autoload 'hexl-hex-string-to-integer "hexl")
- (autoload 'timezone-make-date-arpa-standard "timezone")
(autoload 'mail-extract-address-components "mail-extr"))
(defcustom gnus-save-all-headers t
(cons :value ("" "") regexp (repeat string))
(sexp :value nil))))
-(defcustom gnus-strict-mime t
- "*If nil, MIME-decode even if there is no Mime-Version header."
+(defcustom gnus-article-display-method-for-mime
+ 'gnus-article-display-mime-message
+ "Function to display a MIME message.
+The function is called from the article buffer."
:group 'gnus-article-mime
- :type 'boolean)
+ :type 'function)
-(defcustom gnus-show-mime-method 'metamail-buffer
- "Function to process a MIME message.
+(defcustom gnus-article-display-method-for-encoded-word
+ 'gnus-article-display-message-with-encoded-word
+ "*Function to display a message with MIME encoded-words.
The function is called from the article buffer."
:group 'gnus-article-mime
:type 'function)
-(defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable
- "*Function to decode MIME encoded words.
+(defcustom gnus-article-display-method-for-traditional
+ 'gnus-article-display-traditional-message
+ "*Function to display a traditional message.
The function is called from the article buffer."
:group 'gnus-article-mime
:type 'function)
:type 'regexp
:group 'gnus-article-various)
-(defcustom gnus-article-mode-line-format "Gnus: %%b %S"
+(defcustom gnus-article-mode-line-format "Gnus: %g %S"
"*The format specification for the article mode line.
See `gnus-summary-mode-line-format' for a closer description."
:type 'string
(item :tag "skip" nil)
(face :value default)))))
+(defcustom gnus-article-decode-hook nil
+ "*Hook run to decode charsets in articles."
+ :group 'gnus-article-headers
+ :type 'hook)
+
+(defcustom gnus-display-mime-function 'gnus-display-mime
+ "Function to display MIME articles."
+ :group 'gnus-article-headers
+ :type 'function)
+
+(defvar gnus-decode-header-function 'mail-decode-encoded-word-region
+ "Function used to decode headers.")
+
;;; Internal variables
+(defvar gnus-article-mime-handle-alist nil)
(defvar article-lapsed-timer nil)
(defvar gnus-article-current-summary nil)
(listp gnus-visible-headers))
(mapconcat 'identity gnus-visible-headers "\\|"))))
(inhibit-point-motion-hooks t)
- want-list beg)
+ beg)
;; First we narrow to just the headers.
(widen)
(goto-char (point-min))
from reply-to
(ignore-errors
(equal
- (nth 1 (mail-extract-address-components from))
- (nth 1 (mail-extract-address-components reply-to)))))
+ (nth 1 (funcall gnus-extract-address-components from))
+ (nth 1 (funcall gnus-extract-address-components reply-to)))))
(gnus-article-hide-header "reply-to"))))
((eq elem 'date)
(let ((date (message-fetch-field "date")))
(when (and date
- (< (gnus-days-between (current-time-string) date)
+ (< (days-between (current-time-string) date)
4))
(gnus-article-hide-header "date"))))
((eq elem 'long-to)
(defun article-treat-dumbquotes ()
"Translate M******** sm*rtq**t*s into proper text."
(interactive)
- (article-translate-characters "\221\222\223\223" "`'\"\""))
+ (article-translate-characters "\221\222\223\224" "`'\"\""))
(defun article-translate-characters (from to)
"Translate all characters in the body of the article according to FROM and TO.
(point)
(progn
(while (and (not (bobp))
- (looking-at "^[ \t]*$"))
+ (looking-at "^[ \t]*$")
+ (not (gnus-annotation-in-region-p
+ (point) (gnus-point-at-eol))))
(forward-line -1))
(forward-line 1)
(point))))))
(delete-process "article-x-face"))
(let ((inhibit-point-motion-hooks t)
(case-fold-search t)
- from)
+ from last)
(save-restriction
(nnheader-narrow-to-headers)
(setq from (message-fetch-field "from"))
(goto-char (point-min))
- ;; This used to try to do multiple faces (`while' instead of
- ;; `when' below), but (a) sending multiple EOFs to xv doesn't
- ;; work (b) it can crash some versions of Emacs (c) are
- ;; multiple faces really something to encourage?
- (when (and gnus-article-x-face-command
- (or force
- ;; Check whether this face is censored.
- (not gnus-article-x-face-too-ugly)
- (and gnus-article-x-face-too-ugly from
- (not (string-match gnus-article-x-face-too-ugly
- from))))
- ;; Has to be present.
- (re-search-forward "^X-Face: " nil t))
+ (while (and gnus-article-x-face-command
+ (not last)
+ (or force
+ ;; Check whether this face is censored.
+ (not gnus-article-x-face-too-ugly)
+ (and gnus-article-x-face-too-ugly from
+ (not (string-match gnus-article-x-face-too-ugly
+ from))))
+ ;; Has to be present.
+ (re-search-forward "^X-Face: " nil t))
+ ;; This used to try to do multiple faces (`while' instead of
+ ;; `when' above), but (a) sending multiple EOFs to xv doesn't
+ ;; work (b) it can crash some versions of Emacs (c) are
+ ;; multiple faces really something to encourage?
+ (when (stringp gnus-article-x-face-command)
+ (setq last t))
;; We now have the area of the buffer where the X-Face is stored.
(save-excursion
(let ((beg (point))
(process-send-region "article-x-face" beg end)
(process-send-eof "article-x-face"))))))))))
-(defun gnus-hack-decode-rfc1522 ()
- "Emergency hack function for avoiding problems when decoding."
- (let ((buffer-read-only nil))
- (goto-char (point-min))
- ;; Remove encoded TABs.
- (while (search-forward "=09" nil t)
- (replace-match " " t t))
- ;; Remove encoded newlines.
- (goto-char (point-min))
- (while (search-forward "=10" nil t)
- (replace-match " " t t))))
-
-(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522)
-(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522)
-(defun article-decode-rfc1522 ()
- "Hack to remove QP encoding from headers."
- (let ((case-fold-search t)
- (inhibit-point-motion-hooks t)
- (buffer-read-only nil)
- string)
+(defun article-decode-mime-words ()
+ "Decode all MIME-encoded words in the article."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
+ (mail-decode-encoded-word-region (point-min) (point-max)))))
+
+(defun article-decode-charset (&optional prompt)
+ "Decode charset-encoded text in the article.
+If PROMPT (the prefix), prompt for a coding system to use."
+ (interactive "P")
+ (save-excursion
(save-restriction
- (narrow-to-region
- (goto-char (point-min))
- (or (search-forward "\n\n" nil t) (point-max)))
- (goto-char (point-min))
- (while (re-search-forward
- "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t)
- (setq string (match-string 1))
- (save-restriction
- (narrow-to-region (match-beginning 0) (match-end 0))
- (delete-region (point-min) (point-max))
- (insert string)
- (article-mime-decode-quoted-printable
- (goto-char (point-min)) (point-max))
- (subst-char-in-region (point-min) (point-max) ?_ ? )
- (goto-char (point-max)))
- (goto-char (point-min))))))
+ (message-narrow-to-head)
+ (let* ((inhibit-point-motion-hooks t)
+ (case-fold-search t)
+ (ct (message-fetch-field "Content-Type" t))
+ (cte (message-fetch-field "Content-Transfer-Encoding" t))
+ (ctl (and ct (condition-case ()
+ (mail-header-parse-content-type ct)
+ (error nil))))
+ (charset (cond
+ (prompt
+ (mm-read-coding-system "Charset to decode: "))
+ (ctl
+ (mail-content-type-get ctl 'charset))
+ (gnus-newsgroup-name
+ (gnus-group-find-parameter
+ gnus-newsgroup-name 'charset))))
+ buffer-read-only)
+ (goto-char (point-max))
+ (widen)
+ (forward-line 1)
+ (narrow-to-region (point) (point-max))
+ (when (or (not ct)
+ (equal (car ctl) "text/plain"))
+ (mm-decode-body
+ charset (and cte (intern (downcase
+ (gnus-strip-whitespace cte))))))))))
+
+(defun article-decode-encoded-words ()
+ "Remove encoded-word encoding from headers."
+ (let (buffer-read-only)
+ (let ((charset (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset)))
+ (eword-decode-header charset)
+ )))
(defun article-de-quoted-unreadable (&optional force)
- "Do a naive translation of a quoted-printable-encoded article.
-This is in no way, shape or form meant as a replacement for real MIME
-processing, but is simply a stop-gap measure until MIME support is
-written.
+ "Translate a quoted-printable-encoded article.
If FORCE, decode the article whether it is marked as quoted-printable
or not."
(interactive (list 'force))
(save-excursion
- (let ((case-fold-search t)
- (buffer-read-only nil)
+ (let ((buffer-read-only nil)
(type (gnus-fetch-field "content-transfer-encoding")))
- (gnus-article-decode-rfc1522)
(when (or force
(and type (string-match "quoted-printable" (downcase type))))
(goto-char (point-min))
(search-forward "\n\n" nil 'move)
- (article-mime-decode-quoted-printable (point) (point-max))))))
+ (quoted-printable-decode-region (point) (point-max))))))
(defun article-mime-decode-quoted-printable-buffer ()
"Decode Quoted-Printable in the current buffer."
- (article-mime-decode-quoted-printable (point-min) (point-max)))
-
-(defun article-mime-decode-quoted-printable (from to)
- "Decode Quoted-Printable in the region between FROM and TO."
- (interactive "r")
- (goto-char from)
- (while (search-forward "=" to t)
- (cond ((eq (following-char) ?\n)
- (delete-char -1)
- (delete-char 1))
- ((looking-at "[0-9A-F][0-9A-F]")
- (subst-char-in-region
- (1- (point)) (point) ?=
- (hexl-hex-string-to-integer
- (buffer-substring (point) (+ 2 (point)))))
- (delete-char 2))
- ((looking-at "=")
- (delete-char 1))
- ((gnus-message 3 "Malformed MIME quoted-printable message")))))
+ (quoted-printable-decode-region (point-min) (point-max)))
(defun article-hide-pgp (&optional arg)
"Toggle hiding of any PGP headers and signatures in the current article.
(goto-char (point-min))
(search-forward "\n\n" nil t)
(while (re-search-forward "^[ \t]+$" nil t)
- (replace-match "" nil t))
+ (unless (gnus-annotation-in-region-p
+ (match-beginning 0) (match-end 0))
+ (replace-match "" nil t)))
;; Then replace multiple empty lines with a single empty line.
(goto-char (point-min))
(search-forward "\n\n" nil t)
(while (re-search-forward "\n\n\n+" nil t)
- (replace-match "\n\n" t t)))))
+ (unless (gnus-annotation-in-region-p
+ (match-beginning 0) (match-end 0))
+ (replace-match "\n\n" t t))))))
(defun article-strip-leading-space ()
"Remove all white space from the beginning of the lines in the article."
(while (re-search-forward "^[ \t]*\n" nil t)
(replace-match "" t t)))))
-(defvar mime::preview/content-list)
-(defvar mime::preview-content-info/point-min)
(defun gnus-article-narrow-to-signature ()
"Narrow to the signature; return t if a signature is found, else nil."
(widen)
(let ((inhibit-point-motion-hooks t))
- (when (and (boundp 'mime::preview/content-list)
- mime::preview/content-list)
- ;; We have a MIMEish article, so we use the MIME data to narrow.
- (let ((pcinfo (car (last mime::preview/content-list))))
- (ignore-errors
- (narrow-to-region
- (funcall (intern "mime::preview-content-info/point-min") pcinfo)
- (point-max)))))
-
(when (gnus-article-search-signature)
(forward-line 1)
;; Check whether we have some limits to what we consider
(setq b (point))
(point-max))
(setq e (point-max)))
- (nnheader-temp-write nil
+ (with-temp-buffer
(insert-buffer-substring gnus-article-buffer b e)
(require 'url)
(save-window-excursion
(defun gnus-article-hidden-text-p (type)
"Say whether the current buffer contains hidden text of type TYPE."
- (let ((start (point-min))
- (pos (text-property-any (point-min) (point-max) 'article-type type)))
+ (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
(while (and pos
(not (get-text-property pos 'invisible)))
(setq pos
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
- (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)
- (concat "Date: " (condition-case ()
- (timezone-make-date-arpa-standard date)
- (error date))))
- ;; Convert to Universal Time.
- ((eq type 'ut)
- (concat "Date: "
- (condition-case ()
- (timezone-make-date-arpa-standard date nil "UT")
- (error date))))
- ;; Get the original date from the article.
- ((eq type 'original)
- (concat "Date: " date))
- ;; Let the user define the format.
- ((eq type 'user)
- (if (gnus-functionp gnus-article-time-format)
- (funcall
- gnus-article-time-format
- (ignore-errors
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT"))))
+ (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))))
+ (format "Date: %s %s%04d" (current-time-string time)
+ (if (> tz 0) "+" "-") (abs (/ tz 36)))))
+ ;; 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)))))
+ (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)
(concat
"Date: "
- (format-time-string gnus-article-time-format
- (ignore-errors
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT")))))))
- ;; ISO 8601.
- ((eq type 'iso8601)
- (concat
- "Date: "
- (format-time-string "%Y%M%DT%h%m%s"
- (ignore-errors
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT"))))))
- ;; 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
- (ignore-errors
- (gnus-time-minus
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- (current-time-string now)
- (current-time-zone now) "UT"))
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT")))))
- (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"))))))
- (t
- (error "Unknown conversion type: %s" type))))
+ (format-time-string "%Y%M%DT%h%m%s" time)))
+ ;; 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"))))))
+ (t
+ (error "Unknown conversion type: %s" type)))))
(defun article-date-local (&optional highlight)
"Convert the current article date to the local timezone."
(let (deactivate-mark)
(save-excursion
(ignore-errors
- (when (gnus-buffer-live-p gnus-article-buffer)
- (set-buffer gnus-article-buffer)
- (goto-char (point-min))
- (when (re-search-forward "^X-Sent:" nil t)
- (article-date-lapsed t)))))))
+ (walk-windows
+ (lambda (w)
+ (set-buffer (window-buffer w))
+ (when (eq major-mode 'gnus-article-mode)
+ (goto-char (point-min))
+ (when (re-search-forward "^X-Sent:" nil t)
+ (article-date-lapsed t)))))))))
(defun gnus-start-date-timer (&optional n)
"Start a timer to update the X-Sent header in the article buffers.
(if (not gnus-default-article-saver)
(error "No default saver is defined")
;; !!! Magic! The saving functions all save
- ;; `gnus-original-article-buffer' (or so they think), but we
+ ;; `gnus-save-article-buffer' (or so they think), but we
;; bind that variable to our save-buffer.
(set-buffer gnus-article-buffer)
(let* ((gnus-save-article-buffer save-buffer)
(save-excursion
(save-restriction
(widen)
- (gnus-output-to-rmail filename))))
+ (rmail-output-to-rmail-file filename))))
filename)
(defun gnus-summary-save-in-mail (&optional filename)
(widen)
(if (and (file-readable-p filename)
(mail-file-babyl-p filename))
- (gnus-output-to-rmail filename t)
+ (rmail-output-to-rmail-file filename t)
(gnus-output-to-mail filename)))))
filename)
(article-fill . gnus-article-word-wrap)
article-remove-cr
article-display-x-face
- article-de-quoted-unreadable
- article-mime-decode-quoted-printable
article-hide-pgp
article-hide-pem
article-hide-signature
["Hide signature" gnus-article-hide-signature t]
["Hide citation" gnus-article-hide-citation t]
["Treat overstrike" gnus-article-treat-overstrike t]
- ["Remove carriage return" gnus-article-remove-cr t]
- ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]))
+ ["Remove carriage return" gnus-article-remove-cr t]))
;; Note "Commands" menu is defined in gnus-sum.el for consistency
(make-local-variable 'gnus-button-marker-list)
(make-local-variable 'gnus-article-current-summary)
(gnus-set-default-directory)
- (buffer-disable-undo (current-buffer))
+ (buffer-disable-undo)
(setq buffer-read-only t)
(set-syntax-table gnus-article-mode-syntax-table)
(gnus-run-hooks 'gnus-article-mode-hook))
(substring name (match-end 0))))))
(setq gnus-article-buffer name)
(setq gnus-original-article-buffer original)
+ (setq gnus-article-mime-handle-alist nil)
;; This might be a variable local to the summary buffer.
(unless gnus-single-article-buffer
(save-excursion
;; Init original article buffer.
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
- (buffer-disable-undo (current-buffer))
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
(if (get-buffer name)
(save-excursion
(set-buffer name)
- (buffer-disable-undo (current-buffer))
+ (buffer-disable-undo)
(setq buffer-read-only t)
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
(forward-line line)
(point)))))
+;;; @@ article filters
+;;;
+
+(defun gnus-article-display-mime-message ()
+ "Article display method for MIME message."
+ ;; called from `gnus-original-article-buffer'.
+ (let ((default-mime-charset (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset)))
+ (mime-display-message mime-message-structure
+ gnus-article-buffer nil gnus-article-mode-map))
+ ;; `mime-display-message' changes current buffer to `gnus-article-buffer'.
+ (make-local-variable 'mime-button-mother-dispatcher)
+ (setq mime-button-mother-dispatcher
+ (function gnus-article-push-button))
+ (run-hooks 'gnus-mime-article-prepare-hook))
+
+(defun gnus-article-display-traditional-message ()
+ "Article display method for traditional message."
+ (set-buffer gnus-article-buffer)
+ (let (buffer-read-only)
+ (erase-buffer)
+ (insert-buffer-substring gnus-original-article-buffer)))
+
+(defun gnus-article-display-message-with-encoded-word ()
+ "Article display method for message with encoded-words."
+ (let ((charset (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset)))
+ (gnus-article-display-traditional-message)
+ (let (buffer-read-only)
+ (eword-decode-header charset)
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (decode-mime-charset-region (match-end 0) (point-max) charset)))
+ (mime-maybe-hide-echo-buffer))
+ (gnus-run-hooks 'gnus-mime-article-prepare-hook))
+
(defun gnus-article-prepare (article &optional all-headers header)
"Prepare ARTICLE in article mode buffer.
ARTICLE should either be an article number or a Message-ID.
(setq gnus-summary-buffer (current-buffer))
(let* ((gnus-article (if header (mail-header-number header) article))
(summary-buffer (current-buffer))
- (internal-hook gnus-article-internal-prepare-hook)
+ (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
(group gnus-newsgroup-name)
result)
(save-excursion
(gnus-article-setup-buffer)
- (set-buffer gnus-article-buffer)
+ (set-buffer gnus-original-article-buffer)
;; Deactivate active regions.
(when (and (boundp 'transient-mark-mode)
transient-mark-mode)
(or all-headers gnus-show-all-headers))))
(when (or (numberp article)
(stringp article))
- ;; Hooks for getting information from the article.
- ;; This hook must be called before being narrowed.
- (let (buffer-read-only)
- (gnus-run-hooks 'internal-hook)
- (gnus-run-hooks 'gnus-article-prepare-hook)
- ;; Decode MIME message.
- (when gnus-show-mime
- (if (or (not gnus-strict-mime)
- (gnus-fetch-field "Mime-Version"))
- (let ((coding-system-for-write 'binary)
- (coding-system-for-read 'binary))
- (funcall gnus-show-mime-method))
- (funcall gnus-decode-encoded-word-method)))
- ;; Perform the article display hooks.
- (gnus-run-hooks 'gnus-article-display-hook))
+ (gnus-article-prepare-display)
;; Do page break.
(goto-char (point-min))
(setq gnus-page-broken
(set-window-point (get-buffer-window (current-buffer)) (point))
t))))))
+(defun gnus-article-prepare-display ()
+ "Make the current buffer look like a nice article."
+ (let ((method (if gnus-show-mime
+ (progn
+ (mime-parse-buffer)
+ gnus-article-display-method-for-mime)
+ gnus-article-display-method-for-traditional)))
+ ;; Hooks for getting information from the article.
+ ;; This hook must be called before being narrowed.
+ (gnus-run-hooks 'gnus-tmp-internal-hook)
+ (gnus-run-hooks 'gnus-article-prepare-hook)
+ ;; Display message.
+ (funcall method)
+ ;; Associate this article with the current summary buffer.
+ (setq gnus-article-current-summary summary-buffer)
+ ;; Perform the article display hooks.
+ (gnus-run-hooks 'gnus-article-display-hook)))
+
+;;;
+;;; Gnus MIME viewing functions
+;;;
+
+(defvar gnus-mime-button-line-format "%{%([%p. %t%d%n]%)%}\n"
+ "The following specs can be used:
+%t The MIME type
+%n The `name' parameter
+%d The description, if any
+%l The length of the encoded part
+%p The part identifier")
+
+(defvar gnus-mime-button-line-format-alist
+ '((?t gnus-tmp-type ?s)
+ (?n gnus-tmp-name ?s)
+ (?d gnus-tmp-description ?s)
+ (?p gnus-tmp-id ?s)
+ (?l gnus-tmp-length ?d)))
+
+(defvar gnus-mime-button-map nil)
+(unless gnus-mime-button-map
+ (setq gnus-mime-button-map (copy-keymap gnus-article-mode-map))
+ (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)
+ (define-key gnus-mime-button-map "\r" 'gnus-article-press-button)
+ (define-key gnus-mime-button-map "\M-\r" 'gnus-mime-view-part)
+ (define-key gnus-mime-button-map "v" 'gnus-mime-view-part)
+ (define-key gnus-mime-button-map "o" 'gnus-mime-save-part)
+ (define-key gnus-mime-button-map "c" 'gnus-mime-copy-part)
+ (define-key gnus-mime-button-map "i" 'gnus-mime-inline-part)
+ (define-key gnus-mime-button-map "|" 'gnus-mime-pipe-part))
+
+(defun gnus-mime-view-all-parts ()
+ "View all the MIME parts."
+ (interactive)
+ (let ((handles gnus-article-mime-handles))
+ (while handles
+ (mm-display-part (pop handles)))))
+
+(defun gnus-mime-save-part ()
+ "Save the MIME part under point."
+ (interactive)
+ (let ((data (get-text-property (point) 'gnus-data)))
+ (mm-save-part data)))
+
+(defun gnus-mime-pipe-part ()
+ "Pipe the MIME part under point to a process."
+ (interactive)
+ (let ((data (get-text-property (point) 'gnus-data)))
+ (mm-pipe-part data)))
+
+(defun gnus-mime-view-part ()
+ "Interactively choose a view method for the MIME part under point."
+ (interactive)
+ (let ((data (get-text-property (point) 'gnus-data))
+ (url-standalone-mode (not gnus-plugged)))
+ (mm-interactively-view-part data)))
+
+(defun gnus-mime-copy-part ()
+ "Put the the MIME part under point into a new buffer."
+ (interactive)
+ (let* ((data (get-text-property (point) 'gnus-data))
+ (contents (mm-get-part data)))
+ (switch-to-buffer (generate-new-buffer "*decoded*"))
+ (insert contents)
+ (goto-char (point-min))))
+
+(defun gnus-mime-inline-part ()
+ "Insert the MIME part under point into the current buffer."
+ (interactive)
+ (let* ((data (get-text-property (point) 'gnus-data))
+ (contents (mm-get-part data))
+ (url-standalone-mode (not gnus-plugged))
+ (b (point))
+ buffer-read-only)
+ (if (mm-handle-undisplayer data)
+ (mm-remove-part data)
+ (forward-line 2)
+ (mm-insert-inline data contents)
+ (goto-char b))))
+
+(defun gnus-article-view-part (n)
+ "View MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (save-current-buffer
+ (set-buffer gnus-article-buffer)
+ (when (> n (length gnus-article-mime-handle-alist))
+ (error "No such part"))
+ (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
+ (gnus-article-goto-part n)
+ (mm-display-part handle))))
+
+(defun gnus-article-goto-part (n)
+ "Go to MIME part N."
+ (goto-char (text-property-any (point-min) (point-max) 'gnus-part n)))
+
+(defun gnus-insert-mime-button (handle)
+ (let ((gnus-tmp-name (mail-content-type-get (mm-handle-type handle) 'name))
+ (gnus-tmp-type (car (mm-handle-type handle)))
+ (gnus-tmp-description (mm-handle-description handle))
+ (gnus-tmp-length (save-excursion
+ (set-buffer (mm-handle-buffer handle))
+ (buffer-size)))
+ (gnus-tmp-id (1+ (length gnus-article-mime-handle-alist)))
+ b e)
+ (push (cons gnus-tmp-id handle) gnus-article-mime-handle-alist)
+ (setq gnus-tmp-name
+ (if gnus-tmp-name
+ (concat " (" gnus-tmp-name ")")
+ ""))
+ (setq gnus-tmp-description
+ (if gnus-tmp-description
+ (concat " (" gnus-tmp-description ")")
+ ""))
+ (setq b (point))
+ (gnus-eval-format
+ gnus-mime-button-line-format gnus-mime-button-line-format-alist
+ `(local-map ,gnus-mime-button-map
+ keymap ,gnus-mime-button-map
+ gnus-callback mm-display-part
+ gnus-part ,gnus-tmp-id
+ gnus-type annotation
+ gnus-data ,handle))
+ (setq e (point))
+ (widget-convert-button 'link from to :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap)))
+
+(defun gnus-widget-press-button (elems el)
+ (goto-char (widget-get elems :from))
+ (let ((url-standalone-mode (not gnus-plugged)))
+ (gnus-article-press-button)))
+
+(defun gnus-display-mime ()
+ "Insert MIME buttons in the buffer."
+ (let (ct ctl)
+ (save-restriction
+ (mail-narrow-to-head)
+ (when (setq ct (mail-fetch-field "content-type"))
+ (setq ctl (condition-case ()
+ (mail-header-parse-content-type ct) (error nil)))))
+ (let* ((handles (mm-dissect-buffer))
+ handle name type b e)
+ (mapcar 'mm-destroy-part gnus-article-mime-handles)
+ (setq gnus-article-mime-handles handles
+ gnus-article-mime-handle-alist nil)
+ (when handles
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (delete-region (point) (point-max))
+ (if (not (equal (car ctl) "multipart/alternative"))
+ (while (setq handle (pop handles))
+ (gnus-insert-mime-button handle)
+ (insert "\n\n")
+ (when (and (mm-automatic-display-p
+ (car (mm-handle-type handle)))
+ (mm-inlinable-part-p (car (mm-handle-type handle)))
+ (or (not (mm-handle-disposition handle))
+ (equal (car (mm-handle-disposition handle))
+ "inline")))
+ (forward-line -2)
+ (mm-display-part handle t)
+ (goto-char (point-max))))
+ ;; Here we have multipart/alternative
+ (gnus-mime-display-alternative handles))))))
+
+(defun gnus-mime-display-alternative (handles &optional preferred)
+ (let* ((preferred (mm-preferred-alternative handles preferred))
+ (ihandles handles)
+ handle buffer-read-only)
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (delete-region (point) (point-max))
+ (mapcar 'mm-remove-part gnus-article-mime-handles)
+ (setq gnus-article-mime-handles handles)
+ (while (setq handle (pop handles))
+ (gnus-add-text-properties
+ (point)
+ (progn
+ (insert (format "[%c] %-18s"
+ (if (equal handle preferred) ?* ? )
+ (car (mm-handle-type handle))))
+ (point))
+ `(local-map ,gnus-mime-button-map
+ ,gnus-mouse-face-prop ,gnus-article-mouse-face
+ face ,gnus-article-button-face
+ keymap ,gnus-mime-button-map
+ gnus-callback
+ (lambda (handles)
+ (gnus-mime-display-alternative
+ ',ihandles ,(car (mm-handle-type handle))))
+ gnus-data ,handle))
+ (insert " "))
+ (insert "\n\n")
+ (when preferred
+ (mm-display-part preferred))))
+
(defun gnus-article-wash-status ()
"Return a string which display status of article washing."
(save-excursion
(defun gnus-output-to-file (file-name)
"Append the current article to a file named FILE-NAME."
(let ((artbuf (current-buffer)))
- (nnheader-temp-write nil
+ (with-temp-buffer
(insert-buffer-substring artbuf)
;; Append newline at end of the buffer as separator, and then
;; save it to file.
(assq article gnus-newsgroup-reads)))
gnus-canceled-mark))
nil)
- ;; We first check `gnus-original-article-buffer'.
- ((and (get-buffer gnus-original-article-buffer)
- (numberp article)
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (and (equal (car gnus-original-article) group)
- (eq (cdr gnus-original-article) article))))
- (insert-buffer-substring gnus-original-article-buffer)
- 'article)
;; Check the backlog.
((and gnus-keep-backlog
(gnus-backlog-request-article group article (current-buffer)))
(if (get-buffer gnus-original-article-buffer)
(set-buffer gnus-original-article-buffer)
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
- (buffer-disable-undo (current-buffer))
+ (buffer-disable-undo)
(setq major-mode 'gnus-original-article-mode)
(setq buffer-read-only t))
(let (buffer-read-only)
(erase-buffer)
(insert-buffer-substring gnus-article-buffer))
- (setq gnus-original-article (cons group article))))
+ (setq gnus-original-article (cons group article)))
+
+ ;; Decode charsets.
+ (run-hooks 'gnus-article-decode-hook)
+ ;; Mark article as decoded or not.
+ (setq gnus-article-decoded-p gnus-article-decode-hook))
;; Update sparse articles.
(when (and do-update-line
(setq gnus-original-article nil)))
(set-window-configuration winconf)
;; Tippy-toe some to make sure that point remains where it was.
- (let ((buf (current-buffer)))
+ (save-current-buffer
(set-buffer curbuf)
(set-window-start (get-buffer-window (current-buffer)) window-start)
- (goto-char p)
- (set-buffer buf)))))
+ (goto-char p)))))
(defun gnus-article-edit-full-stops ()
"Interactively repair spacing at end of sentences."
("\\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)
(defun gnus-url-parse-query-string (query &optional downcase)
(let (retval pairs cur key val)
- (setq pairs (gnus-split-string query "&"))
+ (setq pairs (split-string query "&"))
(while pairs
(setq cur (car pairs)
pairs (cdr pairs))
;; Send mail to someone
(when (string-match "mailto:/*\\(.*\\)" url)
(setq url (substring url (match-beginning 1) nil)))
- (let (to args source-url subject func)
+ (let (to args subject func)
(if (string-match (regexp-quote "?") url)
(setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
args (gnus-url-parse-query-string
(setq to (gnus-url-unhex-string url)))
(setq args (cons (list "to" to) args)
subject (cdr-safe (assoc "subject" args)))
- (message-mail)
- (while args
- (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
- (if (fboundp func)
- (funcall func)
- (message-position-on-field (caar args)))
- (insert (mapconcat 'identity (cdar args) ", "))
- (setq args (cdr args)))
- (if subject
- (message-goto-body)
- (message-goto-subject))))
+ (gnus-setup-message 'reply
+ (message-mail)
+ (while args
+ (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
+ (if (fboundp func)
+ (funcall func)
+ (message-position-on-field (caar args)))
+ (insert (mapconcat 'identity (cdar args) ", "))
+ (setq args (cdr args)))
+ (if subject
+ (message-goto-body)
+ (message-goto-subject)))))
(defun gnus-button-mailto (address)
;; Mail to ADDRESS.
(set-buffer (gnus-copy-article-buffer))
- (message-reply address))
+ (gnus-setup-message 'reply
+ (message-reply address)))
(defun gnus-button-reply (address)
;; Reply to ADDRESS.
- (message-reply address))
+ (gnus-setup-message 'reply
+ (message-reply address)))
(defun gnus-button-url (address)
"Browse ADDRESS."
(gnus-article-prev-page)
(select-window win)))
+
+;;; @ for mime-view
+;;;
+
+(defun gnus-article-header-presentation-method (entity situation)
+ (mime-insert-decoded-header entity)
+ )
+
+(set-alist 'mime-header-presentation-method-alist
+ 'gnus-original-article-mode
+ #'gnus-article-header-presentation-method)
+
+(defun gnus-mime-preview-quitting-method ()
+ (if gnus-show-mime
+ (gnus-article-show-summary)
+ (mime-preview-kill-buffer)
+ (delete-other-windows)
+ (gnus-article-show-summary)
+ (gnus-summary-select-article nil t)
+ ))
+
+(set-alist 'mime-preview-quitting-method-alist
+ 'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
+
+(defun gnus-following-method (buf)
+ (set-buffer buf)
+ (message-followup)
+ (message-yank-original)
+ (kill-buffer buf)
+ (goto-char (point-min))
+ )
+
+(set-alist 'mime-preview-following-method-alist
+ 'gnus-original-article-mode #'gnus-following-method)
+
+
+;;; @ end
+;;;
+
(gnus-ems-redefine)
(provide 'gnus-art)
projects / elisp / gnus.git- / blobdiff