1 ;;; nnmh.el --- mhspool access for Gnus
3 ;; Copyright (C) 1995-2018 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7 ;; Keywords: news, mail
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
26 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
27 ;; For an overview of what the interface functions do, please see the
39 (defvoo nnmh-directory message-directory
40 "Mail spool directory.")
42 (defvoo nnmh-get-new-mail t
43 "If non-nil, nnmh will check the incoming mail file and split the mail.")
45 (defvoo nnmh-prepare-save-mail-hook nil
46 "Hook run narrowed to an article before saving.")
48 (defvoo nnmh-be-safe nil
49 "If non-nil, nnmh will check all articles to make sure whether they are new or not.
50 Go through the .nnmh-articles file and compare with the actual
51 articles in this folder. The articles that are \"new\" will be marked
56 (defconst nnmh-version
"nnmh 1.0"
59 (defvoo nnmh-current-directory nil
60 "Current news group directory.")
62 (defvoo nnmh-status-string
"")
63 (defvoo nnmh-group-alist nil
)
64 ;; Don't even think about setting this variable. It does not exist.
65 ;; Forget about it. Uh-huh. Nope. Nobody here. It's only bound
66 ;; dynamically by certain functions in nndraft.
67 (defvar nnmh-allow-delete-final nil
)
71 ;;; Interface functions.
73 (nnoo-define-basics nnmh
)
75 (deffoo nnmh-retrieve-headers
(articles &optional newsgroup server fetch-old
)
76 (with-current-buffer nntp-server-buffer
79 (number (length articles
))
80 (large (and (numberp nnmail-large-newsgroup
)
81 (> number nnmail-large-newsgroup
)))
83 (file-name-coding-system nnmail-pathname-coding-system
)
85 (nnmh-possibly-change-directory newsgroup server
)
86 ;; We don't support fetching by Message-ID.
87 (if (stringp (car articles
))
90 (when (and (file-exists-p
91 (setq file
(concat (file-name-as-directory
92 nnmh-current-directory
)
94 (setq article
(pop articles
))))))
95 (not (file-directory-p file
)))
96 (insert (format "221 %d Article retrieved.\n" article
))
98 (nnheader-insert-head file
)
100 (if (search-forward "\n\n" nil t
)
102 (goto-char (point-max))
105 (delete-region (point) (point-max)))
106 (setq count
(1+ count
))
110 (nnheader-message 5 "nnmh: Receiving headers... %d%%"
111 (floor (* count
100.0) number
))))
114 (nnheader-message 5 "nnmh: Receiving headers...done"))
116 (nnheader-fold-continuation-lines)
119 (deffoo nnmh-open-server
(server &optional defs
)
120 (nnoo-change-server 'nnmh server defs
)
121 (when (not (file-exists-p nnmh-directory
))
123 (make-directory nnmh-directory t
)
126 ((not (file-exists-p nnmh-directory
))
128 (nnheader-report 'nnmh
"Couldn't create directory: %s" nnmh-directory
))
129 ((not (file-directory-p (file-truename nnmh-directory
)))
131 (nnheader-report 'nnmh
"Not a directory: %s" nnmh-directory
))
133 (nnheader-report 'nnmh
"Opened server %s using directory %s"
134 server nnmh-directory
)
137 (deffoo nnmh-request-article
(id &optional newsgroup server buffer
)
138 (nnmh-possibly-change-directory newsgroup server
)
139 (let ((file (if (stringp id
)
141 (concat nnmh-current-directory
(int-to-string id
))))
142 (file-name-coding-system nnmail-pathname-coding-system
)
143 (nntp-server-buffer (or buffer nntp-server-buffer
)))
146 (not (file-directory-p file
))
147 (save-excursion (nnmail-find-file file
))
148 (string-to-number (file-name-nondirectory file
)))))
150 (deffoo nnmh-request-group
(group &optional server dont-check info
)
151 (nnheader-init-server-buffer)
152 (nnmh-possibly-change-directory group server
)
153 (let ((pathname (nnmail-group-pathname group nnmh-directory
))
154 (file-name-coding-system nnmail-pathname-coding-system
)
157 ((not (file-directory-p pathname
))
159 'nnmh
"Can't select group (no such directory): %s" group
))
161 (setq nnmh-current-directory pathname
)
162 (and nnmh-get-new-mail
164 (nnmh-update-gnus-unreads group
))
167 (nnheader-report 'nnmh
"Selected group %s" group
)
170 ;; Re-scan the directory if it's on a foreign system.
171 (nnheader-re-read-dir pathname
)
174 (mapcar 'string-to-number
175 (directory-files pathname nil
"^[0-9]+$" t
))
179 (setq nnmh-group-alist
180 (delq (assoc group nnmh-group-alist
) nnmh-group-alist
))
181 (push (list group
(cons (car dir
) (car (last dir
))))
183 (nnheader-report 'nnmh
"Selected group %s" group
)
185 "211 %d %d %d %s\n" (length dir
) (car dir
)
186 (car (last dir
)) group
))
188 (nnheader-report 'nnmh
"Empty group %s" group
)
189 (nnheader-insert (format "211 0 1 0 %s\n" group
))))))))))
191 (deffoo nnmh-request-scan
(&optional group server
)
192 (nnmail-get-new-mail 'nnmh nil nnmh-directory group
))
194 (deffoo nnmh-request-list
(&optional server dir
)
196 (nnmh-possibly-change-directory nil server
)
197 (let ((file-name-coding-system nnmail-pathname-coding-system
)
199 (file-truename (or dir
(file-name-as-directory nnmh-directory
)))))
200 (nnmh-request-list-1 nnmh-toplev
))
201 (setq nnmh-group-alist
(nnmail-get-active))
205 (defun nnmh-request-list-1 (dir)
206 (setq dir
(expand-file-name dir
))
207 ;; Recurse down all directories.
208 (let ((files (nnheader-directory-files dir t nil t
))
210 min rdir num subdirectoriesp file
)
211 ;; Recurse down directories.
212 (setq subdirectoriesp
213 ;; link number always 1 on MS Windows :(
214 (/= (file-attribute-link-number
215 (file-attributes (file-truename dir
)))
218 (if (or (not subdirectoriesp
)
219 (file-regular-p rdir
))
221 (setq file
(file-name-nondirectory rdir
))
222 (when (string-match "^[0-9]+$" file
)
223 (setq num
(string-to-number file
))
224 (setq max
(max max num
))
228 ;; This is a directory.
229 (when (and (file-readable-p rdir
)
230 (not (equal (file-truename rdir
)
231 (file-truename dir
))))
232 (nnmh-request-list-1 rdir
))))
233 ;; For each directory, generate an active file line.
234 (unless (string= (expand-file-name nnmh-toplev
) dir
)
235 (with-current-buffer nntp-server-buffer
236 (goto-char (point-max))
243 (file-truename (file-name-as-directory
244 (expand-file-name nnmh-toplev
))))
246 (encode-coding-string
247 (nnheader-replace-chars-in-string
248 (substring dir
(match-end 0))
250 nnmail-pathname-coding-system
))
255 (deffoo nnmh-request-newgroups
(date &optional server
)
256 (nnmh-request-list server
))
258 (deffoo nnmh-request-expire-articles
(articles newsgroup
259 &optional server force
)
260 (nnmh-possibly-change-directory newsgroup server
)
262 (dir nnmh-current-directory
)
263 article rest mod-time
)
264 (nnheader-init-server-buffer)
266 (while (and articles is-old
)
267 (setq article
(concat dir
(int-to-string (car articles
))))
268 (when (setq mod-time
(file-attribute-modification-time
269 (file-attributes article
)))
270 (if (and (nnmh-deletable-article-p newsgroup
(car articles
))
272 (nnmail-expired-article-p newsgroup mod-time force
)))
274 ;; Allow a special target group. -- jcn
275 (unless (eq nnmail-expiry-target
'delete
)
277 (nnmh-request-article (car articles
)
278 newsgroup server
(current-buffer))
279 (nnmail-expiry-target-group
280 nnmail-expiry-target newsgroup
)))
281 (nnheader-message 5 "Deleting article %s in %s..."
284 (funcall nnmail-delete-file-function article
)
286 (nnheader-message 1 "Couldn't delete article %s in %s"
288 (push (car articles
) rest
))))
289 (push (car articles
) rest
)))
290 (setq articles
(cdr articles
)))
291 (nnheader-message 5 "")
292 (nconc rest articles
)))
294 (deffoo nnmh-close-group
(group &optional server
)
297 (deffoo nnmh-request-move-article
(article group server accept-form
298 &optional last move-is-internal
)
299 (let ((buf (get-buffer-create " *nnmh move*"))
302 (nnmh-deletable-article-p group article
)
303 (nnmh-request-article article group server
)
304 (with-current-buffer buf
306 (insert-buffer-substring nntp-server-buffer
)
307 (setq result
(eval accept-form
))
308 (kill-buffer (current-buffer))
311 (nnmh-possibly-change-directory group server
)
313 (funcall nnmail-delete-file-function
314 (concat nnmh-current-directory
(int-to-string article
)))
318 (deffoo nnmh-request-accept-article
(group &optional server last noinsert
)
319 (nnmh-possibly-change-directory group server
)
320 (nnmail-check-syntax)
321 (when nnmail-cache-accepted-message-ids
322 (nnmail-cache-insert (nnmail-fetch-field "message-id")
324 (nnmail-fetch-field "subject")
325 (nnmail-fetch-field "from")))
326 (nnheader-init-server-buffer)
330 (nnmh-active-number group
)
332 (list (cons group
(nnmh-active-number group
)))
334 (let ((res (nnmail-article-group 'nnmh-active-number
)))
336 (yes-or-no-p "Moved to `junk' group; delete article? "))
338 (car (nnmh-save-mail res noinsert
)))))
339 (when (and last nnmail-cache-accepted-message-ids
)
340 (nnmail-cache-close))))
342 (deffoo nnmh-request-replace-article
(article group buffer
)
343 (nnmh-possibly-change-directory group
)
344 (with-current-buffer buffer
345 (nnmh-possibly-create-directory group
)
348 (point-min) (point-max)
349 (concat nnmh-current-directory
(int-to-string article
))
350 nil
(if (nnheader-be-verbose 5) nil
'nomesg
))
353 (deffoo nnmh-request-create-group
(group &optional server args
)
354 (nnheader-init-server-buffer)
355 (unless (assoc group nnmh-group-alist
)
357 (push (list group
(setq active
(cons 1 0)))
359 (nnmh-possibly-create-directory group
)
360 (nnmh-possibly-change-directory group server
)
361 (let ((articles (mapcar 'string-to-number
363 nnmh-current-directory nil
"^[0-9]+$"))))
365 (setcar active
(apply 'min articles
))
366 (setcdr active
(apply 'max articles
))))))
369 (deffoo nnmh-request-delete-group
(group &optional force server
)
370 (nnmh-possibly-change-directory group server
)
371 ;; Delete all articles in GROUP.
373 () ; Don't delete the articles.
374 (let ((articles (directory-files nnmh-current-directory t
"^[0-9]+$")))
376 (when (file-writable-p (car articles
))
377 (nnheader-message 5 "Deleting article %s in %s..."
378 (car articles
) group
)
379 (funcall nnmail-delete-file-function
(car articles
)))
380 (setq articles
(cdr articles
))))
381 ;; Try to delete the directory itself.
383 (delete-directory nnmh-current-directory
)))
384 ;; Remove the group from all structures.
385 (setq nnmh-group-alist
386 (delq (assoc group nnmh-group-alist
) nnmh-group-alist
)
387 nnmh-current-directory nil
)
390 (deffoo nnmh-request-rename-group
(group new-name
&optional server
)
391 (nnmh-possibly-change-directory group server
)
392 (let ((new-dir (nnmail-group-pathname new-name nnmh-directory
))
393 (old-dir (nnmail-group-pathname group nnmh-directory
)))
395 (make-directory new-dir t
)
397 ;; We move the articles file by file instead of renaming
398 ;; the directory -- there may be subgroups in this group.
399 ;; One might be more clever, I guess.
400 (let ((files (nnheader-article-to-file-alist old-dir
)))
403 (concat old-dir
(cdar files
))
404 (concat new-dir
(cdar files
)))
406 (when (<= (length (directory-files old-dir
)) 2)
408 (delete-directory old-dir
)))
409 ;; That went ok, so we change the internal structures.
410 (let ((entry (assoc group nnmh-group-alist
)))
412 (setcar entry new-name
))
413 (setq nnmh-current-directory nil
)
416 (nnoo-define-skeleton nnmh
)
419 ;;; Internal functions.
421 (defun nnmh-possibly-change-directory (newsgroup &optional server
)
423 (not (nnmh-server-opened server
)))
424 (nnmh-open-server server
))
426 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory
))
427 (file-name-coding-system nnmail-pathname-coding-system
))
428 (if (file-directory-p pathname
)
429 (setq nnmh-current-directory pathname
)
430 (nnheader-report 'nnmh
"Not a directory: %s" nnmh-directory
)))))
432 (defun nnmh-possibly-create-directory (group)
434 (setq dir
(nnmail-group-pathname group nnmh-directory
))
435 (while (not (file-directory-p dir
))
437 (setq dir
(file-name-directory (directory-file-name dir
))))
439 (when (make-directory (directory-file-name (car dirs
)))
440 (error "Could not create directory %s" (car dirs
)))
441 (nnheader-message 5 "Creating mail directory %s" (car dirs
))
442 (setq dirs
(cdr dirs
)))))
444 (defun nnmh-save-mail (group-art &optional noinsert
)
445 "Called narrowed to an article."
447 (nnmail-insert-lines)
448 (nnmail-insert-xref group-art
))
449 (run-hooks 'nnmail-prepare-save-mail-hook
)
450 (run-hooks 'nnmh-prepare-save-mail-hook
)
451 (goto-char (point-min))
452 (while (looking-at "From ")
453 (replace-match "X-From-Line: ")
455 ;; We save the article in all the newsgroups it belongs in.
459 (nnmh-possibly-create-directory (caar ga
))
460 (let ((file (concat (nnmail-group-pathname
461 (caar ga
) nnmh-directory
)
462 (int-to-string (cdar ga
)))))
464 ;; It was already saved, so we just make a hard link.
465 (funcall nnmail-crosspost-link-function first file t
)
467 (nnmail-write-region (point-min) (point-max) file nil nil
)
472 (defun nnmh-active-number (group)
473 "Compute the next article number in GROUP."
474 (let ((active (cadr (assoc group nnmh-group-alist
)))
475 (dir (nnmail-group-pathname group nnmh-directory
))
476 (file-name-coding-system nnmail-pathname-coding-system
)
479 ;; The group wasn't known to nnmh, so we just create an active
481 (setq active
(cons 1 0))
482 (push (list group active
) nnmh-group-alist
)
483 (unless (file-exists-p dir
)
484 (gnus-make-directory dir
))
485 ;; Find the highest number in the group.
487 (mapcar 'string-to-number
488 (directory-files dir nil
"^[0-9]+$"))
491 (setcdr active
(car files
)))))
492 (setcdr active
(1+ (cdr active
)))
494 ;; See whether the file exists...
496 (setq file
(concat (nnmail-group-pathname group nnmh-directory
)
497 (int-to-string (cdr active
)))))
498 ;; ... or there is a buffer that will make that file exist
500 (get-file-buffer file
))
501 ;; Skip past that file.
502 (setcdr active
(1+ (cdr active
))))
505 (defun nnmh-update-gnus-unreads (group)
506 ;; Go through the .nnmh-articles file and compare with the actual
507 ;; articles in this folder. The articles that are "new" will be
508 ;; marked as unread by Gnus.
509 (let* ((dir nnmh-current-directory
)
510 (files (sort (mapcar 'string-to-number
511 (directory-files nnmh-current-directory
514 (nnmh-file (concat dir
".nnmh-articles"))
516 ;; Load the .nnmh-articles file.
517 (when (file-exists-p nnmh-file
)
519 (let (nnmh-newsgroup-articles)
520 (ignore-errors (load nnmh-file nil t t
))
521 nnmh-newsgroup-articles
)))
522 ;; Add all new articles to the `new' list.
525 (unless (assq (car art
) articles
)
526 (push (car art
) new
))
527 (setq art
(cdr art
))))
528 ;; Remove all deleted articles.
529 (let ((art articles
))
531 (unless (memq (caar art
) files
)
532 (setq articles
(delq (car art
) articles
)))
533 (setq art
(cdr art
))))
534 ;; Check whether the articles really are the ones that Gnus thinks
535 ;; they are by looking at the time-stamps.
536 (let ((arts articles
)
538 (while (setq art
(pop arts
))
540 (file-attribute-modification-time
541 (file-attributes (concat dir
(int-to-string (car art
)))))
543 (setq articles
(delq art articles
))
544 (push (car art
) new
))))
545 ;; Go through all the new articles and add them, and their
546 ;; time-stamps, to the list.
552 (file-attribute-modification-time
554 (concat dir
(int-to-string art
))))))
556 ;; Make Gnus mark all new articles as unread.
558 (gnus-make-articles-unread
559 (gnus-group-prefixed-name group
(list 'nnmh
""))
560 (setq new
(sort new
'<))))
561 ;; Sort the article list with highest numbers first.
562 (setq articles
(sort articles
(lambda (art1 art2
)
563 (> (car art1
) (car art2
)))))
564 ;; Finally write this list back to the .nnmh-articles file.
565 (with-temp-file nnmh-file
566 (insert ";; Gnus article active file for " group
"\n\n")
567 (insert "(setq nnmh-newsgroup-articles '")
568 (gnus-prin1 articles
)
571 (defun nnmh-deletable-article-p (group article
)
572 "Say whether ARTICLE in GROUP can be deleted."
573 (let ((path (concat nnmh-current-directory
(int-to-string article
))))
575 (and (file-writable-p path
)
577 ;; We can never delete the last article in the group.
578 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist
)))
581 nnmh-allow-delete-final
))))
585 ;;; nnmh.el ends here