From 093ffa5fbf7143f4668bb0a3dc9659a5cc836e12 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Sat, 17 Jun 2023 17:20:29 +1000 Subject: Moving things one level deeper To ease gnu stow usage. Now we can do stow -t ~ emacs --- emacs/.emacs.d/lisp/my/my-gnus.el | 327 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 327 insertions(+) create mode 100644 emacs/.emacs.d/lisp/my/my-gnus.el (limited to 'emacs/.emacs.d/lisp/my/my-gnus.el') diff --git a/emacs/.emacs.d/lisp/my/my-gnus.el b/emacs/.emacs.d/lisp/my/my-gnus.el new file mode 100644 index 0000000..aee03b5 --- /dev/null +++ b/emacs/.emacs.d/lisp/my/my-gnus.el @@ -0,0 +1,327 @@ +;;; 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: + + + +(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))))))) + +(provide 'my-gnus) +;;; my-gnus.el ends here -- cgit v1.2.3