;;; my-gnus.el -- Email related extensions for emacs core -*- lexical-binding: t -*- ;; Copyright (C) 2023 Free Software Foundation. ;; Author: Yuchen Pei ;; Package-Requires: ((emacs "28.2")) ;; This file is part of dotfiles. ;; dotfiles is free software: you can redistribute it and/or modify it under ;; the terms of the GNU Affero General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; dotfiles is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General ;; Public License for more details. ;; You should have received a copy of the GNU Affero General Public ;; License along with dotfiles. If not, see . ;;; Commentary: ;; Email related extensions for emacs core. Covers gnus, message mode etc. ;;; Code: ;;; `message-mode', the mode to compose messages (defun my-message-elide-remaining () "Elide all cited text after point." (interactive) (when-let* ((beg (point)) (citexp (concat "^\\(" (concat message-yank-cited-prefix "\\|") message-yank-prefix "\\)")) (end (save-excursion (goto-char (point-max)) (when (re-search-backward citexp nil t) (beginning-of-line 2) (point))))) (when (< beg end) (message-elide-region beg end)))) (defun my-message-remove-trailing-cited-lines () "Remove all trailing cited lines." (interactive) (save-excursion (when-let* ((citexp (concat "^\\(" (concat message-yank-cited-prefix "\\|") message-yank-prefix "\\)+ *\n")) (end (progn (goto-char (point-max)) (when (re-search-backward citexp nil t) (beginning-of-line 2) (point)))) (beg (progn (beginning-of-line 0) (while (looking-at-p citexp) (beginning-of-line 0)) (beginning-of-line 2) (point)))) (when (< beg end) (delete-region beg end))))) (defun my-message-before-previous-cited () "Move point to before previous cited portion." (interactive) (let ((citexp (concat "^\\(" (concat message-yank-cited-prefix "\\|") message-yank-prefix "\\)"))) (beginning-of-line 1) (unless (looking-at-p citexp) (re-search-backward citexp nil t)) (beginning-of-line 0) (while (looking-at-p citexp) (beginning-of-line 0)))) (defun my-message-after-next-cited () "Move point to after the next cited portion." (interactive) (let ((citexp (concat "^\\(" (concat message-yank-cited-prefix "\\|") message-yank-prefix "\\)"))) (beginning-of-line 1) (unless (looking-at-p citexp) (re-search-forward citexp nil t)) (beginning-of-line 2) (while (looking-at-p citexp) (beginning-of-line 2)))) (defun my-gnus-summary-exit-like-mu4e () (interactive) (if (get-buffer-window (gnus-buffer-live-p gnus-article-buffer)) (gnus-summary-expand-window) (gnus-summary-exit))) (defun my-gnus-summary-next-article-like-mu4e () (interactive) (if (get-buffer-window (gnus-buffer-live-p gnus-article-buffer)) (gnus-summary-next-article) (next-line))) (defun my-gnus-summary-prev-article-like-mu4e () (interactive) (if (get-buffer-window (gnus-buffer-live-p gnus-article-buffer)) (gnus-summary-prev-article) (previous-line))) (defun my-gnus-topic-select-group (arg) (interactive "P") (if arg (gnus-topic-select-group t) (gnus-topic-select-group 200))) (defun my-gnus-move-article-like-mu4e () (interactive) (call-interactively 'gnus-summary-move-article) (my-gnus-summary-next-article-like-mu4e)) (defvar my-gnus-group-default-targets '((archive . "Archive") (trash . "Trash"))) (defvar my-gnus-group-alist `((".*" . ,my-gnus-group-default-targets)) "Alist of information about groups such as archive and trash targets. Later entries override earlier ones") (defun my-gnus-refile-article-like-mu4e (key) "Refile an article and move to the next, just like in mu4e. The archiving target comes from `my-gnus-group-alist'. KEY is either 'archive or 'trash." (interactive) (let ((target (alist-get key my-gnus-group-default-targets)) (new-group-name)) (pcase-dolist (`(,re . ,info) my-gnus-group-alist) (when (and (string-match re gnus-newsgroup-name) (alist-get key info)) (setq target (alist-get key info)))) (setq new-group-name (replace-regexp-in-string "/.*" (concat "/" target) gnus-newsgroup-name)) (gnus-summary-move-article 1 new-group-name) (my-gnus-summary-next-article-like-mu4e))) (defun my-gnus-archive-article-like-mu4e () "Archive an article and move to the next, just like in mu4e. The archiving target comes from `my-gnus-group-alist'." (interactive) (my-gnus-refile-article-like-mu4e 'archive)) (defun my-gnus-trash-article-like-mu4e () (interactive) (my-gnus-refile-article-like-mu4e 'trash)) (defun my-org-open-gnus-link (link) (my-select-new-window-matching-mode 'gnus-summary-mode) (org-gnus-open link t)) (defvar my-gnus-inbox-group nil "The default inbox to be opened with `my-gnus-open-inbox'.") (defun my-gnus-open-inbox () (interactive) (gnus-group-read-group t nil my-gnus-inbox-group)) (defun my-gnus-start () (interactive) (let ((buffer (get-buffer "*Group*"))) (if buffer (switch-to-buffer "*Group*") (gnus)))) (defun my-gnus-topic-up () (interactive) (gnus-topic-jump-to-topic (gnus-current-topic))) (defun my-gnus-group-compose () (interactive) (gnus-group-mail '(4))) (defun my-gnus-group-get-new-news-quietly () (interactive) (let ((inhibit-message t)) (gnus-group-get-new-news))) ;; override `mm-display-external' ;; Removed the following nonsensical part ;; ;; So that we pop back to the right place, sort of. ;; (switch-to-buffer gnus-summary-buffer) (defun my-mm-display-external (handle method) "Display HANDLE using METHOD." (let ((outbuf (current-buffer))) (mm-with-unibyte-buffer (if (functionp method) (let ((cur (current-buffer))) (if (eq method 'mailcap-save-binary-file) (progn (set-buffer (generate-new-buffer " *mm*")) (setq method nil)) (mm-insert-part handle) (mm-add-meta-html-tag handle) (let ((win (get-buffer-window cur t))) (when win (select-window win))) (switch-to-buffer (generate-new-buffer " *mm*"))) (buffer-disable-undo) (set-buffer-file-coding-system mm-binary-coding-system) (insert-buffer-substring cur) (goto-char (point-min)) (when method (message "Viewing with %s" method)) (let ((mm (current-buffer)) (attachment-filename (mm-handle-filename handle)) (non-viewer (assq 'non-viewer (mailcap-mime-info (mm-handle-media-type handle) t)))) (unwind-protect (if method (progn (when (and (boundp 'gnus-summary-buffer) (buffer-live-p gnus-summary-buffer)) (when attachment-filename (with-current-buffer mm (rename-buffer (format "*mm* %s" attachment-filename) t))) ;; ;; So that we pop back to the right place, sort of. ;; (switch-to-buffer gnus-summary-buffer) (switch-to-buffer mm)) (funcall method)) (mm-save-part handle)) (when (and (not non-viewer) method) (mm-handle-set-undisplayer handle mm))))) ;; The function is a string to be executed. (mm-insert-part handle) (mm-add-meta-html-tag handle) ;; We create a private sub-directory where we store our files. (let* ((dir (with-file-modes #o700 (make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir))) (filename (or (mail-content-type-get (mm-handle-disposition handle) 'filename) (mail-content-type-get (mm-handle-type handle) 'name))) (mime-info (mailcap-mime-info (mm-handle-media-type handle) t)) (needsterm (or (assoc "needsterm" mime-info) (assoc "needsterminal" mime-info))) (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) (if filename (setq file (expand-file-name (gnus-map-function mm-file-name-rewrite-functions (file-name-nondirectory filename)) dir)) ;; Use nametemplate (defined in RFC1524) if it is specified ;; in mailcap. (let ((suffix (cdr (assoc "nametemplate" mime-info)))) (if (and suffix (string-match "\\`%s\\(\\..+\\)\\'" suffix)) (setq suffix (match-string 1 suffix)) ;; Otherwise, use a suffix according to ;; `mailcap-mime-extensions'. (setq suffix (car (rassoc (mm-handle-media-type handle) mailcap-mime-extensions)))) (setq file (with-file-modes #o600 (make-temp-file (expand-file-name "mm." dir) nil suffix))))) (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) ;; The file is deleted after the viewer exists. If the users edits ;; the file, changes will be lost. Set file to read-only to make it ;; clear. (set-file-modes file #o400 'nofollow) (message "Viewing with %s" method) (cond (needsterm (let ((command (mm-mailcap-command method file (mm-handle-type handle)))) (unwind-protect (if window-system (set-process-sentinel (start-process "*display*" nil mm-external-terminal-program "-e" shell-file-name shell-command-switch command) (lambda (process _state) (if (eq 'exit (process-status process)) (run-at-time 60.0 nil (lambda () (ignore-errors (delete-file file)) (ignore-errors (delete-directory (file-name-directory file)))))))) (require 'term) (require 'gnus-win) (set-buffer (setq buffer (make-term "display" shell-file-name nil shell-command-switch command))) (term-mode) (term-char-mode) (set-process-sentinel (get-buffer-process buffer) (let ((wc gnus-current-window-configuration)) (lambda (process _state) (when (eq 'exit (process-status process)) (ignore-errors (delete-file file)) (ignore-errors (delete-directory (file-name-directory file))) (gnus-configure-windows wc))))) (gnus-configure-windows 'display-term)) (mm-handle-set-external-undisplayer handle (cons file buffer)) (add-to-list 'mm-temp-files-to-be-deleted file t)) (message "Displaying %s..." command)) 'external) (copiousoutput (with-current-buffer outbuf (forward-line 1) (mm-insert-inline handle (unwind-protect (progn (call-process shell-file-name nil (setq buffer (generate-new-buffer " *mm*")) nil shell-command-switch (mm-mailcap-command method file (mm-handle-type handle))) (if (buffer-live-p buffer) (with-current-buffer buffer (buffer-string)))) (progn (ignore-errors (delete-file file)) (ignore-errors (delete-directory (file-name-directory file))) (ignore-errors (kill-buffer buffer)))))) 'inline) (t ;; Deleting the temp file should be postponed for some wrappers, ;; shell scripts, and so on, which might exit right after having ;; started a viewer command as a background job. (let ((command (mm-mailcap-command method file (mm-handle-type handle)))) (unwind-protect (let ((process-connection-type nil)) (start-process "*display*" (setq buffer (generate-new-buffer " *mm*")) shell-file-name shell-command-switch command) (set-process-sentinel (get-buffer-process buffer) (lambda (process _state) (when (eq (process-status process) 'exit) (run-at-time 60.0 nil (lambda () (ignore-errors (delete-file file)) (ignore-errors (delete-directory (file-name-directory file))))) (when (buffer-live-p outbuf) (with-current-buffer outbuf (let ((buffer-read-only nil) (point (point))) (forward-line 2) (let ((start (point))) (mm-insert-inline handle (with-current-buffer buffer (buffer-string))) (put-text-property start (point) 'face 'mm-command-output)) (goto-char point)))) (when (buffer-live-p buffer) (kill-buffer buffer))) (message "Displaying %s...done" command)))) (mm-handle-set-external-undisplayer handle (cons file buffer)) (add-to-list 'mm-temp-files-to-be-deleted file t)) (message "Displaying %s..." command)) 'external))))))) (defun my-gnus-article-copy-region (beg end) "Copy an gnus article region from beginning to end, links included." (interactive "r") (let ((pairs) (copied (buffer-substring-no-properties beg end)) (inhibit-message t)) (save-excursion (goto-char beg) (when-let* ((button (button-at (point))) (url (button-get button 'shr-url))) (push (cons (buffer-substring-no-properties (button-start button) (button-end button)) url) pairs)) (while (and (shr-next-link) (<= (point) end) (button-at (point))) (let ((button (button-at (point)))) (push (cons (buffer-substring-no-properties (button-start button) (button-end button)) (button-get button 'shr-url)) pairs))) (pcase-dolist (`(,label . ,url) (reverse pairs)) (setq copied (concat copied (format "[%s] %s\n" label url))))) (kill-new copied) (setq deactivate-mark t) (let ((inhibit-message nil)) (message "Copied region with %d links." (length pairs))))) (provide 'my-gnus) ;;; my-gnus.el ends here