(require 'nntp)
(require 'nnheader)
(require 'gnus)
(require 'nnoo)
(require 'gnus-util)
(require 'gnus-start)
(require 'gnus-sum)
(require 'gnus-msg)
(eval-when-compile (require 'cl))
(nnoo-declare nnvirtual)
(defvoo nnvirtual-always-rescan t
"If non-nil, always scan groups for unread articles when entering a group.
If this variable is nil 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.")
(defconst nnvirtual-version "nnvirtual 1.1")
(defvoo nnvirtual-current-group nil)
(defvoo nnvirtual-mapping-table nil
"Table of rules on how to map between component group and article number to virtual article number.")
(defvoo nnvirtual-mapping-offsets nil
"Table indexed by component group to an offset to be applied to article numbers in that group.")
(defvoo nnvirtual-mapping-len 0
"Number of articles in this virtual group.")
(defvoo nnvirtual-mapping-reads nil
"Compressed sequence of read articles on the virtual group as computed from the unread status of individual component groups.")
(defvoo nnvirtual-mapping-marks nil
"Compressed marks alist for the virtual group as computed from the marks of individual component groups.")
(defvoo nnvirtual-info-installed nil
"T if we have already installed the group info for this group, and shouldn't blast over it again.")
(defvoo nnvirtual-status-string "")
(eval-and-compile
(autoload 'gnus-cache-articles-in-group "gnus-cache"))
(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
(get-buffer-create " *virtual headers*")))
(carticles (nnvirtual-partition-sequence articles))
(system-name (system-name))
cgroup carticle article result prefix)
(while carticles
(setq cgroup (caar carticles))
(setq articles (cdar carticles))
(pop carticles)
(when (and articles
(gnus-check-server
(gnus-find-method-for-group cgroup) t)
(gnus-request-group cgroup t)
(setq prefix (gnus-group-real-prefix cgroup))
(let ((gnus-use-cache t))
(setq result (gnus-retrieve-headers
articles cgroup nil))))
(set-buffer nntp-server-buffer)
(when (eq result 'headers)
(nnvirtual-convert-headers))
(goto-char (point-min))
(while (not (eobp))
(delete-region (point)
(progn
(setq carticle (read nntp-server-buffer))
(point)))
(setq articles (delq carticle articles))
(setq article (nnvirtual-reverse-map-article cgroup carticle))
(if (null article)
(progn
(beginning-of-line)
(delete-region (point) (progn (forward-line 1) (point))))
(princ article nntp-server-buffer)
(nnvirtual-update-xref-header cgroup carticle
prefix system-name)
(forward-line 1))
)
(set-buffer vbuf)
(goto-char (point-max))
(insert-buffer-substring nntp-server-buffer))
(when articles
(gnus-group-make-articles-read cgroup articles))
)
(prog1
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-buffer-substring vbuf)
(sort-numeric-fields 1 (point-min) (point-max))
'nov)
(kill-buffer vbuf)))))))
(defvoo nnvirtual-last-accessed-component-group nil)
(deffoo nnvirtual-request-article (article &optional group server buffer)
(when (nnvirtual-possibly-change-server server)
(if (stringp article)
(cond
((not nnvirtual-last-accessed-component-group)
(nnheader-report
'nnvirtual "Don't know what server to request from"))
(t
(save-excursion
(when buffer
(set-buffer buffer))
(let* ((gnus-override-method nil)
(method (gnus-find-method-for-group
nnvirtual-last-accessed-component-group)))
(funcall (gnus-get-function method 'request-article)
article nil (nth 1 method) buffer)))))
(let* ((amap (nnvirtual-map-article article))
(cgroup (car amap)))
(cond
((not amap)
(nnheader-report 'nnvirtual "No such article: %s" article))
((not (gnus-check-group cgroup))
(nnheader-report
'nnvirtual "Can't open server where %s exists" cgroup))
((not (gnus-request-group cgroup t))
(nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
(t
(setq nnvirtual-last-accessed-component-group cgroup)
(if buffer
(save-excursion
(set-buffer buffer)
(let ((gnus-article-decode-hook nil))
(gnus-request-article-this-buffer (cdr amap) cgroup)))
(gnus-request-article (cdr amap) cgroup))))))))
(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-table nil
nnvirtual-mapping-offsets nil
nnvirtual-mapping-len 0
nnvirtual-mapping-reads nil
nnvirtual-mapping-marks nil
nnvirtual-info-installed nil)
(when nnvirtual-component-regexp
(let ((newsrc (cdr gnus-newsrc-alist))
group)
(while (setq group (car (pop newsrc)))
(when (string-match nnvirtual-component-regexp group) (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-component-groups)
(setq nnvirtual-current-group nil)
(nnheader-report 'nnvirtual "No component groups in %s" group))
(t
(setq nnvirtual-current-group group)
(when (or (not dont-check)
nnvirtual-always-rescan)
(nnvirtual-create-mapping)
(when nnvirtual-always-rescan
(nnvirtual-request-update-info
(nnvirtual-current-group)
(gnus-get-info (nnvirtual-current-group)))))
(nnheader-insert "211 %d 1 %d %s\n"
nnvirtual-mapping-len nnvirtual-mapping-len group))))
(deffoo nnvirtual-request-type (group &optional article)
(if (not article)
'unknown
(if (numberp article)
(let ((mart (nnvirtual-map-article article)))
(if mart
(gnus-request-type (car mart) (cdr mart))))
(gnus-request-type
nnvirtual-last-accessed-component-group nil))))
(deffoo nnvirtual-request-update-mark (group article mark)
(let* ((nart (nnvirtual-map-article article))
(cgroup (car nart)))
(when (and nart
(memq mark gnus-auto-expirable-marks)
(= mark (gnus-request-update-mark cgroup (cdr nart) mark))
(gnus-group-auto-expirable-p cgroup))
(setq mark gnus-expirable-mark)))
mark)
(deffoo nnvirtual-close-group (group &optional server)
(when (and (nnvirtual-possibly-change-server server)
(not (gnus-ephemeral-group-p (nnvirtual-current-group))))
(nnvirtual-update-read-and-marked t t))
t)
(deffoo nnvirtual-request-list (&optional server)
(nnheader-report 'nnvirtual "LIST is not implemented."))
(deffoo nnvirtual-request-newgroups (date &optional server)
(nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
(deffoo nnvirtual-request-list-newsgroups (&optional server)
(nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
(deffoo nnvirtual-request-update-info (group info &optional server)
(when (and (nnvirtual-possibly-change-server server)
(not nnvirtual-info-installed))
(gnus-atomic-progn
(setcar (cddr info) nnvirtual-mapping-reads)
(if (nthcdr 3 info)
(setcar (nthcdr 3 info) nnvirtual-mapping-marks)
(when nnvirtual-mapping-marks
(setcdr (nthcdr 2 info) (list nnvirtual-mapping-marks))))
(setq nnvirtual-info-installed t))
t))
(deffoo nnvirtual-catchup-group (group &optional server all)
(when (and (nnvirtual-possibly-change-server server)
(not (gnus-ephemeral-group-p (nnvirtual-current-group))))
(nnvirtual-update-read-and-marked nil nil)
(let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
(gnus-expert-user t))
(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)))))
(deffoo nnvirtual-find-group-art (group article)
"Return the real group and article for virtual GROUP and ARTICLE."
(nnvirtual-map-article article))
(deffoo nnvirtual-request-post (&optional server)
(if (not gnus-message-group-art)
(nnheader-report 'nnvirtual "Can't post to an nnvirtual group")
(let ((group (car (nnvirtual-find-group-art
(car gnus-message-group-art)
(cdr gnus-message-group-art)))))
(gnus-request-post (gnus-find-method-for-group group)))))
(deffoo nnvirtual-request-expire-articles (articles group
&optional server force)
(nnvirtual-possibly-change-server server)
(setq nnvirtual-component-groups
(delete (nnvirtual-current-group) nnvirtual-component-groups))
(let (unexpired)
(dolist (group nnvirtual-component-groups)
(setq unexpired (nconc unexpired
(mapcar
#'(lambda (article)
(nnvirtual-reverse-map-article
group article))
(gnus-uncompress-range
(gnus-group-expire-articles-1 group))))))
(sort (delq nil unexpired) '<)))
(defun nnvirtual-convert-headers ()
"Convert HEAD headers into NOV headers."
(save-excursion
(set-buffer nntp-server-buffer)
(let* ((dependencies (make-vector 100 0))
(headers (gnus-get-newsgroup-headers dependencies))
header)
(erase-buffer)
(while (setq header (pop headers))
(nnheader-insert-nov header)))))
(defun nnvirtual-update-xref-header (group article prefix system-name)
"Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines."
(beginning-of-line)
(looking-at
"[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
(goto-char (match-end 0))
(unless (search-forward "\t" (gnus-point-at-eol) 'move)
(insert "\t"))
(while (eq (char-after (1- (point))) ? )
(forward-char -1)
(delete-char 1))
(insert "Xref: " system-name " " group ":")
(princ article (current-buffer))
(insert " ")
(save-restriction
(narrow-to-region (point)
(or (search-forward "\t" (gnus-point-at-eol) t)
(gnus-point-at-eol)))
(goto-char (point-min))
(when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t)
(replace-match "" t t))
(goto-char (point-min))
(when (re-search-forward
(concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+")
nil t)
(replace-match "" t t))
(unless (eobp)
(insert " ")
(when (not (string= "" prefix))
(while (re-search-forward "[^ ]+:[0-9]+" nil t)
(save-excursion
(goto-char (match-beginning 0))
(insert prefix))))))
(end-of-line)
(or (eq (char-after (1- (point))) ?\t)
(insert ?\t)))
(defun nnvirtual-possibly-change-server (server)
(or (not server)
(nnoo-current-server-p 'nnvirtual server)
(nnvirtual-open-server server)))
(defun nnvirtual-update-read-and-marked (read-p update-p)
"Copy marks from the virtual group to the component groups.
If READ-P is not nil, update the (un)read status of the components.
If UPDATE-P is not nil, call gnus-group-update-group on the components."
(when nnvirtual-current-group
(let ((unreads (and read-p
(nnvirtual-partition-sequence
(gnus-list-of-unread-articles
(nnvirtual-current-group)))))
(type-marks
(delq nil
(mapcar (lambda (ml)
(if (eq (car ml) 'score)
nil
(cons (car ml)
(nnvirtual-partition-sequence (cdr ml)))))
(gnus-info-marks (gnus-get-info
(nnvirtual-current-group))))))
mark type groups carticles info entry)
(progn
(let ((gnus-newsgroup-active nil))
(while (setq entry (pop unreads))
(gnus-update-read-articles (car entry) (cdr entry))))
(setq groups nnvirtual-component-groups)
(while groups
(when (and (setq info (gnus-get-info (pop groups)))
(gnus-info-marks info))
(gnus-info-set-marks
info
(if (assq 'score (gnus-info-marks info))
(list (assq 'score (gnus-info-marks info)))
nil))))
(while (setq mark (pop type-marks))
(setq type (car mark))
(setq groups (cdr mark))
(while (setq carticles (pop groups))
(gnus-add-marked-articles (car carticles) type (cdr carticles)
nil t))))
(when update-p
(setq groups nnvirtual-component-groups)
(while groups
(gnus-group-update-group (pop groups) t))))))
(defun nnvirtual-current-group ()
"Return the prefixed name of the current nnvirtual group."
(concat "nnvirtual:" nnvirtual-current-group))
(defun nnvirtual-merge-sorted-lists (&rest lists)
"Merge many sorted lists of numbers."
(if (null (cdr lists))
(car lists)
(sort (apply 'nconc lists) '<)))
(defun nnvirtual-map-article (article)
"Return a cons of the component group and article corresponding to the given virtual ARTICLE."
(let ((table nnvirtual-mapping-table)
entry group-pos)
(while (and table
(> article (aref (car table) 3)))
(setq table (cdr table)))
(when (and table
(> article 0))
(setq entry (car table))
(setq article (- article (aref entry 4) 1))
(setq group-pos (mod article (aref entry 2)))
(cons (car (aref nnvirtual-mapping-offsets group-pos))
(+ (/ article (aref entry 2))
(aref entry 1)
(cdr (aref nnvirtual-mapping-offsets group-pos)))
))
))
(defun nnvirtual-reverse-map-article (group article)
"Return the virtual article number corresponding to the given component GROUP and ARTICLE."
(when (numberp article)
(let ((table nnvirtual-mapping-table)
(group-pos 0)
entry)
(while (not (string= group (car (aref nnvirtual-mapping-offsets
group-pos))))
(setq group-pos (1+ group-pos)))
(setq article (- article (cdr (aref nnvirtual-mapping-offsets
group-pos))))
(while (and table
(> article (aref (car table) 0)))
(setq table (cdr table)))
(setq entry (car table))
(when (and entry
(> article 0)
(< group-pos (aref entry 2))) (+ (aref entry 4)
group-pos
(* (- article (aref entry 1))
(aref entry 2))
1))
)))
(defsubst nnvirtual-reverse-map-sequence (group articles)
"Return list of virtual article numbers for all ARTICLES in GROUP.
The ARTICLES should be sorted, and can be a compressed sequence.
If any of the article numbers has no corresponding virtual article,
then it is left out of the result."
(when (numberp (cdr-safe articles))
(setq articles (list articles)))
(let (result a i j new-a)
(while (setq a (pop articles))
(if (atom a)
(setq i a
j a)
(setq i (car a)
j (cdr a)))
(while (<= i j)
(when (setq new-a (nnvirtual-reverse-map-article group i))
(push new-a result))
(setq i (1+ i))))
(nreverse result)))
(defun nnvirtual-partition-sequence (articles)
"Return an association list of component article numbers.
These are indexed by elements of nnvirtual-component-groups, based on
the sequence ARTICLES of virtual article numbers. ARTICLES should be
sorted, and can be a compressed sequence. If any of the article
numbers has no corresponding component article, then it is left out of
the result."
(when (numberp (cdr-safe articles))
(setq articles (list articles)))
(let ((carticles (mapcar (lambda (g) (list g))
nnvirtual-component-groups))
a i j article entry)
(while (setq a (pop articles))
(if (atom a)
(setq i a
j a)
(setq i (car a)
j (cdr a)))
(while (<= i j)
(when (setq article (nnvirtual-map-article i))
(setq entry (assoc (car article) carticles))
(setcdr entry (cons (cdr article) (cdr entry))))
(setq i (1+ i))))
(mapcar (lambda (x) (setcdr x (nreverse (cdr x))))
carticles)
carticles))
(defun nnvirtual-create-mapping ()
"Build the tables necessary to map between component (group, article) to virtual article.
Generate the set of read messages and marks for the virtual group
based on the marks on the component groups."
(let ((cnt 0)
(tot 0)
(M 0)
(i 0)
actives all-unreads all-marks
active min max size unreads marks
next-M next-tot
reads beg)
(mapcar (lambda (g)
(setq active (gnus-activate-group g)
min (car active)
max (cdr active))
(when (and active (>= max min) (not (zerop max)))
(push (list g (- max min -1) max) actives)
(setq unreads (gnus-list-of-unread-articles g))
(setq marks (gnus-info-marks (gnus-get-info g)))
(when gnus-use-cache
(push (cons 'cache
(gnus-cache-articles-in-group g))
marks))
(push (cons g unreads) all-unreads)
(push (cons g marks) all-marks)
(setq size (- max min -1))
(setq cnt (1+ cnt)
tot (+ tot size)
M (max M size))))
nnvirtual-component-groups)
(setq nnvirtual-mapping-len tot)
(setq actives (sort actives (lambda (g1 g2) (< (nth 1 g1) (nth 1 g2)))))
(setq nnvirtual-mapping-offsets
(vconcat
(nreverse
(mapcar (lambda (entry)
(cons (nth 0 entry)
(- (nth 2 entry) M)))
actives))))
(setq nnvirtual-mapping-table nil)
(setq actives (mapcar (lambda (entry) (nth 1 entry)) actives))
(while actives
(setq size (car actives))
(setq next-M (- M size))
(setq next-tot (- tot (* cnt size)))
(push (vector M next-M cnt tot (- next-tot cnt))
nnvirtual-mapping-table)
(setq M next-M)
(setq tot next-tot)
(setq actives (mapcar (lambda (x) (- x size)) actives))
(while (and actives
(= (car actives) 0))
(pop actives)
(setq cnt (- cnt 1))))
(setq unreads (apply 'nnvirtual-merge-sorted-lists
(mapcar (lambda (x)
(nnvirtual-reverse-map-sequence
(car x) (cdr x)))
all-unreads)))
(setq marks (mapcar
(lambda (type)
(cons (cdr type)
(gnus-compress-sequence
(apply
'nnvirtual-merge-sorted-lists
(mapcar (lambda (x)
(nnvirtual-reverse-map-sequence
(car x)
(cdr (assq (cdr type) (cdr x)))))
all-marks)))))
gnus-article-mark-lists))
(setq nnvirtual-mapping-marks nil)
(while marks
(if (cdr (car marks))
(push (car marks) nnvirtual-mapping-marks))
(setq marks (cdr marks)))
(while (and (<= (incf i) nnvirtual-mapping-len)
unreads)
(if (= i (car unreads))
(setq unreads (cdr unreads))
(setq beg i)
(while (and (<= (incf i) nnvirtual-mapping-len)
(not (= i (car unreads)))))
(setq i (- i 1))
(if (= i beg)
(push i reads)
(push (cons beg i) reads))
))
(when (<= i nnvirtual-mapping-len)
(if (= i nnvirtual-mapping-len)
(push i reads)
(push (cons i nnvirtual-mapping-len) reads)))
(setq nnvirtual-mapping-reads (nreverse reads))
(setq nnvirtual-info-installed nil)
))
(provide 'nnvirtual)