X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnvirtual.el;h=709f1971696eee27e7df0aa2ead74e0d727d55c4;hb=b19ab0bcf7b463d4b14b41bd23f2a5d62d03795a;hp=88e0fcc0f6b881ccccd76cb9dcf8d1c78a742e8f;hpb=e2ddae06fec591dad9c47153d3bb7a10c2d15184;p=gnus diff --git a/lisp/nnvirtual.el b/lisp/nnvirtual.el index 88e0fcc0f..709f19716 100644 --- a/lisp/nnvirtual.el +++ b/lisp/nnvirtual.el @@ -1,7 +1,7 @@ -;;;; nnvirtual.el --- Virtual newsgroups access for (ding) Gnus -;; Copyright (C) 1994,95 Free Software Foundation, Inc. +;;; nnvirtual.el --- virtual newsgroups access for Gnus +;; Copyright (C) 1994,95,96 Free Software Foundation, Inc. -;; Author: Lars Ingebrigtsen +;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA ;; Keywords: news @@ -18,8 +18,9 @@ ;; 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: @@ -32,229 +33,383 @@ (require 'nntp) (require 'nnheader) (require 'gnus) +(require 'nnoo) +(require 'gnus-util) +(require 'gnus-start) +(require 'gnus-sum) +(eval-when-compile (require 'cl)) -(defconst nnvirtual-version "nnvirtual 0.0" - "Version numbers of this version of nnvirual.") +(nnoo-declare nnvirtual) -(defvar nnvirtual-large-newsgroup 50 - "*The number of the articles which indicates a large newsgroup. -If the number of the articles is greater than the value, verbose -messages will be shown to indicate the current status.") +(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.") -(defvar nnvirtual-newsgroups nil - "The newsgroups that belong to this virtual newsgroup.") + -(defvar nnvirtual-newsgroups-regexp nil - "The newsgroups that belong to this virtual newsgroup.") +(defconst nnvirtual-version "nnvirtual 1.0") -(defvar nnvirtual-mapping nil) +(defvoo nnvirtual-current-group nil) +(defvoo nnvirtual-mapping nil) -(defvar nnvirtual-do-not-open nil) +(defvoo nnvirtual-status-string "") -(defvar nnvirtual-status-string "") +(eval-and-compile + (autoload 'gnus-cache-articles-in-group "gnus-cache")) ;;; Interface functions. -(defun nnvirtual-retrieve-headers (sequence &optional newsgroup server) - "Retrieve the headers for the articles in SEQUENCE." - (nnvirtual-possibly-change-newsgroups newsgroup server) - (save-excursion - (set-buffer (get-buffer-create "*virtual headers*")) - (erase-buffer) - (let ((number (length sequence)) - (count 0) - (nntp-xover-is-evil t) - (i 0) - prev articles group-articles beg art-info article group) - (if sequence (setq prev (car (aref nnvirtual-mapping (car sequence))))) - (while sequence - (setq art-info (aref nnvirtual-mapping (car sequence))) - (if (not (equal prev (car art-info))) - (progn - (setq group-articles (cons (list prev (nreverse articles)) - group-articles)) - (setq articles nil) - (setq prev (car art-info)))) - (setq articles (cons (cdr art-info) articles)) - (setq sequence (cdr sequence))) - (if prev - (setq group-articles (cons (list prev (nreverse articles)) - group-articles))) - (setq group-articles (nreverse group-articles)) - (while group-articles - (setq group (car (car group-articles))) - (gnus-retrieve-headers (car (cdr (car group-articles))) group) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char 1) - (insert "\n.\n") - (goto-char 1) - (while (search-forward "\n.\n" nil t) - (if (not (looking-at ".[0-9]+ \\([0-9]+\\) ")) - () - (setq article (string-to-int (gnus-buffer-substring 1 1))) - (setq i 1) - (while (/= article (cdr (aref nnvirtual-mapping i))) - (setq i (1+ i))) - (goto-char (match-beginning 1)) - (looking-at "[0-9]+ ") - (replace-match (format "%d " i)) - (setq beg (point)) - (search-forward "\n.\n" nil t) - (if (not (re-search-backward "^Xref: " beg t)) - (progn - (forward-char -2) - (insert (format "Xref: %s %s:%d\n" (system-name) - group article)) - (forward-char -1))) - ))) - (goto-char (point-max)) - (insert-buffer-substring nntp-server-buffer 4) - (setq group-articles (cdr group-articles))) - ;; Weed out articles that appear twice because of cross-posting. - ;; Suggested by Stephane Laveau . - (let ((id-hashtb (make-vector number 0)) - id) - (goto-char (point-min)) - ;; We look at the message-ids... - (while (search-forward "\nMessage-ID: " nil t) - ;; ... and check if they are entered into the hash table. - (if (boundp (setq id (intern (buffer-substring - (point) (progn (end-of-line) (point))) - id-hashtb))) - ;; Yup, so we delete this header. - (delete-region - (if (search-backward "\n.\n" nil t) (1+ (point)) (point-min)) - (if (search-forward "\n.\n" nil t) (1+ (match-beginning 0)) - (point-max)))) - ;; Nope, so we just enter it into the hash table. - (set id t))) - ;; The headers are ready for reading, so they are inserted into - ;; the nntp-server-buffer, which is where Gnus expects to find - ;; them. - (prog1 - (save-excursion - (if (not nntp-server-buffer) - (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) - (set-buffer nntp-server-buffer) - (erase-buffer) - (insert-buffer-substring "*virtual headers*") - 'headers) - (kill-buffer (current-buffer)))))) - -(defun nnvirtual-open-server (newsgroups &optional something) - "Open a virtual newsgroup that contains NEWSGROUPS." - (let ((newsrc gnus-newsrc-assoc)) - (setq nnvirtual-newsgroups nil) - (setq nnvirtual-newsgroups-regexp newsgroups) - (while newsrc - (if (string-match newsgroups (car (car newsrc))) - (setq nnvirtual-newsgroups (cons (car (car newsrc)) - nnvirtual-newsgroups))) - (setq newsrc (cdr newsrc))) - (if (null nnvirtual-newsgroups) - (setq nnvirtual-status-string - (format - "nnvirtual: No newsgroups for this virtual newsgroup")) - (nnvirtual-open-server-internal)) - nnvirtual-newsgroups)) - -(defun nnvirtual-close-server (&rest dum) - "Close news server." - (nnvirtual-close-server-internal)) - -(fset 'nnvirtual-request-quit (symbol-function 'nnvirtual-close-server)) - -(defun nnvirtual-server-opened (&optional server) - "Return server process status, T or NIL. -If the stream is opened, return T, otherwise return NIL." - (and nntp-server-buffer - (get-buffer nntp-server-buffer))) - -(defun nnvirtual-status-message () - "Return server status response as string." - nnvirtual-status-string) - -(defun nnvirtual-request-article (id &optional newsgroup server buffer) - "Select article by message ID (or number)." - (nnvirtual-possibly-change-newsgroups newsgroup server) - (let (art) - (setq art (aref nnvirtual-mapping id)) - (gnus-request-group (car art)) - (gnus-request-article (cdr art) (car art) buffer))) - -(defun nnvirtual-request-group (group &optional server dont-check) - "Make GROUP the current newsgroup." - (nnvirtual-possibly-change-newsgroups nil server) - (let* ((group (concat gnus-foreign-group-prefix group)) - (info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) - (groups nnvirtual-newsgroups) - (i 0) - (total 0) - unread igroup) - (if (not info) - (error "No such group: %s" group)) - (setcar (nthcdr 2 info) nil) - (while groups - (setq unread (car (gnus-gethash (car groups) gnus-newsrc-hashtb))) - (if (numberp unread) (setq total (+ total unread))) - (setq groups (cdr groups))) - (setq nnvirtual-mapping (make-vector (+ 3 total) nil)) - (setq groups nnvirtual-newsgroups) - (while groups - (setq igroup (car groups)) - (setq unread (gnus-list-of-unread-articles igroup)) - (while unread - (aset nnvirtual-mapping (setq i (1+ i)) (cons igroup (car unread))) - (setq unread (cdr unread))) - (setq groups (cdr groups))) +(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) - (insert (format "211 %d %d %d %s\n" (1+ total) 1 total group))) - t)) - -(defun nnvirtual-request-list (&optional server) - "List active newsgoups." - (setq nnvirtual-status-string "nnvirtual: LIST is not implemented.") - nil) - -(defun nnvirtual-request-list-newsgroups (&optional server) - "List newsgroups (defined in NNTP2)." - (setq nnvirtual-status-string "nnvirtual: LIST NEWSGROUPS is not implemented.") - nil) - -(fset 'nnvirtual-request-post 'nntp-request-post) + (if (stringp (car articles)) + 'headers + (let ((vbuf (nnheader-set-temp-buffer + (get-buffer-create " *virtual headers*"))) + (unfetched (mapcar (lambda (g) (list g)) + nnvirtual-component-groups)) + (system-name (system-name)) + cgroup article result prefix) + (while articles + (setq article (assq (pop articles) nnvirtual-mapping)) + (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 + ;; component group. + (while unfetched + (when (cdar unfetched) + (gnus-group-make-articles-read + (caar unfetched) (sort (cdar unfetched) '<))) + (setq unfetched (cdr unfetched))) + + ;; The headers are ready for reading, so they are inserted into + ;; the nntp-server-buffer, which is where Gnus expects to find + ;; them. + (prog1 + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring vbuf) + 'nov) + (kill-buffer vbuf))))))) + +(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))) + (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 + (if buffer + (save-excursion + (set-buffer buffer) + (gnus-request-article-this-buffer (caddr amap) cgroup)) + (gnus-request-article (caddr 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 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-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))))) + +(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) + +(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)) + 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 (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 + (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 (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) + ;; Add the marks lists to the end of the info. + (when marks + (setcdr (nthcdr 2 info) (list marks)))) + t))) + +(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)))) -(fset 'nnvirtual-request-post-buffer 'nntp-request-post-buffer) +(deffoo nnvirtual-find-group-art (group article) + "Return the real group and article for virtual GROUP and ARTICLE." + (let ((mart (assq article nnvirtual-mapping))) + (when mart + (cons (cadr mart) (caddr mart))))) -;;; Low-Level Interface +;;; Internal functions. -(defun nnvirtual-open-server-internal () - "Fix some internal variables." +(defun nnvirtual-convert-headers () + "Convert HEAD headers into NOV headers." (save-excursion - ;; Initialize communicatin buffer. - (setq nnvirtual-mapping nil) - (setq nntp-server-buffer (get-buffer-create " *nntpd*")) (set-buffer nntp-server-buffer) - (buffer-disable-undo (current-buffer)) - (kill-all-local-variables) - (setq case-fold-search t))) - -(defun nnvirtual-close-server-internal (&rest dum) - "Close connection to news server." - nil) - -(defun nnvirtual-possibly-change-newsgroups (group groups-regexp) - (if (and groups-regexp - (not (and nnvirtual-newsgroups-regexp - (string= groups-regexp nnvirtual-newsgroups-regexp)))) - (nnvirtual-open-server groups-regexp))) + (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-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) + (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 + (when (memq article (cdar marks)) + (push (caar marks) out)) + (setq marks (cdr marks))) + out)) + +(defun nnvirtual-create-mapping () + "Create an article mapping for the current group." + (let* ((div nil) + m marks list article unreads marks active + (map (sort + (apply + 'nconc + (mapcar + (lambda (g) + (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)))))) (provide 'nnvirtual)