;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; 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.
;;; Commentary:
(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 ((map nnvirtual-mapping)
- (vbuf (nnheader-set-temp-buffer
+ (let ((vbuf (nnheader-set-temp-buffer
(get-buffer-create " *virtual headers*")))
(unfetched (mapcar (lambda (g) (list g))
nnvirtual-component-groups))
- beg cgroup active article result prefix)
+ (system-name (system-name))
+ cgroup article result prefix)
(while articles
(setq article (assq (pop articles) nnvirtual-mapping))
- (setq cgroup (cadr article))
- (gnus-request-group cgroup t)
- (setq prefix (gnus-group-real-prefix cgroup))
- (when (setq result (gnus-retrieve-headers
- (list (caddr article)) cgroup))
- (set-buffer nntp-server-buffer)
- (if (zerop (buffer-size))
- (nconc (assq cgroup unfetched) (list (caddr article)))
- ;; If we got HEAD headers, we convert them into NOV
- ;; headers. This is slow, inefficient and, come to think
- ;; of it, downright evil. So sue me. I couldn't be
- ;; bothered to write a header parse routine that could
- ;; parse a mixed HEAD/NOV buffer.
- (when (eq result 'headers)
- (nnvirtual-convert-headers))
- (goto-char (point-min))
- (while (not (eobp))
- (delete-region
- (point) (progn (read nntp-server-buffer) (point)))
- (insert (int-to-string (car article)))
- (beginning-of-line)
- (looking-at
- "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
- (goto-char (match-end 0))
- (or (search-forward
- "\t" (save-excursion (end-of-line) (point)) t)
- (end-of-line))
- (while (= (char-after (1- (point))) ? )
- (forward-char -1)
- (delete-char 1))
- (if (eolp)
- (progn
- (end-of-line)
- (or (= (char-after (1- (point))) ?\t)
- (insert ?\t))
- (insert (format "Xref: %s %s:%d\t" (system-name)
- cgroup (caddr article))))
- (if (not (string= "" prefix))
- (while (re-search-forward
- "[^ ]+:[0-9]+"
- (save-excursion (end-of-line) (point)) t)
- (save-excursion
- (goto-char (match-beginning 0))
- (insert prefix))))
- (end-of-line)
- (or (= (char-after (1- (point))) ?\t)
- (insert ?\t)))
- (forward-line 1))
- (set-buffer vbuf)
- (goto-char (point-max))
- (insert-buffer-substring nntp-server-buffer))))
+ (when (and (setq cgroup (cadr article))
+ (gnus-check-server
+ (gnus-find-method-for-group cgroup) t)
+ (gnus-request-group cgroup t))
+ (setq prefix (gnus-group-real-prefix cgroup))
+ (when (setq result (gnus-retrieve-headers
+ (list (caddr article)) cgroup nil))
+ (set-buffer nntp-server-buffer)
+ (if (zerop (buffer-size))
+ (nconc (assq cgroup unfetched) (list (caddr article)))
+ ;; If we got HEAD headers, we convert them into NOV
+ ;; headers. This is slow, inefficient and, come to think
+ ;; of it, downright evil. So sue me. I couldn't be
+ ;; bothered to write a header parse routine that could
+ ;; parse a mixed HEAD/NOV buffer.
+ (when (eq result 'headers)
+ (nnvirtual-convert-headers))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (delete-region
+ (point) (progn (read nntp-server-buffer) (point)))
+ (princ (car article) (current-buffer))
+ (beginning-of-line)
+ (looking-at
+ "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
+ (goto-char (match-end 0))
+ (or (search-forward
+ "\t" (save-excursion (end-of-line) (point)) t)
+ (end-of-line))
+ (while (= (char-after (1- (point))) ? )
+ (forward-char -1)
+ (delete-char 1))
+ (if (eolp)
+ (progn
+ (end-of-line)
+ (or (= (char-after (1- (point))) ?\t)
+ (insert ?\t))
+ (insert "Xref: " system-name " " cgroup ":")
+ (princ (caddr article) (current-buffer))
+ (insert "\t"))
+ (insert "Xref: " system-name " " cgroup ":")
+ (princ (caddr article) (current-buffer))
+ (insert " ")
+ (if (not (string= "" prefix))
+ (while (re-search-forward
+ "[^ ]+:[0-9]+"
+ (save-excursion (end-of-line) (point)) t)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (insert prefix))))
+ (end-of-line)
+ (or (= (char-after (1- (point))) ?\t)
+ (insert ?\t)))
+ (forward-line 1))
+ (set-buffer vbuf)
+ (goto-char (point-max))
+ (insert-buffer-substring nntp-server-buffer)))))
;; In case some of the articles have expired or been
;; cancelled, we have to mark them as read in the
'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 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 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 marks mr m op)
+ 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)))
- (cons (cadr mart) (caddr mart))))
+ (when mart
+ (cons (cadr mart) (caddr mart)))))
\f
;;; Internal functions.
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 dont-check)
- (let ((inf t))
- (unless (equal group nnvirtual-current-group)
- (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
- (or (not inf)
- (not dont-check)))
- (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 (car (car newsrc)))
- (not (string= (car (car newsrc)) virt-group))
- (setq nnvirtual-component-groups
- (cons (car (car 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)
- (uncompressed '(score bookmark))
- type list calist mart cgroups)
- (while mark-lists
- (setq type (cdar mark-lists))
- (when (setq list (symbol-value (intern (format "gnus-newsgroup-%s"
- (car (pop mark-lists))))))
- (setq cgroups
- (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
- (while list
- (nconc (assoc (cadr (setq mart (assq (pop list) nnvirtual-mapping)))
- cgroups)
- (list (caddr mart))))
- (while cgroups
- (when (cdar cgroups)
- (gnus-add-marked-articles
- (caar cgroups) type (cdar cgroups) nil t)
- (gnus-group-update-group (caar cgroups) t))
- (setq cgroups (cdr cgroups)))))))
-
-(defun nnvirtual-marks (article marks)
+ (marks (gnus-info-marks (gnus-get-info (nnvirtual-current-group))))
+ type list mart cgroups)
+ (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
+ (nconc (assoc (cadr (setq mart (assq (pop list) nnvirtual-mapping)))
+ cgroups)
+ (list (caddr mart))))
+ (while cgroups
+ (gnus-add-marked-articles
+ (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)
(while marks
(defun nnvirtual-create-mapping ()
"Create an article mapping for the current group."
- (let* (div
+ (let* ((div nil)
+ m marks list article 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))))))
+ (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)
- (while map
- (setcar (pop map) (incf i)))))
+ ;; Set the virtual article numbers.
+ (while (setq m (pop map))
+ (setcar m (setq article (incf i))))))
(provide 'nnvirtual)
projects / gnus / blobdiff