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

   1 ;;; nnfolder.el --- mail folder access for Gnus
   2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   6 ;; Keywords: news, mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'nnheader)
  29 (require 'rmail)
  30 (require 'nnmail)
  31
  32 (defvar nnfolder-directory (expand-file-name "~/Mail/")
  33   "The name of the mail box file in the users home directory.")
  34
  35 (defvar nnfolder-active-file (concat nnfolder-directory  "active")
  36   "The name of the active file.")
  37
  38 (defvar nnfolder-newsgroups-file (concat nnfolder-directory "newsgroups")
  39   "Mail newsgroups description file.")
  40
  41 (defvar nnfolder-get-new-mail t
  42   "If non-nil, nnml will check the incoming mail file and split the mail.")
  43
  44 \f
  45
  46 (defconst nnfolder-version "nnfolder 0.1"
  47   "nnfolder version.")
  48
  49 (defvar nnfolder-current-group nil)
  50 (defvar nnfolder-current-buffer nil)
  51 (defvar nnfolder-status-string "")
  52 (defvar nnfolder-group-alist nil)
  53 (defvar nnfolder-buffer-alist nil)
  54
  55 ;;; Interface functions
  56
  57 (defun nnfolder-retrieve-headers (sequence &optional newsgroup server)
  58   "Retrieve the headers for the articles in SEQUENCE.
  59 Newsgroup must be selected before calling this function."
  60   (save-excursion
  61     (set-buffer nntp-server-buffer)
  62     (erase-buffer)
  63     (let ((file nil)
  64           (number (length sequence))
  65           beg article art-string start stop)
  66       (nnfolder-possibly-change-group newsgroup)
  67       (while sequence
  68         (setq article (car sequence))
  69         (setq art-string (nnfolder-article-string article))
  70         (set-buffer nnfolder-current-buffer)
  71         (if (or (search-forward art-string nil t)
  72                 (progn (goto-char 1)
  73                        (search-forward art-string nil t)))
  74             (progn
  75               (setq start
  76                     (save-excursion
  77                       (re-search-backward
  78                        (concat "^" rmail-unix-mail-delimiter) nil t)
  79                       (point)))
  80               (search-forward "\n\n" nil t)
  81               (setq stop (1- (point)))
  82               (set-buffer nntp-server-buffer)
  83               (insert (format "221 %d Article retrieved.\n" article))
  84               (setq beg (point))
  85               (insert-buffer-substring nnfolder-current-buffer start stop)
  86               (goto-char (point-max))
  87               (insert ".\n")))
  88         (setq sequence (cdr sequence)))
  89
  90       ;; Fold continuation lines.
  91       (goto-char 1)
  92       (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
  93         (replace-match " " t t))
  94       'headers)))
  95
  96 (defun nnfolder-open-server (host &optional service)
  97   "Open mbox backend."
  98   (setq nnfolder-status-string "")
  99   (setq nnfolder-group-alist nil)
 100   (nnheader-init-server-buffer))
 101
 102 (defun nnfolder-close-server (&optional server)
 103   "Close news server."
 104   t)
 105
 106 (defun nnfolder-server-opened (&optional server)
 107   "Return server process status, T or NIL.
 108 If the stream is opened, return T, otherwise return NIL."
 109   (and nntp-server-buffer
 110        (buffer-name nntp-server-buffer)))
 111
 112 (defun nnfolder-status-message (&optional server)
 113   "Return server status response as string."
 114   nnfolder-status-string)
 115
 116 (defun nnfolder-request-article (article &optional newsgroup server buffer)
 117   "Select ARTICLE by number."
 118   (nnfolder-possibly-change-group newsgroup)
 119   (if (stringp article)
 120       nil
 121     (save-excursion
 122       (set-buffer nnfolder-current-buffer)
 123       (goto-char 1)
 124       (if (search-forward (nnfolder-article-string article) nil t)
 125           (let (start stop)
 126             (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 127             (setq start (point))
 128             (forward-line 1)
 129             (or (and (re-search-forward
 130                       (concat "^" rmail-unix-mail-delimiter) nil t)
 131                      (forward-line -1))
 132                 (goto-char (point-max)))
 133             (setq stop (point))
 134             (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
 135               (set-buffer nntp-server-buffer)
 136               (erase-buffer)
 137               (insert-buffer-substring nnfolder-current-buffer start stop)
 138               (goto-char (point-min))
 139               (while (looking-at "From ")
 140                 (delete-char 5)
 141                 (insert "X-From-Line: ")
 142                 (forward-line 1))
 143               t))))))
 144
 145 (defun nnfolder-request-group (group &optional server dont-check)
 146   "Select news GROUP."
 147   (save-excursion
 148     (nnfolder-possibly-change-group group)
 149     (and (assoc group nnfolder-group-alist)
 150          (save-excursion
 151            (set-buffer nntp-server-buffer)
 152            (erase-buffer)
 153            (if dont-check
 154                t
 155              (nnfolder-get-new-mail)
 156              (let ((active (assoc group nnfolder-group-alist)))
 157                (insert (format "211 %d %d %d %s\n"
 158                                (1+ (- (cdr (car (cdr active)))
 159                                       (car (car (cdr active)))))
 160                                (car (car (cdr active)))
 161                                (cdr (car (cdr active)))
 162                                (car active))))
 163              t)))))
 164
 165 (defun nnfolder-close-group (group &optional server)
 166   t)
 167
 168 (defun nnfolder-request-list (&optional server)
 169   "List active newsgoups."
 170   (if server (nnfolder-get-new-mail))
 171   (or (nnmail-find-file nnfolder-active-file)
 172       (progn
 173         (setq nnfolder-group-alist (nnmail-get-active))
 174         (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
 175         (nnmail-find-file nnfolder-active-file))))
 176
 177 (defun nnfolder-request-newgroups (date &optional server)
 178   "List groups created after DATE."
 179   (nnfolder-request-list server))
 180
 181 (defun nnfolder-request-list-newsgroups (&optional server)
 182   "List newsgroups (defined in NNTP2)."
 183   (nnmail-find-file nnfolder-newsgroups-file))
 184
 185 (defun nnfolder-request-post (&optional server)
 186   "Post a new news in current buffer."
 187   (mail-send-and-exit nil))
 188
 189 (fset 'nnfolder-request-post-buffer 'nnmail-request-post-buffer)
 190
 191 (defun nnfolder-request-expire-articles (articles newsgroup &optional server force)
 192   "Expire all articles in the ARTICLES list in group GROUP.
 193 The list of unexpired articles will be returned (ie. all articles that
 194 were too fresh to be expired).
 195 If FORCE is non-nil, the ARTICLES will be deleted without looking at
 196 the date."
 197   (nnfolder-possibly-change-group newsgroup)
 198   (let* ((days (or (and nnmail-expiry-wait-function
 199                         (funcall nnmail-expiry-wait-function newsgroup))
 200                    nnmail-expiry-wait))
 201          article rest)
 202     (save-excursion
 203       (set-buffer nnfolder-current-buffer)
 204       (while articles
 205         (goto-char 1)
 206         (if (search-forward (nnfolder-article-string (car articles)) nil t)
 207             (if (or force
 208                     (> (nnmail-days-between
 209                         (current-time-string)
 210                         (buffer-substring
 211                          (point) (progn (end-of-line) (point))))
 212                        days))
 213                 (progn
 214                   (and gnus-verbose-backends
 215                        (message "Deleting: %s" (car articles)))
 216                   (nnfolder-delete-mail))
 217               (setq rest (cons (car articles) rest))))
 218         (setq articles (cdr articles)))
 219       (save-buffer)
 220       rest)))
 221
 222 (defun nnfolder-request-move-article
 223   (article group server accept-form &optional last)
 224   (nnfolder-possibly-change-group group)
 225   (let ((buf (get-buffer-create " *nnfolder move*"))
 226         result)
 227     (and
 228      (nnfolder-request-article article group server)
 229      (save-excursion
 230        (set-buffer buf)
 231        (buffer-disable-undo (current-buffer))
 232        (erase-buffer)
 233        (insert-buffer-substring nntp-server-buffer)
 234        (goto-char (point-min))
 235        (while (re-search-forward
 236                "^X-Gnus-Newsgroup:"
 237                (save-excursion (search-forward "\n\n" nil t) (point)) t)
 238          (delete-region (progn (beginning-of-line) (point))
 239                         (progn (forward-line 1) (point))))
 240        (setq result (eval accept-form))
 241        (kill-buffer buf)
 242        result)
 243      (save-excursion
 244        (nnfolder-possibly-change-group group)
 245        (set-buffer nnfolder-current-buffer)
 246        (goto-char 1)
 247        (if (search-forward (nnfolder-article-string article) nil t)
 248            (nnfolder-delete-mail))
 249        (and last (save-buffer))))
 250     result))
 251
 252 (defun nnfolder-request-accept-article (group &optional last)
 253   (nnfolder-possibly-change-group group)
 254   (let ((buf (current-buffer))
 255         result beg)
 256     (debug (current-buffer))
 257     (goto-char (point-min))
 258     (if (looking-at "X-From-Line: ")
 259         (replace-match "From ")
 260       (insert "From nobody " (current-time-string) "\n"))
 261     (and
 262      (nnfolder-request-list)
 263      (setq nnfolder-group-alist (nnmail-get-active))
 264      (progn
 265        (set-buffer buf)
 266        (goto-char (point-min))
 267        (search-forward "\n\n" nil t)
 268        (forward-line -1)
 269        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
 270          (delete-region (point) (progn (forward-line 1) (point))))
 271        (setq result (nnfolder-save-mail (and (stringp group) group))))
 272      (save-excursion
 273        (set-buffer nnfolder-current-buffer)
 274        (insert-buffer-substring buf)
 275        (and last (save-buffer))
 276        result)
 277      (nnmail-save-active nnfolder-group-alist nnfolder-active-file))
 278     (car result)))
 279
 280 (defun nnfolder-request-replace-article (article group buffer)
 281   (nnfolder-possibly-change-group group)
 282   (save-excursion
 283     (set-buffer nnfolder-current-buffer)
 284     (goto-char 1)
 285     (if (not (search-forward (nnfolder-article-string article) nil t))
 286         nil
 287       (nnfolder-delete-mail t t)
 288       (insert-buffer-substring buffer)
 289       (save-buffer)
 290       t)))
 291
 292 \f
 293 ;;; Internal functions.
 294
 295 (defun nnfolder-delete-mail (&optional force leave-delim)
 296   "If FORCE, delete article no matter how many X-Gnus-Newsgroup
 297 headers there are. If LEAVE-DELIM, don't delete the Unix mbox
 298 delimeter line."
 299   ;; Beginning of the article.
 300   (save-excursion
 301     (save-restriction
 302       (narrow-to-region
 303        (save-excursion
 304          (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 305          (if leave-delim (progn (forward-line 1) (point))
 306            (match-beginning 0)))
 307        (progn
 308          (forward-line 1)
 309          (or (and (re-search-forward (concat "^" rmail-unix-mail-delimiter)
 310                                      nil t)
 311                   (if (and (not (bobp)) leave-delim)
 312                       (progn (forward-line -2) (point))
 313                     (match-beginning 0)))
 314              (point-max))))
 315       (delete-region (point-min) (point-max)))))
 316
 317 (defun nnfolder-possibly-change-group (group)
 318   (or (file-exists-p nnfolder-directory)
 319       (make-directory (directory-file-name nnfolder-directory)))
 320   (if (not nnfolder-group-alist)
 321       (progn
 322         (nnfolder-request-list)
 323         (setq nnfolder-group-alist (nnmail-get-active))))
 324   (or (assoc group nnfolder-group-alist)
 325       (not (file-exists-p (concat nnfolder-directory group)))
 326       (progn
 327         (setq nnfolder-group-alist
 328               (cons (list group (cons 1 0)) nnfolder-group-alist))
 329         (nnmail-save-active nnfolder-group-alist nnfolder-active-file)))
 330   (let (inf file)
 331     (if (and (equal group nnfolder-current-group)
 332              (buffer-name nnfolder-current-buffer))
 333         ()
 334       (if (setq inf (member group nnfolder-buffer-alist))
 335           (setq nnfolder-current-buffer (nth 1 inf)))
 336       (setq nnfolder-current-group group)
 337       (if (not (buffer-name nnfolder-current-buffer))
 338           (progn
 339             (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist))
 340             (setq inf nil)))
 341       (if inf
 342           ()
 343         (save-excursion
 344           (setq file (concat nnfolder-directory group))
 345           (if (not (file-exists-p file))
 346               (write-region 1 1 file t 'nomesg))
 347           (set-buffer (nnfolder-read-folder file))
 348           (setq nnfolder-buffer-alist (cons (list group (current-buffer))
 349                                             nnfolder-buffer-alist))))))
 350   (setq nnfolder-current-group group))
 351
 352 (defun nnfolder-article-string (article)
 353   (concat "\nX-Gnus-Article-Number: " (int-to-string article) " "))
 354
 355 (defun nnfolder-save-mail (&optional group)
 356   "Called narrowed to an article."
 357   (let* ((nnmail-split-methods
 358           (if group (list (list group "")) nnmail-split-methods))
 359          (group-art-list
 360           (nreverse (nnmail-article-group 'nnfolder-active-number)))
 361          group-art)
 362     (nnmail-insert-lines)
 363     (nnmail-insert-xref group-art-list)
 364     (while group-art-list
 365       (setq group-art (car group-art-list)
 366             group-art-list (cdr group-art-list))
 367       (nnfolder-possibly-change-group (car group-art))
 368       (nnfolder-insert-newsgroup-line group-art)
 369       (let ((beg (point-min))
 370             (end (point-max))
 371             (obuf (current-buffer)))
 372         (save-excursion
 373           (set-buffer nnfolder-current-buffer)
 374           (goto-char (point-max))
 375           (insert-buffer-substring obuf beg end)))
 376       (goto-char (point-min))
 377       (search-forward "\nX-Gnus-Article-Number: ")
 378       (delete-region (progn (beginning-of-line) (point))
 379                      (progn (forward-line 1) (point))))))
 380
 381 (defun nnfolder-insert-newsgroup-line (group-art)
 382   (save-excursion
 383     (goto-char (point-min))
 384     (if (search-forward "\n\n" nil t)
 385         (progn
 386           (forward-char -1)
 387           (insert (format "X-Gnus-Article-Number: %d   %s\n"
 388                           (cdr group-art) (current-time-string)))))))
 389
 390 (defun nnfolder-active-number (group)
 391   "Find the next article number in GROUP."
 392   (let ((active (car (cdr (assoc group nnfolder-group-alist)))))
 393     (setcdr active (1+ (cdr active)))
 394     (cdr active)))
 395
 396 (defun nnfolder-read-folder (file)
 397   (nnfolder-request-list)
 398   (setq nnfolder-group-alist (nnmail-get-active))
 399   (save-excursion
 400     (set-buffer
 401      (setq nnfolder-current-buffer
 402            (find-file-noselect file)))
 403     (buffer-disable-undo (current-buffer))
 404     (let ((delim (concat "^" rmail-unix-mail-delimiter))
 405           start end)
 406       (goto-char (point-min))
 407       (while (re-search-forward delim nil t)
 408         (setq start (match-beginning 0))
 409         (if (not (search-forward "\nX-Gnus-Article-Number: "
 410                                  (save-excursion
 411                                    (setq end
 412                                          (or
 413                                           (and
 414                                            (re-search-forward delim nil t)
 415                                            (match-beginning 0))
 416                                           (point-max))))
 417                                  t))
 418             (save-excursion
 419               (save-restriction
 420                 (narrow-to-region start end)
 421                 (nnfolder-insert-newsgroup-line
 422                  (cons nil (nnfolder-active-number nnfolder-current-group))))))
 423         (goto-char end)))
 424     (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
 425     (current-buffer)))
 426
 427 (defun nnfolder-get-new-mail ()
 428   (let (incoming)
 429     (if (and nnmail-spool-file
 430              nnfolder-get-new-mail
 431              (file-exists-p nnmail-spool-file)
 432              (> (nth 7 (file-attributes nnmail-spool-file)) 0))
 433         (progn
 434           (and gnus-verbose-backends
 435                (message "nnfolder: Reading incoming mail..."))
 436           (setq incoming
 437                 (nnmail-move-inbox nnmail-spool-file
 438                                    (concat nnfolder-directory "Incoming")))
 439           (nnmail-split-incoming incoming 'nnfolder-save-mail)
 440           (run-hooks 'nnmail-read-incoming-hook)
 441           (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
 442           (and gnus-verbose-backends
 443                (message "nnfolder: Reading incoming mail...done"))))
 444     (let ((bufs nnfolder-buffer-alist))
 445       (save-excursion
 446         (while bufs
 447           (if (not (buffer-name (nth 1 (car bufs))))
 448               (setq nnfolder-buffer-alist
 449                     (delq (car bufs) nnfolder-buffer-alist))
 450             (set-buffer (nth 1 (car bufs)))
 451             (save-buffer))
 452           (setq bufs (cdr bufs)))))
 453     ;; (if incoming (delete-file incoming))
 454     ))
 455
 456 (provide 'nnfolder)
 457
 458 ;;; nnfolder.el ends here