Mercurial > hg > xemacs-beta

comparison lisp/gnus/nnmh.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 8b8b7f3559a2
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; nnmh.el --- mhspool access for Gnus 1 ;;; nnmh.el --- mhspool access for Gnus
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6 ;; Keywords: news, mail 6 ;; Keywords: news, mail
7 7
24 24
25 ;;; Commentary: 25 ;;; Commentary:
26 26
27 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>. 27 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
28 ;; For an overview of what the interface functions do, please see the 28 ;; For an overview of what the interface functions do, please see the
29 ;; Gnus sources. 29 ;; Gnus sources.
30 30
31 ;;; Code: 31 ;;; Code:
32 32
33 (require 'nnheader) 33 (require 'nnheader)
34 (require 'nnmail) 34 (require 'nnmail)
35 (require 'gnus-start) 35 (require 'gnus)
36 (require 'nnoo) 36 (require 'nnoo)
37 (require 'cl) 37 (eval-and-compile (require 'cl))
38 38
39 (nnoo-declare nnmh) 39 (nnoo-declare nnmh)
40 40
41 (defvoo nnmh-directory message-directory 41 (defvoo nnmh-directory message-directory
42 "*Mail spool directory.") 42 "*Mail spool directory.")
80 (nnmh-possibly-change-directory newsgroup server) 80 (nnmh-possibly-change-directory newsgroup server)
81 ;; We don't support fetching by Message-ID. 81 ;; We don't support fetching by Message-ID.
82 (if (stringp (car articles)) 82 (if (stringp (car articles))
83 'headers 83 'headers
84 (while articles 84 (while articles
85 (when (and (file-exists-p 85 (when (and (file-exists-p
86 (setq file (concat (file-name-as-directory 86 (setq file (concat (file-name-as-directory
87 nnmh-current-directory) 87 nnmh-current-directory)
88 (int-to-string 88 (int-to-string
89 (setq article (pop articles)))))) 89 (setq article (pop articles))))))
90 (not (file-directory-p file))) 90 (not (file-directory-p file)))
91 (insert (format "221 %d Article retrieved.\n" article)) 91 (insert (format "221 %d Article retrieved.\n" article))
103 (and large 103 (and large
104 (zerop (% count 20)) 104 (zerop (% count 20))
105 (message "nnmh: Receiving headers... %d%%" 105 (message "nnmh: Receiving headers... %d%%"
106 (/ (* count 100) number)))) 106 (/ (* count 100) number))))
107 107
108 (when large 108 (and large (message "nnmh: Receiving headers...done"))
109 (message "nnmh: Receiving headers...done"))
110 109
111 (nnheader-fold-continuation-lines) 110 (nnheader-fold-continuation-lines)
112 'headers)))) 111 'headers))))
113 112
114 (deffoo nnmh-open-server (server &optional defs) 113 (deffoo nnmh-open-server (server &optional defs)
115 (nnoo-change-server 'nnmh server defs) 114 (nnoo-change-server 'nnmh server defs)
116 (when (not (file-exists-p nnmh-directory)) 115 (when (not (file-exists-p nnmh-directory))
117 (condition-case () 116 (condition-case ()
118 (make-directory nnmh-directory t) 117 (make-directory nnmh-directory t)
119 (error t))) 118 (error t)))
120 (cond 119 (cond
121 ((not (file-exists-p nnmh-directory)) 120 ((not (file-exists-p nnmh-directory))
122 (nnmh-close-server) 121 (nnmh-close-server)
123 (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory)) 122 (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory))
124 ((not (file-directory-p (file-truename nnmh-directory))) 123 ((not (file-directory-p (file-truename nnmh-directory)))
125 (nnmh-close-server) 124 (nnmh-close-server)
142 (string-to-int (file-name-nondirectory file))))) 141 (string-to-int (file-name-nondirectory file)))))
143 142
144 (deffoo nnmh-request-group (group &optional server dont-check) 143 (deffoo nnmh-request-group (group &optional server dont-check)
145 (let ((pathname (nnmail-group-pathname group nnmh-directory)) 144 (let ((pathname (nnmail-group-pathname group nnmh-directory))
146 dir) 145 dir)
147 (cond 146 (cond
148 ((not (file-directory-p pathname)) 147 ((not (file-directory-p pathname))
149 (nnheader-report 148 (nnheader-report
150 'nnmh "Can't select group (no such directory): %s" group)) 149 'nnmh "Can't select group (no such directory): %s" group))
151 (t 150 (t
152 (setq nnmh-current-directory pathname) 151 (setq nnmh-current-directory pathname)
153 (and nnmh-get-new-mail 152 (and nnmh-get-new-mail
154 nnmh-be-safe 153 nnmh-be-safe
155 (nnmh-update-gnus-unreads group)) 154 (nnmh-update-gnus-unreads group))
156 (cond 155 (cond
157 (dont-check 156 (dont-check
158 (nnheader-report 'nnmh "Selected group %s" group) 157 (nnheader-report 'nnmh "Selected group %s" group)
159 t) 158 t)
160 (t 159 (t
161 ;; Re-scan the directory if it's on a foreign system. 160 ;; Re-scan the directory if it's on a foreign system.
162 (nnheader-re-read-dir pathname) 161 (nnheader-re-read-dir pathname)
163 (setq dir 162 (setq dir
164 (sort 163 (sort
165 (mapcar (lambda (name) (string-to-int name)) 164 (mapcar (lambda (name) (string-to-int name))
166 (directory-files pathname nil "^[0-9]+$" t)) 165 (directory-files pathname nil "^[0-9]+$" t))
167 '<)) 166 '<))
168 (cond 167 (cond
169 (dir 168 (dir
170 (nnheader-report 'nnmh "Selected group %s" group) 169 (nnheader-report 'nnmh "Selected group %s" group)
171 (nnheader-insert 170 (nnheader-insert
172 "211 %d %d %d %s\n" (length dir) (car dir) 171 "211 %d %d %d %s\n" (length dir) (car dir)
173 (progn (while (cdr dir) (setq dir (cdr dir))) (car dir)) 172 (progn (while (cdr dir) (setq dir (cdr dir))) (car dir))
175 (t 174 (t
176 (nnheader-report 'nnmh "Empty group %s" group) 175 (nnheader-report 'nnmh "Empty group %s" group)
177 (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) 176 (nnheader-insert (format "211 0 1 0 %s\n" group))))))))))
178 177
179 (deffoo nnmh-request-scan (&optional group server) 178 (deffoo nnmh-request-scan (&optional group server)
180 (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) 179 (nnmail-get-new-mail 'nnmh nil nnmh-directory group))
181 180
182 (deffoo nnmh-request-list (&optional server dir) 181 (deffoo nnmh-request-list (&optional server dir)
183 (nnheader-insert "") 182 (nnheader-insert "")
184 (let ((nnmh-toplev 183 (let ((nnmh-toplev
185 (or dir (file-truename (file-name-as-directory nnmh-directory))))) 184 (or dir (file-truename (file-name-as-directory nnmh-directory)))))
208 (directory-files dir nil "^[0-9]+$" t)))) 207 (directory-files dir nil "^[0-9]+$" t))))
209 (when files 208 (when files
210 (save-excursion 209 (save-excursion
211 (set-buffer nntp-server-buffer) 210 (set-buffer nntp-server-buffer)
212 (goto-char (point-max)) 211 (goto-char (point-max))
213 (insert 212 (insert
214 (format 213 (format
215 "%s %d %d y\n" 214 "%s %d %d y\n"
216 (progn 215 (progn
217 (string-match 216 (string-match
218 (regexp-quote 217 (regexp-quote
219 (file-truename (file-name-as-directory 218 (file-truename (file-name-as-directory
220 (expand-file-name nnmh-toplev)))) 219 (expand-file-name nnmh-toplev)))) dir)
221 dir)
222 (nnheader-replace-chars-in-string 220 (nnheader-replace-chars-in-string
223 (substring dir (match-end 0)) ?/ ?.)) 221 (substring dir (match-end 0)) ?/ ?.))
224 (apply 'max files) 222 (apply 'max files)
225 (apply 'min files))))))) 223 (apply 'min files)))))))
226 t) 224 t)
227 225
228 (deffoo nnmh-request-newgroups (date &optional server) 226 (deffoo nnmh-request-newgroups (date &optional server)
229 (nnmh-request-list server)) 227 (nnmh-request-list server))
230 228
231 (deffoo nnmh-request-expire-articles (articles newsgroup 229 (deffoo nnmh-request-expire-articles (articles newsgroup &optional server force)
232 &optional server force)
233 (nnmh-possibly-change-directory newsgroup server) 230 (nnmh-possibly-change-directory newsgroup server)
234 (let* ((active-articles 231 (let* ((active-articles
235 (mapcar 232 (mapcar
236 (function 233 (function
237 (lambda (name) 234 (lambda (name)
238 (string-to-int name))) 235 (string-to-int name)))
239 (directory-files nnmh-current-directory nil "^[0-9]+$" t))) 236 (directory-files nnmh-current-directory nil "^[0-9]+$" t)))
240 (is-old t) 237 (is-old t)
241 article rest mod-time) 238 article rest mod-time)
242 (nnmail-activate 'nnmh) 239 (nnmail-activate 'nnmh)
243 240
244 (while (and articles is-old) 241 (while (and articles is-old)
245 (setq article (concat nnmh-current-directory 242 (setq article (concat nnmh-current-directory
246 (int-to-string (car articles)))) 243 (int-to-string (car articles))))
247 (when (setq mod-time (nth 5 (file-attributes article))) 244 (if (setq mod-time (nth 5 (file-attributes article)))
248 (if (and (nnmh-deletable-article-p newsgroup (car articles)) 245 (if (and (nnmh-deletable-article-p newsgroup (car articles))
249 (setq is-old 246 (setq is-old
250 (nnmail-expired-article-p newsgroup mod-time force))) 247 (nnmail-expired-article-p newsgroup mod-time force)))
251 (progn 248 (progn
252 (nnheader-message 5 "Deleting article %s in %s..." 249 (nnheader-message 5 "Deleting article %s in %s..."
253 article newsgroup) 250 article newsgroup)
254 (condition-case () 251 (condition-case ()
255 (funcall nnmail-delete-file-function article) 252 (funcall nnmail-delete-file-function article)
256 (file-error 253 (file-error
257 (nnheader-message 1 "Couldn't delete article %s in %s" 254 (nnheader-message 1 "Couldn't delete article %s in %s"
258 article newsgroup) 255 article newsgroup)
259 (push (car articles) rest)))) 256 (setq rest (cons (car articles) rest)))))
260 (push (car articles) rest))) 257 (setq rest (cons (car articles) rest))))
261 (setq articles (cdr articles))) 258 (setq articles (cdr articles)))
262 (message "") 259 (message "")
263 (nconc rest articles))) 260 (nconc rest articles)))
264 261
265 (deffoo nnmh-close-group (group &optional server) 262 (deffoo nnmh-close-group (group &optional server)
266 t) 263 t)
267 264
268 (deffoo nnmh-request-move-article 265 (deffoo nnmh-request-move-article
269 (article group server accept-form &optional last) 266 (article group server accept-form &optional last)
270 (let ((buf (get-buffer-create " *nnmh move*")) 267 (let ((buf (get-buffer-create " *nnmh move*"))
271 result) 268 result)
272 (and 269 (and
273 (nnmh-deletable-article-p group article) 270 (nnmh-deletable-article-p group article)
274 (nnmh-request-article article group server) 271 (nnmh-request-article article group server)
275 (save-excursion 272 (save-excursion
276 (set-buffer buf) 273 (set-buffer buf)
277 (erase-buffer)
278 (insert-buffer-substring nntp-server-buffer) 274 (insert-buffer-substring nntp-server-buffer)
279 (setq result (eval accept-form)) 275 (setq result (eval accept-form))
280 (kill-buffer (current-buffer)) 276 (kill-buffer (current-buffer))
281 result) 277 result)
282 (progn 278 (progn
288 result)) 284 result))
289 285
290 (deffoo nnmh-request-accept-article (group &optional server last noinsert) 286 (deffoo nnmh-request-accept-article (group &optional server last noinsert)
291 (nnmh-possibly-change-directory group server) 287 (nnmh-possibly-change-directory group server)
292 (nnmail-check-syntax) 288 (nnmail-check-syntax)
293 (when nnmail-cache-accepted-message-ids 289 (if (stringp group)
294 (nnmail-cache-insert (nnmail-fetch-field "message-id"))) 290 (and
295 (prog1 291 (nnmail-activate 'nnmh)
296 (if (stringp group) 292 ;; We trick the choosing function into believing that only one
297 (and 293 ;; group is available.
298 (nnmail-activate 'nnmh) 294 (let ((nnmail-split-methods (list (list group ""))))
299 (car (nnmh-save-mail 295 (car (nnmh-save-mail noinsert))))
300 (list (cons group (nnmh-active-number group))) 296 (and
301 noinsert))) 297 (nnmail-activate 'nnmh)
302 (and 298 (car (nnmh-save-mail noinsert)))))
303 (nnmail-activate 'nnmh)
304 (let ((resu|t (nnmail-article-group 'nnmh-active-number)))
305 (if (not result)
306 'junk
307 (car (nnmh-save-mail result noinsert))))))
308 (when (and last nnmail-cache-accepted-message-ids)
309 (nnmail-cache-close))))
310 299
311 (deffoo nnmh-request-replace-article (article group buffer) 300 (deffoo nnmh-request-replace-article (article group buffer)
312 (nnmh-possibly-change-directory group) 301 (nnmh-possibly-change-directory group)
313 (save-excursion 302 (save-excursion
314 (set-buffer buffer) 303 (set-buffer buffer)
315 (nnmh-possibly-create-directory group) 304 (nnmh-possibly-create-directory group)
316 (ignore-errors 305 (condition-case ()
317 (nnmail-write-region 306 (progn
318 (point-min) (point-max) 307 (write-region
319 (concat nnmh-current-directory (int-to-string article)) 308 (point-min) (point-max)
320 nil (if (nnheader-be-verbose 5) nil 'nomesg)) 309 (concat nnmh-current-directory (int-to-string article))
321 t))) 310 nil (if (nnheader-be-verbose 5) nil 'nomesg))
322 311 t)
323 (deffoo nnmh-request-create-group (group &optional server args) 312 (error nil))))
313
314 (deffoo nnmh-request-create-group (group &optional server)
324 (nnmail-activate 'nnmh) 315 (nnmail-activate 'nnmh)
325 (unless (assoc group nnmh-group-alist) 316 (or (assoc group nnmh-group-alist)
326 (let (active) 317 (let (active)
327 (push (list group (setq active (cons 1 0))) 318 (setq nnmh-group-alist (cons (list group (setq active (cons 1 0)))
328 nnmh-group-alist) 319 nnmh-group-alist))
329 (nnmh-possibly-create-directory group) 320 (nnmh-possibly-create-directory group)
330 (nnmh-possibly-change-directory group server) 321 (nnmh-possibly-change-directory group server)
331 (let ((articles (mapcar 322 (let ((articles (mapcar
332 (lambda (file) 323 (lambda (file)
333 (string-to-int file)) 324 (string-to-int file))
334 (directory-files 325 (directory-files
335 nnmh-current-directory nil "^[0-9]+$")))) 326 nnmh-current-directory nil "^[0-9]+$"))))
336 (when articles 327 (and articles
337 (setcar active (apply 'min articles)) 328 (progn
338 (setcdr active (apply 'max articles)))))) 329 (setcar active (apply 'min articles))
330 (setcdr active (apply 'max articles)))))))
339 t) 331 t)
340 332
341 (deffoo nnmh-request-delete-group (group &optional force server) 333 (deffoo nnmh-request-delete-group (group &optional force server)
342 (nnmh-possibly-change-directory group server) 334 (nnmh-possibly-change-directory group server)
343 ;; Delete all articles in GROUP. 335 ;; Delete all articles in GROUP.
344 (if (not force) 336 (if (not force)
345 () ; Don't delete the articles. 337 () ; Don't delete the articles.
346 (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$"))) 338 (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$")))
347 (while articles 339 (while articles
348 (when (file-writable-p (car articles)) 340 (and (file-writable-p (car articles))
349 (nnheader-message 5 "Deleting article %s in %s..." 341 (progn
350 (car articles) group) 342 (nnheader-message 5 "Deleting article %s in %s..."
351 (funcall nnmail-delete-file-function (car articles))) 343 (car articles) group)
344 (funcall nnmail-delete-file-function (car articles))))
352 (setq articles (cdr articles)))) 345 (setq articles (cdr articles))))
353 ;; Try to delete the directory itself. 346 ;; Try to delete the directory itself.
354 (ignore-errors 347 (condition-case ()
355 (delete-directory nnmh-current-directory))) 348 (delete-directory nnmh-current-directory)
349 (error nil)))
356 ;; Remove the group from all structures. 350 ;; Remove the group from all structures.
357 (setq nnmh-group-alist 351 (setq nnmh-group-alist
358 (delq (assoc group nnmh-group-alist) nnmh-group-alist) 352 (delq (assoc group nnmh-group-alist) nnmh-group-alist)
359 nnmh-current-directory nil) 353 nnmh-current-directory nil)
360 t) 354 t)
361 355
362 (deffoo nnmh-request-rename-group (group new-name &optional server) 356 (deffoo nnmh-request-rename-group (group new-name &optional server)
363 (nnmh-possibly-change-directory group server) 357 (nnmh-possibly-change-directory group server)
364 (let ((new-dir (nnmail-group-pathname new-name nnmh-directory)) 358 ;; Rename directory.
365 (old-dir (nnmail-group-pathname group nnmh-directory))) 359 (and (file-writable-p nnmh-current-directory)
366 (when (ignore-errors 360 (condition-case ()
367 (make-directory new-dir t) 361 (progn
368 t) 362 (rename-file
369 ;; We move the articles file by file instead of renaming 363 (directory-file-name nnmh-current-directory)
370 ;; the directory -- there may be subgroups in this group. 364 (directory-file-name
371 ;; One might be more clever, I guess. 365 (nnmail-group-pathname new-name nnmh-directory)))
372 (let ((files (nnheader-article-to-file-alist old-dir))) 366 t)
373 (while files 367 (error nil))
374 (rename-file 368 ;; That went ok, so we change the internal structures.
375 (concat old-dir (cdar files)) 369 (let ((entry (assoc group nnmh-group-alist)))
376 (concat new-dir (cdar files))) 370 (and entry (setcar entry new-name))
377 (pop files))) 371 (setq nnmh-current-directory nil)
378 (when (<= (length (directory-files old-dir)) 2) 372 t)))
379 (ignore-errors
380 (delete-directory old-dir)))
381 ;; That went ok, so we change the internal structures.
382 (let ((entry (assoc group nnmh-group-alist)))
383 (when entry
384 (setcar entry new-name))
385 (setq nnmh-current-directory nil)
386 t))))
387
388 (nnoo-define-skeleton nnmh)
389 373
390 374
391 ;;; Internal functions. 375 ;;; Internal functions.
392 376
393 (defun nnmh-possibly-change-directory (newsgroup &optional server) 377 (defun nnmh-possibly-change-directory (newsgroup &optional server)
394 (when (and server 378 (when (and server
395 (not (nnmh-server-opened server))) 379 (not (nnmh-server-opened server)))
396 (nnmh-open-server server)) 380 (nnmh-open-server server))
397 (when newsgroup 381 (if newsgroup
398 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))) 382 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)))
399 (if (file-directory-p pathname) 383 (if (file-directory-p pathname)
400 (setq nnmh-current-directory pathname) 384 (setq nnmh-current-directory pathname)
401 (error "No such newsgroup: %s" newsgroup))))) 385 (error "No such newsgroup: %s" newsgroup)))))
402 386
403 (defun nnmh-possibly-create-directory (group) 387 (defun nnmh-possibly-create-directory (group)
404 (let (dir dirs) 388 (let (dir dirs)
405 (setq dir (nnmail-group-pathname group nnmh-directory)) 389 (setq dir (nnmail-group-pathname group nnmh-directory))
406 (while (not (file-directory-p dir)) 390 (while (not (file-directory-p dir))
407 (push dir dirs) 391 (setq dirs (cons dir dirs))
408 (setq dir (file-name-directory (directory-file-name dir)))) 392 (setq dir (file-name-directory (directory-file-name dir))))
409 (while dirs 393 (while dirs
410 (when (make-directory (directory-file-name (car dirs))) 394 (if (make-directory (directory-file-name (car dirs)))
411 (error "Could not create directory %s" (car dirs))) 395 (error "Could not create directory %s" (car dirs)))
412 (nnheader-message 5 "Creating mail directory %s" (car dirs)) 396 (nnheader-message 5 "Creating mail directory %s" (car dirs))
413 (setq dirs (cdr dirs))))) 397 (setq dirs (cdr dirs)))))
414 398
415 (defun nnmh-save-mail (group-art &optional noinsert) 399 (defun nnmh-save-mail (&optional noinsert)
416 "Called narrowed to an article." 400 "Called narrowed to an article."
417 (unless noinsert 401 (let ((group-art (nreverse (nnmail-article-group 'nnmh-active-number))))
418 (nnmail-insert-lines) 402 (unless noinsert
419 (nnmail-insert-xref group-art)) 403 (nnmail-insert-lines)
420 (run-hooks 'nnmail-prepare-save-mail-hook) 404 (nnmail-insert-xref group-art))
421 (run-hooks 'nnmh-prepare-save-mail-hook) 405 (run-hooks 'nnmail-prepare-save-mail-hook)
422 (goto-char (point-min)) 406 (run-hooks 'nnmh-prepare-save-mail-hook)
423 (while (looking-at "From ") 407 (goto-char (point-min))
424 (replace-match "X-From-Line: ") 408 (while (looking-at "From ")
425 (forward-line 1)) 409 (replace-match "X-From-Line: ")
426 ;; We save the article in all the newsgroups it belongs in. 410 (forward-line 1))
427 (let ((ga group-art) 411 ;; We save the article in all the newsgroups it belongs in.
428 first) 412 (let ((ga group-art)
429 (while ga 413 first)
430 (nnmh-possibly-create-directory (caar ga)) 414 (while ga
431 (let ((file (concat (nnmail-group-pathname 415 (nnmh-possibly-create-directory (caar ga))
432 (caar ga) nnmh-directory) 416 (let ((file (concat (nnmail-group-pathname
433 (int-to-string (cdar ga))))) 417 (caar ga) nnmh-directory)
434 (if first 418 (int-to-string (cdar ga)))))
435 ;; It was already saved, so we just make a hard link. 419 (if first
436 (funcall nnmail-crosspost-link-function first file t) 420 ;; It was already saved, so we just make a hard link.
437 ;; Save the article. 421 (funcall nnmail-crosspost-link-function first file t)
438 (nnmail-write-region (point-min) (point-max) file nil nil) 422 ;; Save the article.
439 (setq first file))) 423 (write-region (point-min) (point-max) file nil nil)
440 (setq ga (cdr ga)))) 424 (setq first file)))
441 group-art) 425 (setq ga (cdr ga))))
426 group-art))
442 427
443 (defun nnmh-active-number (group) 428 (defun nnmh-active-number (group)
444 "Compute the next article number in GROUP." 429 "Compute the next article number in GROUP."
445 (let ((active (cadr (assoc group nnmh-group-alist)))) 430 (let ((active (cadr (assoc group nnmh-group-alist))))
446 (unless active 431 ;; The group wasn't known to nnmh, so we just create an active
447 ;; The group wasn't known to nnmh, so we just create an active 432 ;; entry for it.
448 ;; entry for it. 433 (or active
449 (setq active (cons 1 0)) 434 (progn
450 (push (list group active) nnmh-group-alist) 435 (setq active (cons 1 0))
451 ;; Find the highest number in the group. 436 (setq nnmh-group-alist (cons (list group active) nnmh-group-alist))))
452 (let ((files (sort
453 (mapcar
454 (lambda (f)
455 (string-to-int f))
456 (directory-files
457 (nnmail-group-pathname group nnmh-directory)
458 nil "^[0-9]+$"))
459 '>)))
460 (when files
461 (setcdr active (car files)))))
462 (setcdr active (1+ (cdr active))) 437 (setcdr active (1+ (cdr active)))
463 (while (file-exists-p 438 (while (file-exists-p
464 (concat (nnmail-group-pathname group nnmh-directory) 439 (concat (nnmail-group-pathname group nnmh-directory)
465 (int-to-string (cdr active)))) 440 (int-to-string (cdr active))))
466 (setcdr active (1+ (cdr active)))) 441 (setcdr active (1+ (cdr active))))
467 (cdr active))) 442 (cdr active)))
468 443
469 (defun nnmh-update-gnus-unreads (group) 444 (defun nnmh-update-gnus-unreads (group)
470 ;; Go through the .nnmh-articles file and compare with the actual 445 ;; Go through the .nnmh-articles file and compare with the actual
471 ;; articles in this folder. The articles that are "new" will be 446 ;; articles in this folder. The articles that are "new" will be
472 ;; marked as unread by Gnus. 447 ;; marked as unread by Gnus.
473 (let* ((dir nnmh-current-directory) 448 (let* ((dir nnmh-current-directory)
474 (files (sort (mapcar (function (lambda (name) (string-to-int name))) 449 (files (sort (mapcar (function (lambda (name) (string-to-int name)))
475 (directory-files nnmh-current-directory 450 (directory-files nnmh-current-directory
476 nil "^[0-9]+$" t)) 451 nil "^[0-9]+$" t)) '<))
477 '<))
478 (nnmh-file (concat dir ".nnmh-articles")) 452 (nnmh-file (concat dir ".nnmh-articles"))
479 new articles) 453 new articles)
480 ;; Load the .nnmh-articles file. 454 ;; Load the .nnmh-articles file.
481 (when (file-exists-p nnmh-file) 455 (if (file-exists-p nnmh-file)
482 (setq articles 456 (setq articles
483 (let (nnmh-newsgroup-articles) 457 (let (nnmh-newsgroup-articles)
484 (ignore-errors (load nnmh-file nil t t)) 458 (condition-case nil (load nnmh-file nil t t) (error nil))
485 nnmh-newsgroup-articles))) 459 nnmh-newsgroup-articles)))
486 ;; Add all new articles to the `new' list. 460 ;; Add all new articles to the `new' list.
487 (let ((art files)) 461 (let ((art files))
488 (while art 462 (while art
489 (unless (assq (car art) articles) 463 (if (not (assq (car art) articles)) (setq new (cons (car art) new)))
490 (push (car art) new))
491 (setq art (cdr art)))) 464 (setq art (cdr art))))
492 ;; Remove all deleted articles. 465 ;; Remove all deleted articles.
493 (let ((art articles)) 466 (let ((art articles))
494 (while art 467 (while art
495 (unless (memq (caar art) files) 468 (if (not (memq (caar art) files))
496 (setq articles (delq (car art) articles))) 469 (setq articles (delq (car art) articles)))
497 (setq art (cdr art)))) 470 (setq art (cdr art))))
498 ;; Check whether the articles really are the ones that Gnus thinks 471 ;; Check whether the highest-numbered articles really are the ones
499 ;; they are by looking at the time-stamps. 472 ;; that Gnus thinks they are by looking at the time-stamps.
500 (let ((arts articles) 473 (let ((art articles))
501 art) 474 (while (and art
502 (while (setq art (pop arts)) 475 (not (equal
503 (when (not (equal 476 (nth 5 (file-attributes
504 (nth 5 (file-attributes 477 (concat dir (int-to-string (caar art)))))
505 (concat dir (int-to-string (car art))))) 478 (cdar art))))
506 (cdr art))) 479 (setq articles (delq (car art) articles))
507 (setq articles (delq art articles)) 480 (setq new (cons (caar art) new))
508 (push (car art) new)))) 481 (setq art (cdr art))))
509 ;; Go through all the new articles and add them, and their 482 ;; Go through all the new articles and add them, and their
510 ;; time-stamps, to the list. 483 ;; time-stamps to the list.
511 (setq articles 484 (let ((n new))
512 (nconc articles 485 (while n
513 (mapcar 486 (setq articles
514 (lambda (art) 487 (cons (cons
515 (cons art 488 (car n)
516 (nth 5 (file-attributes 489 (nth 5 (file-attributes
517 (concat dir (int-to-string art)))))) 490 (concat dir (int-to-string (car n))))))
518 new))) 491 articles))
492 (setq n (cdr n))))
519 ;; Make Gnus mark all new articles as unread. 493 ;; Make Gnus mark all new articles as unread.
520 (when new 494 (or (zerop (length new))
521 (gnus-make-articles-unread 495 (gnus-make-articles-unread
522 (gnus-group-prefixed-name group (list 'nnmh "")) 496 (gnus-group-prefixed-name group (list 'nnmh ""))
523 (setq new (sort new '<)))) 497 (setq new (sort new '<))))
524 ;; Sort the article list with highest numbers first. 498 ;; Sort the article list with highest numbers first.
525 (setq articles (sort articles (lambda (art1 art2) 499 (setq articles (sort articles (lambda (art1 art2)
526 (> (car art1) (car art2))))) 500 (> (car art1) (car art2)))))
527 ;; Finally write this list back to the .nnmh-articles file. 501 ;; Finally write this list back to the .nnmh-articles file.
528 (nnheader-temp-write nnmh-file 502 (save-excursion
503 (set-buffer (get-buffer-create "*nnmh out*"))
529 (insert ";; Gnus article active file for " group "\n\n") 504 (insert ";; Gnus article active file for " group "\n\n")
530 (insert "(setq nnmh-newsgroup-articles '") 505 (insert "(setq nnmh-newsgroup-articles '")
531 (gnus-prin1 articles) 506 (insert (prin1-to-string articles) ")\n")
532 (insert ")\n")))) 507 (write-region (point-min) (point-max) nnmh-file nil 'nomesg)
508 (kill-buffer (current-buffer)))))
533 509
534 (defun nnmh-deletable-article-p (group article) 510 (defun nnmh-deletable-article-p (group article)
535 "Say whether ARTICLE in GROUP can be deleted." 511 "Say whether ARTICLE in GROUP can be deleted."
536 (let ((path (concat nnmh-current-directory (int-to-string article)))) 512 (let ((path (concat nnmh-current-directory (int-to-string article))))
537 ;; Writable.
538 (and (file-writable-p path) 513 (and (file-writable-p path)
539 ;; We can never delete the last article in the group. 514 (or (not nnmail-keep-last-article)
540 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) 515 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist)))
541 article))))) 516 article))))))
542 517
543 (provide 'nnmh) 518 (provide 'nnmh)
544 519
545 ;;; nnmh.el ends here 520 ;;; nnmh.el ends here