scratch/lexical-gnus e1e9e4e 2/6: * lisp/gnus/gnus-art.el: Add `event` args and operate at its position.

[Stefan Monnier]

branch: scratch/lexical-gnus
commit e1e9e4eefa41bacb6b412e57a569440a0847e4fa
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * lisp/gnus/gnus-art.el: Add `event` args and operate at its position.
    
    (gnus-mime-save-part-and-strip)
    (gnus-mime-delete-part, gnus-mime-save-part, gnus-mime-pipe-part)
    (gnus-mime-view-part, gnus-mime-view-part-as-type)
    (gnus-mime-copy-part, gnus-mime-print-part, gnus-mime-inline-part)
    (gnus-mime-view-part-as-charset, gnus-mime-view-part-externally)
    (gnus-mime-view-part-internally, gnus-article-press-button):
    Add `event` arg and operate at its position.
---
 lisp/gnus/gnus-art.el | 367 ++++++++++++++++++++++++++------------------------
 1 file changed, 194 insertions(+), 173 deletions(-)

diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 588e753..6a66dc6 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -2707,7 +2707,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))))
@@ -5074,50 +5074,53 @@ and `gnus-mime-delete-part', and not provided at 
run-time normally."
           file))
   (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)
-  (gnus-article-check-buffer)
-  (when (gnus-group-read-only-p)
-    (error "The current group does not support deleting of parts"))
-  (when (mm-complicated-handles gnus-article-mime-handles)
-    (error "\
+  (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"))
+    (when (mm-complicated-handles gnus-article-mime-handles)
+      (error "\
 The current article has a complicated MIME structure, giving up..."))
-  (let* ((data (get-text-property (point) 'gnus-data))
-        (id (get-text-property (point) 'gnus-part))
-        (handles gnus-article-mime-handles))
-    (unless file
-      (setq file
-           (and data (mm-save-part data "Delete MIME part and save to: "))))
-    (when file
-      (with-current-buffer (mm-handle-buffer data)
-       (erase-buffer)
-       (insert "Content-Type: " (mm-handle-media-type data))
-       (mml-insert-parameter-string (cdr (mm-handle-type data))
-                                    '(charset))
-       ;; Add a filename for the sake of saving the part again.
-       (mml-insert-parameter
-        (mail-header-encode-parameter "name" (file-name-nondirectory file)))
-       (insert "\n")
-       (insert "Content-ID: " (message-make-message-id) "\n")
-       (insert "Content-Transfer-Encoding: binary\n")
-       (insert "\n"))
-      (setcdr data
-             (cdr (mm-make-handle nil
-                                  `("message/external-body"
-                                    (access-type . "LOCAL-FILE")
-                                    (name . ,file)))))
-      ;; (set-buffer gnus-summary-buffer)
-      (gnus-article-edit-part handles id))))
+    (let* ((data (get-text-property (point) 'gnus-data))
+          (id (get-text-property (point) 'gnus-part))
+          (handles gnus-article-mime-handles))
+      (unless file
+       (setq file
+             (and data (mm-save-part data "Delete MIME part and save to: "))))
+      (when file
+       (with-current-buffer (mm-handle-buffer data)
+         (erase-buffer)
+         (insert "Content-Type: " (mm-handle-media-type data))
+         (mml-insert-parameter-string (cdr (mm-handle-type data))
+                                      '(charset))
+         ;; Add a filename for the sake of saving the part again.
+         (mml-insert-parameter
+          (mail-header-encode-parameter "name" (file-name-nondirectory file)))
+         (insert "\n")
+         (insert "Content-ID: " (message-make-message-id) "\n")
+         (insert "Content-Transfer-Encoding: binary\n")
+         (insert "\n"))
+       (setcdr data
+               (cdr (mm-make-handle nil
+                                    `("message/external-body"
+                                      (access-type . "LOCAL-FILE")
+                                      (name . ,file)))))
+       ;; (set-buffer gnus-summary-buffer)
+       (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"))
@@ -5163,33 +5166,37 @@ 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)
+(defun gnus-mime-pipe-part (&optional cmd event)
   "Pipe the MIME part under point to a process.
 Use CMD as the process."
-  (interactive)
+  (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)
@@ -5206,48 +5213,51 @@ 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)
-  (unless mime-type
-    (setq mime-type
-         (let ((default (gnus-mime-view-part-as-type-internal)))
-           (gnus-completing-read
-            "View as MIME type"
-            (if pred
-                (seq-filter pred (mailcap-mime-types))
-              (mailcap-mime-types))
-            nil nil nil
-            (car default)))))
-  (gnus-article-check-buffer)
-  (let ((handle (get-text-property (point) 'gnus-data)))
-    (when handle
-      (when (equal (mm-handle-media-type handle) "message/external-body")
-       (unless (mm-handle-cache handle)
-         (mm-extern-cache-contents handle))
-       (setq handle (mm-handle-cache handle)))
-      (setq handle
-           (mm-make-handle (mm-handle-buffer handle)
-                           (cons mime-type (cdr (mm-handle-type handle)))
-                           (mm-handle-encoding handle)
-                           (mm-handle-undisplayer handle)
-                           (mm-handle-disposition handle)
-                           (mm-handle-description handle)
-                           nil
-                           (mm-handle-id handle)))
-      (setq gnus-article-mime-handles
-           (mm-merge-handles gnus-article-mime-handles handle))
-      (when (mm-handle-displayed-p handle)
-       (mm-remove-part handle))
-      (gnus-mm-display-part handle))))
-
-(defun gnus-mime-copy-part (&optional handle arg)
+  (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)))
+             (gnus-completing-read
+              "View as MIME type"
+              (if pred
+                  (seq-filter pred (mailcap-mime-types))
+                (mailcap-mime-types))
+              nil nil nil
+              (car default)))))
+    (gnus-article-check-buffer)
+    (let ((handle (get-text-property (point) 'gnus-data)))
+      (when handle
+       (when (equal (mm-handle-media-type handle) "message/external-body")
+         (unless (mm-handle-cache handle)
+           (mm-extern-cache-contents handle))
+         (setq handle (mm-handle-cache handle)))
+       (setq handle
+             (mm-make-handle (mm-handle-buffer handle)
+                             (cons mime-type (cdr (mm-handle-type handle)))
+                             (mm-handle-encoding handle)
+                             (mm-handle-undisplayer handle)
+                             (mm-handle-disposition handle)
+                             (mm-handle-description handle)
+                             nil
+                             (mm-handle-id handle)))
+       (setq gnus-article-mime-handles
+             (mm-merge-handles gnus-article-mime-handles handle))
+       (when (mm-handle-displayed-p handle)
+         (mm-remove-part handle))
+       (gnus-mm-display-part handle)))))
+
+(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)))
@@ -5299,15 +5309,18 @@ 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)))
-  (gnus-article-check-buffer)
-  (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
-        (contents (and handle (mm-get-part handle)))
-        (file (make-temp-file (expand-file-name "mm." mm-tmp-directory)))
-        (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
-    (when contents
+  (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)))
+          (file (make-temp-file (expand-file-name "mm." mm-tmp-directory)))
+          (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
+      (when contents
        (if printer
            (unwind-protect
                (progn
@@ -5322,12 +5335,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))
@@ -5421,82 +5435,88 @@ 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))
-  (gnus-article-check-buffer)
-  (let ((handle (or handle (get-text-property (point) 'gnus-data)))
-       (fun (get-text-property (point) 'gnus-callback))
-       (gnus-newsgroup-ignored-charsets 'gnus-all)
-       charset form preferred parts)
-    (when handle
-      (when (prog1
-               (and fun
-                    (setq charset
-                          (or (cdr (assq
-                                    arg
-                                    gnus-summary-show-article-charset-alist))
-                              (read-coding-system "Charset: "))))
-             (if (mm-handle-undisplayer handle)
-                 (mm-remove-part handle)))
-       (gnus-mime-set-charset-parameters handle charset)
-       (when (and (consp (setq form (cdr-safe fun)))
-                  (setq form (ignore-errors
-                               (assq 'gnus-mime-display-alternative form)))
-                  (setq preferred (caddr form))
-                  (progn
-                    (when (eq (car preferred) 'quote)
-                      (setq preferred (cadr preferred)))
-                    (not (equal preferred
-                                (get-text-property (point) 'gnus-data))))
-                  (setq parts (get-text-property (point) 'gnus-part))
-                  (setq parts (cdr (assq parts
-                                         gnus-article-mime-handle-alist)))
-                  (equal (mm-handle-media-type parts) "multipart/alternative")
-                  (setq parts (reverse (cdr parts))))
-         (setcar (cddr form)
-                 (list 'quote (or (cadr (member preferred parts))
-                                  (car parts)))))
-       (funcall fun handle)))))
-
-(defun gnus-mime-view-part-externally (&optional handle)
-  "View the MIME part under point with an external viewer."
-  (interactive)
-  (gnus-article-check-buffer)
-  (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
-        (mm-inlined-types nil)
-        (mail-parse-charset gnus-newsgroup-charset)
-        (mail-parse-ignored-charsets
-          (with-current-buffer gnus-summary-buffer
-            gnus-newsgroup-ignored-charsets))
-         (type (mm-handle-media-type handle))
-         (method (mailcap-mime-info type))
-         (mm-enable-external t))
-    (if (not (stringp method))
-       (gnus-mime-view-part-as-type
-        nil (lambda (type) (stringp (mailcap-mime-info type))))
+  (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))
+         (gnus-newsgroup-ignored-charsets 'gnus-all)
+         charset form preferred parts)
       (when handle
-       (mm-display-part handle nil t)))))
-
-(defun gnus-mime-view-part-internally (&optional handle)
+       (when (prog1
+                 (and fun
+                      (setq charset
+                            (or (cdr (assq
+                                      arg
+                                      gnus-summary-show-article-charset-alist))
+                                (read-coding-system "Charset: "))))
+               (if (mm-handle-undisplayer handle)
+                   (mm-remove-part handle)))
+         (gnus-mime-set-charset-parameters handle charset)
+         (when (and (consp (setq form (cdr-safe fun)))
+                    (setq form (ignore-errors
+                                 (assq 'gnus-mime-display-alternative form)))
+                    (setq preferred (caddr form))
+                    (progn
+                      (when (eq (car preferred) 'quote)
+                        (setq preferred (cadr preferred)))
+                      (not (equal preferred
+                                  (get-text-property (point) 'gnus-data))))
+                    (setq parts (get-text-property (point) 'gnus-part))
+                    (setq parts (cdr (assq parts
+                                           gnus-article-mime-handle-alist)))
+                    (equal (mm-handle-media-type parts) 
"multipart/alternative")
+                    (setq parts (reverse (cdr parts))))
+           (setcar (cddr form)
+                   (list 'quote (or (cadr (member preferred parts))
+                                    (car parts)))))
+         (funcall fun handle))))))
+
+(defun gnus-mime-view-part-externally (&optional handle event)
+  "View the MIME part under point with an external viewer."
+  (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)
+          (mail-parse-charset gnus-newsgroup-charset)
+          (mail-parse-ignored-charsets
+            (with-current-buffer gnus-summary-buffer
+              gnus-newsgroup-ignored-charsets))
+           (type (mm-handle-media-type handle))
+           (method (mailcap-mime-info type))
+           (mm-enable-external t))
+      (if (not (stringp method))
+         (gnus-mime-view-part-as-type
+          nil (lambda (type) (stringp (mailcap-mime-info type))))
+       (when handle
+         (mm-display-part handle nil t))))))
+
+(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)
-  (gnus-article-check-buffer)
-  (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
-        (mm-inlined-types '(".*"))
-        (mm-inline-large-images t)
-        (mail-parse-charset gnus-newsgroup-charset)
-        (mail-parse-ignored-charsets
-         (with-current-buffer gnus-summary-buffer
-           gnus-newsgroup-ignored-charsets))
-        (inhibit-read-only t))
-    (if (not (mm-inlinable-p handle))
-        (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))))))
+  (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 '(".*"))
+          (mm-inline-large-images t)
+          (mail-parse-charset gnus-newsgroup-charset)
+          (mail-parse-ignored-charsets
+           (with-current-buffer gnus-summary-buffer
+             gnus-newsgroup-ignored-charsets))
+          (inhibit-read-only t))
+      (if (not (mm-inlinable-p handle))
+          (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)))))))
 
 (defun gnus-mime-action-on-part (&optional action)
   "Do something with the MIME attachment at (point)."
@@ -7866,15 +7886,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.