diff options
author | jao <jao@gnu.org> | 2022-03-02 03:33:51 +0000 |
---|---|---|
committer | jao <jao@gnu.org> | 2022-03-02 03:33:51 +0000 |
commit | c44f4a5447cce0c94d0cf054545979cb200428a8 (patch) | |
tree | 2019c8cdb1ae9a0fb2b747d42eba4a47be99beee /attic | |
parent | 4ad52a17ba5bdf9b695c476ec55584cfd7941dbb (diff) | |
download | elibs-c44f4a5447cce0c94d0cf054545979cb200428a8.tar.gz elibs-c44f4a5447cce0c94d0cf054545979cb200428a8.tar.bz2 |
attic: jao-maildir
Diffstat (limited to 'attic')
-rw-r--r-- | attic/net/jao-maildir.el | 189 | ||||
-rw-r--r-- | attic/net/jao-notmuch-move.el | 75 |
2 files changed, 264 insertions, 0 deletions
diff --git a/attic/net/jao-maildir.el b/attic/net/jao-maildir.el new file mode 100644 index 0000000..18a1725 --- /dev/null +++ b/attic/net/jao-maildir.el @@ -0,0 +1,189 @@ +;; jao-maildir.el -- Utilities for reading maildirs -*- lexical-binding: t; -*- + +;; Copyright (c) 2019, 2020, 2021 jao + +;; Author: jao <mail@jao.io> +;; Start date: Sun Dec 01, 2019 15:48 +;; Keywords: mail + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Comentary: + +;; Inspecting the contents of maildirs and reporting it. + +;;; Code: + +(require 'seq) +(require 'jao-minibuffer) + +(defvar jao-maildir-debug-p nil) +(defvar jao-maildir-echo-p t) +(defvar jao-maildir-tracked-maildirs nil) +(defvar jao-maildir-info-string "") +(defvar jao-maildir-home (expand-file-name "~/var/mail")) +(defvar jao-maildir-news-home (expand-file-name "~/var/news")) + +(defgroup jao-maildir-faces nil "Faces" + :group 'faces) +(defun jao-maildir--maildir-new (mbox) (expand-file-name "new" mbox)) + +(defun jao-maildir--maildir-new-count (mbox) + (- (length (directory-files (jao-maildir--maildir-new mbox))) 2)) + +(defface jao-maildir-emph '((t :inherit font-lock-keyword-face)) + "Face used to highlihgt non-boring tracked maildirs" + :group 'jao-maildir-faces) + +(defvar jao-maildir--maildirs nil) +(defvar jao-maildir--counts nil) +(defvar jao-maildir--label-mboxes nil) +(defvar jao-maildir--trackers nil) +(defvar jao-maildir--track-strings ()) + +(defun jao-maildir--update-counts () + (dolist (mbox jao-maildir--maildirs) + (puthash mbox (jao-maildir--maildir-new-count mbox) jao-maildir--counts))) + +(defun jao-maildir--init-counts (maildirs) + (setq jao-maildir--counts (make-hash-table :test 'equal)) + (setq jao-maildir--maildirs maildirs) + (jao-maildir--update-counts)) + +(defun jao-maildir--set-trackers (maildirs tracked-maildirs) + (jao-maildir--init-counts maildirs) + (let* ((label-mboxes (make-hash-table :test 'equal)) + (trackers (seq-map-indexed + (lambda (track idx) + (puthash (car track) () label-mboxes) + (let ((tr (seq-take track 2)) + (l (elt track 2))) + (append tr + (cond ((eq l t) '(jao-maildir-emph)) + ((null l) '(default)) + (t (list l))) + (list (or (elt track 3) idx))))) + tracked-maildirs))) + (dolist (mbox maildirs) + (let ((lb (seq-find (lambda (lb) (when lb (string-match-p lb mbox))) + (hash-table-keys label-mboxes)))) + (puthash lb (cons mbox (gethash lb label-mboxes)) label-mboxes))) + (setq jao-maildir--label-mboxes label-mboxes) + (setq jao-maildir--trackers trackers))) + +(defun jao-maildir--tracked-count (track) + (seq-reduce (lambda (c k) (+ c (gethash k jao-maildir--counts 0))) + (gethash (car track) jao-maildir--label-mboxes) + 0)) + +(defun jao-maildir--update-track-string (mbox) + (when-let ((track (seq-find (lambda (td) (string-match-p (car td) mbox)) + jao-maildir--trackers))) + (let* ((label (cadr track)) + (other (assoc-delete-all label jao-maildir--track-strings)) + (cnt (jao-maildir--tracked-count track))) + (if (> cnt 0) + (let* ((face (car (last (butlast track)))) + (order (car (last track))) + (str (propertize (format "%s%s" label cnt) 'face face)) + (str (cons label (cons order str)))) + (setq jao-maildir--track-strings (cons str other))) + (setq jao-maildir--track-strings other))))) + +;;;###autoload +(defun jao-maildir-update-info-string (&optional mbox) + (cond ((eq mbox t) + (seq-do 'jao-maildir--update-track-string jao-maildir--maildirs)) + ((stringp mbox) + (puthash mbox (jao-maildir--maildir-new-count mbox) jao-maildir--counts) + (jao-maildir--update-track-string mbox))) + (let* ((s (seq-sort-by #'cadr #'< jao-maildir--track-strings)) + (s (mapconcat 'identity (mapcar 'cddr s) " "))) + (setq jao-maildir-info-string (if (string-blank-p s) "" (concat s " ")))) + (when jao-maildir-echo-p (jao-minibuffer-refresh))) + +(defvar jao-maildir--watches nil) + +(defun jao-maildir-cancel-watchers () + (dolist (w jao-maildir--watches) (file-notify-rm-watch w)) + (setq jao-maildir--watches nil)) + +(defun jao-maildir--log-watch (mbox e) + (when jao-maildir-debug-p + (message "[%s] watch: %s: %s" (current-time-string) mbox e))) + +(defun jao-maildir--watcher (mbox cb) + (lambda (e) + (jao-maildir--log-watch e mbox) + (when (memq (cadr e) '(created deleted)) + (jao-maildir-update-info-string mbox) + (when cb (funcall cb mbox))))) + +(defun jao-maildir--setup-watches (cb) + (jao-maildir-cancel-watchers) + (setq jao-maildir--watches + (mapcar (lambda (mbox) + (file-notify-add-watch (jao-maildir--maildir-new mbox) + '(change) + (jao-maildir--watcher mbox cb))) + jao-maildir--maildirs))) + +;;;###autoload +(defun jao-maildir-setup (maildirs trackers mode-line &optional cb) + (jao-maildir--set-trackers maildirs trackers) + (cond ((eq 'mode-line mode-line) + (add-to-list 'global-mode-string 'jao-maildir-info-string t)) + ((numberp mode-line) + (jao-minibuffer-add-variable 'jao-maildir-info-string mode-line) + (jao-maildir-update-info-string t)) + (t (error "Invalid mode-line value"))) + (jao-maildir--setup-watches cb)) + +;;;###autoload +(defun jao-maildir-file-to-group (file &optional maildir newsdir) + "Calculate the Gnus group name from the given file name. +Example: + + IN: /home/jao/var/mail/jao/foo/cur/1259184569.M4818P3384.localhost,W=6921:2,S + OUT: nnml:jao.foo + + IN: /home/jao/.emacs.d/gnus/Mail/jao.trove/32570, /home/jao/.emacs.d/gnus/Mail/ + OUT: nnml:jao.trove + + IN: /home/jao/var/mail/gmane/foo/bar/100 + OUT: nntp:gmane.foo.bar + + IN: /home/jao/var/mail/bigml/cur/1259176906.M17483P24679.localhost,W=2488:2,S + OUT:nnimap:bigml/inbox" + (let* ((g (directory-file-name (file-name-directory file))) + (g (replace-regexp-in-string + (file-name-as-directory (or maildir jao-maildir-home)) "" g)) + (g (replace-regexp-in-string + (file-name-as-directory (or newsdir jao-maildir-news-home)) "" g)) + (nntp (string-match-p "^\\(gmane\\|gwene\\)/" g)) + (g (cond (nntp (concat "nntp:" g)) + ((file-name-directory g) + (replace-regexp-in-string "^\\([^/]+\\)/" "nnml:\\1/" + (file-name-directory g) t)) + (t (concat "nnml:" g)))) + (g (replace-regexp-in-string "/" "." g)) + (g (replace-regexp-in-string "[/.]$" "" g))) + (cond ((string-match ":$" g) (concat g "inbox")) + (nntp g) + (t (replace-regexp-in-string ":\\." ":" g))))) + +(provide 'jao-maildir) +;;; jao-maildir.el ends here diff --git a/attic/net/jao-notmuch-move.el b/attic/net/jao-notmuch-move.el new file mode 100644 index 0000000..eb7ea4c --- /dev/null +++ b/attic/net/jao-notmuch-move.el @@ -0,0 +1,75 @@ +;;; jao-notmuch-move.el --- Move messages around in notmuch -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 jao + +;; Author: jao <mail@jao.io> +;; Keywords: mail + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Moving messages around + +;;; Code: + +(require 'notmuch) + +(defvar jao-notmuch-mailboxes nil) +(defvar jao-notmuch-mailboxes-rx nil) + +(defun jao-notmuch--path-to-mailbox (full-path) + (unless jao-notmuch-mailboxes-rx + (setq jao-notmuch-mailboxes-rx (regexp-opt jao-notmuch-mailboxes))) + (if (string-match jao-notmuch-mailboxes-rx full-path) + (match-string 0 full-path) + (user-error "Message not in any registered mailbox!"))) + +(defun jao-notmuch--msg-props () + (if-let ((p (save-excursion + (beginning-of-line) + (text-property-search-forward :notmuch-message-properties)))) + (prop-match-value p) + (user-error "No message at point"))) + +(defun jao-notmuch--full-path () + (seq-find #'file-exists-p (plist-get (jao-notmuch--msg-props) :filename))) + +(defun jao-notmuch--move (&optional full-path d) + (let* ((full-path (or full-path (jao-notmuch--full-path))) + (ff (jao-notmuch--path-to-mailbox full-path)) + (d (or d (completing-read (format "From %s to: " ff) + (remove ff jao-notmuch-mailboxes) nil t))) + (dest (string-replace ff d full-path)) + (dest (replace-regexp-in-string ",U=.+$" "m:2,S" dest)) + (ftags (split-string ff "/")) + (ttags (split-string d "/"))) + (when (y-or-n-p (format "%s -> %s? " ftags ttags)) + (notmuch-tree-close-message-window) + (notmuch-tree-tag (append (notmuch-tag-change-list ftags t) + (notmuch-tag-change-list ttags))) + (rename-file (jao-notmuch--full-path) dest) + (shell-command-to-string "notmuch new") + (notmuch-refresh-this-buffer)))) + +(defun jao-notmuch-move-message () + "Move message at point to another folder." + (interactive) + (jao-notmuch--move)) + + + + +(provide 'jao-notmuch-move) +;;; jao-notmuch-move.el ends here |