;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2012 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(require 'wid-edit)
(require 'mm-uu)
(require 'message)
+(require 'mouse)
(autoload 'gnus-msg-mail "gnus-msg" nil t)
(autoload 'gnus-button-mailto "gnus-msg")
"*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."
- :type '(choice :custom-show nil
- regexp
+ :type '(choice regexp
(repeat regexp))
:group 'gnus-article-hiding)
(if (or (gnus-image-type-available-p 'xface)
(gnus-image-type-available-p 'pbm))
'gnus-display-x-face-in-from
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
+ "{ echo \
+'/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\
+; uncompface; } | icontopbm | ee -")
(if (gnus-image-type-available-p 'pbm)
'gnus-display-x-face-in-from
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
-display -"))
+ "{ echo \
+'/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\
+; uncompface; } | icontopbm | display -"))
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
;; Note that "Rmail format" is mbox since Emacs 23, but Babyl before.
(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
- "A function to save articles in your favourite format.
+ "A function to save articles in your favorite format.
The function will be called by way of the `gnus-summary-save-article'
command, and friends such as `gnus-summary-save-article-rmail'.
If the match is a string, it is used as a regexp match on the
article. If the match is a symbol, that symbol will be funcalled
from the buffer of the article to be saved with the newsgroup as the
-parameter. If it is a list, it will be evaled in the same buffer.
+parameter. If it is a list, it will be evalled in the same buffer.
If this form or function returns a string, this string will be used as a
possible file name; and if it returns a non-nil list, that list will be
:type 'regexp
:group 'gnus-article-various)
-(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
+(defcustom gnus-article-mode-line-format "Gnus: %g %S%m"
"*The format specification for the article mode line.
See `gnus-summary-mode-line-format' for a closer description.
%w The article washing status.
%m The number of MIME parts in the article."
+ :version "24.1"
:type 'string
:group 'gnus-article-various)
(item :tag "ISO8601 format" :value 'iso8601)
(item :tag "User-defined" :value 'user-defined)))
-(defcustom gnus-article-update-date-headers 1
- "How often to update the date header.
+(defcustom gnus-article-update-date-headers nil
+ "A number that says how often to update the date header (in seconds).
If nil, don't update it at all."
:version "24.1"
:group 'gnus-article-headers
(defcustom gnus-treat-hide-citation nil
"Hide cited text.
Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
+predicate. See Info node `(gnus)Customizing Articles'.
+
+See `gnus-article-highlight-citation' for variables used to
+control what it hides."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-hide-citation-maybe nil
- "Hide cited text.
+ "Hide cited text according to certain conditions.
Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
+predicate. See Info node `(gnus)Customizing Articles'.
+
+See `gnus-cite-hide-percentage' and `gnus-cite-hide-absolute' for
+how to control what it hides."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
+(gnus-define-group-parameter
+ list-identifier
+ :variable-document
+ "Alist of regexps and correspondent identifiers."
+ :variable-group gnus-article-washing
+ :parameter-type
+ '(choice :tag "Identifier"
+ :value nil
+ (symbol :tag "Item in `gnus-list-identifiers'" none)
+ regexp
+ (const :tag "None" nil))
+ :parameter-document
+ "If non-nil, specify how to remove `identifiers' from articles' subject.
+
+Any symbol is used to look up a regular expression to match the
+banner in `gnus-list-identifiers'. A string is used as a regular
+expression to match the identifier directly.")
+
(make-obsolete-variable 'gnus-treat-strip-pgp nil
"Gnus 5.10 (Emacs 22.1)")
gnus-treat-from-picon
gnus-treat-from-gravatar
gnus-treat-mail-gravatar)
- ;; If there's much decoration, the user might prefer a boundery.
+ ;; If there's much decoration, the user might prefer a boundary.
'head
nil)
"Draw a boundary at the end of the headers.
(defvar gnus-article-mime-handle-alist-1 nil)
(defvar gnus-treatment-function-alist
- '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
+ '((gnus-treat-strip-cr gnus-article-remove-cr)
+ (gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
(gnus-treat-strip-banner gnus-article-strip-banner)
(gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
(gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-buttonize gnus-article-add-buttons)
(gnus-treat-fill-article gnus-article-fill-cited-article)
(gnus-treat-fill-long-lines gnus-article-fill-cited-long-lines)
- (gnus-treat-strip-cr gnus-article-remove-cr)
(gnus-treat-unsplit-urls gnus-article-unsplit-urls)
(gnus-treat-display-x-face gnus-article-display-x-face)
(gnus-treat-display-face gnus-article-display-face)
(put 'gnus-with-article-headers 'edebug-form-spec '(body))
(defmacro gnus-with-article-buffer (&rest forms)
- `(with-current-buffer gnus-article-buffer
- (let ((inhibit-read-only t))
- ,@forms)))
+ `(when (buffer-live-p (get-buffer gnus-article-buffer))
+ (with-current-buffer gnus-article-buffer
+ (let ((inhibit-read-only t))
+ ,@forms))))
(put 'gnus-with-article-buffer 'lisp-indent-function 0)
(put 'gnus-with-article-buffer 'edebug-form-spec '(body))
(dolist (elem gnus-article-image-alist)
(gnus-delete-images (car elem))))))
+(autoload 'w3m-toggle-inline-images "w3m")
+
(defun gnus-article-show-images ()
"Show any images that are in the HTML-rendered article buffer.
This only works if the article in question is HTML."
(gnus-with-article-buffer
(save-restriction
(widen)
- (dolist (region (gnus-find-text-property-region (point-min) (point-max)
- 'image-displayer))
- (destructuring-bind (start end function) region
- (funcall function (get-text-property start 'image-url)
- start end))))))
+ (if (eq mm-text-html-renderer 'w3m)
+ (let ((mm-inline-text-html-with-images nil))
+ (w3m-toggle-inline-images))
+ (dolist (region (gnus-find-text-property-region (point-min) (point-max)
+ 'image-displayer))
+ (destructuring-bind (start end function) region
+ (funcall function (get-text-property start 'image-url)
+ start end)))))))
(defun gnus-article-treat-fold-newsgroups ()
"Unfold folded message headers.
(let ((start (point)))
(insert "X-Boundary: ")
(gnus-add-text-properties start (point) '(invisible t intangible t))
- (insert (let (str)
- (while (>= (window-width) (length str))
+ (insert (let (str (max (window-width)))
+ (if (featurep 'xemacs)
+ (setq max (1- max)))
+ (while (>= max (length str))
(setq str (concat str gnus-body-boundary-delimiter)))
- (substring str 0 (window-width)))
+ (substring str 0 max))
"\n")
(gnus-put-text-property start (point) 'gnus-decoration 'header)))))
((equal (concat "<" cid ">") (mm-handle-id handle))
(setq file
(expand-file-name
- (or (mail-content-type-get
- (mm-handle-disposition handle) 'filename)
- (mail-content-type-get
- (setq type (mm-handle-type handle)) 'name)
- (concat
- (make-temp-name "cid")
- (car (rassoc (car type) 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))))))))
((or (equal (car (setq type (mm-handle-type handle))) "text/html")
(and (equal (car type) "message/external-body")
(or header
- (setq file (or (mail-content-type-get type 'name)
- (mail-content-type-get
- (mm-handle-disposition handle)
- 'filename))))
+ (setq file (mm-handle-filename handle)))
(or (mm-handle-cache handle)
(condition-case code
(progn (mm-extern-cache-contents handle) t)
(with-current-buffer gnus-article-buffer
gnus-article-mime-handles)
cid-dir))
+ (when (eq system-type 'cygwin)
+ (setq cid-file
+ (concat "/" (substring
+ (with-output-to-string
+ (call-process "cygpath" nil
+ standard-output
+ nil "-m" cid-file))
+ 0 -1))))
(replace-match (concat "file://" cid-file)
nil nil nil 1))))
(unless content (setq content (buffer-string))))
The `gnus-list-identifiers' variable specifies what to do."
(interactive)
(let ((inhibit-point-motion-hooks t)
- (regexp (if (consp gnus-list-identifiers)
- (mapconcat 'identity gnus-list-identifiers " *\\|")
- gnus-list-identifiers))
- (inhibit-read-only t))
+ (regexp (gnus-group-get-list-identifiers gnus-newsgroup-name))
+ (inhibit-read-only t))
(when regexp
(save-excursion
(save-restriction
(setq ended t)))))
(defun article-treat-date ()
- (article-date-ut gnus-article-date-headers t))
+ (article-date-ut (if (gnus-buffer-live-p gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ gnus-article-date-headers)
+ gnus-article-date-headers)
+ t))
(defun article-date-ut (&optional type highlight date-position)
"Convert DATE date to TYPE in the current article.
(inhibit-read-only t)
(inhibit-point-motion-hooks t)
(first t)
+ (visible-date (mail-fetch-field "Date"))
pos date bface eface)
(save-excursion
- (save-restriction
- (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)))
- (goto-char (point-min))
- ;; Delete any old Date headers.
- (if date-position
- (progn
- (goto-char date-position)
- (setq date (get-text-property (point) 'original-date))
- (delete-region (point)
- (progn
- (gnus-article-forward-header)
- (point)))
+ (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))
+ (delete-region (point)
+ (progn
+ (gnus-article-forward-header)
+ (point)))
+ (article-transform-date date type bface eface))
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (or (get-text-property (setq pos (point)) 'original-date)
+ (and (setq pos (next-single-property-change
+ (point) 'original-date))
+ (goto-char pos)))
+ (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))))
+ (when (and (not date)
+ visible-date)
+ (setq date visible-date))
+ (when date
(article-transform-date date type bface eface))
- (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))))
- (when date
- (article-transform-date date type bface eface)))))))
+ (goto-char (point-max))
+ (widen)))))))
(defun article-transform-date (date type bface eface)
(dolist (this-type (cond
combined-lapsed))
(error "Unknown conversion type: %s" type))
(condition-case ()
- (let ((time (date-to-time date)))
+ (let ((time (ignore-errors (date-to-time date))))
(cond
;; Convert to the local timezone.
((eq type 'local)
(segments 3)
lapsed-string)
(while (and
+ time
(setq lapsed-string
(concat " (" (article-lapsed-string time segments) ")"))
(> (+ (length date-string)
(let ((type (get-text-property (match-beginning 0)
'gnus-date-type)))
(when (memq type '(lapsed combined-lapsed user-format))
- (unless (= window-start
- (save-excursion
- (forward-line 1)
- (point)))
+ (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)))
(gnus-run-hooks 'gnus-article-menu-hook)))
(defvar bookmark-make-record-function)
+(defvar shr-put-image-function)
(defun gnus-article-mode ()
"Major mode for displaying an article.
;; Prevent Emacs 22 from displaying non-break space with `nobreak-space'
;; face.
(set (make-local-variable 'nobreak-char-display) nil)
+ ;; Enable `gnus-article-remove-images' to delete images shr.el renders.
+ (set (make-local-variable 'shr-put-image-function) 'gnus-shr-put-image)
(setq cursor-in-non-selected-windows nil)
(gnus-set-default-directory)
(buffer-disable-undo)
(defun gnus-article-setup-buffer ()
"Initialize the article buffer."
(let* ((name (if gnus-single-article-buffer "*Article*"
- (concat "*Article " gnus-newsgroup-name "*")))
+ (concat "*Article "
+ (gnus-group-decoded-name gnus-newsgroup-name)
+ "*")))
(original
(progn (string-match "\\*Article" name)
(concat " *Original Article"
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))
(setq gnus-summary-buffer
(gnus-summary-buffer-name gnus-newsgroup-name))
(gnus-summary-set-local-parameters gnus-newsgroup-name)
- (cond
- ((and gnus-article-update-date-headers
- (not article-lapsed-timer))
+ (when article-lapsed-timer
+ (gnus-stop-date-timer))
+ (when gnus-article-update-date-headers
(gnus-start-date-timer gnus-article-update-date-headers))
- ((and (not gnus-article-update-date-headers)
- article-lapsed-timer)
- (gnus-stop-date-timer)))
(current-buffer)))))
+(defun gnus-article-stop-animations ()
+ (dolist (timer (and (boundp 'timer-list)
+ timer-list))
+ (when (eq (elt timer 5) 'image-animate-timeout)
+ (cancel-timer timer))))
+
;; Set article window start at LINE, where LINE is the number of lines
;; from the head of the article.
(defun gnus-article-set-window-start (&optional line)
(forward-line -1))
(set-window-point (get-buffer-window (current-buffer)) (point))
(gnus-configure-windows 'article)
+ (gnus-run-hooks 'gnus-article-prepare-hook)
t))))))
;;;###autoload
gnus-article-image-alist nil)
(gnus-run-hooks 'gnus-tmp-internal-hook)
(when gnus-display-mime-function
- (funcall gnus-display-mime-function))
- (gnus-run-hooks 'gnus-article-prepare-hook)))
+ (funcall gnus-display-mime-function))))
;;;
;;; Gnus Sticky Article Mode
(let* ((data (get-text-property (point) 'gnus-data))
(id (get-text-property (point) 'gnus-part))
(handles gnus-article-mime-handles)
- (none "(none)")
(description
(let ((desc (mm-handle-description data)))
(when desc
(mail-decode-encoded-word-string desc))))
- (filename
- (or (mail-content-type-get (mm-handle-disposition data) 'filename)
- none))
+ (filename (or (mm-handle-filename data) "(none)"))
(type (mm-handle-media-type data)))
(unless data
(error "No MIME part under point"))
(unless handle
(setq handle (get-text-property (point) 'gnus-data)))
(when handle
- (let ((filename (or (mail-content-type-get (mm-handle-type handle)
- 'name)
- (mail-content-type-get (mm-handle-disposition handle)
- 'filename)))
+ (let ((filename (mm-handle-filename handle))
contents dont-decode charset coding-system)
(mm-with-unibyte-buffer
(mm-insert-part handle)
(mm-with-unibyte-buffer
(mm-insert-part handle)
(setq contents
- (or (mm-decompress-buffer
- (or (mail-content-type-get (mm-handle-type handle)
- 'name)
- (mail-content-type-get (mm-handle-disposition handle)
- 'filename))
- nil t)
+ (or (mm-decompress-buffer (mm-handle-filename handle) nil t)
(buffer-string))))
(cond
((not arg)
(defun gnus-article-part-wrapper (n function &optional no-handle interactive)
"Call FUNCTION on MIME part N.
-Unless NO-HANDLE, call FUNCTION with N-th MIME handle as it's only argument.
-If INTERACTIVE, call FUNCTION interactivly."
+Unless NO-HANDLE, call FUNCTION with N-th MIME handle as its only argument.
+If INTERACTIVE, call FUNCTION interactively."
(let (window frame)
;; Check whether the article is displayed.
(unless (and (gnus-buffer-live-p gnus-article-buffer)
(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
(let ((gnus-tmp-name
- (or (mail-content-type-get (mm-handle-type handle) 'name)
- (mail-content-type-get (mm-handle-disposition handle) 'filename)
+ (or (mm-handle-filename handle)
(mail-content-type-get (mm-handle-type handle) 'url)
""))
(gnus-tmp-type (mm-handle-media-type handle))
gnus-callback gnus-mm-display-part
gnus-part ,gnus-tmp-id
article-type annotation
- gnus-data ,handle))
+ gnus-data ,handle
+ rear-nonsticky t))
(setq e (if (bolp)
;; Exclude a newline.
(1- (point))
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
gnus-part ,id
- article-type multipart))
+ article-type multipart
+ rear-nonsticky t))
(widget-convert-button 'link from (point)
:action 'gnus-widget-press-button
:button-keymap gnus-widget-button-keymap)
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
gnus-part ,id
- gnus-data ,handle))
+ gnus-data ,handle
+ rear-nonsticky t))
(widget-convert-button 'link from (point)
:action 'gnus-widget-press-button
:button-keymap gnus-widget-button-keymap)
(not gnus-inhibit-hiding))
(gnus-article-hide-headers)))
+(declare-function shr-put-image "shr" (data alt))
+
+(defun gnus-shr-put-image (data alt)
+ "Put image DATA with a string ALT. Enable image to be deleted."
+ (let ((image (shr-put-image data (propertize (or alt "*")
+ 'gnus-image-category 'shr))))
+ (when image
+ (gnus-add-image 'shr image))))
+
;;; Article savers.
(defun gnus-output-to-file (file-name)
(defun gnus-article-next-page-1 (lines)
(condition-case ()
- (let ((scroll-in-place nil))
+ (let ((scroll-in-place nil)
+ (auto-window-vscroll nil))
(scroll-up lines))
(end-of-buffer
;; Long lines may cause an end-of-buffer error.
(numberp article))
(let ((gnus-override-method gnus-override-method)
(methods (and (stringp article)
- gnus-refer-article-method))
+ (with-current-buffer gnus-summary-buffer
+ (gnus-refer-article-methods))))
(backend (car (gnus-find-method-for-group
gnus-newsgroup-name)))
result
(inhibit-read-only t))
- (if (or (not (listp methods))
- (and (symbolp (car methods))
- (assq (car methods) nnoo-definition-alist)))
- (setq methods (list methods)))
(when (and (null gnus-override-method)
methods)
(setq gnus-override-method (pop methods)))
(while (not result)
- (when (eq gnus-override-method 'current)
- (setq gnus-override-method
- (with-current-buffer gnus-summary-buffer
- gnus-current-select-method)))
(erase-buffer)
(gnus-kill-all-overlays)
(let ((gnus-newsgroup-name group))
gnus-summary-buffer)
(when gnus-keep-backlog
(gnus-backlog-enter-article
- group article (current-buffer))))
+ group article (current-buffer)))
+ (when (and gnus-agent
+ (gnus-agent-group-covered-p group))
+ (gnus-agent-store-article article group)))
(setq result 'article))
(methods
(setq gnus-override-method (pop methods)))
projects / gnus / blobdiff