;;; 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
"*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
(item :tag "ISO8601 format" :value 'iso8601)
(item :tag "User-defined" :value 'user-defined)))
-(defcustom gnus-article-update-date-headers 1
+(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"
(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)
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-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))
(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 ((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 (format
- "Delete all %s temporary HTML file%s? "
- files
- (if (> files 1) "s" ""))))
+ (gnus-y-or-n-p
+ (if (= files 1)
+ "Delete the temporary HTML file? "
+ (format "Delete all %s temporary HTML files? "
+ files))))
how)))
(dolist (file gnus-article-browse-html-temp-list)
(cond ((file-directory-p file)
(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))))
Point is left at the beginning of the narrowed-to region."
(narrow-to-region
(goto-char (point-min))
- (if (search-forward "\n\n" nil 1)
- (1- (point))
- (point-max)))
+ (cond
+ ;; Absolutely no headers displayed.
+ ((looking-at "\n")
+ (point))
+ ;; Normal headers.
+ ((search-forward "\n\n" nil 1)
+ (1- (point)))
+ ;; Nothing but headers.
+ (t
+ (point-max))))
(goto-char (point-min)))
(defun article-goto-body ()
(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 (and (not date)
- visible-date)
- (setq date visible-date))
- (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
(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))
(gnus-start-date-timer gnus-article-update-date-headers))
(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))))
+
+(defun gnus-stop-downloads ()
+ (when (boundp 'url-queue)
+ (set (intern "url-queue" obarray) nil)))
+
;; 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)
(when (eq major-mode 'gnus-sticky-article-mode)
(gnus-kill-buffer buffer))))
-(defun gnus-kill-sticky-article-buffers (arg)
- "Kill all sticky article buffers.
-If a prefix ARG is given, ask for confirmation."
- (interactive "P")
- (dolist (buf (gnus-buffers))
- (with-current-buffer buf
- (when (eq major-mode 'gnus-sticky-article-mode)
- (if (not arg)
- (gnus-kill-buffer buf)
- (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? "))
- (gnus-kill-buffer buf)))))))
-
;;;
;;; Gnus MIME viewing functions
;;;
(let ((desc (mm-handle-description data)))
(when desc
(mail-decode-encoded-word-string desc))))
- (filename (or (mm-handle-filename (mm-handle-disposition data)) "(none)"))
+ (filename (or (mm-handle-filename data) "(none)"))
(type (mm-handle-media-type data)))
(unless data
(error "No MIME part under point"))
(or (cdr (assq arg
gnus-summary-show-article-charset-alist))
(mm-read-coding-system "Charset: "))))
- (t
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle))))
+ ((mm-handle-undisplayer handle)
+ (mm-remove-part handle)))
(forward-line 2)
(mm-display-inline handle)
(goto-char b)))))
(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)
(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)
+ (progn
+ (beginning-of-line) ;; Make it toggle subparts
+ (gnus-article-press-button))
(when (eq (gnus-mm-display-part handle) 'internal)
(gnus-set-window-start)))))))
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))
+(declare-function shr-put-image "shr" (data alt &optional flags))
-(defun gnus-shr-put-image (data alt)
+(defun gnus-shr-put-image (data alt &optional flags)
"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))))
+ 'gnus-image-category 'shr)
+ flags)))
(when image
(gnus-add-image 'shr image))))
(ding)
(unless (member keys nosave-in-article)
(set-buffer gnus-article-current-summary))
- (when (get func 'disabled)
+ (when (and (symbolp func)
+ (get func 'disabled))
(error "Function %s disabled" func))
(call-interactively func)
(setq new-sum-point (point)))
(gnus-article-hide-citation-maybe arg force)
(gnus-article-hide-signature arg))
-(defun gnus-article-maybe-highlight ()
- "Do some article highlighting if article highlighting is requested."
- (when (gnus-visual-p 'article-highlight 'highlight)
- (gnus-article-highlight-some)))
-
(defun gnus-check-group-server ()
;; Make sure the connection to the server is alive.
(unless (gnus-server-opened
(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))
projects / gnus / blobdiff