;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2014 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(defvar w3m-minor-mode-map)
(require 'gnus)
+(require 'gnus-util)
(require 'gnus-sum)
(require 'gnus-spec)
(require 'gnus-int)
`gnus-article-update-date-headers' for details."
:version "24.1"
:group 'gnus-article-headers
- :type '(repeat
- (item :tag "Universal time (UT)" :value 'ut)
- (item :tag "Local time zone" :value 'local)
- (item :tag "Readable English" :value 'english)
- (item :tag "Elapsed time" :value 'lapsed)
- (item :tag "Original and elapsed time" :value 'combined-lapsed)
- (item :tag "Original date header" :value 'original)
- (item :tag "ISO8601 format" :value 'iso8601)
- (item :tag "User-defined" :value 'user-defined)))
+ :type '(set
+ (const :tag "Universal time (UT)" ut)
+ (const :tag "Local time zone" local)
+ (const :tag "Readable English" english)
+ (const :tag "Elapsed time" lapsed)
+ (const :tag "Original and elapsed time" combined-lapsed)
+ (const :tag "Original date header" original)
+ (const :tag "ISO8601 format" iso8601)
+ (const :tag "User-defined" user-defined)))
(defcustom gnus-article-update-date-headers nil
"A number that says how often to update the date header (in seconds).
(const :tag "Header" head)))
(defvar gnus-article-treat-types '("text/plain" "text/x-verbatim"
- "text/x-patch")
- "Parts to treat.")
+ "text/x-patch" "text/html")
+ "Part types eligible for treatment.")
(defvar gnus-inhibit-treatment nil
"Whether to inhibit treatment.")
regexp."
:version "24.1"
:group 'gnus-art
- :type 'regexp)
+ :type '(choice regexp function))
;;; Internal variables
(put-text-property (max (1- b) (point-min))
b 'intangible nil)))
-(defun gnus-article-hide-text-of-type (type)
- "Hide text of TYPE in the current buffer."
- (save-excursion
- (let ((b (point-min))
- (e (point-max)))
- (while (setq b (text-property-any b e 'article-type type))
- (add-text-properties b (incf b) gnus-hidden-properties)))))
-
(defun gnus-article-delete-text-of-type (type)
"Delete text of TYPE in the current buffer."
(save-excursion
b (or (text-property-not-all b (point-max) 'invisible t)
(point-max)))))))
-(defun gnus-article-text-type-exists-p (type)
- "Say whether any text of type TYPE exists in the buffer."
- (text-property-any (point-min) (point-max) 'article-type type))
-
(defsubst gnus-article-header-rank ()
"Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
(let ((list gnus-sorted-header-list)
props)
(insert replace)))))))))
-(defun article-translate-characters (from to)
- "Translate all characters in the body of the article according to FROM and TO.
-FROM is a string of characters to translate from; to is a string of
-characters to translate to."
- (save-excursion
- (when (article-goto-body)
- (let ((inhibit-read-only t)
- (x (make-string 225 ?x))
- (i -1))
- (while (< (incf i) (length x))
- (aset x i i))
- (setq i 0)
- (while (< i (length from))
- (aset x (aref from i) (aref to i))
- (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\")."
(unfoldable
(or (equal gnus-article-unfold-long-headers t)
(and (stringp gnus-article-unfold-long-headers)
- (string-match gnus-article-unfold-long-headers header)))))
+ (string-match gnus-article-unfold-long-headers
+ header)))))
(with-temp-buffer
(insert header)
(goto-char (point-min))
(apply 'gnus-create-image png 'png t
(cdr (assq 'png gnus-face-properties-alist))))
(goto-char from)
- (gnus-add-wash-type 'face)
- (gnus-add-image 'face image)
- (gnus-put-image image nil 'face))))))))))
+ (when image
+ (gnus-add-wash-type 'face)
+ (gnus-add-image 'face image)
+ (gnus-put-image image nil 'face)))))))))))
(defun article-display-x-face (&optional force)
"Look for an X-Face header and display it if present."
(string-match "quoted-printable" type))))
(article-goto-body)
(quoted-printable-decode-region
- (point) (point-max) (mm-charset-to-coding-system charset))))))
+ (point) (point-max) (mm-charset-to-coding-system charset nil t))))))
(defun article-de-base64-unreadable (&optional force read-charset)
"Translate a base64 article.
(narrow-to-region (point) (point-max))
(base64-decode-region (point-min) (point-max))
(mm-decode-coding-region
- (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
+ (point-min) (point-max)
+ (mm-charset-to-coding-system charset nil t)))))))
(eval-when-compile
(require 'rfc1843))
(while (re-search-forward
"\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
(replace-match "\\1\\3" t)))
- (when (interactive-p)
+ (when (gmm-called-interactively-p 'any)
(gnus-treat-article nil))))
(defun article-wash-html ()
(let ((handles nil)
(buffer-read-only nil))
(when (gnus-buffer-live-p gnus-original-article-buffer)
- (setq handles (mm-dissect-buffer t t)))
+ (with-current-buffer gnus-original-article-buffer
+ (setq handles (mm-dissect-buffer t t))))
(article-goto-body)
(delete-region (point) (point-max))
+ (mm-enable-multibyte)
(mm-inline-text-html handles)))
(defvar gnus-article-browse-html-temp-list nil
(or how (setq how gnus-article-browse-delete-temp))
(if (eq how 'ask)
(let ((files (length gnus-article-browse-html-temp-list)))
- (gnus-y-or-n-p
- (if (= files 1)
- "Delete the temporary HTML file? "
- (format "Delete all %s temporary HTML files? "
- files))))
+ (or (gnus-y-or-n-p
+ (if (= files 1)
+ "Delete the temporary HTML file? "
+ (format "Delete all %s temporary HTML files? "
+ files)))
+ (setq gnus-article-browse-html-temp-list nil)))
how)))
(dolist (file gnus-article-browse-html-temp-list)
(cond ((file-directory-p file)
(dolist (handle handles)
(cond
((not (listp handle)))
+ ;; Exclude broken handles that `gnus-summary-enter-digest-group'
+ ;; may create.
+ ((not (or (bufferp (car handle)) (stringp (car handle)))))
((equal (mm-handle-media-supertype handle) "multipart")
(when (setq file (gnus-article-browse-html-save-cid-content
cid handle directory))
((equal (concat "<" cid ">") (mm-handle-id handle))
(setq file
(expand-file-name
- (or (mm-handle-filename handle)
- (concat
- (make-temp-name "cid")
- (car (rassoc (car (mm-handle-type handle)) mailcap-mime-extensions))))
- directory))
+ (or (mm-handle-filename handle)
+ (concat
+ (make-temp-name "cid")
+ (car (rassoc (car (mm-handle-type handle))
+ mailcap-mime-extensions))))
+ directory))
(mm-save-part-to-file handle file)
(throw 'found file))))))))
;; Add a meta html tag to specify charset and a header.
(cond
(header
- (let (title eheader body hcharset coding force-charset)
+ (let (title eheader body hcharset coding)
(with-temp-buffer
(mm-enable-multibyte)
(setq case-fold-search t)
(insert header "\n")
(setq title (message-fetch-field "subject"))
(goto-char (point-min))
- (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|&" nil t)
+ (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|\\(&\\)\\|\n"
+ nil t)
(replace-match (cond ((match-beginning 1) "<")
((match-beginning 2) ">")
- (t "&"))))
+ ((match-beginning 3) "&")
+ (t "<br>\n"))))
(goto-char (point-min))
- (insert "<pre>\n")
+ (while (re-search-forward "^[\t ]+" nil t)
+ (dotimes (i (prog1
+ (current-column)
+ (delete-region (match-beginning 0)
+ (match-end 0))))
+ (insert " ")))
+ (goto-char (point-min))
+ (insert "<div align=\"left\">\n")
(goto-char (point-max))
- (insert "</pre>\n<hr>\n")
+ (insert "</div>\n<hr>\n")
;; We have to examine charset one by one since
;; charset specified in parts might be different.
(if (eq charset 'gnus-decoded)
charset)
title (when title
(mm-encode-coding-string title charset))
- body (mm-encode-coding-string content charset)
- force-charset t)
+ body (mm-encode-coding-string content charset))
(setq hcharset (mm-find-mime-charset-region (point-min)
(point-max)))
(cond ((= (length hcharset) 1)
(setq hcharset (car hcharset)
coding (mm-charset-to-coding-system
- hcharset)))
+ hcharset nil t)))
((> (length hcharset) 1)
(setq hcharset 'utf-8
coding hcharset)))
(if charset
(progn
(setq body
- (mm-charset-to-coding-system charset))
+ (mm-charset-to-coding-system charset
+ nil t))
(if (eq coding body)
(setq eheader (mm-encode-coding-string
(buffer-string) coding)
body (mm-encode-coding-string
(mm-decode-coding-string
content body)
- charset)
- force-charset t)))
+ charset))))
(setq charset hcharset
eheader (mm-encode-coding-string
(buffer-string) coding)
(mm-disable-multibyte)
(insert body)
(when charset
- (mm-add-meta-html-tag handle charset force-charset))
+ (mm-add-meta-html-tag handle charset t))
(when title
(goto-char (point-min))
(unless (search-forward "<title>" nil t)
(visible-date (mail-fetch-field "Date"))
pos date bface eface)
(save-excursion
- (goto-char (point-min))
- (when (re-search-forward "^Date:" nil t)
- (setq bface (get-text-property (point-at-bol) 'face)
- eface (get-text-property (1- (point-at-eol)) 'face)))
- ;; Delete any old Date headers.
(if date-position
(progn
(goto-char date-position)
(setq date (get-text-property (point) 'original-date))
+ (when (looking-at "[^:]+:[\t ]*")
+ (setq bface (get-text-property (match-beginning 0) 'face)
+ eface (get-text-property (match-end 0) 'face)))
(delete-region (point)
(progn
(gnus-article-forward-header)
(narrow-to-region pos (if (search-forward "\n\n" nil t)
(1+ (match-beginning 0))
(point-max)))
- (goto-char (point-min))
- (while (re-search-forward "^Date:" nil t)
- (setq date (get-text-property (match-beginning 0) 'original-date))
- (delete-region (point-at-bol) (progn
- (gnus-article-forward-header)
- (point))))
+ (while (setq pos (text-property-not-all pos (point-max)
+ 'gnus-date-type nil))
+ (setq date (get-text-property pos 'original-date))
+ (goto-char pos)
+ (when (looking-at "[^:]+:[\t ]*")
+ (setq bface (get-text-property (match-beginning 0) 'face)
+ eface (get-text-property (match-end 0) 'face)))
+ (delete-region pos (or (text-property-any pos (point-max)
+ 'gnus-date-type nil)
+ (point-max))))
+ (unless date ;; the 1st time
+ (goto-char (point-min))
+ (while (re-search-forward "^Date:[\t ]*" nil t)
+ (setq date (get-text-property (match-beginning 0)
+ 'original-date)
+ bface (get-text-property (match-beginning 0) 'face)
+ eface (get-text-property (match-end 0) 'face))
+ (delete-region (point-at-bol) (progn
+ (gnus-article-forward-header)
+ (point)))))
(when (and (not date)
visible-date)
(setq date visible-date))
(list type))
(t
type)))
- (insert (article-make-date-line date (or this-type 'ut)) "\n")
- (forward-line -1)
- (beginning-of-line)
- (put-text-property (point) (1+ (point))
- 'original-date date)
- (put-text-property (point) (1+ (point))
- 'gnus-date-type this-type)
+ (goto-char
+ (prog1
+ (point)
+ (add-text-properties
+ (point)
+ (progn
+ (insert (article-make-date-line date (or this-type 'ut)) "\n")
+ (point))
+ (list 'original-date date 'gnus-date-type this-type))))
;; Do highlighting.
- (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'face bface)
- (put-text-property (match-beginning 2) (match-end 2)
- 'face eface))
- (forward-line 1)))
+ (when (looking-at
+ "\\([^:]+:\\)[\t ]*\\(\\(?:[^\t\n ]+[\t ]+\\)*[^\t\n ]+\\)?")
+ (put-text-property (match-beginning 1) (match-end 1) 'face bface)
+ (when (match-beginning 2)
+ (put-text-property (match-beginning 2) (match-end 2) 'face eface))
+ (while (and (zerop (forward-line 1))
+ (looking-at "[\t ]+\\(\\(?:[^\t\n ]+[\t ]+\\)*[^\t\n ]+\\)?"))
+ (when (match-beginning 1)
+ (put-text-property (match-beginning 1) (match-end 1) 'face eface))))))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
(walk-windows
(lambda (w)
(set-buffer (window-buffer w))
- (when (eq major-mode 'gnus-article-mode)
+ (when (derived-mode-p 'gnus-article-mode)
(let ((old-line (count-lines (point-min) (point)))
(old-column (- (point) (line-beginning-position)))
- (window-start
- (window-start (get-buffer-window (current-buffer)))))
- (goto-char (point-min))
- (while (re-search-forward "^Date:" nil t)
- (let ((type (get-text-property (match-beginning 0)
- 'gnus-date-type)))
- (when (memq type '(lapsed combined-lapsed user-format))
- (when (and window-start
- (not (= window-start
- (save-excursion
- (forward-line 1)
- (point)))))
- (setq window-start nil))
- (save-excursion
- (article-date-ut type t (match-beginning 0)))
- (forward-line 1)
- (when window-start
- (set-window-start (get-buffer-window (current-buffer))
- (point))))))
+ (window-start (window-start w))
+ (pos (point-min))
+ type next end)
+ (while (setq pos (text-property-not-all pos (point-max)
+ 'gnus-date-type nil))
+ (setq next (or (next-single-property-change pos
+ 'gnus-date-type)
+ (point-max)))
+ (setq type (get-text-property pos 'gnus-date-type))
+ (when (memq type '(lapsed combined-lapsed user-defined))
+ (article-date-ut type t pos)
+ (setq end (or (next-single-property-change pos
+ 'gnus-date-type)
+ (point-max)))
+ (when window-start
+ (if (/= window-start next)
+ (setq window-start nil)
+ (set-window-start w end)))
+ (setq next end))
+ (setq pos next))
(goto-char (point-min))
(when (> old-column 0)
(setq old-line (1- old-line)))
(gnus-define-keys gnus-article-mode-map
" " gnus-article-goto-next-page
+ [?\S-\ ] gnus-article-goto-prev-page
"\177" gnus-article-goto-prev-page
[delete] gnus-article-goto-prev-page
- [backspace] gnus-article-goto-prev-page
"\C-c^" gnus-article-refer-article
"h" gnus-article-show-summary
"s" gnus-article-show-summary
(defvar bookmark-make-record-function)
(defvar shr-put-image-function)
-(defun gnus-article-mode ()
+(define-derived-mode gnus-article-mode fundamental-mode "Article"
"Major mode for displaying an article.
All normal editing commands are switched off.
\\[gnus-article-mail]\t Send a reply to the address near point
\\[gnus-article-describe-briefly]\t Describe the current mode briefly
\\[gnus-info-find-node]\t Go to the Gnus info node"
- (interactive)
- (kill-all-local-variables)
(gnus-simplify-mode-line)
- (setq mode-name "Article")
- (setq major-mode 'gnus-article-mode)
(make-local-variable 'minor-mode-alist)
- (use-local-map gnus-article-mode-map)
(when (gnus-visual-p 'article-menu 'menu)
(gnus-article-make-menu-bar)
(when gnus-summary-tool-bar-map
(buffer-disable-undo)
(setq buffer-read-only t
show-trailing-whitespace nil)
- (set-syntax-table gnus-article-mode-syntax-table)
- (mm-enable-multibyte)
- (gnus-run-mode-hooks 'gnus-article-mode-hook))
+ (mm-enable-multibyte))
(defun gnus-article-setup-buffer ()
"Initialize the article buffer."
nil)
(error "Action aborted"))
t)))
- (with-current-buffer name
- (set (make-local-variable 'gnus-article-edit-mode) nil)
- (gnus-article-stop-animations)
- (when gnus-article-mime-handles
- (mm-destroy-parts gnus-article-mime-handles)
- (setq gnus-article-mime-handles nil))
- ;; Set it to nil in article-buffer!
- (setq gnus-article-mime-handle-alist nil)
- (buffer-disable-undo)
- (setq buffer-read-only t)
- (unless (eq major-mode 'gnus-article-mode)
- (gnus-article-mode))
+ (let ((summary gnus-summary-buffer))
+ (with-current-buffer name
+ (set (make-local-variable 'gnus-article-edit-mode) nil)
+ (gnus-article-stop-animations)
+ (when gnus-article-mime-handles
+ (mm-destroy-parts gnus-article-mime-handles)
+ (setq gnus-article-mime-handles nil))
+ ;; Set it to nil in article-buffer!
+ (setq gnus-article-mime-handle-alist nil)
+ (buffer-disable-undo)
+ (setq buffer-read-only t)
+ (unless (derived-mode-p 'gnus-article-mode)
+ (gnus-article-mode))
+ (set (make-local-variable 'gnus-summary-buffer) summary)
+ (setq truncate-lines gnus-article-truncate-lines)
+ (current-buffer)))
+ (let ((summary gnus-summary-buffer))
+ (with-current-buffer (gnus-get-buffer-create name)
+ (gnus-article-mode)
(setq truncate-lines gnus-article-truncate-lines)
- (current-buffer))