(require 'gnus-int)
(require 'browse-url)
(require 'mm-bodies)
+(require 'mail-parse)
+(require 'mm-decode)
+(require 'mm-view)
+(require 'wid-edit)
+(require 'mm-uu)
(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-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:"
+ "^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:"
(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."
- :group 'gnus-article-mime
- :type 'boolean)
-
-(defcustom gnus-show-mime-method 'metamail-buffer
- "Function to process a MIME message.
-The function is called from the article buffer."
- :group 'gnus-article-mime
- :type 'function)
-
-(defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable
- "*Function to decode MIME encoded words.
-The function is called from the article buffer."
- :group 'gnus-article-mime
- :type 'function)
-
(defcustom gnus-page-delimiter "^\^L"
"*Regexp describing what to use as article page delimiters.
The default value is \"^\^L\", which is a form linefeed at the
(item :tag "skip" nil)
(face :value default)))))
+(defcustom gnus-article-decode-hook
+ '(article-decode-charset article-decode-encoded-words)
+ "*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.")
+
+(defvar gnus-article-dumbquotes-map
+ '(("\202" ",")
+ ("\203" "f")
+ ("\204" ",,")
+ ("\205" "...")
+ ("\213" "<")
+ ("\214" "OE")
+ ("\205" "...")
+ ("\221" "`")
+ ("\222" "'")
+ ("\223" "``")
+ ("\224" "''")
+ ("\225" "*")
+ ("\226" "-")
+ ("\227" "-")
+ ("\231" "(TM)")
+ ("\233" ">")
+ ("\234" "oe")
+ ("\264" "'"))
+ "Table for MS-to-Latin1 translation.")
+
+(defcustom gnus-ignored-mime-types nil
+ "List of MIME types that should be ignored by Gnus."
+ :group 'gnus-mime
+ :type '(repeat regexp))
+
+(defcustom gnus-treat-body-highlight-signature t
+ "Highlight the signature."
+ :group 'gnus-article
+ :type '(choice (const :tag "Off" nil)
+ (const :tag "On" t)
+ (const :tag "Last" last)
+ (integer :tag "Less")
+ (sexp :tag "Predicate")))
+
+(defcustom gnus-article-mime-part-function nil
+ "Function called with a MIME handle as the argument."
+ :group 'gnus-article
+ :type 'function)
+
;;; Internal variables
+(defvar gnus-treatment-function-alist
+ '((gnus-treat-body-highlight-signature gnus-article-highlight-signature nil)
+ ))
+
+(defvar gnus-article-mime-handle-alist nil)
(defvar article-lapsed-timer nil)
(defvar gnus-article-current-summary nil)
(defun article-treat-dumbquotes ()
"Translate M******** sm*rtq**t*s into proper text."
(interactive)
- (article-translate-characters "\221\222\223\223" "`'\"\""))
+ (article-translate-strings gnus-article-dumbquotes-map))
(defun article-translate-characters (from to)
"Translate all characters in the body of the article according to FROM and TO.
(incf i))
(translate-region (point) (point-max) x)))))
+(defun article-translate-strings (map)
+ "Translate all string in the body of the article according to MAP.
+MAP is an alist where the elements are on the form (\"from\" \"to\")."
+ (save-excursion
+ (goto-char (point-min))
+ (when (search-forward "\n\n" nil t)
+ (let ((buffer-read-only nil)
+ elem)
+ (while (setq elem (pop map))
+ (save-excursion
+ (while (search-forward (car elem) nil t)
+ (replace-match (cadr elem)))))))))
+
(defun article-treat-overstrike ()
"Translate overstrikes into bold text."
(interactive)
(when (search-forward "\n\n" nil t)
(let ((buffer-read-only nil))
(while (search-forward "\b" nil t)
- (let ((next (following-char))
+ (let ((next (char-after))
(previous (char-after (- (point) 2))))
;; We do the boldification/underlining by hiding the
;; overstrikes and putting the proper text property
(end-of-line 2))))))
(defun article-remove-cr ()
- "Remove carriage returns from an article."
+ "Translate CRLF pairs into LF, and then CR into LF.."
(interactive)
(save-excursion
(let ((buffer-read-only nil))
(goto-char (point-min))
+ (while (search-forward "\r$" nil t)
+ (replace-match "" t t))
+ (goto-char (point-min))
(while (search-forward "\r" nil t)
- (replace-match "" t t)))))
+ (replace-match "\n" t t)))))
(defun article-remove-trailing-blank-lines ()
"Remove all trailing blank lines from the article."
(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))))))
(process-send-region "article-x-face" beg end)
(process-send-eof "article-x-face"))))))))))
-(defun gnus-article-decode-mime-words ()
+(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)
- (rfc2047-decode-region (point-min) (point-max)))))
+ (mail-decode-encoded-word-region (point-min) (point-max)))))
-(defun gnus-article-decode-charset (&optional prompt)
+(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
- (set-buffer gnus-article-buffer)
(save-restriction
(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: "))
- (ct
- (mm-content-type-charset ct))
+ (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)
- (string-match "text/plain" ct))
+ (when (or (not ctl)
+ (equal (car ctl) "text/plain"))
(mm-decode-body
charset (and cte (intern (downcase
- (gnus-strip-whitespace cte))))))))))
+ (gnus-strip-whitespace cte))))
+ (car ctl)))))))
-(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522)
-(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522)
-(defun article-decode-rfc1522 ()
- "Remove QP encoding from headers."
+(defun article-decode-encoded-words ()
+ "Remove encoded-word encoding from headers."
(let ((inhibit-point-motion-hooks t)
(buffer-read-only nil))
(save-restriction
(message-narrow-to-head)
- (rfc2047-decode-region (point-min) (point-max)))))
+ (funcall gnus-decode-header-function (point-min) (point-max)))))
(defun article-de-quoted-unreadable (&optional force)
"Translate a quoted-printable-encoded article.
(save-excursion
(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)
- (quoted-printable-decode-region (point) (point-max))))))
-
-(defun article-mime-decode-quoted-printable-buffer ()
- "Decode Quoted-Printable in the current buffer."
- (quoted-printable-decode-region (point-min) (point-max)))
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (quoted-printable-decode-region (point-min) (point-max))
+ (when mm-default-coding-system
+ (mm-decode-body mm-default-coding-system)))))))
(defun article-hide-pgp (&optional arg)
"Toggle hiding of any PGP headers and signatures in the current article.
;; Hide the "header".
(when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
(delete-region (1+ (match-beginning 0)) (match-end 0))
+ ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too
+ (when (looking-at "Hash:.*$")
+ (delete-region (point) (1+ (gnus-point-at-eol))))
(setq beg (point))
;; Hide the actual signature.
(and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
(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
(text-property-any (1+ pos) (point-max) 'article-type type)))
(if pos
'hidden
- 'shown)))
+ nil)))
(defun gnus-article-show-hidden-text (type &optional hide)
"Show all hidden text of type TYPE.
(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: " (current-time-string (date-to-time date))))
- ;; Convert to Universal Time.
- ((eq type 'ut)
- (concat "Date: "
- (current-time-string
- (let ((e (parse-time-string date)))
- (setcar (last e) 0)
- (encode-time e)))))
- ;; 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 (date-to-time date))
+ (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 (date-to-time date)))))
- ;; ISO 8601.
- ((eq type 'iso8601)
- (concat
- "Date: "
- (format-time-string "%Y%M%DT%h%m%s" (date-to-time date))))
- ;; 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 (date-to-time date)))
- (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)
- (rmail-output-to-rmail-file filename))))
+ (gnus-output-to-rmail filename))))
filename)
(defun gnus-summary-save-in-mail (&optional filename)
(defun gnus-summary-save-in-pipe (&optional command)
"Pipe this article to subprocess."
(setq command
- (cond ((eq command 'default)
+ (cond ((and (eq command 'default)
+ gnus-last-shell-command)
gnus-last-shell-command)
(command command)
(t (read-string
article-date-iso8601
article-date-original
article-date-ut
+ article-decode-mime-words
+ article-decode-charset
+ article-decode-encoded-words
article-date-user
article-date-lapsed
article-emphasize
(put 'gnus-article-mode 'mode-class 'special)
+(set-keymap-parent gnus-article-mode-map widget-keymap)
+
(gnus-define-keys gnus-article-mode-map
" " gnus-article-goto-next-page
"\177" gnus-article-goto-prev-page
"s" gnus-article-show-summary
"\C-c\C-m" gnus-article-mail
"?" gnus-article-describe-briefly
- gnus-mouse-2 gnus-article-push-button
- "\r" gnus-article-press-button
- "\t" gnus-article-next-button
- "\M-\t" gnus-article-prev-button
"e" gnus-article-edit
"<" beginning-of-buffer
">" end-of-buffer
(setq mode-name "Article")
(setq major-mode 'gnus-article-mode)
(make-local-variable 'minor-mode-alist)
- (unless (assq 'gnus-show-mime minor-mode-alist)
- (push (list 'gnus-show-mime " MIME") minor-mode-alist))
(use-local-map gnus-article-mode-map)
(gnus-update-format-specifications nil 'article-mode)
(set (make-local-variable 'page-delimiter) gnus-page-delimiter)
(make-local-variable 'gnus-page-broken)
(make-local-variable 'gnus-button-marker-list)
(make-local-variable 'gnus-article-current-summary)
+ (make-local-variable 'gnus-article-mime-handles)
+ (make-local-variable 'gnus-article-decoded-p)
+ (make-local-variable 'gnus-article-mime-handle-alist)
(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)
(mm-enable-multibyte)
(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
(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))
(set-buffer (gnus-get-buffer-create name))
(gnus-article-mode)
(make-local-variable 'gnus-summary-buffer)
+ (gnus-summary-set-local-parameters gnus-newsgroup-name)
(current-buffer)))))
;; Set article window start at LINE, where LINE is the number of lines
(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 'gnus-tmp-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."
+ ;; Hooks for getting information from the article.
+ ;; This hook must be called before being narrowed.
+ (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-run-hooks 'gnus-tmp-internal-hook)
+ (gnus-run-hooks 'gnus-article-prepare-hook)
+ (when gnus-display-mime-function
+ (let ((url-standalone-mode (not gnus-plugged)))
+ (funcall gnus-display-mime-function)))
+ ;; 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]%)%}%e\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
+%e Dots if the part isn't displayed")
+
+(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)
+ (?e gnus-tmp-dots ?s)))
+
+(defvar gnus-mime-button-commands
+ '((gnus-article-press-button "\r" "Toggle Display")
+ ;(gnus-mime-view-part "\M-\r" "View Interactively...")
+ (gnus-mime-view-part "v" "View Interactively...")
+ (gnus-mime-save-part "o" "Save...")
+ (gnus-mime-copy-part "c" "View In Buffer")
+ (gnus-mime-inline-part "i" "View Inline")
+ (gnus-mime-pipe-part "|" "Pipe To Command...")))
+
+(defvar gnus-mime-button-map nil)
+(unless gnus-mime-button-map
+ (setq gnus-mime-button-map (make-sparse-keymap))
+ (set-keymap-parent gnus-mime-button-map gnus-article-mode-map)
+ (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)
+ (define-key gnus-mime-button-map gnus-mouse-3 'gnus-mime-button-menu)
+ (mapcar (lambda (c)
+ (define-key gnus-mime-button-map (cadr c) (car c)))
+ gnus-mime-button-commands))
+
+(defun gnus-mime-button-menu (event)
+ "Construct a context-sensitive menu of MIME commands."
+ (interactive "e")
+ (let ((response (x-popup-menu
+ t `("MIME Part"
+ ("" ,@(mapcar (lambda (c)
+ (cons (caddr c) (car c)))
+ gnus-mime-button-commands)))))
+ (pos (event-start event)))
+ (when response
+ (set-buffer (window-buffer (posn-window pos)))
+ (goto-char (posn-point pos))
+ (funcall response))))
+
+(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* ((handle (get-text-property (point) 'gnus-data))
+ (contents (mm-get-part handle))
+ (buffer (generate-new-buffer
+ (file-name-nondirectory
+ (or
+ (mail-content-type-get (mm-handle-type handle) 'name)
+ (mail-content-type-get (mm-handle-type handle)
+ 'filename)
+ "*decoded*")))))
+ (switch-to-buffer buffer)
+ (insert contents)
+ (normal-mode)
+ (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))))
+ (when (gnus-article-goto-part n)
+ (if (equal (car handle) "multipart/alternative")
+ (gnus-article-press-button)
+ (when (eq (gnus-mm-display-part handle) 'internal)
+ (gnus-set-window-start)))))))
+
+(defun gnus-mm-display-part (handle)
+ "Display HANDLE and fix MIME button."
+ (let ((id (get-text-property (point) 'gnus-part))
+ (point (point))
+ buffer-read-only)
+ (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
+ (gnus-insert-mime-button
+ handle id (list (not (mm-handle-displayed-p handle))))
+ (prog1
+ (let ((window (selected-window)))
+ (save-excursion
+ (unwind-protect
+ (let ((win (get-buffer-window (current-buffer) t)))
+ (if win
+ (select-window win))
+ (goto-char point)
+ (forward-line)
+ (mm-display-part handle))
+ (select-window window))))
+ (goto-char point))))
+
+(defun gnus-article-goto-part (n)
+ "Go to MIME part N."
+ (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
+ (when point
+ (goto-char point))))
+
+(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
+ (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-dots
+ (if (if displayed (car displayed)
+ (mm-handle-displayed-p handle))
+ "" "..."))
+ (gnus-tmp-length (save-excursion
+ (set-buffer (mm-handle-buffer handle))
+ (buffer-size)))
+ b e)
+ (setq gnus-tmp-name
+ (if gnus-tmp-name
+ (concat " (" gnus-tmp-name ")")
+ ""))
+ (setq gnus-tmp-description
+ (if gnus-tmp-description
+ (concat " (" gnus-tmp-description ")")
+ ""))
+ (unless (bolp)
+ (insert "\n"))
+ (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 gnus-mm-display-part
+ gnus-part ,gnus-tmp-id
+ article-type annotation
+ gnus-data ,handle))
+ (setq e (point))
+ (widget-convert-button 'link b e :action 'gnus-widget-press-button
+ :button-keymap gnus-mime-button-map)))
+
+(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 (&optional ihandles)
+ "Insert MIME buttons in the buffer."
+ (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
+ handle name type b e display)
+ (unless ihandles
+ ;; Top-level call; we clean up.
+ (mm-destroy-parts gnus-article-mime-handles)
+ (setq gnus-article-mime-handles handles
+ gnus-article-mime-handle-alist nil)
+ ;; We allow users to glean info from the handles.
+ (when gnus-article-mime-part-function
+ (gnus-mime-part-function handles)))
+ (when (and handles
+ (or (not (stringp (car handles)))
+ (cdr handles)))
+ (unless ihandles
+ ;; Clean up for mime parts.
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (delete-region (point) (point-max)))
+ (if (stringp (car handles))
+ (if (equal (car handles) "multipart/alternative")
+ (let ((id (1+ (length gnus-article-mime-handle-alist))))
+ (push (cons id handles) gnus-article-mime-handle-alist)
+ (gnus-mime-display-alternative (cdr handles) nil nil id))
+ (gnus-mime-display-mixed (cdr handles)))
+ (gnus-mime-display-single handles)))))
+
+(defun gnus-mime-part-function (handles)
+ (if (stringp (car handles))
+ (mapcar 'gnus-mime-part-function (cdr handles))
+ (funcall gnus-article-mime-part-function handles)))
+
+(defun gnus-mime-display-mixed (handles)
+ (let (handle)
+ (while (setq handle (pop handles))
+ (if (stringp (car handle))
+ (if (equal (car handle) "multipart/alternative")
+ (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))
+ (gnus-mime-display-mixed (cdr handle)))
+ (gnus-mime-display-single handle)))))
+
+(defun gnus-mime-display-single (handle)
+ (let ((type (car (mm-handle-type handle)))
+ (ignored gnus-ignored-mime-types)
+ display text)
+ (catch 'ignored
+ (progn
+ (while ignored
+ (when (string-match (pop ignored) type)
+ (throw 'ignored nil)))
+ (if (and (mm-automatic-display-p type)
+ (mm-inlinable-part-p type)
+ (or (not (mm-handle-disposition handle))
+ (equal (car (mm-handle-disposition handle))
+ "inline")))
+ (setq display t)
+ (when (equal (car (split-string type "/"))
+ "text")
+ (setq text t)))
+ (let ((id (1+ (length gnus-article-mime-handle-alist))))
+ (push (cons id handle) gnus-article-mime-handle-alist)
+ (gnus-insert-mime-button handle id (list (or display text))))
+ (insert "\n\n")
+ (cond
+ (display
+ (forward-line -2)
+ (mm-display-part handle t)
+ (goto-char (point-max)))
+ (text
+ (forward-line -2)
+ (insert "\n")
+ (mm-insert-inline handle (mm-get-part handle))
+ (goto-char (point-max))))))))
+
+(defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
+ (let* ((preferred (or preferred (mm-preferred-alternative handles)))
+ (ihandles handles)
+ (point (point))
+ handle buffer-read-only from props begend not-pref)
+ (save-restriction
+ (when ibegend
+ (narrow-to-region (car ibegend) (cdr ibegend))
+ (delete-region (point-min) (point-max))
+ (mm-remove-parts handles))
+ (setq begend (list (point-marker)))
+ ;; Do the toggle.
+ (unless (setq not-pref (cadr (member preferred ihandles)))
+ (setq not-pref (car ihandles)))
+ (gnus-add-text-properties
+ (setq from (point))
+ (progn
+ (insert (format "%d. " id))
+ (point))
+ `(gnus-callback
+ (lambda (handles)
+ (gnus-mime-display-alternative
+ ',ihandles ',not-pref
+ ',begend ,id))
+ 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-part ,id
+ gnus-data ,handle))
+ (widget-convert-button 'link from (point)
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap)
+ ;; Do the handles
+ (while (setq handle (pop handles))
+ (gnus-add-text-properties
+ (setq from (point))
+ (progn
+ (insert (format "[%c] %-18s"
+ (if (equal handle preferred) ?* ? )
+ (if (stringp (car handle))
+ (car handle)
+ (car (mm-handle-type handle)))))
+ (point))
+ `(gnus-callback
+ (lambda (handles)
+ (gnus-mime-display-alternative
+ ',ihandles ',handle
+ ',begend ,id))
+ 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-part ,id
+ gnus-data ,handle))
+ (widget-convert-button 'link from (point)
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap)
+ (insert " "))
+ (insert "\n\n")
+ (when preferred
+ (if (stringp (car preferred))
+ (gnus-display-mime preferred)
+ (mm-display-part preferred)
+ (goto-char (point-max)))
+ (setcdr begend (point-marker))))
+ (when ibegend
+ (goto-char point))))
+
(defun gnus-article-wash-status ()
"Return a string which display status of article washing."
(save-excursion
(pem (gnus-article-hidden-text-p 'pem))
(signature (gnus-article-hidden-text-p 'signature))
(overstrike (gnus-article-hidden-text-p 'overstrike))
- (emphasis (gnus-article-hidden-text-p 'emphasis))
- (mime gnus-show-mime))
- (format "%c%c%c%c%c%c%c"
+ (emphasis (gnus-article-hidden-text-p 'emphasis)))
+ (format "%c%c%c%c%c%c"
(if cite ?c ? )
(if (or headers boring) ?h ? )
(if (or pgp pem) ?p ? )
(if signature ?s ? )
(if overstrike ?o ? )
- (if mime ?m ? )
(if emphasis ?e ? )))))
(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
(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
(defvar gnus-article-edit-mode-map nil)
+;; Should we be using derived.el for this?
(unless gnus-article-edit-mode-map
- (setq gnus-article-edit-mode-map (copy-keymap text-mode-map))
+ (setq gnus-article-edit-mode-map (make-sparse-keymap))
+ (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
(gnus-define-keys gnus-article-edit-mode-map
"\C-c\C-c" gnus-article-edit-done
(save-excursion
(set-buffer buf)
(let ((buffer-read-only nil))
- (funcall func arg)))
+ (funcall func arg))
+ ;; The cache and backlog have to be flushed somewhat.
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ ;; Flush original article as well.
+ (save-excursion
+ (when (get-buffer gnus-original-article-buffer)
+ (set-buffer gnus-original-article-buffer)
+ (setq gnus-original-article nil)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current))))
(set-buffer buf)
(set-window-start (get-buffer-window buf) start)
(set-window-point (get-buffer-window buf) (point))))
(insert buf)
(let ((winconf gnus-prev-winconf))
(gnus-article-mode)
- ;; The cache and backlog have to be flushed somewhat.
- (when gnus-use-cache
- (gnus-cache-update-article
- (car gnus-article-current) (cdr gnus-article-current)))
- (when gnus-keep-backlog
- (gnus-backlog-remove-article
- (car gnus-article-current) (cdr gnus-article-current)))
- ;; Flush original article as well.
- (save-excursion
- (when (get-buffer gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
- (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."
: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 ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
+ 0 t gnus-button-message-id 2)
+ ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
("\\(\\b<\\(url:[>\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)
(when fun
(funcall fun data))))
-(defun gnus-article-prev-button (n)
- "Move point to N buttons backward.
-If N is negative, move forward instead."
- (interactive "p")
- (gnus-article-next-button (- n)))
-
-(defun gnus-article-next-button (n)
- "Move point to N buttons forward.
-If N is negative, move backward instead."
- (interactive "p")
- (let ((function (if (< n 0) 'previous-single-property-change
- 'next-single-property-change))
- (inhibit-point-motion-hooks t)
- (backward (< n 0))
- (limit (if (< n 0) (point-min) (point-max))))
- (setq n (abs n))
- (while (and (not (= limit (point)))
- (> n 0))
- ;; Skip past the current button.
- (when (get-text-property (point) 'gnus-callback)
- (goto-char (funcall function (point) 'gnus-callback nil limit)))
- ;; Go to the next (or previous) button.
- (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
- ;; Put point at the start of the button.
- (when (and backward (not (get-text-property (point) 'gnus-callback)))
- (goto-char (funcall function (point) 'gnus-callback nil limit)))
- ;; Skip past intangible buttons.
- (when (get-text-property (point) 'intangible)
- (incf n))
- (decf n))
- (unless (zerop n)
- (gnus-message 5 "No more buttons"))
- n))
-
(defun gnus-article-highlight (&optional force)
"Highlight current article.
This function calls `gnus-article-highlight-headers',
(nconc (and gnus-article-mouse-face
(list gnus-mouse-face-prop gnus-article-mouse-face))
(list 'gnus-callback fun)
- (and data (list 'gnus-data data)))))
+ (and data (list 'gnus-data data))))
+ (widget-convert-button 'link from to :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap))
;;; Internal functions:
(defun gnus-button-push (marker)
;; Push button starting at MARKER.
(save-excursion
- (set-buffer gnus-article-buffer)
(goto-char marker)
(let* ((entry (gnus-button-entry))
(inhibit-point-motion-hooks t)
gnus-prev-page-line-format nil
`(gnus-prev t local-map ,gnus-prev-page-map
gnus-callback gnus-article-button-prev-page
- gnus-type annotation))))
+ article-type annotation))))
(defvar gnus-next-page-map nil)
(unless gnus-next-page-map
`(gnus-next
t local-map ,gnus-next-page-map
gnus-callback gnus-article-button-next-page
- gnus-type annotation))))
+ article-type annotation))))
(defun gnus-article-button-next-page (arg)
"Go to the next page."
(gnus-article-prev-page)
(select-window win)))
+(defvar gnus-decode-header-methods
+ '(mail-decode-encoded-word-region)
+ "List of methods used to decode headers
+
+This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is
+FUNCTION, FUNCTION will be apply to all newsgroups. If item is a
+(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
+whose names match REGEXP.
+
+For example:
+((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
+ mail-decode-encoded-word-region
+ (\"chinese\" . rfc1843-decode-region))
+")
+
+(defvar gnus-decode-header-methods-cache nil)
+
+(defun gnus-multi-decode-header (start end)
+ "Apply the functions from `gnus-encoded-word-methods' that match."
+ (unless (and gnus-decode-header-methods-cache
+ (eq gnus-newsgroup-name
+ (car gnus-decode-header-methods-cache)))
+ (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
+ (mapc '(lambda (x)
+ (if (symbolp x)
+ (nconc gnus-decode-header-methods-cache (list x))
+ (if (and gnus-newsgroup-name
+ (string-match (car x) gnus-newsgroup-name))
+ (nconc gnus-decode-header-methods-cache
+ (list (cdr x))))))
+ gnus-decode-header-methods))
+ (let ((xlist gnus-decode-header-methods-cache))
+ (pop xlist)
+ (save-restriction
+ (narrow-to-region start end)
+ (while xlist
+ (funcall (pop xlist) (point-min) (point-max))))))
+
(gnus-ems-redefine)
(provide 'gnus-art)
projects / gnus / blobdiff