From 26f7ffb67c1740835e966fe3832a6ddf9bc0b9cf Mon Sep 17 00:00:00 2001 From: jao Date: Thu, 19 Aug 2021 01:49:40 +0100 Subject: attic misc rename --- attic/misc/jao-notmuch-tree-fold.el | 139 ------------------- attic/misc/nnnm.el | 265 ------------------------------------ attic/net/jao-notmuch-tree-fold.el | 139 +++++++++++++++++++ attic/net/nnnm.el | 265 ++++++++++++++++++++++++++++++++++++ 4 files changed, 404 insertions(+), 404 deletions(-) delete mode 100644 attic/misc/jao-notmuch-tree-fold.el delete mode 100644 attic/misc/nnnm.el create mode 100644 attic/net/jao-notmuch-tree-fold.el create mode 100644 attic/net/nnnm.el (limited to 'attic') diff --git a/attic/misc/jao-notmuch-tree-fold.el b/attic/misc/jao-notmuch-tree-fold.el deleted file mode 100644 index ef528df..0000000 --- a/attic/misc/jao-notmuch-tree-fold.el +++ /dev/null @@ -1,139 +0,0 @@ -;;; jao-notmuch-tree-fold.el --- Show/hide (sub)tress in notmuch-tree -*- lexical-binding: t; -*- - -;; Copyright (C) 2021 jao - -;; Author: jao -;; 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 . - -;;; Commentary: - -;; - -;;; Code: - -(require 'jao-notmuch) - - -;; Show/hide threads - -(defun jao-notmuch--tree-top () (notmuch-tree-get-prop :first)) - -(defun jao-notmuch--tree-bottom () - (let ((line-move-ignore-invisible t)) - (save-excursion - (when (zerop (forward-line 1)) - (or (not (notmuch-tree-get-message-properties)) - (jao-notmuch--tree-top)))))) - -(defun jao-notmuch-tree-hide-thread () - (interactive) - (notmuch-tree-thread-top) - (save-excursion - (forward-line 1) - (when (not (jao-notmuch--tree-top)) - (let ((line-move-ignore-invisible nil) - (inhibit-read-only t) - (p (point))) - (unless (notmuch-tree-next-thread-in-tree) - (forward-line -1)) - (add-text-properties p (point) '(invisible t)))))) - -(defun jao-notmuch-tree-show-thread () - (interactive) - (when (or (jao-notmuch--tree-top) (invisible-p (point))) - (let ((line-move-ignore-invisible nil)) - (notmuch-tree-thread-top) - (let ((inhibit-read-only t) - (p (point))) - (notmuch-tree-next-thread-in-tree) - (remove-text-properties p (point) '(invisible nil)) - (goto-char p))))) - -(defun jao-notmuch-tree-show-all () - (interactive) - (let ((inhibit-read-only t)) - (put-text-property (point-min) (point-max) 'invisible nil))) - -(defun jao-notmuch-tree-hide-all () - (interactive) - (let ((inhibit-read-only t) - (line-move-ignore-invisible nil)) - (goto-char (point-min)) - (jao-notmuch-tree-hide-thread) - (while (notmuch-tree-next-thread-in-tree) - (jao-notmuch-tree-hide-thread))) - (goto-char (point-min))) - -(defun jao-notmuch-tree-toggle-thread () - (interactive) - (let ((line-move-ignore-invisible nil)) - (forward-line 1) - (when (jao-notmuch--tree-top) - (forward-line -1)) - (if (invisible-p (point)) - (jao-notmuch-tree-show-thread) - (jao-notmuch-tree-hide-thread)))) - -(defvar notmuch-tree-thread-map - (let ((m (make-keymap "Thread operations"))) - (define-key m (kbd "TAB") #'jao-notmuch-tree-toggle-thread) - (define-key m (kbd "t") #'jao-notmuch-tree-toggle-thread) - (define-key m (kbd "s") #'jao-notmuch-tree-show-thread) - (define-key m (kbd "S") #'jao-notmuch-tree-show-all) - (define-key m (kbd "h") #'jao-notmuch-tree-hide-thread) - (define-key m (kbd "H") #'jao-notmuch-tree-hide-all) - m)) - -(defun jao-notmuch--tree-next (prev thread no-exit) - (let ((line-move-ignore-invisible t)) - (cond ((looking-at-p "^End of search results") - (unless no-exit - (notmuch-tree-close-message-window) - (notmuch-tree-quit))) - ((jao-notmuch--looking-at-new-p) - (save-excursion (jao-notmuch-tree-show-thread)) - (notmuch-tree-show-message nil)) - (thread - (save-excursion (jao-notmuch-tree-hide-thread)) - (when (notmuch-tree-next-thread prev) - (save-excursion (jao-notmuch-tree-show-thread))) - (unless (jao-notmuch--looking-at-new-p) - (notmuch-tree-matching-message prev (not no-exit)))) - ((or (and (not prev) (jao-notmuch--tree-bottom)) - (and prev (jao-notmuch--tree-top))) - (save-excursion (jao-notmuch-tree-hide-thread)) - (forward-line (if prev -1 1)) - (jao-notmuch--tree-next prev nil no-exit)) - ((notmuch-tree-get-message-id) - (save-excursion (jao-notmuch-tree-show-thread)) - (notmuch-tree-matching-message prev (not no-exit))))) - (when (notmuch-tree-get-message-id) - (notmuch-tree-show-message nil)) - (jao-notmuch--tree-update-buffer-name)) - -(defun jao-notmuch-tree-next (thread &optional no-exit) - "Next message or thread in forest, taking care of thread visibility." - (interactive "P") - (jao-notmuch--tree-next nil thread no-exit)) - -(defun jao-notmuch-tree-previous (thread) - "Previous message or thread in forest, taking care of thread visibility.." - (interactive "P") - (jao-notmuch--tree-next t thread t)) - - -(provide 'jao-notmuch-tree-fold) -;;; jao-notmuch-tree-fold.el ends here diff --git a/attic/misc/nnnm.el b/attic/misc/nnnm.el deleted file mode 100644 index 552e95c..0000000 --- a/attic/misc/nnnm.el +++ /dev/null @@ -1,265 +0,0 @@ -;;; nnnm.el --- Gnus backend for notmuch -*- lexical-binding: t; -*- - -;; Copyright (C) 2021 jao - -;; Author: jao -;; 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 . - -;;; Commentary: - -;; A Gnus mail backend using notmuch. - -;;; Code: - -(require 'gnus) -(require 'nnheader) -(require 'nnmail) -(require 'nnoo) - - -(nnoo-declare nnnm) - -(defvar nnnm-marks-to-tags '((tick . "flagged"))) - -(defvar nnnm-saved-searches nil) - -(defvar nnnm-maildir nil) - -(defvar nnnm--group-data nil) - -(defun nnnm--group-data (group) (cdr (assoc group nnnm--group-data))) - -(defun nnnm--set-group-data (group data) - (setf (alist-get group nnnm--group-data nil t #'string=) data)) - - -(defun nnnm--find-query (name) - (when-let (s (seq-find (lambda (s) (string= (plist-get s :name) name)) - nnnm-saved-searches)) - (plist-get s :query))) - -(defun nnnm--find-message-file (id) - (car (split-string - (shell-command-to-string - (format "notmuch search --output=files %s" - (if (string-prefix-p "id:" id) id (concat "id:" id))))))) - -(defun nnnm--article-data (article group) - (cond ((stringp article) (list article)) - ((numberp article) - (when-let (data (nnnm--group-data group)) - (elt data (1- article)))))) - -(defun nnnm-article-to-file (article group) - (when-let (d (nnnm--article-data article group)) - (or (cadr d) (nnnm--find-message-file (car d))))) - -(defun nnnm--count (query &optional context) - (let ((cmd (format "notmuch count -- '(%s)%s'" - query - (if context (concat " AND " context) "")))) - (string-to-number (shell-command-to-string cmd)))) - -(defun nnnm--search (query &optional context) - (let ((cmd (format "notmuch search --sort=oldest-first --output=messages -- %s%s" - (shell-quote-argument (format "(%s)" query)) - (if context (concat " AND " context) "")))) - (split-string (shell-command-to-string cmd)))) - -(defun nnnm--tag (query tags) - (let ((cmd (format "notmuch tag %s -- '(%s)'" tags query))) - (shell-command-to-string cmd))) - -(defun nnnm--ids-query (ids) (mapconcat #'identity ids " OR ")) - -(defun nnnm--prefixed (group server) - (gnus-group-prefixed-name group `(nnnm ,server))) - -(defun nnnm--get-group-marks (group server) - (gnus-info-marks (gnus-get-info (nnnm--prefixed group server)))) - -(defun nnnm--set-group-marks (marks group server) - (let* ((full-group (nnnm--prefixed group server)) - (info (gnus-get-info full-group))) - (gnus-info-set-marks info marks) - (gnus-set-info full-group info))) - -(defun nnnm--subtract-from-ranges (ranges lst) - (let ((ranges (gnus-uncompress-sequence ranges))) - (dolist (n lst) - (let ((rs (seq-group-by (lambda (r) (> n r)) ranges))) - (setq ranges - (append (alist-get t rs) (mapcar #'1- (alist-get nil rs)))))) - (gnus-compress-sequence ranges))) - -(defun nnnm--remove-articles-from-marks (ranges group server) - (let ((marks (nnnm--get-group-marks group server)) - (lst (gnus-uncompress-sequence ranges)) - (new-marks)) - (dolist (m marks) - (push (cons (car m) (nnnm--subtract-from-ranges (cdr m))) lst)) - (nnnm--set-group-marks marks group server))) - -(defun nnnm--set-active (n group server) - (gnus-set-active (nnnm--prefixed group server) (cons 1 n))) - -(defun nnnm--update-group-data (group &optional server) - (when-let (query (nnnm--find-query group)) - (let* ((data (or (nnnm--group-data group) - (mapcar #'list (nnnm--search query "NOT tag:new")))) - (ids (nnnm--search query "tag:new")) - (nids (length ids)) - (new-data (mapcar (lambda (id) - (list id (nnnm--find-message-file id))) - ids))) - (when (> nids 0) - (nnnm--tag (nnnm--ids-query ids) "-new") - (nnheader-report 'nnnm "%s: %d new messages retrieved" group nids)) - (nnnm--set-group-data group (append data new-data)) - (nnnm--set-active (+ nids (length data)) group server) - (length ids)))) - - - -;;; Interface functions. - -(nnoo-define-basics nnnm) - -(defun nnnm-request-type (_group &optional _article) - 'mail) - -(deffoo nnnm-open-server (server &optional defs) - (nnoo-change-server 'nnnm server defs) - (setq nnnm--group-data nil) - (nnheader-report 'nnnm "Opened server %s" server) - t) - -(deffoo nnnm-close-server (_server) - (setq nnnm--group-data nil)) - -(deffoo nnnm-request-regenerate (_server) - (setq nnnm--group-data nil) - t) - -(deffoo nnnm-request-list (&optional _server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (dolist (s nnnm-saved-searches) - (when-let (query (plist-get s :query)) - (let ((name (plist-get s :name)) - (total (nnnm--count query))) - (insert (format "%s %d 1 y\n" name total)))))) - t) - -(deffoo nnnm-retrieve-headers (sequence &optional group server _fetch-old) - (when (nnnm--update-group-data group server) - (with-current-buffer nntp-server-buffer - (delete-region (point-min) (point-max)) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (count -1)) - (if (stringp (car sequence)) - 'headers - (dolist (article sequence) - (when-let (file (nnnm-article-to-file article group)) - (insert (format "221 %d Article retrieved.\n" article)) - (save-excursion (nnheader-insert-head file)) - (if (re-search-forward "\n\r?\n" nil t) - (forward-char -1) - (goto-char (point-max)) - (insert "\n\n")) - (insert ".\n") - (delete-region (point) (point-max))) - (when (zerop (% (cl-incf count) 20)) - (nnheader-message 6 "nnnm: Receiving headers... %d%%" - (floor (* count 100.0) (length sequence))))) - (nnheader-fold-continuation-lines) - 'headers))))) - -(deffoo nnnm-request-article (id &optional group _server buffer) - (let* ((nntp-server-buffer (or buffer nntp-server-buffer)) - (file-name-coding-system nnmail-pathname-coding-system) - (d (nnnm--article-data id group)) - (id (car d)) - (file (when id (or (cadr d) (nnnm--find-message-file id))))) - (cond - ((not file) - (nnheader-report 'nnnm "No such article: %s" id)) - ((not (file-exists-p file)) - (nnheader-report 'nnnm "No such file: %s" file)) - ((not (save-excursion (nnmail-find-file file))) - (nnheader-report 'nnnm "Couldn't read file: %s" file)) - (t - (nnnm--tag id "-unread") - (nnheader-report 'nnnm "Article %s retrieved and tagged" id) - (cons group id))))) - -(deffoo nnnm-request-expire-articles (articles group &optional _server _force) - (let* ((articles (gnus-uncompress-range articles)) - (ids (mapcar (lambda (a) (car (nnnm--article-data a group))) articles))) - (when ids - (nnnm--tag (nnnm--ids-query ids) "+deleted") - (let ((data (nnnm--group-data group))) - (dolist (id ids) - (setq data - (cl-delete-if (lambda (d) (string= (car d) id)) data :count 1))) - (nnnm--set-group-data group data) - (nnnm--remove-articles-from-marks articles group server) - (nnnm--set-active (length data) group server))) - articles)) - -(deffoo nnnm-request-set-mark (group actions &optional _server) - (message "set marks: %s: %S" group actions) - actions) - -;; (deffoo nnnm-request-move-article -;; (article group server accept-form &optional last _move-is-internal) -;; (error "Not implemented yet")) - -(deffoo nnnm-request-group (group &optional server _dont-check info) - (nnheader-message 7 "nnnm: Opening %s -- %s" info group) - (if (nnnm--update-group-data group server) - (let ((n (length (nnnm--group-data group)))) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (nnheader-insert "211 %d %d %d %s\n" n 1 n group) - n)) - (nnheader-report 'nnnm "Invalid group"))) - -(deffoo nnnm-request-newgroups (_date &optional server) - (nnnm-request-list server)) - -(deffoo nnnm-request-group-scan (group &optional server _info) - (nnnm--set-group-data group nil) - (nnnm--update-group-data group server)) - -(deffoo nnnm-request-scan (&optional group server) - (if group - (nnnm--update-group-data group server) - (setq nnnm--group-data nil))) - -(deffoo nnnm-request-create-group (group &optional _server _args) - (let ((query (read-string "Query: "))) - (add-to-list 'nnnm-saved-searches `(:name ,group :query ,query)))) - -;; (deffoo nnnm-request-rename-group (group new-name &optional _server) -;; (error "Not implemented yet")) - -(deffoo nnnm-close-group (_group &optional _server) t) - - - -(provide 'nnnm) -;;; nnnm.el ends here diff --git a/attic/net/jao-notmuch-tree-fold.el b/attic/net/jao-notmuch-tree-fold.el new file mode 100644 index 0000000..ef528df --- /dev/null +++ b/attic/net/jao-notmuch-tree-fold.el @@ -0,0 +1,139 @@ +;;; jao-notmuch-tree-fold.el --- Show/hide (sub)tress in notmuch-tree -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 jao + +;; Author: jao +;; 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 . + +;;; Commentary: + +;; + +;;; Code: + +(require 'jao-notmuch) + + +;; Show/hide threads + +(defun jao-notmuch--tree-top () (notmuch-tree-get-prop :first)) + +(defun jao-notmuch--tree-bottom () + (let ((line-move-ignore-invisible t)) + (save-excursion + (when (zerop (forward-line 1)) + (or (not (notmuch-tree-get-message-properties)) + (jao-notmuch--tree-top)))))) + +(defun jao-notmuch-tree-hide-thread () + (interactive) + (notmuch-tree-thread-top) + (save-excursion + (forward-line 1) + (when (not (jao-notmuch--tree-top)) + (let ((line-move-ignore-invisible nil) + (inhibit-read-only t) + (p (point))) + (unless (notmuch-tree-next-thread-in-tree) + (forward-line -1)) + (add-text-properties p (point) '(invisible t)))))) + +(defun jao-notmuch-tree-show-thread () + (interactive) + (when (or (jao-notmuch--tree-top) (invisible-p (point))) + (let ((line-move-ignore-invisible nil)) + (notmuch-tree-thread-top) + (let ((inhibit-read-only t) + (p (point))) + (notmuch-tree-next-thread-in-tree) + (remove-text-properties p (point) '(invisible nil)) + (goto-char p))))) + +(defun jao-notmuch-tree-show-all () + (interactive) + (let ((inhibit-read-only t)) + (put-text-property (point-min) (point-max) 'invisible nil))) + +(defun jao-notmuch-tree-hide-all () + (interactive) + (let ((inhibit-read-only t) + (line-move-ignore-invisible nil)) + (goto-char (point-min)) + (jao-notmuch-tree-hide-thread) + (while (notmuch-tree-next-thread-in-tree) + (jao-notmuch-tree-hide-thread))) + (goto-char (point-min))) + +(defun jao-notmuch-tree-toggle-thread () + (interactive) + (let ((line-move-ignore-invisible nil)) + (forward-line 1) + (when (jao-notmuch--tree-top) + (forward-line -1)) + (if (invisible-p (point)) + (jao-notmuch-tree-show-thread) + (jao-notmuch-tree-hide-thread)))) + +(defvar notmuch-tree-thread-map + (let ((m (make-keymap "Thread operations"))) + (define-key m (kbd "TAB") #'jao-notmuch-tree-toggle-thread) + (define-key m (kbd "t") #'jao-notmuch-tree-toggle-thread) + (define-key m (kbd "s") #'jao-notmuch-tree-show-thread) + (define-key m (kbd "S") #'jao-notmuch-tree-show-all) + (define-key m (kbd "h") #'jao-notmuch-tree-hide-thread) + (define-key m (kbd "H") #'jao-notmuch-tree-hide-all) + m)) + +(defun jao-notmuch--tree-next (prev thread no-exit) + (let ((line-move-ignore-invisible t)) + (cond ((looking-at-p "^End of search results") + (unless no-exit + (notmuch-tree-close-message-window) + (notmuch-tree-quit))) + ((jao-notmuch--looking-at-new-p) + (save-excursion (jao-notmuch-tree-show-thread)) + (notmuch-tree-show-message nil)) + (thread + (save-excursion (jao-notmuch-tree-hide-thread)) + (when (notmuch-tree-next-thread prev) + (save-excursion (jao-notmuch-tree-show-thread))) + (unless (jao-notmuch--looking-at-new-p) + (notmuch-tree-matching-message prev (not no-exit)))) + ((or (and (not prev) (jao-notmuch--tree-bottom)) + (and prev (jao-notmuch--tree-top))) + (save-excursion (jao-notmuch-tree-hide-thread)) + (forward-line (if prev -1 1)) + (jao-notmuch--tree-next prev nil no-exit)) + ((notmuch-tree-get-message-id) + (save-excursion (jao-notmuch-tree-show-thread)) + (notmuch-tree-matching-message prev (not no-exit))))) + (when (notmuch-tree-get-message-id) + (notmuch-tree-show-message nil)) + (jao-notmuch--tree-update-buffer-name)) + +(defun jao-notmuch-tree-next (thread &optional no-exit) + "Next message or thread in forest, taking care of thread visibility." + (interactive "P") + (jao-notmuch--tree-next nil thread no-exit)) + +(defun jao-notmuch-tree-previous (thread) + "Previous message or thread in forest, taking care of thread visibility.." + (interactive "P") + (jao-notmuch--tree-next t thread t)) + + +(provide 'jao-notmuch-tree-fold) +;;; jao-notmuch-tree-fold.el ends here diff --git a/attic/net/nnnm.el b/attic/net/nnnm.el new file mode 100644 index 0000000..552e95c --- /dev/null +++ b/attic/net/nnnm.el @@ -0,0 +1,265 @@ +;;; nnnm.el --- Gnus backend for notmuch -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 jao + +;; Author: jao +;; 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 . + +;;; Commentary: + +;; A Gnus mail backend using notmuch. + +;;; Code: + +(require 'gnus) +(require 'nnheader) +(require 'nnmail) +(require 'nnoo) + + +(nnoo-declare nnnm) + +(defvar nnnm-marks-to-tags '((tick . "flagged"))) + +(defvar nnnm-saved-searches nil) + +(defvar nnnm-maildir nil) + +(defvar nnnm--group-data nil) + +(defun nnnm--group-data (group) (cdr (assoc group nnnm--group-data))) + +(defun nnnm--set-group-data (group data) + (setf (alist-get group nnnm--group-data nil t #'string=) data)) + + +(defun nnnm--find-query (name) + (when-let (s (seq-find (lambda (s) (string= (plist-get s :name) name)) + nnnm-saved-searches)) + (plist-get s :query))) + +(defun nnnm--find-message-file (id) + (car (split-string + (shell-command-to-string + (format "notmuch search --output=files %s" + (if (string-prefix-p "id:" id) id (concat "id:" id))))))) + +(defun nnnm--article-data (article group) + (cond ((stringp article) (list article)) + ((numberp article) + (when-let (data (nnnm--group-data group)) + (elt data (1- article)))))) + +(defun nnnm-article-to-file (article group) + (when-let (d (nnnm--article-data article group)) + (or (cadr d) (nnnm--find-message-file (car d))))) + +(defun nnnm--count (query &optional context) + (let ((cmd (format "notmuch count -- '(%s)%s'" + query + (if context (concat " AND " context) "")))) + (string-to-number (shell-command-to-string cmd)))) + +(defun nnnm--search (query &optional context) + (let ((cmd (format "notmuch search --sort=oldest-first --output=messages -- %s%s" + (shell-quote-argument (format "(%s)" query)) + (if context (concat " AND " context) "")))) + (split-string (shell-command-to-string cmd)))) + +(defun nnnm--tag (query tags) + (let ((cmd (format "notmuch tag %s -- '(%s)'" tags query))) + (shell-command-to-string cmd))) + +(defun nnnm--ids-query (ids) (mapconcat #'identity ids " OR ")) + +(defun nnnm--prefixed (group server) + (gnus-group-prefixed-name group `(nnnm ,server))) + +(defun nnnm--get-group-marks (group server) + (gnus-info-marks (gnus-get-info (nnnm--prefixed group server)))) + +(defun nnnm--set-group-marks (marks group server) + (let* ((full-group (nnnm--prefixed group server)) + (info (gnus-get-info full-group))) + (gnus-info-set-marks info marks) + (gnus-set-info full-group info))) + +(defun nnnm--subtract-from-ranges (ranges lst) + (let ((ranges (gnus-uncompress-sequence ranges))) + (dolist (n lst) + (let ((rs (seq-group-by (lambda (r) (> n r)) ranges))) + (setq ranges + (append (alist-get t rs) (mapcar #'1- (alist-get nil rs)))))) + (gnus-compress-sequence ranges))) + +(defun nnnm--remove-articles-from-marks (ranges group server) + (let ((marks (nnnm--get-group-marks group server)) + (lst (gnus-uncompress-sequence ranges)) + (new-marks)) + (dolist (m marks) + (push (cons (car m) (nnnm--subtract-from-ranges (cdr m))) lst)) + (nnnm--set-group-marks marks group server))) + +(defun nnnm--set-active (n group server) + (gnus-set-active (nnnm--prefixed group server) (cons 1 n))) + +(defun nnnm--update-group-data (group &optional server) + (when-let (query (nnnm--find-query group)) + (let* ((data (or (nnnm--group-data group) + (mapcar #'list (nnnm--search query "NOT tag:new")))) + (ids (nnnm--search query "tag:new")) + (nids (length ids)) + (new-data (mapcar (lambda (id) + (list id (nnnm--find-message-file id))) + ids))) + (when (> nids 0) + (nnnm--tag (nnnm--ids-query ids) "-new") + (nnheader-report 'nnnm "%s: %d new messages retrieved" group nids)) + (nnnm--set-group-data group (append data new-data)) + (nnnm--set-active (+ nids (length data)) group server) + (length ids)))) + + + +;;; Interface functions. + +(nnoo-define-basics nnnm) + +(defun nnnm-request-type (_group &optional _article) + 'mail) + +(deffoo nnnm-open-server (server &optional defs) + (nnoo-change-server 'nnnm server defs) + (setq nnnm--group-data nil) + (nnheader-report 'nnnm "Opened server %s" server) + t) + +(deffoo nnnm-close-server (_server) + (setq nnnm--group-data nil)) + +(deffoo nnnm-request-regenerate (_server) + (setq nnnm--group-data nil) + t) + +(deffoo nnnm-request-list (&optional _server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (s nnnm-saved-searches) + (when-let (query (plist-get s :query)) + (let ((name (plist-get s :name)) + (total (nnnm--count query))) + (insert (format "%s %d 1 y\n" name total)))))) + t) + +(deffoo nnnm-retrieve-headers (sequence &optional group server _fetch-old) + (when (nnnm--update-group-data group server) + (with-current-buffer nntp-server-buffer + (delete-region (point-min) (point-max)) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (count -1)) + (if (stringp (car sequence)) + 'headers + (dolist (article sequence) + (when-let (file (nnnm-article-to-file article group)) + (insert (format "221 %d Article retrieved.\n" article)) + (save-excursion (nnheader-insert-head file)) + (if (re-search-forward "\n\r?\n" nil t) + (forward-char -1) + (goto-char (point-max)) + (insert "\n\n")) + (insert ".\n") + (delete-region (point) (point-max))) + (when (zerop (% (cl-incf count) 20)) + (nnheader-message 6 "nnnm: Receiving headers... %d%%" + (floor (* count 100.0) (length sequence))))) + (nnheader-fold-continuation-lines) + 'headers))))) + +(deffoo nnnm-request-article (id &optional group _server buffer) + (let* ((nntp-server-buffer (or buffer nntp-server-buffer)) + (file-name-coding-system nnmail-pathname-coding-system) + (d (nnnm--article-data id group)) + (id (car d)) + (file (when id (or (cadr d) (nnnm--find-message-file id))))) + (cond + ((not file) + (nnheader-report 'nnnm "No such article: %s" id)) + ((not (file-exists-p file)) + (nnheader-report 'nnnm "No such file: %s" file)) + ((not (save-excursion (nnmail-find-file file))) + (nnheader-report 'nnnm "Couldn't read file: %s" file)) + (t + (nnnm--tag id "-unread") + (nnheader-report 'nnnm "Article %s retrieved and tagged" id) + (cons group id))))) + +(deffoo nnnm-request-expire-articles (articles group &optional _server _force) + (let* ((articles (gnus-uncompress-range articles)) + (ids (mapcar (lambda (a) (car (nnnm--article-data a group))) articles))) + (when ids + (nnnm--tag (nnnm--ids-query ids) "+deleted") + (let ((data (nnnm--group-data group))) + (dolist (id ids) + (setq data + (cl-delete-if (lambda (d) (string= (car d) id)) data :count 1))) + (nnnm--set-group-data group data) + (nnnm--remove-articles-from-marks articles group server) + (nnnm--set-active (length data) group server))) + articles)) + +(deffoo nnnm-request-set-mark (group actions &optional _server) + (message "set marks: %s: %S" group actions) + actions) + +;; (deffoo nnnm-request-move-article +;; (article group server accept-form &optional last _move-is-internal) +;; (error "Not implemented yet")) + +(deffoo nnnm-request-group (group &optional server _dont-check info) + (nnheader-message 7 "nnnm: Opening %s -- %s" info group) + (if (nnnm--update-group-data group server) + (let ((n (length (nnnm--group-data group)))) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (nnheader-insert "211 %d %d %d %s\n" n 1 n group) + n)) + (nnheader-report 'nnnm "Invalid group"))) + +(deffoo nnnm-request-newgroups (_date &optional server) + (nnnm-request-list server)) + +(deffoo nnnm-request-group-scan (group &optional server _info) + (nnnm--set-group-data group nil) + (nnnm--update-group-data group server)) + +(deffoo nnnm-request-scan (&optional group server) + (if group + (nnnm--update-group-data group server) + (setq nnnm--group-data nil))) + +(deffoo nnnm-request-create-group (group &optional _server _args) + (let ((query (read-string "Query: "))) + (add-to-list 'nnnm-saved-searches `(:name ,group :query ,query)))) + +;; (deffoo nnnm-request-rename-group (group new-name &optional _server) +;; (error "Not implemented yet")) + +(deffoo nnnm-close-group (_group &optional _server) t) + + + +(provide 'nnnm) +;;; nnnm.el ends here -- cgit v1.2.3