1 ;;; nnmh.el --- mail spool access for Gnus (mhspool)
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
4 ;; Author: Lars Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6 ;; Keywords: news, mail
8 ;; This file is part of GNU Emacs.
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)
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.
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.
26 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
35 (defvar nnmh-directory "~/Mail/"
38 (defvar nnmh-get-new-mail t
39 "If non-nil, nnmh will check the incoming mail file and split the mail.")
43 (defconst nnmh-version "nnmh 0.1"
46 (defvar nnmh-current-directory nil
47 "Current news group directory.")
49 (defvar nnmh-status-string "")
51 (defvar nnmh-group-alist nil)
55 ;;; Interface functions.
57 (defun nnmh-retrieve-headers (sequence &optional newsgroup server)
58 "Retrieve the headers for the articles in SEQUENCE.
59 Newsgroup must be selected before calling this function."
61 (set-buffer nntp-server-buffer)
64 (number (length sequence))
67 (nnmh-possibly-change-directory newsgroup)
69 (setq article (car sequence))
71 (concat nnmh-current-directory (prin1-to-string article)))
72 (if (and (file-exists-p file)
73 (not (file-directory-p file)))
75 (insert (format "221 %d Article retrieved.\n" article))
77 (insert-file-contents file)
79 (if (search-forward "\n\n" nil t)
81 (goto-char (point-max))
84 (delete-region (point) (point-max))))
85 (setq sequence (cdr sequence))
86 (setq count (1+ count))
87 (and (numberp nnmail-large-newsgroup)
88 (> number nnmail-large-newsgroup)
90 (message "nnmh: Receiving headers... %d%%"
91 (/ (* count 100) number))))
93 (and (numberp nnmail-large-newsgroup)
94 (> number nnmail-large-newsgroup)
95 (message "nnmh: Receiving headers... done"))
97 ;; Fold continuation lines.
99 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
100 (replace-match " " t t))
103 (defun nnmh-open-server (host &optional service)
104 "Open nnmh mail backend."
105 (setq nnmh-status-string "")
106 (nnmh-open-server-internal host service))
108 (defun nnmh-close-server (&optional server)
110 (nnmh-close-server-internal))
112 (fset 'nnmh-request-quit (symbol-function 'nnmh-close-server))
114 (defun nnmh-server-opened (&optional server)
115 "Return server process status, T or NIL.
116 If the stream is opened, return T, otherwise return NIL."
117 (and nntp-server-buffer
118 (get-buffer nntp-server-buffer)))
120 (defun nnmh-status-message ()
121 "Return server status response as string."
124 (defun nnmh-request-article (id &optional newsgroup server buffer)
125 "Select article by message ID (or number)."
126 (nnmh-possibly-change-directory newsgroup)
127 (let ((file (if (stringp id)
129 (concat nnmh-current-directory (prin1-to-string id))))
130 (nntp-server-buffer (or buffer nntp-server-buffer)))
131 (if (and (stringp file)
133 (not (file-directory-p file)))
135 (nnmail-find-file file)))))
137 (defun nnmh-request-group (group &optional server dont-check)
139 (and nnmh-get-new-mail (or dont-check (nnmh-get-new-mail)))
140 (let ((pathname (nnmail-article-pathname group nnmh-directory))
142 (if (file-directory-p pathname)
144 (setq nnmh-current-directory pathname)
145 (and nnmh-get-new-mail (nnmh-update-gnus-unreads group))
153 (string-to-int name)))
154 (directory-files pathname nil "^[0-9]+$" t))
157 (set-buffer nntp-server-buffer)
160 (insert (format "211 %d %d %d %s\n" (length dir)
162 (progn (while (cdr dir)
163 (setq dir (cdr dir)))
166 (insert (format "211 0 1 0 %s\n" group))))))
169 (defun nnmh-request-list (&optional server dir)
170 "Get list of active articles in all newsgroups."
171 (and server nnmh-get-new-mail (nnmh-get-new-mail))
174 (set-buffer nntp-server-buffer)
176 (setq dir nnmh-directory)))
177 (setq dir (expand-file-name dir))
178 ;; Recurse down all directories.
179 (let ((dirs (directory-files dir t nil t)))
181 (if (and (not (string-match "/\\.\\.$" (car dirs)))
182 (not (string-match "/\\.$" (car dirs)))
183 (file-directory-p (car dirs)))
184 (nnmh-request-list server (car dirs)))
185 (setq dirs (cdr dirs))))
186 ;; For each directory, generate an active file line.
187 (if (not (string= (expand-file-name nnmh-directory) dir))
189 (lambda (name) (string-to-int name))
190 (directory-files dir nil "^[0-9]+$" t))))
192 (set-buffer nntp-server-buffer)
197 (string-match (expand-file-name nnmh-directory) dir)
198 (nnmail-replace-chars-in-string
199 (substring dir (match-end 0)) ?/ ?.))
200 (if files (apply (function max) files) 0)
201 (if files (apply (function min) files) 0))))))
204 (defun nnmh-request-newgroups (date &optional server)
205 "List groups created after DATE."
206 (nnmh-request-list server))
208 (defun nnmh-request-post (&optional server)
209 "Post a new news in current buffer."
210 (mail-send-and-exit nil))
212 (fset 'nnmh-request-post-buffer 'nnmail-request-post-buffer)
214 (defun nnmh-request-expire-articles (articles newsgroup &optional server force)
215 "Expire all articles in the ARTICLES list in group GROUP.
216 The list of unexpired articles will be returned (ie. all articles that
217 were too fresh to be expired).
218 If FORCE is non-nil, ARTICLES will be deleted whether they are old or not."
219 (nnmh-possibly-change-directory newsgroup)
220 (let* ((days (or (and nnmail-expiry-wait-function
221 (funcall nnmail-expiry-wait-function newsgroup))
223 article rest mod-time)
225 (setq article (concat nnmh-current-directory (int-to-string
227 (if (setq mod-time (nth 5 (file-attributes article)))
229 (> (nnmail-days-between
230 (current-time-string)
231 (current-time-string mod-time))
234 (message "Deleting %s..." article)
236 (delete-file article)
238 (setq rest (cons (car articles) rest))))
239 (setq articles (cdr articles)))
242 (defun nnmh-close-group (group &optional server)
245 (defun nnmh-request-move-article (article group server accept-form)
246 (let ((buf (get-buffer-create " *nnmh move*"))
249 (nnmh-request-article article group server)
252 (insert-buffer-substring nntp-server-buffer)
253 (setq result (eval accept-form))
254 (kill-buffer (current-buffer))
257 (delete-file (concat nnmh-current-directory
258 (int-to-string article)))
262 (defun nnmh-request-accept-article (group)
266 (setq nnmh-group-alist (nnmail-get-active))
267 ;; We trick the choosing function into believing that only one
268 ;; group is availiable.
269 (let ((nnmail-split-methods '(group "")))
270 (cons group (nnmh-save-mail))))
273 (setq nnmh-group-alist (nnmail-get-active))
277 ;;; Low-Level Interface
279 (defun nnmh-open-server-internal (host &optional service)
280 "Open connection to news server on HOST by SERVICE."
282 ;; Initialize communication buffer.
283 (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
284 (set-buffer nntp-server-buffer)
285 (buffer-disable-undo (current-buffer))
287 (kill-all-local-variables)
288 (setq case-fold-search t) ;Should ignore case.
291 (defun nnmh-close-server-internal ()
292 "Close connection to news server."
295 (defun nnmh-possibly-change-directory (newsgroup)
297 (let ((pathname (nnmail-article-pathname newsgroup nnmh-directory)))
298 (if (file-directory-p pathname)
299 (setq nnmh-current-directory pathname)
300 (error "No such newsgroup: %s" newsgroup)))))
302 (defun nnmh-create-directories ()
303 (let ((methods nnmail-split-methods)
306 (setq dir (nnmail-article-pathname (car (car methods)) nnmh-directory))
307 (while (not (file-directory-p dir))
308 (setq dirs (cons dir dirs))
309 (setq dir (file-name-directory (directory-file-name dir))))
311 (if (make-directory (directory-file-name (car dirs)))
312 (error "Could not create directory %s" (car dirs)))
313 (message "Creating mail directory %s" (car dirs))
314 (setq dirs (cdr dirs)))
315 (setq methods (cdr methods)))))
317 (defun nnmh-save-mail ()
318 "Called narrowed to an article."
319 (let ((group-art (nreverse (nnmail-article-group 'nnmh-active-number)))
320 chars nov-line lines hbeg hend)
321 (setq chars (nnmail-insert-lines))
322 (nnmail-insert-xref group-art)
323 (goto-char (point-min))
324 (while (looking-at "From ")
325 (replace-match "X-From-Line: ")
327 ;; We save the article in all the newsgroups it belongs in.
331 (let ((file (concat (nnmail-article-pathname
332 (car (car ga)) nnmh-directory)
333 (int-to-string (cdr (car ga))))))
335 ;; It was already saved, so we just make a hard link.
336 (add-name-to-file first file t)
338 (write-region (point-min) (point-max) file nil nil)
343 (defun nnmh-active-number (group)
344 "Compute the next article number in GROUP."
345 (let ((active (car (cdr (assoc group nnmh-group-alist)))))
346 (setcdr active (1+ (cdr active)))
348 (while (file-exists-p
349 (setq file (concat (nnmail-article-pathname
350 group nnmh-directory)
351 (int-to-string (cdr active)))))
352 (setcdr active (1+ (cdr active)))))
355 (defun nnmh-get-new-mail ()
356 "Read new incoming mail."
358 (nnmh-create-directories)
359 (if (and nnmh-get-new-mail nnmail-spool-file
360 (file-exists-p nnmail-spool-file)
361 (> (nth 7 (file-attributes nnmail-spool-file)) 0))
363 (message "nnmh: Reading incoming mail...")
365 (nnmail-move-inbox nnmail-spool-file
366 (concat nnmh-directory "Incoming")))
368 (setq nnmh-group-alist (nnmail-get-active))
369 (nnmail-split-incoming incoming 'nnmh-save-mail)
370 (run-hooks 'nnmail-read-incoming-hook)
371 ;; (delete-file incoming)
372 (message "nnmh: Reading incoming mail...done")))))
374 (defun nnmh-update-gnus-unreads (group)
375 ;; Go through the .nnmh-articles file and compare with the actual
376 ;; articles in this folder. The articles that are "new" will be
377 ;; marked as unread by Gnus.
378 (let* ((dir nnmh-current-directory)
379 (files (sort (mapcar (function (lambda (name) (string-to-int name)))
380 (directory-files nnmh-current-directory
381 nil "^[0-9]+$" t)) '<))
382 (nnmh-file (concat dir ".nnmh-articles"))
384 ;; Load the .nnmh-articles file.
385 (if (file-exists-p nnmh-file)
387 (let (nnmh-newsgroup-articles)
388 (condition-case nil (load nnmh-file nil t t) (error nil))
389 nnmh-newsgroup-articles)))
390 ;; Add all new articles to the `new' list.
393 (if (not (assq (car art) articles)) (setq new (cons (car art) new)))
394 (setq art (cdr art))))
395 ;; Remove all deleted articles.
396 (let ((art articles))
398 (if (not (memq (car (car art)) files))
399 (setq articles (delq (car art) articles)))
400 (setq art (cdr art))))
401 ;; Check whether the highest-numbered articles really are the ones
402 ;; that Gnus thinks they are by looking at the time-stamps.
403 (let ((art articles))
406 (nth 5 (file-attributes
407 (concat dir (int-to-string (car (car art))))))
409 (setq articles (delq (car art) articles))
410 (setq new (cons (car (car art)) new))
411 (setq art (cdr art))))
412 ;; Go through all the new articles and add them, and their
413 ;; time-stamps to the list.
419 (nth 5 (file-attributes
420 (concat dir (int-to-string (car n))))))
423 ;; Make Gnus mark all new articles as unread.
424 (or (zerop (length new))
425 (gnus-make-articles-unread
426 (gnus-group-prefixed-name group (list 'nnmh ""))
427 (setq new (sort new '<))))
428 ;; Sort the article list with highest numbers first.
429 (setq articles (sort articles (lambda (art1 art2)
430 (> (car art1) (car art2)))))
431 ;; Finally write this list back to the .nnmh-articles file.
433 (set-buffer (get-buffer-create "*nnmh out*"))
434 (insert ";; Gnus article active file for " group "\n\n")
435 (insert "(setq nnmh-newsgroup-articles '")
436 (insert (prin1-to-string articles) ")\n")
437 (write-region (point-min) (point-max) nnmh-file nil 'nomesg)
438 (kill-buffer (current-buffer)))))
442 ;;; nnmh.el ends here