;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 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)
(defcustom gnus-visible-headers
- "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"
+ "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:"
"*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."
(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)
:group 'gnus-article-mime
:type '(repeat (cons :format "%v" (string :tag "MIME type") function)))
-(defcustom gnus-article-date-lapsed-new-header nil
- "Whether the X-Sent and Date headers can coexist.
-When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
-either replace the old \"Date:\" header (if this variable is nil), or
-be added below it (otherwise)."
- :version "21.1"
+(defcustom gnus-article-date-headers '(combined-lapsed)
+ "A list of Date header formats to display.
+Valid formats are `ut' (universal time), `local' (local time
+zone), `english' (readable English), `lapsed' (elapsed time),
+`combined-lapsed' (both the original date and the elapsed time),
+`original' (the original date header), `iso8601' (ISO8601
+format), and `user-defined' (a user-defined format defined by the
+`gnus-article-time-format' variable).
+
+You have as many date headers as you want in the article buffer.
+Some of these headers are updated automatically. See
+`gnus-article-update-date-headers' for details."
+ :version "24.1"
:group 'gnus-article-headers
- :type 'boolean)
+ :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)))
+
+(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
+ :type '(choice
+ (item :tag "Don't update" :value nil)
+ integer))
(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
"Function called with a MIME handle as the argument.
:type gnus-article-treat-head-custom)
(put 'gnus-treat-buttonize-head 'highlight t)
+(defcustom gnus-treat-date 'head
+ "Display dates according to the `gnus-article-date-headers' variable.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
+ :version "24.1"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-head-custom)
+
(defcustom gnus-treat-emphasize 50000
"Emphasize text.
Valid values are nil, t, `head', `first', `last', an integer or a
(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)")
:type gnus-article-treat-custom)
(put 'gnus-treat-highlight-citation 'highlight t)
-(defcustom gnus-treat-date-ut nil
- "Display the Date in UT (GMT).
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-local nil
- "Display the Date in the local timezone.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-english nil
- "Display the Date in a format that can be read aloud in English.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :version "22.1"
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-lapsed nil
- "Display the Date header in a way that says how much time has elapsed.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-original nil
- "Display the date in the original timezone.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-iso8601 nil
- "Display the date in the ISO8601 format.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :version "21.1"
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-user-defined nil
- "Display the date in a user-defined format.
-The format is defined by the `gnus-article-time-format' variable.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
(defcustom gnus-treat-strip-headers-in-body t
"Strip the X-No-Archive header line from the beginning of the body.
Valid values are nil, t, `head', `first', `last', an integer or a
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.
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(defcustom gnus-treat-fill-long-lines nil
+(defcustom gnus-treat-fill-long-lines '(typep "text/plain")
"Fill long lines.
Valid values are nil, t, `head', `first', `last', an integer or a
predicate. See Info node `(gnus)Customizing Articles'."
+ :version "24.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
:group 'gnus-article
:type 'boolean)
+(defcustom gnus-inhibit-images nil
+ "Non-nil means inhibit displaying of images inline in the article body."
+ :version "24.1"
+ :group 'gnus-article
+ :type 'boolean)
+
(defcustom gnus-blocked-images 'gnus-block-private-groups
"Images that have URLs matching this regexp will be blocked.
This can also be a function to be evaluated. If so, it will be
(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-long-lines)
- (gnus-treat-strip-cr gnus-article-remove-cr)
+ (gnus-treat-fill-long-lines gnus-article-fill-cited-long-lines)
(gnus-treat-unsplit-urls gnus-article-unsplit-urls)
- (gnus-treat-date-ut gnus-article-date-ut)
- (gnus-treat-date-local gnus-article-date-local)
- (gnus-treat-date-english gnus-article-date-english)
- (gnus-treat-date-original gnus-article-date-original)
- (gnus-treat-date-user-defined gnus-article-date-user)
- (gnus-treat-date-iso8601 gnus-article-date-iso8601)
- (gnus-treat-date-lapsed gnus-article-date-lapsed)
(gnus-treat-display-x-face gnus-article-display-x-face)
(gnus-treat-display-face gnus-article-display-face)
(gnus-treat-hide-headers gnus-article-maybe-hide-headers)
(gnus-treat-mail-picon gnus-treat-mail-picon)
(gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
(gnus-treat-strip-pem gnus-article-hide-pem)
+ (gnus-treat-date gnus-article-treat-date)
(gnus-treat-from-gravatar gnus-treat-from-gravatar)
(gnus-treat-mail-gravatar gnus-treat-mail-gravatar)
(gnus-treat-highlight-headers gnus-article-highlight-headers)
(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))
(interactive)
(article-translate-strings gnus-article-dumbquotes-map))
+(defvar org-entities)
+
+(defun article-treat-non-ascii ()
+ "Translate many Unicode characters into their ASCII equivalents."
+ (interactive)
+ (require 'org-entities)
+ (let ((table (make-char-table (if (featurep 'xemacs) 'generic))))
+ (dolist (elem org-entities)
+ (when (and (listp elem)
+ (= (length (nth 6 elem)) 1))
+ (if (featurep 'xemacs)
+ (put-char-table (aref (nth 6 elem) 0) (nth 4 elem) table)
+ (set-char-table-range table (aref (nth 6 elem) 0) (nth 4 elem)))))
+ (save-excursion
+ (when (article-goto-body)
+ (let ((inhibit-read-only t)
+ replace props)
+ (while (not (eobp))
+ (if (not (setq replace (if (featurep 'xemacs)
+ (get-char-table (following-char) table)
+ (aref table (following-char)))))
+ (forward-char 1)
+ (if (prog1
+ (setq props (text-properties-at (point)))
+ (delete-char 1))
+ (add-text-properties (point) (progn (insert replace) (point))
+ 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
"Remove all images from the article buffer."
(interactive)
(gnus-with-article-buffer
- (dolist (elem gnus-article-image-alist)
- (gnus-delete-images (car elem)))))
+ (save-restriction
+ (widen)
+ (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."
+ (interactive)
+ (gnus-with-article-buffer
+ (save-restriction
+ (widen)
+ (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
(forward-line 1)
(setq ended t)))))
-(defun article-date-ut (&optional type highlight)
- "Convert DATE date to universal time in the current article.
-If TYPE is `local', convert to local time; if it is `lapsed', output
-how much time has lapsed since DATE. For `lapsed', the value of
-`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
-should replace the \"Date:\" one, or should be added below it."
+(defun article-treat-date ()
+ (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.
+The default type is `ut'. See `gnus-article-date-headers' for
+possible values."
(interactive (list 'ut t))
- (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
- (date-regexp (cond ((not gnus-article-date-lapsed-new-header)
- tdate-regexp)
- ((eq type 'lapsed)
- "^X-Sent:[ \t]")
- (article-lapsed-timer
- "^Date:[ \t]")
- (t
- tdate-regexp)))
- (case-fold-search t)
+ (let* ((case-fold-search t)
(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
- (widen)
- (goto-char (point-min))
- (while (or (setq date (get-text-property (setq pos (point))
- 'original-date))
- (when (setq pos (next-single-property-change
- (point) 'original-date))
- (setq date (get-text-property pos 'original-date))
- t))
- (narrow-to-region
- pos (if (setq pos (text-property-any pos (point-max)
- 'original-date nil))
- (progn
- (goto-char pos)
- (if (or (bolp) (eobp))
- (point)
- (1+ (point))))
- (point-max)))
- (goto-char (point-min))
- (when (re-search-forward tdate-regexp nil t)
- (setq bface (get-text-property (point-at-bol) 'face)
- eface (get-text-property (1- (point-at-eol)) 'face)))
+ (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))
- (setq pos nil)
- ;; Delete any old Date headers.
- (while (re-search-forward date-regexp nil t)
- (if pos
- (delete-region (point-at-bol) (progn
- (gnus-article-forward-header)
- (point)))
+ (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)
- (forward-char -1)
- (point)))
- (setq pos (point))))
- (when (and (not pos)
- (re-search-forward tdate-regexp nil t))
- (forward-line 1))
- (gnus-goto-char pos)
- (insert (article-make-date-line date (or type 'ut)))
- (unless pos
- (insert "\n")
- (forward-line -1))
- ;; Do highlighting.
- (beginning-of-line)
- (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))
- (put-text-property (point-min) (1- (point-max)) 'original-date date)
- (goto-char (point-max))
- (widen))))))
+ (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
+ ((null type)
+ (list 'ut))
+ ((atom type)
+ (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)
+ ;; 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)))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
- (unless (memq type '(local ut original user iso8601 lapsed english))
+ (unless (memq type '(local ut original user-defined iso8601 lapsed english
+ 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)
(substring date 0 (match-beginning 0))
date)))
;; Let the user define the format.
- ((eq type 'user)
+ ((eq type 'user-defined)
(let ((format (or (condition-case nil
(with-current-buffer gnus-summary-buffer
gnus-article-time-format)
(format "%s%02d%02d"
(if (> tz 0) "+" "-") (/ (abs tz) 3600)
(/ (% (abs tz) 3600) 60)))))
- ;; Do an X-Sent lapsed format.
+ ;; Do a 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"))))))
+ (concat "Date: " (article-lapsed-string time)))
+ ;; A combined date/lapsed format.
+ ((eq type 'combined-lapsed)
+ (let ((date-string (article-make-date-line date 'original))
+ (segments 3)
+ lapsed-string)
+ (while (and
+ time
+ (setq lapsed-string
+ (concat " (" (article-lapsed-string time segments) ")"))
+ (> (+ (length date-string)
+ (length lapsed-string))
+ (+ fill-column 6))
+ (> segments 0))
+ (setq segments (1- segments)))
+ (if (> segments 0)
+ (concat date-string lapsed-string)
+ date-string)))
;; Display the date in proper English
((eq type 'english)
(let ((dtime (decode-time time)))
(format "%02d" (nth 2 dtime))
":"
(format "%02d" (nth 1 dtime)))))))
- (error
+ (foo
(format "Date: %s (from Gnus)" date))))
+(defun article-lapsed-string (time &optional max-segments)
+ ;; 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)))
+ (segments 0)
+ num prev)
+ (unless max-segments
+ (setq max-segments (length article-time-units)))
+ (cond
+ ((null real-time)
+ "Unknown")
+ ((zerop sec)
+ "Now")
+ (t
+ (concat
+ ;; 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 (or (zerop (setq num (ffloor (/ sec (cdr unit)))))
+ (>= segments max-segments))
+ ;; 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
+ segments (1+ segments)))))
+ 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"))))))
+
(defun article-date-local (&optional highlight)
"Convert the current article date to the local timezone."
(interactive (list t))
(interactive (list t))
(article-date-ut 'lapsed highlight))
+(defun article-date-combined-lapsed (&optional highlight)
+ "Convert the current article date to time lapsed since it was sent."
+ (interactive (list t))
+ (article-date-ut 'combined-lapsed highlight))
+
(defun article-update-date-lapsed ()
"Function to be run from a timer to update the lapsed time line."
(save-match-data
- (let (deactivate-mark)
- (save-excursion
- (ignore-errors
- (walk-windows
- (lambda (w)
- (set-buffer (window-buffer w))
- (when (eq major-mode 'gnus-article-mode)
- (let ((mark (point-marker)))
- (goto-char (point-min))
- (when (re-search-forward "^X-Sent:" nil t)
- (article-date-lapsed t))
- (goto-char (marker-position mark))
- (move-marker mark nil))))
- nil 'visible))))))
+ (let ((buffer (current-buffer)))
+ (ignore-errors
+ (walk-windows
+ (lambda (w)
+ (set-buffer (window-buffer w))
+ (when (eq major-mode '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))))))
+ (goto-char (point-min))
+ (when (> old-column 0)
+ (setq old-line (1- old-line)))
+ (forward-line old-line)
+ (end-of-line)
+ (when (> (current-column) old-column)
+ (beginning-of-line)
+ (forward-char old-column)))))
+ nil 'visible))
+ (set-buffer buffer))))
(defun gnus-start-date-timer (&optional n)
- "Start a timer to update the X-Sent header in the article buffers.
+ "Start a timer to update the Date headers in the article buffers.
The numerical prefix says how frequently (in seconds) the function
is to run."
(interactive "p")
(run-at-time 1 n 'article-update-date-lapsed)))
(defun gnus-stop-date-timer ()
- "Stop the X-Sent timer."
+ "Stop the Date timer."
(interactive)
(when article-lapsed-timer
(nnheader-cancel-timer article-lapsed-timer)
article-date-english
article-date-iso8601
article-date-original
+ article-treat-date
article-date-ut
article-decode-mime-words
article-decode-charset
article-decode-encoded-words
article-date-user
article-date-lapsed
+ article-date-combined-lapsed
article-emphasize
article-treat-dumbquotes
+ article-treat-non-ascii
article-normalize-headers
;;(article-show-all . gnus-article-show-all-headers)
)))
(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.
(gnus-update-format-specifications nil 'article-mode)
(set (make-local-variable 'page-delimiter) gnus-page-delimiter)
(set (make-local-variable 'gnus-page-broken) nil)
- (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)
;; 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)
(mm-enable-multibyte)
(gnus-run-mode-hooks 'gnus-article-mode-hook))
-(defvar gnus-button-marker-list nil
- "Regexp matching any of the regexps from `gnus-button-alist'.
-Internal variable.")
-
(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-article-mime-handle-alist nil)
(buffer-disable-undo)
(setq buffer-read-only t)
- ;; This list just keeps growing if we don't reset it.
- (setq gnus-button-marker-list nil)
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
(setq truncate-lines gnus-article-truncate-lines)
(setq gnus-summary-buffer
(gnus-summary-buffer-name gnus-newsgroup-name))
(gnus-summary-set-local-parameters gnus-newsgroup-name)
+ (when article-lapsed-timer
+ (gnus-stop-date-timer))
+ (when gnus-article-update-date-headers
+ (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))))
+
;; 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
(when (zerop parts)
(error "No such part"))
(pop-to-buffer gnus-article-buffer)
- ;; FIXME: why is it necessary?
- (sit-for 0)
(or n
(setq n (if (= parts 1)
1
(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)
(if (mm-handle-undisplayer handle)
(mm-remove-part handle))))
(forward-line 2)
- (mm-insert-inline
- handle
- (if (or coding-system
- (and charset
- (setq coding-system
- (mm-charset-to-coding-system charset))
- (not (eq coding-system 'ascii))))
- (mm-decode-coding-string contents coding-system)
- (mm-string-to-multibyte contents)))
+ (mm-display-inline handle)
(goto-char b)))))
(defun gnus-mime-set-charset-parameters (handle charset)
(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-article-goto-part (n)
"Go to MIME part N."
- (let ((start (text-property-any (point-min) (point-max) 'gnus-part n))
- part handle end next handles)
- (when start
- (goto-char start)
- (if (setq handle (get-text-property start 'gnus-data))
- start
- ;; Go to the displayed subpart, assuming this is multipart/alternative.
- (setq part start
- end (point-at-eol))
- (while (and (not handle)
- part
- (< part end)
- (setq next (text-property-not-all part end
- 'gnus-data nil)))
- (setq part next
- handle (get-text-property part 'gnus-data))
- (push (cons handle part) handles)
- (unless (mm-handle-displayed-p handle)
- (setq handle nil
- part (text-property-any part end 'gnus-data nil))))
- (unless handle
- ;; No subpart is displayed, so we find preferred one.
- (setq part
- (cdr (assq (mm-preferred-alternative
- (nreverse (mapcar 'car handles)))
- handles))))
- (if part
- (goto-char (1+ part))
- start)))))
+ (when gnus-break-pages
+ (widen))
+ (prog1
+ (let ((start (text-property-any (point-min) (point-max) 'gnus-part n))
+ part handle end next handles)
+ (when start
+ (goto-char start)
+ (if (setq handle (get-text-property start 'gnus-data))
+ start
+ ;; Go to the displayed subpart, assuming this is
+ ;; multipart/alternative.
+ (setq part start
+ end (point-at-eol))
+ (while (and (not handle)
+ part
+ (< part end)
+ (setq next (text-property-not-all part end
+ 'gnus-data nil)))
+ (setq part next
+ handle (get-text-property part 'gnus-data))
+ (push (cons handle part) handles)
+ (unless (mm-handle-displayed-p handle)
+ (setq handle nil
+ part (text-property-any part end 'gnus-data nil))))
+ (unless handle
+ ;; No subpart is displayed, so we find preferred one.
+ (setq part
+ (cdr (assq (mm-preferred-alternative
+ (nreverse (mapcar 'car handles)))
+ handles))))
+ (if part
+ (goto-char (1+ part))
+ start))))
+ (when gnus-break-pages
+ (gnus-narrow-to-page))))
(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))
(save-restriction
(article-goto-body)
(narrow-to-region (point) (point-max))
- (gnus-treat-article nil 1 1)
+ (gnus-treat-article nil 1 1 "text/plain")
(widen)))
(unless ihandles
;; Highlight the headers.
(while ignored
(when (string-match (pop ignored) type)
(throw 'ignored nil)))
- (if (and (setq not-attachment
+ (if (and (not (and (if (gnus-buffer-live-p gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ gnus-inhibit-images)
+ gnus-inhibit-images)
+ (string-match "\\`image/" type)))
+ (setq not-attachment
(and (not (mm-inline-override-p handle))
(or (not (mm-handle-disposition handle))
(equal (car (mm-handle-disposition handle))
(forward-line -1)
(setq beg (point)))
(gnus-article-insert-newline)
- (mm-insert-inline
- handle
- (let ((charset (or (mail-content-type-get (mm-handle-type handle)
- 'charset)
- (and (equal type "text/calendar") 'utf-8))))
- (cond ((not charset)
- (mm-string-as-multibyte (mm-get-part handle)))
- ((eq charset 'gnus-decoded)
- (with-current-buffer (mm-handle-buffer handle)
- (buffer-string)))
- (t
- (mm-decode-string (mm-get-part handle) charset)))))
+ (mm-display-inline handle)
(goto-char (point-max))))
;; Do highlighting.
(save-excursion
,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)
(gnus-treat-article
nil (length gnus-article-mime-handle-alist)
(gnus-article-mime-total-parts)
- (mm-handle-media-type handle))))))
+ (mm-handle-media-type preferred))))))
(goto-char (point-max))
(setcdr begend (point-marker)))))
(when ibegend
(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)
(save-excursion
(end-of-line)
(and (pos-visible-in-window-p) ;Not continuation line.
- (>= (1+ (point)) (point-max))))) ;Allow for trailing newline.
+ (>= (point) (point-max)))))
;; Nothing in this page.
(if (or (not gnus-page-broken)
(save-excursion
(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.
(ding)
(unless (member keys nosave-in-article)
(set-buffer gnus-article-current-summary))
+ (when (get func 'disabled)
+ (error "Function %s disabled" func))
(call-interactively func)
(setq new-sum-point (point)))
(when (member keys nosave-but-article)
(select-window win))))
(setq in-buffer (current-buffer))
;; We disable the pick minor mode commands.
- (if (and (setq func (let (gnus-pick-mode)
- (key-binding keys t)))
+ (setq func (let (gnus-pick-mode)
+ (key-binding keys t)))
+ (when (get func 'disabled)
+ (error "Function %s disabled" func))
+ (if (and func
(functionp func)
(condition-case code
(progn
(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)))
(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
-;; FIXME: Maybe we should merge some of the functions that do quite similar
-;; stuff?
-
(defun gnus-button-handle-describe-function (url)
"Call `describe-function' when pushing the corresponding URL button."
(describe-function
;; Info links like `C-h i d m Gnus RET' or `C-h i d m Gnus RET i partial RET'
0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 0)
;; This is custom
- ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
+ ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET\\>" 0
(>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2)
;; Emacs help commands
- ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
;; regexp doesn't match arguments containing ` '.
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
- ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
- ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
- ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
;; The following entries may lead to many false positives so don't enable
;; them by default (use a high button level).
0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)"
1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
- ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
- ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
- ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
("`\\(\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
;; Unlike the other regexps we really have to require quoting
(gnus-article-highlight-headers)
(gnus-article-highlight-citation force)
(gnus-article-highlight-signature)
- (gnus-article-add-buttons force)
+ (gnus-article-add-buttons)
(gnus-article-add-buttons-to-head))
(defun gnus-article-highlight-some (&optional force)
"Say whether PROP exists in the region."
(text-property-not-all b e prop nil))
-(defun gnus-article-add-buttons (&optional force)
+(defun gnus-article-add-buttons ()
"Find external references in the article and make buttons of them.
\"External references\" are things like Message-IDs and URLs, as
specified by `gnus-button-alist'."
- (interactive (list 'force))
+ (interactive)
(gnus-with-article-buffer
(let ((inhibit-point-motion-hooks t)
(case-fold-search t)
(alist gnus-button-alist)
beg entry regexp)
- ;; Remove all old markers.
- (let (marker entry new-list)
- (while (setq marker (pop gnus-button-marker-list))
- (if (or (< marker (point-min)) (>= marker (point-max)))
- (push marker new-list)
- (goto-char marker)
- (when (setq entry (gnus-button-entry))
- (put-text-property (match-beginning (nth 1 entry))
- (match-end (nth 1 entry))
- 'gnus-callback nil))
- (set-marker marker nil)))
- (setq gnus-button-marker-list new-list))
;; We skip the headers.
(article-goto-body)
(setq beg (point))
(let ((start (match-beginning (nth 1 entry)))
(end (match-end (nth 1 entry)))
(from (match-beginning 0)))
- (when (and (or (eq t (nth 2 entry))
- (eval (nth 2 entry)))
+ (when (and (eval (nth 2 entry))
(not (gnus-button-in-region-p
start end 'gnus-callback)))
;; That optional form returned non-nil, so we add the
;; button.
(setq from (set-marker (make-marker) from))
- (push from gnus-button-marker-list)
(unless (and (eq (car entry) 'gnus-button-url-regexp)
(gnus-article-extend-url-button from start end))
(gnus-article-add-button start end
- 'gnus-button-push from)
+ 'gnus-button-push (list from entry))
(gnus-put-text-property
start end
'gnus-string (buffer-substring-no-properties
(let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
(gnus-set-mode-line 'article))))
-(defun gnus-button-entry ()
- ;; Return the first entry in `gnus-button-alist' matching this place.
- (let ((alist gnus-button-alist)
- (entry nil))
- (while alist
- (setq entry (pop alist))
- (if (looking-at (eval (car entry)))
- (setq alist nil)
- (setq entry nil)))
- entry))
-
-(defun gnus-button-push (marker)
+(defun gnus-button-push (marker-and-entry)
;; Push button starting at MARKER.
(save-excursion
- (goto-char marker)
- (let* ((entry (gnus-button-entry))
- (inhibit-point-motion-hooks t)
- (fun (nth 3 entry))
- (args (or (and (eq (car entry) 'gnus-button-url-regexp)
- (get-char-property marker 'gnus-button-url))
- (mapcar (lambda (group)
- (let ((string (match-string group)))
- (set-text-properties
- 0 (length string) nil string)
- string))
- (nthcdr 4 entry)))))
- (cond
- ((fboundp fun)
- (apply fun args))
- ((and (boundp fun)
- (fboundp (symbol-value fun)))
- (apply (symbol-value fun) args))
- (t
- (gnus-message 1 "You must define `%S' to use this button"
- (cons fun args)))))))
+ (let* ((marker (car marker-and-entry))
+ (entry (cadr marker-and-entry))
+ (regexp (car entry))
+ (inhibit-point-motion-hooks t))
+ (goto-char marker)
+ ;; This is obviously true, or something bad is happening :)
+ ;; But we need it to have the match-data
+ (when (looking-at (or (if (symbolp regexp)
+ (symbol-value regexp)
+ regexp)))
+ (let ((fun (nth 3 entry))
+ (args (or (and (eq (car entry) 'gnus-button-url-regexp)
+ (get-char-property marker 'gnus-button-url))
+ (mapcar (lambda (group)
+ (let ((string (match-string group)))
+ (set-text-properties
+ 0 (length string) nil string)
+ string))
+ (nthcdr 4 entry)))))
+
+ (cond
+ ((fboundp fun)
+ (apply fun args))
+ ((and (boundp fun)
+ (fboundp (symbol-value fun)))
+ (apply (symbol-value fun) args))
+ (t
+ (gnus-message 1 "You must define `%S' to use this button"
+ (cons fun args)))))))))
(defun gnus-parse-news-url (url)
(let (scheme server port group message-id articles)
(if (string-match
(concat "\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+"
"\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
- "\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET"
+ "\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\>"
"\\(?:[ \t\n,]*\\)\\)?")
url)
(setq node (match-string 2 url)
(Info-directory)
(Info-menu node)
(when (> (length indx) 0)
- (string-match (concat "[ \t\n]+i[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
+ (string-match (concat "[ \t\n]+i[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET\\>"
"\\([ \t\n,]*\\)")
indx)
(setq comma (match-string 2 indx))
(Info-index-next 1)))
nil)))
+(autoload 'pgg-snarf-keys-region "pgg")
;; Called after pgg-snarf-keys-region, which autoloads pgg.el.
(declare-function pgg-display-output-buffer "pgg" (start end status))
(defun gnus-url-mailto (url)
;; Send mail to someone
+ (setq url (replace-regexp-in-string "\n" " " url))
(when (string-match "mailto:/*\\(.*\\)" url)
(setq url (substring url (match-beginning 1) nil)))
(let (to args subject func)
(if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
(concat "to=" (match-string 1 url) "&"
(match-string 2 url))
- (concat "to=" url)))
- t)
+ (concat "to=" url))))
subject (cdr-safe (assoc "subject" args)))
(gnus-msg-mail)
(while args
;;; Treatment top-level handling.
;;;
-(defun gnus-treat-article (condition &optional part-number total-parts type)
- (let ((length (- (point-max) (point-min)))
+(defvar gnus-inhibit-article-treatments nil)
+
+(defun gnus-treat-article (gnus-treat-condition
+ &optional part-number total-parts gnus-treat-type)
+ (let ((gnus-treat-length (- (point-max) (point-min)))
(alist gnus-treatment-function-alist)
(article-goto-body-goes-to-point-min-p t)
(treated-type
- (or (not type)
+ (or (not gnus-treat-type)
(catch 'found
(let ((list gnus-article-treat-types))
(while list
- (when (string-match (pop list) type)
+ (when (string-match (pop list) gnus-treat-type)
(throw 'found t)))))))
(highlightp (gnus-visual-p 'article-highlight 'highlight))
val elem)
(symbol-value (car elem))))
(when (and (or (consp val)
treated-type)
+ (or (not gnus-inhibit-article-treatments)
+ (eq gnus-treat-condition 'head))
(gnus-treat-predicate val)
(or (not (get (car elem) 'highlight))
highlightp))
;; Dynamic variables.
(defvar part-number)
(defvar total-parts)
-(defvar type)
-(defvar condition)
-(defvar length)
+(defvar gnus-treat-type)
+(defvar gnus-treat-condition)
+(defvar gnus-treat-length)
(defun gnus-treat-predicate (val)
(cond
((null val)
nil)
- (condition
- (eq condition val))
+ (gnus-treat-condition
+ (eq gnus-treat-condition val))
((and (listp val)
(stringp (car val)))
(apply 'gnus-or (mapcar `(lambda (s)
((eq pred 'not)
(not (gnus-treat-predicate (car val))))
((eq pred 'typep)
- (equal (car val) type))
+ (equal (car val) gnus-treat-type))
(t
(error "%S is not a valid predicate" pred)))))
((eq val t)
((eq val 'last)
(eq part-number total-parts))
((numberp val)
- (< length val))
+ (< gnus-treat-length val))
(t
(error "%S is not a valid value" val))))
projects / gnus / blobdiff