/[emacs]/emacs/lisp/gnus/gnus-cache.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-cache.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6.18.2 by miles, Tue Oct 14 23:34:50 2003 UTC revision 1.6.18.3 by miles, Thu Sep 16 00:12:15 2004 UTC
# Line 1  Line 1 
1  ;;; gnus-cache.el --- cache interface for Gnus  ;;; gnus-cache.el --- cache interface for Gnus
2  ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000  ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
3  ;;        Free Software Foundation, Inc.  ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
# Line 33  Line 33 
33  (require 'gnus-range)  (require 'gnus-range)
34  (require 'gnus-start)  (require 'gnus-start)
35  (eval-when-compile  (eval-when-compile
36      (if (not (fboundp 'gnus-agent-load-alist))
37          (defun gnus-agent-load-alist (group)))
38    (require 'gnus-sum))    (require 'gnus-sum))
39    
40  (defcustom gnus-cache-active-file  (defcustom gnus-cache-active-file
# Line 160  it's not cached." Line 162  it's not cached."
162        (when (and number        (when (and number
163                   (> number 0)           ; Reffed article.                   (> number 0)           ; Reffed article.
164                   (or force                   (or force
165                       (and (or (not gnus-cacheable-groups)                       (and (gnus-cache-fully-p group)
                               (string-match gnus-cacheable-groups group))  
                           (or (not gnus-uncacheable-groups)  
                               (not (string-match  
                                     gnus-uncacheable-groups group)))  
166                            (gnus-cache-member-of-class                            (gnus-cache-member-of-class
167                             gnus-cache-enter-articles ticked dormant unread)))                             gnus-cache-enter-articles ticked dormant unread)))
168                   (not (file-exists-p (setq file (gnus-cache-file-name                   (not (file-exists-p (setq file (gnus-cache-file-name
# Line 183  it's not cached." Line 181  it's not cached."
181              (when (> (buffer-size) 0)              (when (> (buffer-size) 0)
182                (let ((coding-system-for-write gnus-cache-coding-system))                (let ((coding-system-for-write gnus-cache-coding-system))
183                  (gnus-write-buffer file))                  (gnus-write-buffer file))
184                (setq headers (nnheader-parse-head t))                (nnheader-remove-body)
185                  (setq headers (nnheader-parse-naked-head))
186                (mail-header-set-number headers number)                (mail-header-set-number headers number)
187                (gnus-cache-change-buffer group)                (gnus-cache-change-buffer group)
188                (set-buffer (cdr gnus-cache-buffer))                (set-buffer (cdr gnus-cache-buffer))
# Line 209  it's not cached." Line 208  it's not cached."
208                (nnheader-insert-nov headers)                (nnheader-insert-nov headers)
209                ;; Update the active info.                ;; Update the active info.
210                (set-buffer gnus-summary-buffer)                (set-buffer gnus-summary-buffer)
211                (gnus-cache-update-active group number)                (gnus-cache-possibly-update-active group (cons number number))
212                (push article gnus-newsgroup-cached)                (setq gnus-newsgroup-cached
213                        (gnus-add-to-sorted-list gnus-newsgroup-cached article))
214                (gnus-summary-update-secondary-mark article))                (gnus-summary-update-secondary-mark article))
215              t))))))              t))))))
216    
# Line 235  it's not cached." Line 235  it's not cached."
235    
236  (defun gnus-cache-possibly-remove-articles-1 ()  (defun gnus-cache-possibly-remove-articles-1 ()
237    "Possibly remove some of the removable articles."    "Possibly remove some of the removable articles."
238    (unless (eq gnus-use-cache 'passive)    (when (gnus-cache-fully-p gnus-newsgroup-name)
239      (let ((articles gnus-cache-removable-articles)      (let ((articles gnus-cache-removable-articles)
240            (cache-articles gnus-newsgroup-cached)            (cache-articles gnus-newsgroup-cached)
241            article)            article)
# Line 283  it's not cached." Line 283  it's not cached."
283          ;; the normal way.          ;; the normal way.
284          (let ((gnus-use-cache nil))          (let ((gnus-use-cache nil))
285            (gnus-retrieve-headers articles group fetch-old))            (gnus-retrieve-headers articles group fetch-old))
286        (let ((uncached-articles (gnus-sorted-intersection        (let ((uncached-articles (gnus-sorted-difference articles cached))
                                 (gnus-sorted-complement articles cached)  
                                 articles))  
287              (cache-file (gnus-cache-file-name group ".overview"))              (cache-file (gnus-cache-file-name group ".overview"))
288              type)              type)
289          ;; We first retrieve all the headers that we don't have in          ;; We first retrieve all the headers that we don't have in
# Line 335  Returns the list of articles entered." Line 333  Returns the list of articles entered."
333            (when (gnus-cache-possibly-enter-article            (when (gnus-cache-possibly-enter-article
334                   gnus-newsgroup-name article                   gnus-newsgroup-name article
335                   nil nil nil t)                   nil nil nil t)
336                (setq gnus-newsgroup-undownloaded (delq article gnus-newsgroup-undownloaded))
337              (push article out))              (push article out))
338          (gnus-message 2 "Can't cache article %d" article))          (gnus-message 2 "Can't cache article %d" article))
339          (gnus-summary-update-download-mark article)
340        (gnus-summary-update-secondary-mark article))        (gnus-summary-update-secondary-mark article))
341      (gnus-summary-next-subject 1)      (gnus-summary-next-subject 1)
342      (gnus-summary-position-point)      (gnus-summary-position-point)
343      (nreverse out)))      (nreverse out)))
344    
345  (defun gnus-cache-remove-article (n)  (defun gnus-cache-remove-article (&optional n)
346    "Remove the next N articles from the cache.    "Remove the next N articles from the cache.
347  If not given a prefix, use the process marked articles instead.  If not given a prefix, use the process marked articles instead.
348  Returns the list of articles removed."  Returns the list of articles removed."
# Line 354  Returns the list of articles removed." Line 354  Returns the list of articles removed."
354        (setq article (pop articles))        (setq article (pop articles))
355        (gnus-summary-remove-process-mark article)        (gnus-summary-remove-process-mark article)
356        (when (gnus-cache-possibly-remove-article article nil nil nil t)        (when (gnus-cache-possibly-remove-article article nil nil nil t)
357            (when gnus-newsgroup-agentized
358              (let ((alist (gnus-agent-load-alist gnus-newsgroup-name)))
359                (unless (cdr (assoc article alist))
360                  (setq gnus-newsgroup-undownloaded
361                        (gnus-add-to-sorted-list
362                         gnus-newsgroup-undownloaded article)))))
363          (push article out))          (push article out))
364          (gnus-summary-update-download-mark article)
365        (gnus-summary-update-secondary-mark article))        (gnus-summary-update-secondary-mark article))
366      (gnus-summary-next-subject 1)      (gnus-summary-next-subject 1)
367      (gnus-summary-position-point)      (gnus-summary-position-point)
# Line 367  Returns the list of articles removed." Line 374  Returns the list of articles removed."
374  (defun gnus-summary-insert-cached-articles ()  (defun gnus-summary-insert-cached-articles ()
375    "Insert all the articles cached for this group into the current buffer."    "Insert all the articles cached for this group into the current buffer."
376    (interactive)    (interactive)
377    (let ((cached (sort (copy-sequence gnus-newsgroup-cached) '>))    (let ((gnus-verbose (max 6 gnus-verbose)))
378          (gnus-verbose (max 6 gnus-verbose)))      (if (not gnus-newsgroup-cached)
379      (unless cached          (gnus-message 3 "No cached articles for this group")
380        (gnus-message 3 "No cached articles for this group"))        (gnus-summary-goto-subjects gnus-newsgroup-cached))))
     (while cached  
       (gnus-summary-goto-subject (pop cached) t))))  
381    
382  (defalias 'gnus-summary-limit-include-cached  (defun gnus-summary-limit-include-cached ()
383    'gnus-summary-insert-cached-articles)    "Limit the summary buffer to articles that are cached."
384      (interactive)
385      (let ((gnus-verbose (max 6 gnus-verbose)))
386        (if gnus-newsgroup-cached
387            (progn
388              (gnus-summary-limit gnus-newsgroup-cached)
389              (gnus-summary-position-point))
390          (gnus-message 3 "No cached articles for this group"))))
391    
392  ;;; Internal functions.  ;;; Internal functions.
393    
# Line 422  Returns the list of articles removed." Line 434  Returns the list of articles removed."
434                        ?. ?_)))                        ?. ?_)))
435            ;; Translate the first colon into a slash.            ;; Translate the first colon into a slash.
436            (when (string-match ":" group)            (when (string-match ":" group)
437              (aset group (match-beginning 0) ?/))                    (setq group (concat (substring group 0 (match-beginning 0))
438                                          "/" (substring group (match-end 0)))))
439            (nnheader-replace-chars-in-string group ?. ?/)))            (nnheader-replace-chars-in-string group ?. ?/)))
440        t)        t)
441       gnus-cache-directory))))       gnus-cache-directory))))
# Line 460  Returns the list of articles removed." Line 473  Returns the list of articles removed."
473          (when (or (looking-at (concat (int-to-string number) "\t"))          (when (or (looking-at (concat (int-to-string number) "\t"))
474                    (search-forward (concat "\n" (int-to-string number) "\t")                    (search-forward (concat "\n" (int-to-string number) "\t")
475                                    (point-max) t))                                    (point-max) t))
476            (delete-region (progn (beginning-of-line) (point))            (gnus-delete-line)))
477                           (progn (forward-line 1) (point)))))        (unless (setq gnus-newsgroup-cached
478        (setq gnus-newsgroup-cached                      (delq article gnus-newsgroup-cached))
479              (delq article gnus-newsgroup-cached))          (gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb)
480            (setq gnus-cache-active-altered t))
481        (gnus-summary-update-secondary-mark article)        (gnus-summary-update-secondary-mark article)
482        t)))        t)))
483    
# Line 477  Returns the list of articles removed." Line 491  Returns the list of articles removed."
491                            (directory-files dir nil "^[0-9]+$" t))                            (directory-files dir nil "^[0-9]+$" t))
492                    '<))                    '<))
493        ;; Update the cache active file, just to synch more.        ;; Update the cache active file, just to synch more.
494        (when articles        (if articles
495          (gnus-cache-update-active group (car articles) t)            (progn
496          (gnus-cache-update-active group (car (last articles))))              (gnus-cache-update-active group (car articles) t)
497                (gnus-cache-update-active group (car (last articles))))
498            (when (gnus-gethash group gnus-cache-active-hashtb)
499              (gnus-sethash group nil gnus-cache-active-hashtb)
500              (setq gnus-cache-active-altered t)))
501        articles)))        articles)))
502    
503  (defun gnus-cache-braid-nov (group cached &optional file)  (defun gnus-cache-braid-nov (group cached &optional file)
# Line 503  Returns the list of articles removed." Line 521  Returns the list of articles removed."
521                    (< (read (current-buffer)) (car cached)))                    (< (read (current-buffer)) (car cached)))
522          (forward-line 1))          (forward-line 1))
523        (beginning-of-line)        (beginning-of-line)
524        (save-excursion        (set-buffer cache-buf)
525          (set-buffer cache-buf)        (if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
526          (if (search-forward (concat "\n" (int-to-string (car cached)) "\t")                            nil t)
527                              nil t)            (setq beg (gnus-point-at-bol)
528              (setq beg (progn (beginning-of-line) (point))                  end (progn (end-of-line) (point)))
529                    end (progn (end-of-line) (point)))          (setq beg nil))
530            (setq beg nil)))        (set-buffer nntp-server-buffer)
531        (when beg        (when beg
532          (insert-buffer-substring cache-buf beg end)          (insert-buffer-substring cache-buf beg end)
533          (insert "\n"))          (insert "\n"))
# Line 531  Returns the list of articles removed." Line 549  Returns the list of articles removed."
549                       (car cached)))                       (car cached)))
550          (search-forward "\n.\n" nil 'move))          (search-forward "\n.\n" nil 'move))
551        (beginning-of-line)        (beginning-of-line)
552        (save-excursion        (set-buffer cache-buf)
553          (set-buffer cache-buf)        (erase-buffer)
554          (erase-buffer)        (let ((coding-system-for-read
555          (let ((coding-system-for-read               gnus-cache-coding-system))
556                 gnus-cache-coding-system))          (insert-file-contents (gnus-cache-file-name group (car cached))))
557            (insert-file-contents (gnus-cache-file-name group (car cached))))        (goto-char (point-min))
558          (goto-char (point-min))        (insert "220 ")
559          (insert "220 ")        (princ (car cached) (current-buffer))
560          (princ (car cached) (current-buffer))        (insert " Article retrieved.\n")
561          (insert " Article retrieved.\n")        (search-forward "\n\n" nil 'move)
562          (search-forward "\n\n" nil 'move)        (delete-region (point) (point-max))
563          (delete-region (point) (point-max))        (forward-char -1)
564          (forward-char -1)        (insert ".")
565          (insert "."))        (set-buffer nntp-server-buffer)
566        (insert-buffer-substring cache-buf)        (insert-buffer-substring cache-buf)
567        (setq cached (cdr cached)))        (setq cached (cdr cached)))
568      (kill-buffer cache-buf)))      (kill-buffer cache-buf)))
# Line 604  $ emacs -batch -l ~/.emacs -l gnus -f gn Line 622  $ emacs -batch -l ~/.emacs -l gnus -f gn
622      ;; Mark the active hashtb as unaltered.      ;; Mark the active hashtb as unaltered.
623      (setq gnus-cache-active-altered nil)))      (setq gnus-cache-active-altered nil)))
624    
625    (defun gnus-cache-possibly-update-active (group active)
626      "Update active info bounds of GROUP with ACTIVE if necessary.
627    The update is performed if ACTIVE contains a higher or lower bound
628    than the current."
629      (let ((lower t) (higher t))
630        (if gnus-cache-active-hashtb
631            (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
632              (when cache-active
633                (unless (< (car active) (car cache-active))
634                  (setq lower nil))
635                (unless (> (cdr active) (cdr cache-active))
636                  (setq higher nil))))
637          (gnus-cache-read-active))
638        (when lower
639          (gnus-cache-update-active group (car active) t))
640        (when higher
641          (gnus-cache-update-active group (cdr active)))))
642    
643  (defun gnus-cache-update-active (group number &optional low)  (defun gnus-cache-update-active (group number &optional low)
644    "Update the upper bound of the active info of GROUP to NUMBER.    "Update the upper bound of the active info of GROUP to NUMBER.
645  If LOW, update the lower bound instead."  If LOW, update the lower bound instead."
# Line 641  If LOW, update the lower bound instead." Line 677  If LOW, update the lower bound instead."
677        (gnus-message 5 "Generating the cache active file...")        (gnus-message 5 "Generating the cache active file...")
678        (setq gnus-cache-active-hashtb (gnus-make-hashtable 123)))        (setq gnus-cache-active-hashtb (gnus-make-hashtable 123)))
679      (when (string-match "^\\(nn[^_]+\\)_" group)      (when (string-match "^\\(nn[^_]+\\)_" group)
680        (setq group (replace-match "\\1:" t t group)))        (setq group (replace-match "\\1:" t nil group)))
681      ;; Separate articles from all other files and directories.      ;; Separate articles from all other files and directories.
682      (while files      (while files
683        (if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))        (if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))
# Line 670  If LOW, update the lower bound instead." Line 706  If LOW, update the lower bound instead."
706    (interactive (list gnus-cache-directory))    (interactive (list gnus-cache-directory))
707    (gnus-cache-close)    (gnus-cache-close)
708    (let ((nnml-generate-active-function 'identity))    (let ((nnml-generate-active-function 'identity))
709      (nnml-generate-nov-databases-1 dir)))      (nnml-generate-nov-databases-1 dir))
710      (gnus-cache-open))
711    
712  (defun gnus-cache-move-cache (dir)  (defun gnus-cache-move-cache (dir)
713    "Move the cache tree to somewhere else."    "Move the cache tree to somewhere else."
714    (interactive "FMove the cache tree to: ")    (interactive "FMove the cache tree to: ")
715    (rename-file gnus-cache-directory dir))    (rename-file gnus-cache-directory dir))
716    
717    (defun gnus-cache-fully-p (&optional group)
718      "Returns non-nil if the cache should be fully used.
719    If GROUP is non-nil, also cater to `gnus-cacheable-groups' and
720    `gnus-uncacheable-groups'."
721      (and gnus-use-cache
722           (not (eq gnus-use-cache 'passive))
723           (if (null group)
724               t
725             (and (or (not gnus-cacheable-groups)
726                      (string-match gnus-cacheable-groups group))
727                  (or (not gnus-uncacheable-groups)
728                      (not (string-match gnus-uncacheable-groups group)))))))
729    
730  (provide 'gnus-cache)  (provide 'gnus-cache)
731    
732  ;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a  ;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a

Legend:
Removed from v.1.6.18.2  
changed lines
  Added in v.1.6.18.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26