X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=82ad4974fd447ba220211b772febb88c313e9738;hp=3b749262c65fd71bfeef30846c5533ac0ea05ebc;hb=b2ea476e0bc6e2973976b376c15be5381fe3127f;hpb=173afc58a02260a715d5201ed6cbbb7ba6aca57d diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 3b749262c..82ad4974f 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,7 +1,6 @@ ;;; 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-2011 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -25,7 +24,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile @@ -169,7 +168,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :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." @@ -684,7 +683,7 @@ beginning of a line." :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. @@ -692,6 +691,7 @@ The following additional specs are available: %w The article washing status. %m The number of MIME parts in the article." + :version "24.1" :type 'string :group 'gnus-article-various) @@ -916,25 +916,25 @@ image type in XEmacs if it is built with the libcompface library." "Function used to decode addresses.") (defvar gnus-article-dumbquotes-map - '(("\200" "EUR") - ("\202" ",") - ("\203" "f") - ("\204" ",,") - ("\205" "...") - ("\213" "<") - ("\214" "OE") - ("\221" "`") - ("\222" "'") - ("\223" "``") - ("\224" "\"") - ("\225" "*") - ("\226" "-") - ("\227" "--") - ("\230" "~") - ("\231" "(TM)") - ("\233" ">") - ("\234" "oe") - ("\264" "'")) + '((?\200 "EUR") + (?\202 ",") + (?\203 "f") + (?\204 ",,") + (?\205 "...") + (?\213 "<") + (?\214 "OE") + (?\221 "`") + (?\222 "'") + (?\223 "``") + (?\224 "\"") + (?\225 "*") + (?\226 "-") + (?\227 "--") + (?\230 "~") + (?\231 "(TM)") + (?\233 ">") + (?\234 "oe") + (?\264 "'")) "Table for MS-to-Latin1 translation.") (defcustom gnus-ignored-mime-types nil @@ -1015,14 +1015,38 @@ on parts -- for instance, adding Vcard info to a database." :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 1 + "How often to update the date header. +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. @@ -1127,6 +1151,15 @@ predicate. See Info node `(gnus)Customizing Articles'." :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 @@ -1258,65 +1291,6 @@ predicate. See Info node `(gnus)Customizing Articles'." :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 @@ -1590,10 +1564,11 @@ predicate. See Info node `(gnus)Customizing Articles'." :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) @@ -1621,9 +1596,6 @@ It is a string, such as \"PGP\". If nil, ask user." :type 'string :group 'mime-security) -(defvar gnus-article-wash-function nil - "Function used for converting HTML into text.") - (defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) (mm-coding-system-p 'utf-8) (executable-find idna-program)) @@ -1639,6 +1611,21 @@ This requires GNU Libidn, and by default only enabled if it is found." :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 +called with the group name as the parameter, and should return a +regexp." + :version "24.1" + :group 'gnus-art + :type 'regexp) + ;;; Internal variables (defvar gnus-english-month-names @@ -1658,16 +1645,9 @@ This requires GNU Libidn, and by default only enabled if it is found." (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-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-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) @@ -1679,6 +1659,7 @@ This requires GNU Libidn, and by default only enabled if it is found." (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) @@ -2108,6 +2089,35 @@ try this wash." (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 @@ -2132,9 +2142,18 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (when (article-goto-body) (let ((inhibit-read-only t)) (dolist (elem map) - (save-excursion - (while (search-forward (car elem) nil t) - (replace-match (cadr elem))))))))) + (let ((from (car elem)) + (to (cadr elem))) + (save-excursion + (if (stringp from) + (while (search-forward from nil t) + (replace-match to)) + (while (not (eobp)) + (if (eq (following-char) from) + (progn + (delete-char 1) + (insert to)) + (forward-char 1))))))))))) (defun article-treat-overstrike () "Translate overstrikes into bold text." @@ -2224,8 +2243,23 @@ unfolded." "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)))))) + +(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) + (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. @@ -2679,118 +2713,16 @@ If READ-CHARSET, ask for a coding system." (when (interactive-p) (gnus-treat-article nil)))) - -(defun article-wash-html (&optional read-charset) - "Format an HTML article. -If READ-CHARSET, ask for a coding system. If it is a number, the -charset defined in `gnus-summary-show-article-charset-alist' is used." - (interactive "P") - (save-excursion - (let ((inhibit-read-only t) - charset) - (if read-charset - (if (or (and (numberp read-charset) - (setq charset - (cdr - (assq read-charset - gnus-summary-show-article-charset-alist)))) - (setq charset (mm-read-coding-system "Charset: "))) - (let ((gnus-summary-show-article-charset-alist - (list (cons 1 charset)))) - (with-current-buffer gnus-summary-buffer - (gnus-summary-show-article 1))) - (error "No charset is given")) - (when (gnus-buffer-live-p gnus-original-article-buffer) - (with-current-buffer gnus-original-article-buffer - (let* ((ct (gnus-fetch-field "content-type")) - (ctl (and ct (mail-header-parse-content-type ct)))) - (setq charset (and ctl - (mail-content-type-get ctl 'charset))) - (when (stringp charset) - (setq charset (intern (downcase charset))))))) - (unless charset - (setq charset gnus-newsgroup-charset))) - (article-goto-body) - (save-window-excursion - (save-restriction - (narrow-to-region (point) (point-max)) - (let* ((func (or gnus-article-wash-function mm-text-html-renderer)) - (entry (assq func mm-text-html-washer-alist))) - (when entry - (setq func (cdr entry))) - (cond - ((functionp func) - (funcall func)) - (t - (apply (car func) (cdr func)))))))))) - -;; External. -(declare-function w3-region "ext:w3-display" (st nd)) - -(defun gnus-article-wash-html-with-w3 () - "Wash the current buffer with w3." - (mm-setup-w3) - (let ((w3-strict-width (window-width)) - (url-standalone-mode t) - (url-gateway-unplugged t) - (w3-honor-stylesheets nil)) - (condition-case () - (w3-region (point-min) (point-max)) - (error)))) - -;; External. -(declare-function w3m-region "ext:w3m" (start end &optional url charset)) - -(defun gnus-article-wash-html-with-w3m () - "Wash the current buffer with emacs-w3m." - (mm-setup-w3m) - (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) - w3m-force-redisplay) - (w3m-region (point-min) (point-max))) - ;; Put the mark meaning this part was rendered by emacs-w3m. - (put-text-property (point-min) (point-max) 'mm-inline-text-html-with-w3m t) - (when (and mm-inline-text-html-with-w3m-keymap - (boundp 'w3m-minor-mode-map) - w3m-minor-mode-map) - (if (and (boundp 'w3m-link-map) - w3m-link-map) - (let* ((start (point-min)) - (end (point-max)) - (on (get-text-property start 'w3m-href-anchor)) - (map (copy-keymap w3m-link-map)) - next) - (set-keymap-parent map w3m-minor-mode-map) - (while (< start end) - (if on - (progn - (setq next (or (text-property-any start end - 'w3m-href-anchor nil) - end)) - (put-text-property start next 'keymap map)) - (setq next (or (text-property-not-all start end - 'w3m-href-anchor nil) - end)) - (put-text-property start next 'keymap w3m-minor-mode-map)) - (setq start next - on (not on)))) - (put-text-property (point-min) (point-max) 'keymap w3m-minor-mode-map)))) - -(defvar charset) ;; Bound by `article-wash-html'. - -(defun gnus-article-wash-html-with-w3m-standalone () - "Wash the current buffer with w3m." - (if (mm-w3m-standalone-supports-m17n-p) - (progn - (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'. - ;; The default. - (setq charset 'iso-8859-1)) - (let ((coding-system-for-write charset) - (coding-system-for-read charset)) - (call-process-region - (point-min) (point-max) - "w3m" t t nil "-dump" "-T" "text/html" - "-I" (symbol-name charset) "-O" (symbol-name charset)))) - (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html"))) +(defun article-wash-html () + "Format an HTML article." + (interactive) + (let ((handles nil) + (buffer-read-only nil)) + (when (gnus-buffer-live-p gnus-original-article-buffer) + (setq handles (mm-dissect-buffer t t))) + (article-goto-body) + (delete-region (point) (point-max)) + (mm-inline-text-html handles))) (defvar gnus-article-browse-html-temp-list nil "List of temporary files created by `gnus-article-browse-html-parts'. @@ -3460,84 +3392,75 @@ lines forward." (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 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)) - (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))) - (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)))))) + (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))) + (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))))))) + +(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))) @@ -3565,7 +3488,7 @@ should replace the \"Date:\" one, or should be added below it." (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) @@ -3583,49 +3506,25 @@ should replace the \"Date:\" one, or should be added below it." (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 + (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))) @@ -3647,9 +3546,56 @@ should replace the \"Date:\" one, or should be added below it." (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)) @@ -3672,26 +3618,54 @@ function and want to see what the date was before converting." (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") @@ -3702,7 +3676,7 @@ is to run." (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) @@ -4327,14 +4301,17 @@ If variable `gnus-use-long-file-name' is non-nil, it is 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) ))) @@ -4387,7 +4364,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is (defun gnus-article-make-menu-bar () (unless (boundp 'gnus-article-commands-menu) (gnus-summary-make-menu-bar)) - (gnus-turn-off-edit-menu 'article) (unless (boundp 'gnus-article-article-menu) (easy-menu-define gnus-article-article-menu gnus-article-mode-map "" @@ -4453,7 +4429,6 @@ commands: (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) @@ -4468,7 +4443,6 @@ commands: ;; face. (set (make-local-variable 'nobreak-char-display) nil) (setq cursor-in-non-selected-windows nil) - (setq truncate-lines gnus-article-truncate-lines) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t @@ -4477,10 +4451,6 @@ commands: (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*" @@ -4524,17 +4494,24 @@ Internal variable.") (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) (current-buffer)) (with-current-buffer (gnus-get-buffer-create name) (gnus-article-mode) + (setq truncate-lines gnus-article-truncate-lines) (make-local-variable 'gnus-summary-buffer) (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)) + (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))))) ;; Set article window start at LINE, where LINE is the number of lines @@ -4898,11 +4875,15 @@ General format specifiers can also be used. See Info node (defun gnus-article-jump-to-part (n) "Jump to MIME part N." (interactive "P") - (pop-to-buffer gnus-article-buffer) - ;; FIXME: why is it necessary? - (sit-for 0) - (let ((parts (length gnus-article-mime-handle-alist))) - (or n (setq n (read-number (format "Jump to part (2..%s): " parts)))) + (let ((parts (with-current-buffer gnus-article-buffer + (length gnus-article-mime-handle-alist)))) + (when (zerop parts) + (error "No such part")) + (pop-to-buffer gnus-article-buffer) + (or n + (setq n (if (= parts 1) + 1 + (read-number (format "Jump to part (1..%s): " parts))))) (unless (and (integerp n) (<= n parts) (>= n 1)) (setq n (progn @@ -5133,7 +5114,9 @@ available media-types." (let ((default (gnus-mime-view-part-as-type-internal))) (gnus-completing-read "View as MIME type" - (gnus-remove-if-not pred (mailcap-mime-types)) + (if pred + (gnus-remove-if-not pred (mailcap-mime-types)) + (mailcap-mime-types)) nil nil nil (car default))))) (gnus-article-check-buffer) @@ -5200,7 +5183,7 @@ are decompressed." (if (or coding-system (and charset (setq coding-system (mm-charset-to-coding-system charset)) - (not (eq charset 'ascii)))) + (not (eq coding-system 'ascii)))) (progn (mm-enable-multibyte) (insert (mm-decode-coding-string contents coding-system)) @@ -5287,15 +5270,7 @@ Compressed files like .gz and .bz2 are decompressed." (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) @@ -5373,11 +5348,9 @@ specified charset." (mm-enable-external t)) (if (not (stringp method)) (gnus-mime-view-part-as-type - nil (lambda (types) (stringp (mailcap-mime-info (car types))))) + nil (lambda (type) (stringp (mailcap-mime-info type)))) (when handle - (if (mm-handle-undisplayer handle) - (mm-remove-part handle) - (mm-display-part handle)))))) + (mm-display-part handle nil t))))) (defun gnus-mime-view-part-internally (&optional handle) "View the MIME part under point with an internal viewer. @@ -5394,11 +5367,9 @@ If no internal viewer is available, use an external viewer." (inhibit-read-only t)) (if (not (mm-inlinable-p handle)) (gnus-mime-view-part-as-type - nil (lambda (types) (mm-inlinable-p handle (car types)))) + nil (lambda (type) (mm-inlinable-p handle type))) (when handle - (if (mm-handle-undisplayer handle) - (mm-remove-part handle) - (gnus-bind-safe-url-regexp (mm-display-part handle))))))) + (gnus-bind-safe-url-regexp (mm-display-part handle)))))) (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at \(point\)." @@ -5461,6 +5432,10 @@ If INTERACTIVE, call FUNCTION interactivly." (when (gnus-article-goto-part n) ;; We point the cursor and the arrow at the MIME button ;; when the `function' prompt the user for something. + (unless (and (pos-visible-in-window-p) + (> (count-lines (point) (window-end)) + (/ (1- (window-height)) 3))) + (recenter (/ (1- (window-height)) 3))) (let ((cursor-in-non-selected-windows t) (overlay-arrow-string "=>") (overlay-arrow-position (point-marker))) @@ -5472,11 +5447,10 @@ If INTERACTIVE, call FUNCTION interactivly." (funcall function)) (interactive (call-interactively - function - (cdr (assq n gnus-article-mime-handle-alist)))) + function (get-text-property (point) 'gnus-data))) (t (funcall function - (cdr (assq n gnus-article-mime-handle-alist))))) + (get-text-property (point) 'gnus-data)))) (set-marker overlay-arrow-position nil) (unless gnus-auto-select-part (gnus-select-frame-set-input-focus frame) @@ -5641,7 +5615,41 @@ all parts." (defun gnus-article-goto-part (n) "Go to MIME part N." - (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n))) + (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 @@ -5750,7 +5758,7 @@ all parts." (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. @@ -5850,7 +5858,12 @@ If displaying \"text/html\" is discouraged \(see (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)) @@ -5901,18 +5914,7 @@ If displaying \"text/html\" is discouraged \(see (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 @@ -6038,7 +6040,7 @@ If displaying \"text/html\" is discouraged \(see (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 @@ -6283,7 +6285,7 @@ Argument LINES specifies lines to be scrolled up." (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 @@ -6447,6 +6449,8 @@ not have a face in `gnus-article-boring-faces'." (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) @@ -6475,8 +6479,11 @@ not have a face in `gnus-article-boring-faces'." (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 @@ -6879,6 +6886,18 @@ If given a prefix, show the hidden text instead." (point)) (set-buffer buf)))))) +(defun gnus-block-private-groups (group) + (if (gnus-news-group-p group) + ;; Block nothing in news groups. + nil + ;; Block everything anywhere else. + ".")) + +(defun gnus-blocked-images () + (if (functionp gnus-blocked-images) + (funcall gnus-blocked-images gnus-newsgroup-name) + gnus-blocked-images)) + ;;; ;;; Article editing ;;; @@ -7323,9 +7342,6 @@ as a symbol to FUN." (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|?\\)") -;; 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 @@ -7471,17 +7487,17 @@ positives are possible." ;; 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). @@ -7496,11 +7512,11 @@ positives are possible." 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\\|?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + ("\\b\\(C-h\\|?\\)[ \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\\|?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + ("\\b\\(C-h\\|?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2) ("`\\(\\(C-h\\|?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'" ;; Unlike the other regexps we really have to require quoting @@ -7639,7 +7655,7 @@ do the highlighting. See the documentation for those functions." (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) @@ -7707,28 +7723,16 @@ It does this by highlighting everything after "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)) @@ -7739,18 +7743,16 @@ specified by `gnus-button-alist'." (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 @@ -7897,41 +7899,38 @@ url is put as the `gnus-button-url' overlay property on the button." (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) @@ -8042,7 +8041,7 @@ url is put as the `gnus-button-url' overlay property on the button." (if (string-match (concat "\\b\\(C-h\\|?\\)[ \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) @@ -8052,7 +8051,7 @@ url is put as the `gnus-button-url' overlay property on the button." (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)) @@ -8068,6 +8067,7 @@ url is put as the `gnus-button-url' overlay property on the button." (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)) @@ -8128,6 +8128,7 @@ url is put as the `gnus-button-url' overlay property on the button." (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) @@ -8137,8 +8138,7 @@ url is put as the `gnus-button-url' overlay property on the button." (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 @@ -8171,9 +8171,6 @@ url is put as the `gnus-button-url' overlay property on the button." (defvar gnus-next-page-map (let ((map (make-sparse-keymap))) - (unless (>= emacs-major-version 21) - ;; XEmacs doesn't care. - (set-keymap-parent map gnus-article-mode-map)) (define-key map gnus-mouse-2 'gnus-button-next-page) (define-key map "\r" 'gnus-button-next-page) map)) @@ -8292,16 +8289,19 @@ For example: ;;; 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) @@ -8314,6 +8314,8 @@ For example: (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)) @@ -8323,16 +8325,16 @@ For example: ;; 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) @@ -8348,7 +8350,7 @@ For example: ((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) @@ -8360,7 +8362,7 @@ For example: ((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))))