diff options
author | jao <jao@gnu.org> | 2021-02-02 05:16:17 +0000 |
---|---|---|
committer | jao <jao@gnu.org> | 2021-02-02 05:16:17 +0000 |
commit | 771abb84830678455de4625ac7f082d8100f0ea0 (patch) | |
tree | 0d303c2cb0861b949ca73a9705954f6a69c4f877 /lib/net/jao-maildir.el | |
parent | 81eceb5507aa0659e9f0c9761e54e9102085c4ac (diff) | |
download | elibs-771abb84830678455de4625ac7f082d8100f0ea0.tar.gz elibs-771abb84830678455de4625ac7f082d8100f0ea0.tar.bz2 |
libs -> lib/
Diffstat (limited to 'lib/net/jao-maildir.el')
-rw-r--r-- | lib/net/jao-maildir.el | 155 |
1 files changed, 155 insertions, 0 deletions
diff --git a/lib/net/jao-maildir.el b/lib/net/jao-maildir.el new file mode 100644 index 0000000..76a9f9e --- /dev/null +++ b/lib/net/jao-maildir.el @@ -0,0 +1,155 @@ +;; 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 "") + +(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 attribute-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)) + + +(provide 'jao-maildir) +;;; jao-maildir.el ends here |