;;; Commentary:
;; The other access methods (nntp, nnspool, etc) are general news
-;; access methods. This module relies on Gnus and can not be used
+;; access methods. This module relies on Gnus and can not be used
;; separately.
;;; Code:
(require 'nntp)
(require 'nnheader)
(require 'gnus)
+(require 'nnoo)
+(require 'gnus-util)
+(require 'gnus-start)
+(require 'gnus-sum)
(eval-when-compile (require 'cl))
-(defvar nnvirtual-always-rescan nil
+(nnoo-declare nnvirtual)
+
+(defvoo nnvirtual-always-rescan nil
"*If non-nil, always scan groups for unread articles when entering a group.
If this variable is nil (which is the default) and you read articles
in a component group after the virtual group has been activated, the
read articles from the component group will show up when you enter the
virtual group.")
+(defvoo nnvirtual-component-regexp nil
+ "*Regexp to match component groups.")
+
+(defvoo nnvirtual-component-groups nil
+ "Component group in this nnvirtual group.")
+
\f
-(defconst nnvirtual-version "nnvirtual 1.0"
- "Version number of this version of nnvirtual.")
+(defconst nnvirtual-version "nnvirtual 1.0")
-(defvar nnvirtual-group-alist nil)
-(defvar nnvirtual-current-group nil)
-(defvar nnvirtual-component-groups nil)
-(defvar nnvirtual-mapping nil)
+(defvoo nnvirtual-current-group nil)
+(defvoo nnvirtual-mapping nil)
-(defvar nnvirtual-status-string "")
+(defvoo nnvirtual-status-string "")
(eval-and-compile
(autoload 'gnus-cache-articles-in-group "gnus-cache"))
;;; Interface functions.
-(defun nnvirtual-retrieve-headers (articles &optional newsgroup server fetch-old)
- (when (nnvirtual-possibly-change-group newsgroup server t)
+(nnoo-define-basics nnvirtual)
+
+(deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
+ server fetch-old)
+ (when (nnvirtual-possibly-change-server server)
(save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
(if (stringp (car articles))
'headers
(let ((vbuf (nnheader-set-temp-buffer
(gnus-request-group cgroup t))
(setq prefix (gnus-group-real-prefix cgroup))
(when (setq result (gnus-retrieve-headers
- (list (caddr article)) cgroup fetch-old))
+ (list (caddr article)) cgroup nil))
(set-buffer nntp-server-buffer)
(if (zerop (buffer-size))
(nconc (assq cgroup unfetched) (list (caddr article)))
'nov)
(kill-buffer vbuf)))))))
-(defun nnvirtual-open-server (server &optional something)
- (nnheader-init-server-buffer))
-
-(defun nnvirtual-close-server (&rest dum)
- t)
-
-(defun nnvirtual-request-close ()
- (setq nnvirtual-current-group nil
- nnvirtual-component-groups nil
- nnvirtual-mapping nil
- nnvirtual-group-alist nil)
- t)
-
-(defun nnvirtual-server-opened (&optional server)
- (and nntp-server-buffer
- (get-buffer nntp-server-buffer)))
-
-(defun nnvirtual-status-message (&optional server)
- nnvirtual-status-string)
-
-(defun nnvirtual-request-article (article &optional group server buffer)
- (when (and (nnvirtual-possibly-change-group group server t)
+(deffoo nnvirtual-request-article (article &optional group server buffer)
+ (when (and (nnvirtual-possibly-change-server server)
(numberp article))
(let* ((amap (assq article nnvirtual-mapping))
(cgroup (cadr amap)))
(gnus-request-article-this-buffer (caddr amap) cgroup))
(gnus-request-article (caddr amap) cgroup)))))))
-(defun nnvirtual-request-group (group &optional server dont-check)
+(deffoo nnvirtual-open-server (server &optional defs)
+ (unless (assq 'nnvirtual-component-regexp defs)
+ (push `(nnvirtual-component-regexp ,server)
+ defs))
+ (nnoo-change-server 'nnvirtual server defs)
+ (if nnvirtual-component-groups
+ t
+ (setq nnvirtual-mapping nil)
+ (when nnvirtual-component-regexp
+ ;; Go through the newsrc alist and find all component groups.
+ (let ((newsrc (cdr gnus-newsrc-alist))
+ group)
+ (while (setq group (car (pop newsrc)))
+ (when (string-match nnvirtual-component-regexp group) ; Match
+ ;; Add this group to the list of component groups.
+ (setq nnvirtual-component-groups
+ (cons group (delete group nnvirtual-component-groups)))))))
+ (if (not nnvirtual-component-groups)
+ (nnheader-report 'nnvirtual "No component groups: %s" server)
+ t)))
+
+(deffoo nnvirtual-request-group (group &optional server dont-check)
+ (nnvirtual-possibly-change-server server)
+ (setq nnvirtual-component-groups
+ (delete (nnvirtual-current-group) nnvirtual-component-groups))
(cond
- ((null (nnvirtual-possibly-change-group
- group server
- (if nnvirtual-always-rescan nil (not dont-check))))
+ ((null nnvirtual-component-groups)
(setq nnvirtual-current-group nil)
(nnheader-report 'nnvirtual "No component groups in %s" group))
(t
+ (unless dont-check
+ (nnvirtual-create-mapping))
+ (setq nnvirtual-current-group group)
(let ((len (length nnvirtual-mapping)))
(nnheader-insert "211 %d 1 %d %s\n" len len group)))))
-(defun nnvirtual-request-type (group &optional article)
- (when (nnvirtual-possibly-change-group group nil t)
- (if (not article)
- 'unknown
- (let ((mart (assq article nnvirtual-mapping)))
- (when mart
- (gnus-request-type (cadr mart) (car mart)))))))
-
-(defun nnvirtual-request-update-mark (group article mark)
- (when (nnvirtual-possibly-change-group group nil t)
- (let* ((nart (assq article nnvirtual-mapping))
- (cgroup (cadr nart))
- ;; The component group might be a virtual group.
- (nmark (gnus-request-update-mark cgroup (caddr nart) mark)))
- (when (and (= mark nmark)
- (gnus-group-auto-expirable-p cgroup))
- (setq mark gnus-expirable-mark))))
+(deffoo nnvirtual-request-type (group &optional article)
+ (if (not article)
+ 'unknown
+ (let ((mart (assq article nnvirtual-mapping)))
+ (when mart
+ (gnus-request-type (cadr mart) (car mart))))))
+
+(deffoo nnvirtual-request-update-mark (group article mark)
+ (let* ((nart (assq article nnvirtual-mapping))
+ (cgroup (cadr nart))
+ ;; The component group might be a virtual group.
+ (nmark (gnus-request-update-mark cgroup (caddr nart) mark)))
+ (when (and nart
+ (= mark nmark)
+ (gnus-group-auto-expirable-p cgroup))
+ (setq mark gnus-expirable-mark)))
mark)
-(defun nnvirtual-close-group (group &optional server)
- (when (nnvirtual-possibly-change-group group server t)
+(deffoo nnvirtual-close-group (group &optional server)
+ (when (and (nnvirtual-possibly-change-server server)
+ (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
+ ;; Copy (un)read articles.
+ (nnvirtual-update-reads)
;; We copy the marks from this group to the component
;; groups here.
- (nnvirtual-update-marked)
- ;; Reset all relevant variables.
- (setq nnvirtual-current-group nil
- nnvirtual-component-groups nil
- nnvirtual-mapping nil)
- (setq nnvirtual-group-alist
- (delq (assoc group nnvirtual-group-alist) nnvirtual-group-alist)))
+ (nnvirtual-update-marked))
t)
-(defun nnvirtual-request-list (&optional server)
+(deffoo nnvirtual-request-list (&optional server)
(nnheader-report 'nnvirtual "LIST is not implemented."))
-(defun nnvirtual-request-newgroups (date &optional server)
+(deffoo nnvirtual-request-newgroups (date &optional server)
(nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
-(defun nnvirtual-request-list-newsgroups (&optional server)
+(deffoo nnvirtual-request-list-newsgroups (&optional server)
(nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
-(defun nnvirtual-request-update-info (group info &optional server)
- (when (nnvirtual-possibly-change-group group server)
+(deffoo nnvirtual-request-update-info (group info &optional server)
+ (when (nnvirtual-possibly-change-server server)
(let ((map nnvirtual-mapping)
(marks (mapcar (lambda (m) (list (cdr m))) gnus-article-mark-lists))
reads mr m op)
+ ;; Go through the mapping.
(while map
- (setq m (pop map))
- (unless (nth 3 m)
+ (unless (nth 3 (setq m (pop map)))
+ ;; Read article.
(push (car m) reads))
+ ;; Copy marks.
(when (setq mr (nth 4 m))
(while mr
(setcdr (setq op (assq (pop mr) marks)) (cons (car m) (cdr op))))))
+ ;; Compress the marks and the reads.
(setq mr marks)
(while mr
- (setcdr (car mr) (gnus-compress-sequence (sort (cdar mr) '<)))
- (setq mr (cdr mr)))
+ (setcdr (car mr) (gnus-compress-sequence (sort (cdr (pop mr)) '<))))
(setcar (cddr info) (gnus-compress-sequence (nreverse reads)))
-
+ ;; Remove empty marks lists.
+ (while (and marks (not (cdar marks)))
+ (setq marks (cdr marks)))
+ (setq mr marks)
+ (while (cdr mr)
+ (if (cdadr mr)
+ (setq mr (cdr mr))
+ (setcdr mr (cddr mr))))
+
;; Enter these new marks into the info of the group.
(if (nthcdr 3 info)
(setcar (nthcdr 3 info) marks)
(setcdr (nthcdr 2 info) (list marks))))
t)))
-(defun nnvirtual-catchup-group (group &optional server all)
- (nnvirtual-possibly-change-group group server t)
- (let ((gnus-group-marked nnvirtual-component-groups)
+(deffoo nnvirtual-catchup-group (group &optional server all)
+ (nnvirtual-possibly-change-server server)
+ (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
(gnus-expert-user t))
+ ;; Make sure all groups are activated.
+ (mapcar
+ (lambda (g)
+ (when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb))))
+ (gnus-activate-group g)))
+ nnvirtual-component-groups)
(save-excursion
(set-buffer gnus-group-buffer)
(gnus-group-catchup-current nil all))))
-(defun nnvirtual-find-group-art (group article)
+(deffoo nnvirtual-find-group-art (group article)
"Return the real group and article for virtual GROUP and ARTICLE."
- (nnvirtual-possibly-change-group group nil t)
(let ((mart (assq article nnvirtual-mapping)))
(when mart
(cons (cadr mart) (caddr mart)))))
header)
(erase-buffer)
(while (setq header (pop headers))
- (insert (int-to-string (mail-header-number header)) "\t"
- (or (mail-header-subject header) "") "\t"
- (or (mail-header-from header) "") "\t"
- (or (mail-header-date header) "") "\t"
- (or (mail-header-id header) "") "\t"
- (or (mail-header-references header) "") "\t"
- (int-to-string (or (mail-header-chars header) 0)) "\t"
- (int-to-string (or (mail-header-lines header) 0)) "\t"
- (if (mail-header-xref header)
- (concat "Xref: " (mail-header-xref header) "\t")
- "") "\n")))))
-
-(defun nnvirtual-possibly-change-group (group regexp &optional check)
- (let ((inf t))
- (when (or (not (equal group nnvirtual-current-group))
- check)
- (and (setq inf (assoc group nnvirtual-group-alist))
- regexp
- (string= (nth 3 inf) regexp)
- (progn
- (setq nnvirtual-current-group (car inf))
- (setq nnvirtual-component-groups (nth 1 inf))
- (setq nnvirtual-mapping (nth 2 inf))))
- (when (and regexp (not inf))
- (and inf (setq nnvirtual-group-alist
- (delq inf nnvirtual-group-alist)))
- (setq nnvirtual-mapping nil)
- (setq nnvirtual-current-group group)
- (let ((newsrc gnus-newsrc-alist)
- (virt-group (gnus-group-prefixed-name
- nnvirtual-current-group '(nnvirtual ""))))
- (setq nnvirtual-component-groups nil)
- (while newsrc
- (and (string-match regexp (caar newsrc))
- (not (string= (caar newsrc) virt-group))
- (setq nnvirtual-component-groups
- (cons (caar newsrc) nnvirtual-component-groups)))
- (setq newsrc (cdr newsrc))))
- (if nnvirtual-component-groups
- (progn
- (nnvirtual-create-mapping)
- (setq nnvirtual-group-alist
- (cons (list group nnvirtual-component-groups
- nnvirtual-mapping regexp)
- nnvirtual-group-alist)))
- (nnheader-report 'nnvirtual "No component groups: %s" group)))))
- nnvirtual-component-groups)
+ (nnheader-insert-nov header)))))
+
+(defun nnvirtual-possibly-change-server (server)
+ (or (not server)
+ (nnoo-current-server-p 'nnvirtual server)
+ (nnvirtual-open-server server)))
(defun nnvirtual-update-marked ()
"Copy marks from the virtual group to the component groups."
(let ((mark-lists gnus-article-mark-lists)
+ (marks (gnus-info-marks (gnus-get-info (nnvirtual-current-group))))
type list mart cgroups)
- (when (and gnus-summary-buffer
- (get-buffer gnus-summary-buffer)
- (buffer-name (get-buffer gnus-summary-buffer)))
- (set-buffer gnus-summary-buffer))
- (while mark-lists
- (setq type (cdar mark-lists))
- (setq list (symbol-value (intern (format "gnus-newsgroup-%s"
- (car (pop mark-lists))))))
+ (while (setq type (cdr (pop mark-lists)))
+ (setq list (gnus-uncompress-range (cdr (assq type marks))))
(setq cgroups
(mapcar (lambda (g) (list g)) nnvirtual-component-groups))
(while list
(caar cgroups) type (cdar cgroups) nil t)
(gnus-group-update-group (car (pop cgroups)) t)))))
+(defun nnvirtual-update-reads ()
+ "Copy (un)reads from the current group to the component groups."
+ (let ((groups (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
+ (articles (gnus-list-of-unread-articles
+ (nnvirtual-current-group)))
+ m)
+ (while articles
+ (setq m (assq (pop articles) nnvirtual-mapping))
+ (nconc (assoc (nth 1 m) groups) (list (nth 2 m))))
+ (while groups
+ (gnus-update-read-articles (caar groups) (cdr (pop groups))))))
+
+(defun nnvirtual-current-group ()
+ "Return the prefixed name of the current nnvirtual group."
+ (concat "nnvirtual:" nnvirtual-current-group))
+
(defsubst nnvirtual-marks (article marks)
"Return a list of mark types for ARTICLE."
(let (out)
(defun nnvirtual-create-mapping ()
"Create an article mapping for the current group."
- (let* (div m marks list article
+ (let* ((div nil)
+ m unreads marks active
(map (sort
(apply
'nconc
(mapcar
(lambda (g)
- (let* ((active (or (gnus-active g) (gnus-activate-group g)))
- (unreads (and active (gnus-list-of-unread-articles
- g)))
- (marks (gnus-uncompress-marks
- (gnus-info-marks (gnus-get-info g)))))
- (when active
- (when gnus-use-cache
- (push (cons 'cache (gnus-cache-articles-in-group g))
- marks))
- (when active
- (setq div (/ (float (car active))
- (if (zerop (cdr active))
- 1 (cdr active)) ))
- (mapcar (lambda (n)
- (list (* div (- n (car active)))
- g n (and (memq n unreads) t)
- (nnvirtual-marks n marks)))
- (gnus-uncompress-range active))))))
- nnvirtual-component-groups))
+ (when (and (setq active (gnus-activate-group g))
+ (> (cdr active) (car active)))
+ (setq unreads (gnus-list-of-unread-articles g)
+ marks (gnus-uncompress-marks
+ (gnus-info-marks (gnus-get-info g))))
+ (when gnus-use-cache
+ (push (cons 'cache (gnus-cache-articles-in-group g))
+ marks))
+ (setq div (/ (float (car active))
+ (if (zerop (cdr active))
+ 1 (cdr active))))
+ (mapcar (lambda (n)
+ (list (* div (- n (car active)))
+ g n (and (memq n unreads) t)
+ (inline (nnvirtual-marks n marks))))
+ (gnus-uncompress-range active))))
+ nnvirtual-component-groups))
(lambda (m1 m2)
(< (car m1) (car m2)))))
(i 0))
(setq nnvirtual-mapping map)
- ;; Nix out any old marks.
- (let ((marks gnus-article-mark-lists))
- (set (intern (format "gnus-newsgroup-%s" (car (pop marks)))) nil))
- ;; Copy in all marks from the component groups.
+ ;; Set the virtual article numbers.
(while (setq m (pop map))
- (setcar m (setq article (incf i)))
- (when (setq marks (nth 4 m))
- (while marks
- (set (setq list
- (intern (concat "gnus-newsgroup-"
- (symbol-name
- (car (rassq (pop marks)
- gnus-article-mark-lists))))))
- (cons article (symbol-value list))))))))
+ (setcar m (incf i)))))
(provide 'nnvirtual)
projects / gnus / blobdiff