diff options
Diffstat (limited to 'lisp/gnus/gnus-art.el')
| -rw-r--r-- | lisp/gnus/gnus-art.el | 284 |
1 files changed, 144 insertions, 140 deletions
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index d826faca5bd..6b5a21eaf55 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -1615,7 +1615,7 @@ It is a string, such as \"PGP\". If nil, ask user." :group 'gnus-article :type 'boolean) -(defcustom gnus-blocked-images 'gnus-block-private-groups +(defcustom gnus-blocked-images #'gnus-block-private-groups "Images that have URLs matching this regexp will be blocked. Note that the main reason external images are included in HTML emails (these days) is to allow tracking whether you've read the @@ -2693,7 +2693,7 @@ If READ-CHARSET, ask for a coding system." "Format an HTML article." (interactive) (let ((handles nil) - (buffer-read-only nil)) + (inhibit-read-only t)) (when (gnus-buffer-live-p gnus-original-article-buffer) (with-current-buffer gnus-original-article-buffer (setq handles (mm-dissect-buffer t t)))) @@ -4302,71 +4302,67 @@ If variable `gnus-use-long-file-name' is non-nil, it is (canlock-verify gnus-original-article-buffer))) (eval-and-compile - (mapc - (lambda (func) - (let (afunc gfunc) - (if (consp func) - (setq afunc (car func) - gfunc (cdr func)) - (setq afunc func - gfunc (intern (format "gnus-%s" func)))) - (defalias gfunc - (when (fboundp afunc) - `(lambda (&optional interactive &rest args) - ,(documentation afunc t) - (interactive (list t)) - (with-current-buffer gnus-article-buffer - (if interactive - (call-interactively ',afunc) - (apply #',afunc args)))))))) - '(article-hide-headers - article-verify-x-pgp-sig - article-verify-cancel-lock - article-hide-boring-headers - article-treat-overstrike - article-treat-ansi-sequences - article-fill-long-lines - article-capitalize-sentences - article-remove-cr - article-remove-leading-whitespace - article-display-x-face - article-display-face - article-de-quoted-unreadable - article-de-base64-unreadable - article-decode-HZ - article-wash-html - article-unsplit-urls - article-hide-list-identifiers - article-strip-banner - article-babel - article-hide-pem - article-hide-signature - article-strip-headers-in-body - article-remove-trailing-blank-lines - article-strip-leading-blank-lines - article-strip-multiple-blank-lines - article-strip-leading-space - article-strip-trailing-space - article-strip-blank-lines - article-strip-all-blank-lines - article-date-local - 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) - ))) + (defmacro gnus-art-defun (gnus-fun &optional article-fun) + "Define GNUS-FUN as a function that runs ARTICLE-FUN in the article buffer." + (unless article-fun + (if (not (string-match "\\`gnus-" (symbol-name gnus-fun))) + (error "Can't guess article-fun argument") + (setq article-fun (intern (substring (symbol-name gnus-fun) + (match-end 0)))))) + `(defun ,gnus-fun (&optional interactive &rest args) + ,(format "Run `%s' in the article buffer." article-fun) + (interactive (list t)) + (with-current-buffer gnus-article-buffer + (if interactive + (call-interactively ',article-fun) + (apply #',article-fun args)))))) +(gnus-art-defun gnus-article-hide-headers) +(gnus-art-defun gnus-article-verify-x-pgp-sig) +(gnus-art-defun gnus-article-verify-cancel-lock) +(gnus-art-defun gnus-article-hide-boring-headers) +(gnus-art-defun gnus-article-treat-overstrike) +(gnus-art-defun gnus-article-treat-ansi-sequences) +(gnus-art-defun gnus-article-fill-long-lines) +(gnus-art-defun gnus-article-capitalize-sentences) +(gnus-art-defun gnus-article-remove-cr) +(gnus-art-defun gnus-article-remove-leading-whitespace) +(gnus-art-defun gnus-article-display-x-face) +(gnus-art-defun gnus-article-display-face) +(gnus-art-defun gnus-article-de-quoted-unreadable) +(gnus-art-defun gnus-article-de-base64-unreadable) +(gnus-art-defun gnus-article-decode-HZ) +(gnus-art-defun gnus-article-wash-html) +(gnus-art-defun gnus-article-unsplit-urls) +(gnus-art-defun gnus-article-hide-list-identifiers) +(gnus-art-defun gnus-article-strip-banner) +(gnus-art-defun gnus-article-babel) +(gnus-art-defun gnus-article-hide-pem) +(gnus-art-defun gnus-article-hide-signature) +(gnus-art-defun gnus-article-strip-headers-in-body) +(gnus-art-defun gnus-article-remove-trailing-blank-lines) +(gnus-art-defun gnus-article-strip-leading-blank-lines) +(gnus-art-defun gnus-article-strip-multiple-blank-lines) +(gnus-art-defun gnus-article-strip-leading-space) +(gnus-art-defun gnus-article-strip-trailing-space) +(gnus-art-defun gnus-article-strip-blank-lines) +(gnus-art-defun gnus-article-strip-all-blank-lines) +(gnus-art-defun gnus-article-date-local) +(gnus-art-defun gnus-article-date-english) +(gnus-art-defun gnus-article-date-iso8601) +(gnus-art-defun gnus-article-date-original) +(gnus-art-defun gnus-article-treat-date) +(gnus-art-defun gnus-article-date-ut) +(gnus-art-defun gnus-article-decode-mime-words) +(gnus-art-defun gnus-article-decode-charset) +(gnus-art-defun gnus-article-decode-encoded-words) +(gnus-art-defun gnus-article-date-user) +(gnus-art-defun gnus-article-date-lapsed) +(gnus-art-defun gnus-article-date-combined-lapsed) +(gnus-art-defun gnus-article-emphasize) +(gnus-art-defun gnus-article-treat-dumbquotes) +(gnus-art-defun gnus-article-treat-non-ascii) +(gnus-art-defun gnus-article-normalize-headers) +;;(gnus-art-defun gnus-article-show-all-headers article-show-all) ;;; ;;; Gnus article mode @@ -4869,17 +4865,18 @@ General format specifiers can also be used. See Info node (defvar gnus-mime-button-map (let ((map (make-sparse-keymap))) (define-key map [mouse-2] 'gnus-article-push-button) - (define-key map [down-mouse-3] 'gnus-mime-button-menu) (dolist (c gnus-mime-button-commands) (define-key map (cadr c) (car c))) - map)) -(easy-menu-define - gnus-mime-button-menu gnus-mime-button-map "MIME button menu." - `("MIME Part" - ,@(mapcar (lambda (c) - (vector (caddr c) (car c) :active t)) - gnus-mime-button-commands))) + (easy-menu-define gnus-mime-button-menu map "MIME button menu." + `("MIME Part" + ,@(mapcar (lambda (c) + (vector (caddr c) (car c) :active t)) + gnus-mime-button-commands))) + + (define-key map [down-mouse-3] + (easy-menu-binding gnus-mime-button-menu)) + map)) (defvar gnus-url-button-commands '((gnus-article-copy-string "u" "Copy URL to kill ring"))) @@ -4923,16 +4920,6 @@ General format specifiers can also be used. See Info node (setq mm-w3m-safe-url-regexp nil))) ,@body)) -(defun gnus-mime-button-menu (event prefix) - "Construct a context-sensitive menu of MIME commands." - (interactive "e\nP") - (save-window-excursion - (let ((pos (event-start event))) - (select-window (posn-window pos)) - (goto-char (posn-point pos)) - (gnus-article-check-buffer) - (popup-menu gnus-mime-button-menu nil prefix)))) - (defun gnus-mime-view-all-parts (&optional handles) "View all the MIME parts." (interactive) @@ -5055,10 +5042,12 @@ and `gnus-mime-delete-part', and not provided at run-time normally." nil nil))) (gnus-mime-save-part-and-strip file)) -(defun gnus-mime-save-part-and-strip (&optional file) +(defun gnus-mime-save-part-and-strip (&optional file event) "Save the MIME part under point then replace it with an external body. If FILE is given, use it for the external part." - (interactive) + (interactive (list nil last-nonmenu-event)) + (save-excursion + (mouse-set-point event) (gnus-article-check-buffer) (when (gnus-group-read-only-p) (error "The current group does not support deleting of parts")) @@ -5090,15 +5079,16 @@ The current article has a complicated MIME structure, giving up...")) (access-type . "LOCAL-FILE") (name . ,file))))) ;; (set-buffer gnus-summary-buffer) - (gnus-article-edit-part handles id)))) + (gnus-article-edit-part handles id))))) ;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all ;; parts...>') but with stripping would be nice. -(defun gnus-mime-delete-part () +(defun gnus-mime-delete-part (&optional event) "Delete the MIME part under point. Replace it with some information about the removed part." - (interactive) + (interactive (list last-nonmenu-event)) + (mouse-set-point event) (gnus-article-check-buffer) (when (gnus-group-read-only-p) (error "The current group does not support deleting of parts")) @@ -5144,33 +5134,36 @@ Deleting parts may malfunction or destroy the article; continue? ")) ;; (set-buffer gnus-summary-buffer) (gnus-article-edit-part handles id)))) -(defun gnus-mime-save-part () +(defun gnus-mime-save-part (&optional event) "Save the MIME part under point." - (interactive) + (interactive (list last-nonmenu-event)) + (mouse-set-point event) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) (when data (mm-save-part data)))) -(defun gnus-mime-pipe-part (&optional cmd) - "Pipe the MIME part under point to a process. -Use CMD as the process." - (interactive) +(defun gnus-mime-pipe-part (&optional cmd event) + "Pipe the MIME part under point to a process." + (interactive (list nil last-nonmenu-event)) + (mouse-set-point event) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) (when data (mm-pipe-part data cmd)))) -(defun gnus-mime-view-part () +(defun gnus-mime-view-part (&optional event) "Interactively choose a viewing method for the MIME part under point." - (interactive) - (gnus-article-check-buffer) - (let ((data (get-text-property (point) 'gnus-data))) - (when data - (setq gnus-article-mime-handles - (mm-merge-handles - gnus-article-mime-handles (setq data (copy-sequence data)))) - (mm-interactively-view-part data)))) + (interactive (list last-nonmenu-event)) + (save-excursion + (mouse-set-point event) + (gnus-article-check-buffer) + (let ((data (get-text-property (point) 'gnus-data))) + (when data + (setq gnus-article-mime-handles + (mm-merge-handles + gnus-article-mime-handles (setq data (copy-sequence data)))) + (mm-interactively-view-part data))))) (defun gnus-mime-view-part-as-type-internal () (gnus-article-check-buffer) @@ -5187,11 +5180,13 @@ Use CMD as the process." '("text/plain" . 0)) '("application/octet-stream" . 0)))) -(defun gnus-mime-view-part-as-type (&optional mime-type pred) +(defun gnus-mime-view-part-as-type (&optional mime-type pred event) "Choose a MIME media type, and view the part as such. If non-nil, PRED is a predicate to use during completion to limit the available media-types." - (interactive) + (interactive (list nil nil last-nonmenu-event)) + (save-excursion + (if event (mouse-set-point event)) (unless mime-type (setq mime-type (let ((default (gnus-mime-view-part-as-type-internal))) @@ -5222,13 +5217,14 @@ available media-types." (mm-merge-handles gnus-article-mime-handles handle)) (when (mm-handle-displayed-p handle) (mm-remove-part handle)) - (gnus-mm-display-part handle)))) + (gnus-mm-display-part handle))))) -(defun gnus-mime-copy-part (&optional handle arg) +(defun gnus-mime-copy-part (&optional handle arg event) "Put the MIME part under point into a new buffer. If `auto-compression-mode' is enabled, compressed files like .gz and .bz2 are decompressed." - (interactive (list nil current-prefix-arg)) + (interactive (list nil current-prefix-arg last-nonmenu-event)) + (mouse-set-point event) (gnus-article-check-buffer) (unless handle (setq handle (get-text-property (point) 'gnus-data))) @@ -5280,9 +5276,12 @@ are decompressed." (setq buffer-file-name nil)) (goto-char (point-min))))) -(defun gnus-mime-print-part (&optional handle filename) +(defun gnus-mime-print-part (&optional handle filename event) "Print the MIME part under point." - (interactive (list nil (ps-print-preprint current-prefix-arg))) + (interactive + (list nil (ps-print-preprint current-prefix-arg) last-nonmenu-event)) + (save-excursion + (mouse-set-point event) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (contents (and handle (mm-get-part handle))) @@ -5303,12 +5302,13 @@ are decompressed." (with-temp-buffer (insert contents) (gnus-print-buffer)) - (ps-despool filename))))) + (ps-despool filename)))))) -(defun gnus-mime-inline-part (&optional handle arg) +(defun gnus-mime-inline-part (&optional handle arg event) "Insert the MIME part under point into the current buffer. Compressed files like .gz and .bz2 are decompressed." - (interactive (list nil current-prefix-arg)) + (interactive (list nil current-prefix-arg last-nonmenu-event)) + (if event (mouse-set-point event)) (gnus-article-check-buffer) (let* ((inhibit-read-only t) (b (point)) @@ -5402,10 +5402,12 @@ CHARSET may either be a string or a symbol." (setcdr param charset) (setcdr type (cons (cons 'charset charset) (cdr type))))))) -(defun gnus-mime-view-part-as-charset (&optional handle arg) +(defun gnus-mime-view-part-as-charset (&optional handle arg event) "Insert the MIME part under point into the current buffer using the specified charset." - (interactive (list nil current-prefix-arg)) + (interactive (list nil current-prefix-arg last-nonmenu-event)) + (save-excursion + (mouse-set-point event) (gnus-article-check-buffer) (let ((handle (or handle (get-text-property (point) 'gnus-data))) (fun (get-text-property (point) 'gnus-callback)) @@ -5439,11 +5441,13 @@ specified charset." (setcar (cddr form) (list 'quote (or (cadr (member preferred parts)) (car parts))))) - (funcall fun handle))))) + (funcall fun handle)))))) -(defun gnus-mime-view-part-externally (&optional handle) +(defun gnus-mime-view-part-externally (&optional handle event) "View the MIME part under point with an external viewer." - (interactive) + (interactive (list nil last-nonmenu-event)) + (save-excursion + (mouse-set-point event) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (mm-inlined-types nil) @@ -5458,12 +5462,14 @@ specified charset." (gnus-mime-view-part-as-type nil (lambda (type) (stringp (mailcap-mime-info type)))) (when handle - (mm-display-part handle nil t))))) + (mm-display-part handle nil t)))))) -(defun gnus-mime-view-part-internally (&optional handle) +(defun gnus-mime-view-part-internally (&optional handle event) "View the MIME part under point with an internal viewer. If no internal viewer is available, use an external viewer." - (interactive) + (interactive (list nil last-nonmenu-event)) + (save-excursion + (mouse-set-point event) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (mm-inlined-types '(".*")) @@ -5477,7 +5483,7 @@ If no internal viewer is available, use an external viewer." (gnus-mime-view-part-as-type nil (lambda (type) (mm-inlinable-p handle type))) (when handle - (gnus-bind-mm-vars (mm-display-part handle nil t)))))) + (gnus-bind-mm-vars (mm-display-part handle nil t))))))) (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at (point)." @@ -5849,7 +5855,7 @@ all parts." (widget-convert-button 'link b e :mime-handle handle - :action 'gnus-widget-press-button + :action #'gnus-widget-press-button :button-keymap gnus-mime-button-map :help-echo (lambda (widget) @@ -6148,7 +6154,7 @@ If nil, don't show those extra buttons." article-type multipart rear-nonsticky t)) (widget-convert-button 'link from (point) - :action 'gnus-widget-press-button) + :action #'gnus-widget-press-button) ;; Do the handles (while (setq handle (pop handles)) (add-text-properties @@ -6172,7 +6178,7 @@ If nil, don't show those extra buttons." gnus-data ,handle rear-nonsticky t)) (widget-convert-button 'link from (point) - :action 'gnus-widget-press-button) + :action #'gnus-widget-press-button) (insert " ")) (insert "\n\n")) (when preferred @@ -7115,13 +7121,11 @@ If given a prefix, show the hidden text instead." (when (and do-update-line (or (numberp article) (stringp article))) - (let ((buf (current-buffer))) - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-summary-update-article do-update-line sparse-header) (gnus-summary-goto-subject do-update-line nil t) (set-window-point (gnus-get-buffer-window (current-buffer) t) - (point)) - (set-buffer buf)))))) + (point))))))) (defun gnus-block-private-groups (group) "Allows images in newsgroups to be shown, blocks images in all @@ -7316,8 +7320,7 @@ groups." (gnus-article-mode) (set-window-configuration winconf) ;; Tippy-toe some to make sure that point remains where it was. - (save-current-buffer - (set-buffer curbuf) + (with-current-buffer curbuf (set-window-start (get-buffer-window (current-buffer)) window-start) (goto-char p)))) (gnus-summary-show-article))) @@ -7869,15 +7872,16 @@ call it with the value of the `gnus-data' text property." (when fun (funcall fun data)))) -(defun gnus-article-press-button () +(defun gnus-article-press-button (&optional event) "Check text at point for a callback function. If the text at point has a `gnus-callback' property, call it with the value of the `gnus-data' text property." - (interactive) - (let ((data (get-text-property (point) 'gnus-data)) - (fun (get-text-property (point) 'gnus-callback))) - (when fun - (funcall fun data)))) + (interactive (list last-nonmenu-event)) + (save-excursion + (mouse-set-point event) + (let ((fun (get-text-property (point) 'gnus-callback))) + (when fun + (funcall fun (get-text-property (point) 'gnus-data)))))) (defun gnus-article-highlight (&optional force) "Highlight current article. @@ -8095,7 +8099,7 @@ url is put as the `gnus-button-url' overlay property on the button." (list 'mouse-face gnus-article-mouse-face)) (list 'gnus-callback fun) (and data (list 'gnus-data data)))) - (widget-convert-button 'link from to :action 'gnus-widget-press-button + (widget-convert-button 'link from to :action #'gnus-widget-press-button :help-echo (or text "Follow the link") :keymap gnus-url-button-map)) |