X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnvirtual.el;h=709f1971696eee27e7df0aa2ead74e0d727d55c4;hb=b19ab0bcf7b463d4b14b41bd23f2a5d62d03795a;hp=af07285d5cd7d98f821111136bf3c2d8e374a4fa;hpb=b36b862ca27ad784cbad9cdb36e9d1a97b0c0b97;p=gnus diff --git a/lisp/nnvirtual.el b/lisp/nnvirtual.el index af07285d5..709f19716 100644 --- a/lisp/nnvirtual.el +++ b/lisp/nnvirtual.el @@ -33,26 +33,35 @@ (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.") + -(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")) @@ -61,18 +70,22 @@ virtual group.") ;;; 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)) (system-name (system-name)) - beg cgroup active article result prefix) + cgroup article result prefix) (while articles (setq article (assq (pop articles) nnvirtual-mapping)) (when (and (setq cgroup (cadr article)) @@ -81,7 +94,7 @@ virtual group.") (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))) @@ -153,28 +166,8 @@ virtual group.") '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))) @@ -193,76 +186,107 @@ virtual group.") (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 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) @@ -271,17 +295,22 @@ virtual group.") (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))))) @@ -298,63 +327,20 @@ virtual group.") 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) - (uncompressed '(score bookmark)) - type list calist mart cgroups) - (while mark-lists - (setq type (cdar mark-lists)) - (setq list (symbol-value (intern (format "gnus-newsgroup-%s" - (car (pop mark-lists)))))) + (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 @@ -366,6 +352,22 @@ virtual group.") (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) @@ -377,47 +379,37 @@ virtual group.") (defun nnvirtual-create-mapping () "Create an article mapping for the current group." - (let* (div m marks list article + (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)))))) - 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) + ;; 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 (setq article (incf i)))))) (provide 'nnvirtual)