cgit.sxemacs.org Git - gnus/blob - lisp/gnus-cache.el

   1 ;;; gnus-cache.el --- cache interface for Gnus
   2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'gnus)
  28
  29 (defvar gnus-cache-directory (concat gnus-article-save-directory "cache/")
  30   "*The directory where cached articles will be stored.")
  31
  32 (defvar gnus-cache-enter-articles '(ticked dormant)
  33   "*Classes of articles to enter into the cache.")
  34
  35 (defvar gnus-cache-remove-articles '(read)
  36   "*Classes of articles to remove from the cache.")
  37
  38 \f
  39
  40 (defvar gnus-cache-buffer nil)
  41 (defvar gnus-cache-removeable-articles nil)
  42
  43 \f
  44
  45 (defun gnus-cache-change-buffer (group)
  46   (save-excursion
  47     (cond ((null gnus-cache-buffer)
  48            ;; No current cache, so we create and init the buffer.
  49            (setq gnus-cache-buffer
  50                  (cons group (get-buffer-create " *gnus-cache-overview*")))
  51            (set-buffer (cdr gnus-cache-buffer))
  52            (buffer-disable-undo (current-buffer))
  53            (erase-buffer)
  54            (gnus-add-current-to-buffer-list)
  55            (let ((file (gnus-cache-file-name group ".overview")))
  56              (and (file-exists-p file)
  57                   (insert-file-contents file))))
  58           ((not (string= group (car gnus-cache-buffer)))
  59            ;; If a different overview cache is the current, we
  60            ;; (possibly) save it and change to this groups.
  61            (set-buffer (cdr gnus-cache-buffer))
  62            (and (buffer-modified-p)
  63                 (write-region (point-min) (point-max)
  64                               (gnus-cache-file-name
  65                                (car gnus-cache-buffer) ".overview")
  66                               nil 'quiet))
  67            (erase-buffer)
  68            (setcar gnus-cache-buffer group)
  69            (let ((file (gnus-cache-file-name group ".overview")))
  70              (and (file-exists-p file)
  71                   (insert-file-contents file))))))
  72   (setq gnus-cache-removeable-articles nil))
  73
  74
  75 ;; Just save the overview buffer.
  76 (defun gnus-cache-save-buffers ()
  77   (and gnus-cache-buffer
  78        (save-excursion
  79          (set-buffer (cdr gnus-cache-buffer))
  80          (and (buffer-modified-p)
  81               (write-region (point-min) (point-max)
  82                             (gnus-cache-file-name (car gnus-cache-buffer)
  83                                                   ".overview")
  84                             nil 'quiet))))
  85   (setq gnus-cache-buffer nil))
  86
  87 ;; Return whether an article is a member of a class.
  88 (defun gnus-cache-member-of-class (class ticked dormant unread)
  89   (or (and ticked (memq 'ticked class))
  90       (and dormant (memq 'dormant class))
  91       (and unread (memq 'unread class))
  92       (and (not unread) (memq 'read class))))
  93
  94 (defun gnus-cache-file-name (group article)
  95   (concat (file-name-as-directory gnus-cache-directory)
  96           (if (gnus-use-long-file-name 'not-cache)
  97               group (gnus-replace-chars-in-string group ?. ?/))
  98           "/" (if (stringp article) article (int-to-string article))))
  99
 100 (defun gnus-cache-possibly-enter-article
 101   (group article headers ticked dormant unread)
 102   (let ((number (header-number headers))
 103         file dir)
 104     (if (or (not (gnus-cache-member-of-class
 105                   gnus-cache-enter-articles ticked dormant unread))
 106             (file-exists-p (setq file (gnus-cache-file-name group article))))
 107         ()
 108       ;; Possibly create the cache directory.
 109       (or (file-exists-p (setq dir (file-name-directory file)))
 110           (gnus-make-directory dir))
 111       ;; Save the article in the cache.
 112       (if (file-exists-p file)
 113           t ; The article already is saved, so we end here.
 114         (gnus-summary-select-article)
 115         (save-excursion
 116           (set-buffer gnus-article-buffer)
 117           (write-region (point-min) (point-max) file nil 'quiet)
 118           (gnus-cache-change-buffer group)
 119           (set-buffer (cdr gnus-cache-buffer))
 120           (goto-char (point-max))
 121           (forward-line -1)
 122           (while (and (not (bobp))
 123                       (> (read (current-buffer)) number))
 124             (forward-line -1))
 125           (if (bobp)
 126               (if (not (eobp))
 127                   (progn
 128                     (beginning-of-line)
 129                     (if (< (read (current-buffer)) number)
 130                         (forward-line 1)))
 131                 (beginning-of-line))
 132             (forward-line 1))
 133           (beginning-of-line)
 134           ;; [number subject from date id references chars lines xref]
 135           (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n"
 136                           (header-number headers)
 137                           (header-subject headers)
 138                           (header-from headers)
 139                           (header-date headers)
 140                           (header-id headers)
 141                           (or (header-references headers) "")
 142                           (or (header-chars headers) "")
 143                           (or (header-lines headers) "")
 144                           (or (header-xref headers) ""))))
 145         t))))
 146
 147 (defun gnus-cache-enter-remove-article (article)
 148   (setq gnus-cache-removeable-articles
 149         (cons article gnus-cache-removeable-articles)))
 150
 151 (defun gnus-cache-possibly-remove-articles ()
 152   (let ((articles gnus-cache-removeable-articles)
 153         (cache-articles (gnus-cache-articles-in-group gnus-newsgroup-name))
 154         article)
 155     (while articles
 156       (setq article (car articles)
 157             articles (cdr articles))
 158       (if (memq article cache-articles)
 159           ;; The article was in the cache, so we see whether we are
 160           ;; supposed to remove it from the cache.
 161           (gnus-cache-possibly-remove-article
 162            gnus-newsgroup-name article
 163            (memq article gnus-newsgroup-marked)
 164            (memq article gnus-newsgroup-dormant)
 165            (or (memq article gnus-newsgroup-unreads)
 166                (memq article gnus-newsgroup-unselected)))))))
 167
 168 (defun gnus-cache-possibly-remove-article
 169   (group article ticked dormant unread)
 170   (let ((file (gnus-cache-file-name group article)))
 171     (if (or (not (file-exists-p file))
 172             (not (gnus-cache-member-of-class
 173                   gnus-cache-remove-articles ticked dormant unread)))
 174         nil
 175       (save-excursion
 176         (delete-file file)
 177         (gnus-cache-change-buffer group)
 178         (set-buffer (cdr gnus-cache-buffer))
 179         (goto-char (point-min))
 180         (if (or (looking-at (concat (int-to-string article) "\t"))
 181                 (search-forward (concat "\n" (int-to-string article) "\t")
 182                                 (point-max) t))
 183             (delete-region (progn (beginning-of-line) (point))
 184                            (progn (forward-line 1) (point))))))))
 185
 186 (defun gnus-cache-request-article (article group)
 187   (let ((file (gnus-cache-file-name group article)))
 188     (if (not (file-exists-p file))
 189         ()
 190       (erase-buffer)
 191       (insert-file-contents file)
 192       t)))
 193
 194 (defun gnus-cache-articles-in-group (group)
 195   (let ((dir (file-name-directory (gnus-cache-file-name group 1)))
 196         articles)
 197     (if (not (file-exists-p dir))
 198         nil
 199       (setq articles (directory-files dir nil "^[0-9]+$" t))
 200       (if (not articles)
 201           nil
 202         (sort (mapcar (function (lambda (name)
 203                                   (string-to-int name)))
 204                       articles)
 205               '<)))))
 206
 207 (defun gnus-cache-active-articles (group)
 208   (let ((articles (gnus-cache-articles-in-group group)))
 209     (and articles
 210          (cons (car articles) (gnus-last-element articles)))))
 211
 212 (defun gnus-cache-possibly-alter-active (group active)
 213   (let ((cache-active (gnus-cache-active-articles group)))
 214     (and cache-active (< (car cache-active) (car active))
 215          (setcar active (car cache-active)))
 216     (and cache-active (> (cdr cache-active) (cdr active))
 217          (setcdr active (cdr cache-active)))))
 218
 219 (defun gnus-cache-retrieve-headers (articles group)
 220   (let* ((cached (gnus-cache-articles-in-group group))
 221          (articles (gnus-sorted-complement articles cached))
 222          (cache-file (gnus-cache-file-name group ".overview"))
 223          type)
 224     (let ((gnus-use-cache nil))
 225       (setq type (and articles (gnus-retrieve-headers articles group))))
 226     (gnus-cache-save-buffers)
 227     (save-excursion
 228       (cond ((not (file-exists-p cache-file))
 229              type)
 230             ((null type)
 231              (set-buffer nntp-server-buffer)
 232              (erase-buffer)
 233              (insert-file-contents cache-file)
 234              'nov)
 235             ((eq type 'nov)
 236              (gnus-cache-braid-nov group cached)
 237              type)
 238             (t
 239              (gnus-cache-braid-heads group cached)
 240              type)))))
 241
 242 (defun gnus-cache-braid-nov (group cached)
 243   (let ((cache-buf (get-buffer-create " *gnus-cache*"))
 244         beg end)
 245     (gnus-cache-save-buffers)
 246     (save-excursion
 247       (set-buffer cache-buf)
 248       (buffer-disable-undo (current-buffer))
 249       (erase-buffer)
 250       (insert-file-contents (gnus-cache-file-name group ".overview"))
 251       (goto-char (point-min))
 252       (insert "\n")
 253       (goto-char (point-min)))
 254     (set-buffer nntp-server-buffer)
 255     (goto-char (point-min))
 256     (while cached
 257       (while (and (not (eobp))
 258                   (< (read (current-buffer)) (car cached)))
 259         (forward-line 1))
 260       (beginning-of-line)
 261       (save-excursion
 262         (set-buffer cache-buf)
 263         (if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
 264                             nil t)
 265             (setq beg (progn (beginning-of-line) (point))
 266                   end (progn (forward-line 1) (point)))
 267           (setq beg nil)))
 268       (and beg (insert-buffer-substring cache-buf beg end))
 269       (setq cached (cdr cached)))
 270     (kill-buffer cache-buf)))
 271
 272 (defun gnus-cache-braid-heads (group cached)
 273   (let ((cache-buf (get-buffer-create " *gnus-cache*")))
 274     (save-excursion
 275       (set-buffer cache-buf)
 276       (buffer-disable-undo (current-buffer))
 277       (erase-buffer))
 278     (set-buffer nntp-server-buffer)
 279     (goto-char (point-min))
 280     (while cached
 281       (while (and (not (eobp))
 282                   (looking-at "2.. +\\([0-9]+\\) ")
 283                   (< (progn (goto-char (match-beginning 1))
 284                             (read (current-buffer)))
 285                      (car cached)))
 286         (search-forward "\n.\n" nil 'move))
 287       (beginning-of-line)
 288       (save-excursion
 289         (set-buffer cache-buf)
 290         (erase-buffer)
 291         (insert-file-contents (gnus-cache-file-name group (car cached)))
 292         (goto-char (point-min))
 293         (insert "220 " (int-to-string (car cached)) " Article retrieved.\n")
 294         (search-forward "\n\n" nil 'move)
 295         (delete-region (point) (point-max))
 296         (forward-char -1)
 297         (insert "."))
 298       (insert-buffer-substring cache-buf)
 299       (setq cached (cdr cached)))
 300     (kill-buffer cache-buf)))
 301
 302 (defun gnus-jog-cache ()
 303   "Go through all groups and put the articles into the cache."
 304   (interactive)
 305   (let ((newsrc (cdr gnus-newsrc-alist))
 306         (gnus-cache-enter-articles '(unread))
 307         (gnus-mark-article-hook nil)
 308         (gnus-expert-user t)
 309         (gnus-large-newsgroup nil))
 310     (while newsrc
 311       (gnus-summary-read-group (car (car newsrc)))
 312       (if (not (eq major-mode 'gnus-summary-mode))
 313           ()
 314         (while gnus-newsgroup-unreads
 315           (gnus-summary-select-article t t nil (car gnus-newsgroup-unreads))
 316           (setq gnus-newsgroup-unreads (cdr gnus-newsgroup-unreads)))
 317         (kill-buffer (current-buffer)))
 318       (setq newsrc (cdr newsrc)))))
 319
 320 (provide 'gnus-cache)
 321
 322 ;;; gnus-cache.el ends here