Mercurial > hg > xemacs-beta

comparison lisp/gnus/nnml.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents 376386a54a3c
children d95e72db5c07
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
1 ;;; nnml.el --- mail spool access for Gnus 1 ;;; nnml.el --- mail spool access for Gnus
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96,97 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
52 "If non-nil, nnml will check the incoming mail file and split the mail.") 52 "If non-nil, nnml will check the incoming mail file and split the mail.")
53 53
54 (defvoo nnml-nov-is-evil nil 54 (defvoo nnml-nov-is-evil nil
55 "If non-nil, Gnus will never generate and use nov databases for mail groups. 55 "If non-nil, Gnus will never generate and use nov databases for mail groups.
56 Using nov databases will speed up header fetching considerably. 56 Using nov databases will speed up header fetching considerably.
57 This variable shouldn't be flipped much. If you have, for some reason, 57 This variable shouldn't be flipped much. If you have, for some reason,
58 set this to t, and want to set it to nil again, you should always run 58 set this to t, and want to set it to nil again, you should always run
59 the `nnml-generate-nov-databases' command. The function will go 59 the `nnml-generate-nov-databases' command. The function will go
60 through all nnml directories and generate nov databases for them 60 through all nnml directories and generate nov databases for them
61 all. This may very well take some time.") 61 all. This may very well take some time.")
62 62
63 (defvoo nnml-prepare-save-mail-hook nil 63 (defvoo nnml-prepare-save-mail-hook nil
64 "Hook run narrowed to an article before saving.") 64 "Hook run narrowed to an article before saving.")
65 65
66 (defvoo nnml-inhibit-expiry nil 66 (defvoo nnml-inhibit-expiry nil
88 88
89 ;;; Interface functions. 89 ;;; Interface functions.
90 90
91 (nnoo-define-basics nnml) 91 (nnoo-define-basics nnml)
92 92
93 (deffoo nnml-retrieve-headers (sequence &optional newsgroup server fetch-old) 93 (deffoo nnml-retrieve-headers (sequence &optional group server fetch-old)
94 (save-excursion 94 (when (nnml-possibly-change-directory group server)
95 (set-buffer nntp-server-buffer) 95 (save-excursion
96 (erase-buffer) 96 (set-buffer nntp-server-buffer)
97 (let ((file nil) 97 (erase-buffer)
98 (number (length sequence)) 98 (let ((file nil)
99 (count 0) 99 (number (length sequence))
100 beg article) 100 (count 0)
101 (if (stringp (car sequence)) 101 beg article)
102 'headers 102 (if (stringp (car sequence))
103 (nnml-possibly-change-directory newsgroup server) 103 'headers
104 (unless nnml-article-file-alist 104 (unless nnml-article-file-alist
105 (setq nnml-article-file-alist 105 (setq nnml-article-file-alist
106 (nnheader-article-to-file-alist nnml-current-directory))) 106 (nnheader-article-to-file-alist nnml-current-directory)))
107 (if (nnml-retrieve-headers-with-nov sequence fetch-old) 107 (if (nnml-retrieve-headers-with-nov sequence fetch-old)
108 'nov 108 'nov
109 (while sequence 109 (while sequence
110 (setq article (car sequence)) 110 (setq article (car sequence))
111 (setq file 111 (setq file
112 (concat nnml-current-directory 112 (concat nnml-current-directory
113 (or (cdr (assq article nnml-article-file-alist)) 113 (or (cdr (assq article nnml-article-file-alist))
114 ""))) 114 "")))
115 (if (and (file-exists-p file) 115 (when (and (file-exists-p file)
116 (not (file-directory-p file))) 116 (not (file-directory-p file)))
117 (progn 117 (insert (format "221 %d Article retrieved.\n" article))
118 (insert (format "221 %d Article retrieved.\n" article)) 118 (setq beg (point))
119 (setq beg (point)) 119 (nnheader-insert-head file)
120 (nnheader-insert-head file) 120 (goto-char beg)
121 (goto-char beg) 121 (if (search-forward "\n\n" nil t)
122 (if (search-forward "\n\n" nil t) 122 (forward-char -1)
123 (forward-char -1) 123 (goto-char (point-max))
124 (goto-char (point-max)) 124 (insert "\n\n"))
125 (insert "\n\n")) 125 (insert ".\n")
126 (insert ".\n") 126 (delete-region (point) (point-max)))
127 (delete-region (point) (point-max)))) 127 (setq sequence (cdr sequence))
128 (setq sequence (cdr sequence)) 128 (setq count (1+ count))
129 (setq count (1+ count)) 129 (and (numberp nnmail-large-newsgroup)
130 (> number nnmail-large-newsgroup)
131 (zerop (% count 20))
132 (nnheader-message 6 "nnml: Receiving headers... %d%%"
133 (/ (* count 100) number))))
134
130 (and (numberp nnmail-large-newsgroup) 135 (and (numberp nnmail-large-newsgroup)
131 (> number nnmail-large-newsgroup) 136 (> number nnmail-large-newsgroup)
132 (zerop (% count 20)) 137 (nnheader-message 6 "nnml: Receiving headers...done"))
133 (nnheader-message 6 "nnml: Receiving headers... %d%%" 138
134 (/ (* count 100) number)))) 139 (nnheader-fold-continuation-lines)
135 140 'headers))))))
136 (and (numberp nnmail-large-newsgroup)
137 (> number nnmail-large-newsgroup)
138 (nnheader-message 6 "nnml: Receiving headers...done"))
139
140 (nnheader-fold-continuation-lines)
141 'headers)))))
142 141
143 (deffoo nnml-open-server (server &optional defs) 142 (deffoo nnml-open-server (server &optional defs)
144 (nnoo-change-server 'nnml server defs) 143 (nnoo-change-server 'nnml server defs)
145 (when (not (file-exists-p nnml-directory)) 144 (when (not (file-exists-p nnml-directory))
146 (condition-case () 145 (condition-case ()
147 (make-directory nnml-directory t) 146 (make-directory nnml-directory t)
148 (error t))) 147 (error)))
149 (cond 148 (cond
150 ((not (file-exists-p nnml-directory)) 149 ((not (file-exists-p nnml-directory))
151 (nnml-close-server) 150 (nnml-close-server)
152 (nnheader-report 'nnml "Couldn't create directory: %s" nnml-directory)) 151 (nnheader-report 'nnml "Couldn't create directory: %s" nnml-directory))
153 ((not (file-directory-p (file-truename nnml-directory))) 152 ((not (file-directory-p (file-truename nnml-directory)))
156 (t 155 (t
157 (nnheader-report 'nnml "Opened server %s using directory %s" 156 (nnheader-report 'nnml "Opened server %s using directory %s"
158 server nnml-directory) 157 server nnml-directory)
159 t))) 158 t)))
160 159
161 (deffoo nnml-request-article (id &optional newsgroup server buffer) 160 (defun nnml-request-regenerate (server)
162 (nnml-possibly-change-directory newsgroup server) 161 (nnml-possibly-change-directory nil server)
162 (nnml-generate-nov-databases))
163
164 (deffoo nnml-request-article (id &optional group server buffer)
165 (nnml-possibly-change-directory group server)
163 (let* ((nntp-server-buffer (or buffer nntp-server-buffer)) 166 (let* ((nntp-server-buffer (or buffer nntp-server-buffer))
164 file path gpath group-num) 167 path gpath group-num)
165 (if (stringp id) 168 (if (stringp id)
166 (when (and (setq group-num (nnml-find-group-number id)) 169 (when (and (setq group-num (nnml-find-group-number id))
167 (setq file (cdr 170 (cdr
168 (assq (cdr group-num) 171 (assq (cdr group-num)
169 (nnheader-article-to-file-alist 172 (nnheader-article-to-file-alist
170 (setq gpath 173 (setq gpath
171 (nnmail-group-pathname 174 (nnmail-group-pathname
172 (car group-num) 175 (car group-num)
173 nnml-directory))))))) 176 nnml-directory))))))
174 (setq path (concat gpath (int-to-string (cdr group-num))))) 177 (setq path (concat gpath (int-to-string (cdr group-num)))))
175 (unless nnml-article-file-alist 178 (setq path (nnml-article-to-file id)))
176 (setq nnml-article-file-alist
177 (nnheader-article-to-file-alist nnml-current-directory)))
178 (when (setq file (cdr (assq id nnml-article-file-alist)))
179 (setq path (concat nnml-current-directory file))))
180 (cond 179 (cond
181 ((not path) 180 ((not path)
182 (nnheader-report 'nnml "No such article: %s" id)) 181 (nnheader-report 'nnml "No such article: %s" id))
183 ((not (file-exists-p path)) 182 ((not (file-exists-p path))
184 (nnheader-report 'nnml "No such file: %s" path)) 183 (nnheader-report 'nnml "No such file: %s" path))
187 ((not (save-excursion (nnmail-find-file path))) 186 ((not (save-excursion (nnmail-find-file path)))
188 (nnheader-report 'nnml "Couldn't read file: %s" path)) 187 (nnheader-report 'nnml "Couldn't read file: %s" path))
189 (t 188 (t
190 (nnheader-report 'nnml "Article %s retrieved" id) 189 (nnheader-report 'nnml "Article %s retrieved" id)
191 ;; We return the article number. 190 ;; We return the article number.
192 (cons newsgroup (string-to-int (file-name-nondirectory path))))))) 191 (cons group (string-to-int (file-name-nondirectory path)))))))
193 192
194 (deffoo nnml-request-group (group &optional server dont-check) 193 (deffoo nnml-request-group (group &optional server dont-check)
195 (cond 194 (cond
196 ((not (nnml-possibly-change-directory group server)) 195 ((not (nnml-possibly-change-directory group server))
197 (nnheader-report 'nnml "Invalid group (no such directory)")) 196 (nnheader-report 'nnml "Invalid group (no such directory)"))
197 ((not (file-exists-p nnml-current-directory))
198 (nnheader-report 'nnml "Directory %s does not exist"
199 nnml-current-directory))
198 ((not (file-directory-p nnml-current-directory)) 200 ((not (file-directory-p nnml-current-directory))
199 (nnheader-report 'nnml "%s is not a directory" nnml-current-directory)) 201 (nnheader-report 'nnml "%s is not a directory" nnml-current-directory))
200 (dont-check 202 (dont-check
201 (nnheader-report 'nnml "Group %s selected" group) 203 (nnheader-report 'nnml "Group %s selected" group)
202 t) 204 t)
203 (t 205 (t
206 (nnheader-re-read-dir nnml-current-directory)
204 (nnmail-activate 'nnml) 207 (nnmail-activate 'nnml)
205 (let ((active (nth 1 (assoc group nnml-group-alist)))) 208 (let ((active (nth 1 (assoc group nnml-group-alist))))
206 (if (not active) 209 (if (not active)
207 (nnheader-report 'nnml "No such group: %s" group) 210 (nnheader-report 'nnml "No such group: %s" group)
208 (nnheader-report 'nnml "Selected group %s" group) 211 (nnheader-report 'nnml "Selected group %s" group)
210 (max (1+ (- (cdr active) (car active))) 0) 213 (max (1+ (- (cdr active) (car active))) 0)
211 (car active) (cdr active) group)))))) 214 (car active) (cdr active) group))))))
212 215
213 (deffoo nnml-request-scan (&optional group server) 216 (deffoo nnml-request-scan (&optional group server)
214 (setq nnml-article-file-alist nil) 217 (setq nnml-article-file-alist nil)
218 (nnml-possibly-change-directory group server)
215 (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group)) 219 (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group))
216 220
217 (deffoo nnml-close-group (group &optional server) 221 (deffoo nnml-close-group (group &optional server)
218 (setq nnml-article-file-alist nil) 222 (setq nnml-article-file-alist nil)
219 t) 223 t)
220 224
221 (deffoo nnml-request-create-group (group &optional server) 225 (deffoo nnml-request-create-group (group &optional server args)
222 (nnmail-activate 'nnml) 226 (nnmail-activate 'nnml)
223 (or (assoc group nnml-group-alist) 227 (unless (assoc group nnml-group-alist)
224 (let (active) 228 (let (active)
225 (setq nnml-group-alist (cons (list group (setq active (cons 1 0))) 229 (push (list group (setq active (cons 1 0)))
226 nnml-group-alist)) 230 nnml-group-alist)
227 (nnml-possibly-create-directory group) 231 (nnml-possibly-create-directory group)
228 (nnml-possibly-change-directory group server) 232 (nnml-possibly-change-directory group server)
229 (let ((articles 233 (let ((articles (nnheader-directory-articles nnml-current-directory)))
230 (nnheader-directory-articles nnml-current-directory ))) 234 (when articles
231 (and articles 235 (setcar active (apply 'min articles))
232 (progn 236 (setcdr active (apply 'max articles))))
233 (setcar active (apply 'min articles)) 237 (nnmail-save-active nnml-group-alist nnml-active-file)))
234 (setcdr active (apply 'max articles)))))
235 (nnmail-save-active nnml-group-alist nnml-active-file)))
236 t) 238 t)
237 239
238 (deffoo nnml-request-list (&optional server) 240 (deffoo nnml-request-list (&optional server)
239 (save-excursion 241 (save-excursion
240 (nnmail-find-file nnml-active-file) 242 (nnmail-find-file nnml-active-file)
241 (setq nnml-group-alist (nnmail-get-active)))) 243 (setq nnml-group-alist (nnmail-get-active))
244 t))
242 245
243 (deffoo nnml-request-newgroups (date &optional server) 246 (deffoo nnml-request-newgroups (date &optional server)
244 (nnml-request-list server)) 247 (nnml-request-list server))
245 248
246 (deffoo nnml-request-list-newsgroups (&optional server) 249 (deffoo nnml-request-list-newsgroups (&optional server)
247 (save-excursion 250 (save-excursion
248 (nnmail-find-file nnml-newsgroups-file))) 251 (nnmail-find-file nnml-newsgroups-file)))
249 252
250 (deffoo nnml-request-expire-articles (articles newsgroup &optional server force) 253 (deffoo nnml-request-expire-articles (articles group
251 (nnml-possibly-change-directory newsgroup server) 254 &optional server force)
255 (nnml-possibly-change-directory group server)
252 (let* ((active-articles 256 (let* ((active-articles
253 (nnheader-directory-articles nnml-current-directory)) 257 (nnheader-directory-articles nnml-current-directory))
254 (is-old t) 258 (is-old t)
255 article rest mod-time number) 259 article rest mod-time number)
256 (nnmail-activate 'nnml) 260 (nnmail-activate 'nnml)
258 (unless nnml-article-file-alist 262 (unless nnml-article-file-alist
259 (setq nnml-article-file-alist 263 (setq nnml-article-file-alist
260 (nnheader-article-to-file-alist nnml-current-directory))) 264 (nnheader-article-to-file-alist nnml-current-directory)))
261 265
262 (while (and articles is-old) 266 (while (and articles is-old)
263 (setq article (concat nnml-current-directory 267 (when (setq article
264 (int-to-string 268 (assq (setq number (pop articles))
265 (setq number (pop articles))))) 269 nnml-article-file-alist))
266 (when (setq mod-time (nth 5 (file-attributes article))) 270 (setq article (concat nnml-current-directory (cdr article)))
267 (if (and (nnml-deletable-article-p newsgroup number) 271 (when (setq mod-time (nth 5 (file-attributes article)))
268 (setq is-old 272 (if (and (nnml-deletable-article-p group number)
269 (nnmail-expired-article-p newsgroup mod-time force 273 (setq is-old
270 nnml-inhibit-expiry))) 274 (nnmail-expired-article-p group mod-time force
271 (progn 275 nnml-inhibit-expiry)))
272 (nnheader-message 5 "Deleting article %s in %s..." 276 (progn
273 article newsgroup) 277 (nnheader-message 5 "Deleting article %s in %s"
274 (condition-case () 278 article group)
275 (funcall nnmail-delete-file-function article) 279 (condition-case ()
276 (file-error 280 (funcall nnmail-delete-file-function article)
277 (push number rest))) 281 (file-error
278 (setq active-articles (delq number active-articles)) 282 (push number rest)))
279 (nnml-nov-delete-article newsgroup number)) 283 (setq active-articles (delq number active-articles))
280 (push number rest)))) 284 (nnml-nov-delete-article group number))
281 (let ((active (nth 1 (assoc newsgroup nnml-group-alist)))) 285 (push number rest)))))
286 (let ((active (nth 1 (assoc group nnml-group-alist))))
282 (when active 287 (when active
283 (setcar active (or (and active-articles 288 (setcar active (or (and active-articles
284 (apply 'min active-articles)) 289 (apply 'min active-articles))
285 (1+ (cdr active))))) 290 (1+ (cdr active)))))
286 (nnmail-save-active nnml-group-alist nnml-active-file)) 291 (nnmail-save-active nnml-group-alist nnml-active-file))
287 (nnml-save-nov) 292 (nnml-save-nov)
288 (message "")
289 (nconc rest articles))) 293 (nconc rest articles)))
290 294
291 (deffoo nnml-request-move-article 295 (deffoo nnml-request-move-article
292 (article group server accept-form &optional last) 296 (article group server accept-form &optional last)
293 (let ((buf (get-buffer-create " *nnml move*")) 297 (let ((buf (get-buffer-create " *nnml move*"))
321 (nnmail-check-syntax) 325 (nnmail-check-syntax)
322 (let (result) 326 (let (result)
323 (if (stringp group) 327 (if (stringp group)
324 (and 328 (and
325 (nnmail-activate 'nnml) 329 (nnmail-activate 'nnml)
326 ;; We trick the choosing function into believing that only one 330 (setq result (car (nnml-save-mail
327 ;; group is available. 331 (list (cons group (nnml-active-number group))))))
328 (let ((nnmail-split-methods (list (list group ""))))
329 (setq result (car (nnml-save-mail))))
330 (progn 332 (progn
331 (nnmail-save-active nnml-group-alist nnml-active-file) 333 (nnmail-save-active nnml-group-alist nnml-active-file)
332 (and last (nnml-save-nov)))) 334 (and last (nnml-save-nov))))
333 (and 335 (and
334 (nnmail-activate 'nnml) 336 (nnmail-activate 'nnml)
335 (setq result (car (nnml-save-mail))) 337 (setq result (car (nnml-save-mail
338 (nnmail-article-group 'nnml-active-number))))
336 (progn 339 (progn
337 (nnmail-save-active nnml-group-alist nnml-active-file) 340 (nnmail-save-active nnml-group-alist nnml-active-file)
338 (and last (nnml-save-nov))))) 341 (and last (nnml-save-nov)))))
339 result)) 342 result))
340 343
346 (let ((chars (nnmail-insert-lines)) 349 (let ((chars (nnmail-insert-lines))
347 (art (concat (int-to-string article) "\t")) 350 (art (concat (int-to-string article) "\t"))
348 headers) 351 headers)
349 (when (condition-case () 352 (when (condition-case ()
350 (progn 353 (progn
351 (write-region 354 (nnmail-write-region
352 (point-min) (point-max) 355 (point-min) (point-max)
353 (concat nnml-current-directory (int-to-string article)) 356 (concat nnml-current-directory
357 (int-to-string article))
354 nil (if (nnheader-be-verbose 5) nil 'nomesg)) 358 nil (if (nnheader-be-verbose 5) nil 'nomesg))
355 t) 359 t)
356 (error nil)) 360 (error nil))
357 (setq headers (nnml-parse-head chars article)) 361 (setq headers (nnml-parse-head chars article))
358 ;; Replace the NOV line in the NOV file. 362 ;; Replace the NOV line in the NOV file.
363 (search-forward (concat "\n" art) nil t)) 367 (search-forward (concat "\n" art) nil t))
364 ;; Delete the old NOV line. 368 ;; Delete the old NOV line.
365 (delete-region (progn (beginning-of-line) (point)) 369 (delete-region (progn (beginning-of-line) (point))
366 (progn (forward-line 1) (point))) 370 (progn (forward-line 1) (point)))
367 ;; The line isn't here, so we have to find out where 371 ;; The line isn't here, so we have to find out where
368 ;; we should insert it. (This situation should never 372 ;; we should insert it. (This situation should never
369 ;; occur, but one likes to make sure...) 373 ;; occur, but one likes to make sure...)
370 (while (and (looking-at "[0-9]+\t") 374 (while (and (looking-at "[0-9]+\t")
371 (< (string-to-int 375 (< (string-to-int
372 (buffer-substring 376 (buffer-substring
373 (match-beginning 0) (match-end 0))) 377 (match-beginning 0) (match-end 0)))
406 (nnmail-save-active nnml-group-alist nnml-active-file) 410 (nnmail-save-active nnml-group-alist nnml-active-file)
407 t) 411 t)
408 412
409 (deffoo nnml-request-rename-group (group new-name &optional server) 413 (deffoo nnml-request-rename-group (group new-name &optional server)
410 (nnml-possibly-change-directory group server) 414 (nnml-possibly-change-directory group server)
411 ;; Rename directory. 415 (let ((new-dir (nnmail-group-pathname new-name nnml-directory))
412 (and (file-writable-p nnml-current-directory) 416 (old-dir (nnmail-group-pathname group nnml-directory)))
413 (condition-case () 417 (when (condition-case ()
414 (let ((parent 418 (progn
415 (file-name-directory 419 (make-directory new-dir t)
416 (directory-file-name 420 t)
417 (nnmail-group-pathname new-name nnml-directory))))) 421 (error nil))
418 (unless (file-exists-p parent) 422 ;; We move the articles file by file instead of renaming
419 (make-directory parent t)) 423 ;; the directory -- there may be subgroups in this group.
420 (rename-file 424 ;; One might be more clever, I guess.
421 (directory-file-name nnml-current-directory) 425 (let ((files (nnheader-article-to-file-alist old-dir)))
422 (directory-file-name 426 (while files
423 (nnmail-group-pathname new-name nnml-directory))) 427 (rename-file
424 t) 428 (concat old-dir (cdar files))
425 (error nil)) 429 (concat new-dir (cdar files)))
426 ;; That went ok, so we change the internal structures. 430 (pop files)))
427 (let ((entry (assoc group nnml-group-alist))) 431 ;; Move .overview file.
428 (and entry (setcar entry new-name)) 432 (let ((overview (concat old-dir nnml-nov-file-name)))
429 (setq nnml-current-directory nil 433 (when (file-exists-p overview)
430 nnml-current-group nil) 434 (rename-file overview (concat new-dir nnml-nov-file-name))))
431 ;; Save the new group alist. 435 (when (<= (length (directory-files old-dir)) 2)
432 (nnmail-save-active nnml-group-alist nnml-active-file) 436 (condition-case ()
433 t))) 437 (delete-directory old-dir)
438 (error nil)))
439 ;; That went ok, so we change the internal structures.
440 (let ((entry (assoc group nnml-group-alist)))
441 (when entry
442 (setcar entry new-name))
443 (setq nnml-current-directory nil
444 nnml-current-group nil)
445 ;; Save the new group alist.
446 (nnmail-save-active nnml-group-alist nnml-active-file)
447 t))))
448
449 (deffoo nnml-set-status (article name value &optional group server)
450 (nnml-possibly-change-directory group server)
451 (let ((file (nnml-article-to-file article)))
452 (cond
453 ((not (file-exists-p file))
454 (nnheader-report 'nnml "File %s does not exist" file))
455 (t
456 (nnheader-temp-write file
457 (nnheader-insert-file-contents file)
458 (nnmail-replace-status name value))
459 t))))
434 460
435 461
436 ;;; Internal functions. 462 ;;; Internal functions.
463
464 (defun nnml-article-to-file (article)
465 (unless nnml-article-file-alist
466 (setq nnml-article-file-alist
467 (nnheader-article-to-file-alist nnml-current-directory)))
468 (let (file)
469 (when (setq file (cdr (assq article nnml-article-file-alist)))
470 (concat nnml-current-directory file))))
437 471
438 (defun nnml-deletable-article-p (group article) 472 (defun nnml-deletable-article-p (group article)
439 "Say whether ARTICLE in GROUP can be deleted." 473 "Say whether ARTICLE in GROUP can be deleted."
440 (let (file path) 474 (let (file path)
441 (when (setq file (cdr (assq article nnml-article-file-alist))) 475 (when (setq file (cdr (assq article nnml-article-file-alist)))
442 (setq path (concat nnml-current-directory file)) 476 (setq path (concat nnml-current-directory file))
443 (and (file-writable-p path) 477 (when (file-writable-p path)
444 (or (not nnmail-keep-last-article) 478 (or (not nnmail-keep-last-article)
445 (not (eq (cdr (nth 1 (assoc group nnml-group-alist))) 479 (not (eq (cdr (nth 1 (assoc group nnml-group-alist)))
446 article))))))) 480 article)))))))
447 481
448 ;; Find an article number in the current group given the Message-ID. 482 ;; Find an article number in the current group given the Message-ID.
449 (defun nnml-find-group-number (id) 483 (defun nnml-find-group-number (id)
450 (save-excursion 484 (save-excursion
451 (set-buffer (get-buffer-create " *nnml id*")) 485 (set-buffer (get-buffer-create " *nnml id*"))
471 (erase-buffer) 505 (erase-buffer)
472 (let ((nov (concat (nnmail-group-pathname group nnml-directory) 506 (let ((nov (concat (nnmail-group-pathname group nnml-directory)
473 nnml-nov-file-name)) 507 nnml-nov-file-name))
474 number found) 508 number found)
475 (when (file-exists-p nov) 509 (when (file-exists-p nov)
476 (insert-file-contents nov) 510 (nnheader-insert-file-contents nov)
477 (while (and (not found) 511 (while (and (not found)
478 (search-forward id nil t)) ; We find the ID. 512 (search-forward id nil t)) ; We find the ID.
479 ;; And the id is in the fourth field. 513 ;; And the id is in the fourth field.
480 (if (search-backward 514 (if (not (and (search-backward "\t" nil t 4)
481 "\t" (save-excursion (beginning-of-line) (point)) t 4) 515 (not (search-backward"\t" (gnus-point-at-bol) t))))
482 (progn 516 (forward-line 1)
483 (beginning-of-line) 517 (beginning-of-line)
484 (setq found t) 518 (setq found t)
485 ;; We return the article number. 519 ;; We return the article number.
486 (setq number 520 (setq number
487 (condition-case () 521 (condition-case ()
488 (read (current-buffer)) 522 (read (current-buffer))
489 (error nil)))))) 523 (error nil)))))
490 number))) 524 number)))
491 525
492 (defun nnml-retrieve-headers-with-nov (articles &optional fetch-old) 526 (defun nnml-retrieve-headers-with-nov (articles &optional fetch-old)
493 (if (or gnus-nov-is-evil nnml-nov-is-evil) 527 (if (or gnus-nov-is-evil nnml-nov-is-evil)
494 nil 528 nil
495 (let ((first (car articles)) 529 (let ((nov (concat nnml-current-directory nnml-nov-file-name)))
496 (last (progn (while (cdr articles) (setq articles (cdr articles)))
497 (car articles)))
498 (nov (concat nnml-current-directory nnml-nov-file-name)))
499 (when (file-exists-p nov) 530 (when (file-exists-p nov)
500 (save-excursion 531 (save-excursion
501 (set-buffer nntp-server-buffer) 532 (set-buffer nntp-server-buffer)
502 (erase-buffer) 533 (erase-buffer)
503 (insert-file-contents nov) 534 (nnheader-insert-file-contents nov)
504 (if (and fetch-old 535 (if (and fetch-old
505 (not (numberp fetch-old))) 536 (not (numberp fetch-old)))
506 t ; Don't remove anything. 537 t ; Don't remove anything.
507 (if fetch-old 538 (nnheader-nov-delete-outside-range
508 (setq first (max 1 (- first fetch-old)))) 539 (if fetch-old (max 1 (- (car articles) fetch-old))
509 (goto-char (point-min)) 540 (car articles))
510 (while (and (not (eobp)) (> first (read (current-buffer)))) 541 (car (last articles)))
511 (forward-line 1))
512 (beginning-of-line)
513 (if (not (eobp)) (delete-region 1 (point)))
514 (while (and (not (eobp)) (>= last (read (current-buffer))))
515 (forward-line 1))
516 (beginning-of-line)
517 (if (not (eobp)) (delete-region (point) (point-max)))
518 t)))))) 542 t))))))
519 543
520 (defun nnml-possibly-change-directory (group &optional server) 544 (defun nnml-possibly-change-directory (group &optional server)
521 (when (and server 545 (when (and server
522 (not (nnml-server-opened server))) 546 (not (nnml-server-opened server)))
523 (nnml-open-server server)) 547 (nnml-open-server server))
524 (when group 548 (if (not group)
549 t
525 (let ((pathname (nnmail-group-pathname group nnml-directory))) 550 (let ((pathname (nnmail-group-pathname group nnml-directory)))
526 (when (not (equal pathname nnml-current-directory)) 551 (when (not (equal pathname nnml-current-directory))
527 (setq nnml-current-directory pathname 552 (setq nnml-current-directory pathname
528 nnml-current-group group 553 nnml-current-group group
529 nnml-article-file-alist nil)))) 554 nnml-article-file-alist nil))
530 t) 555 (file-exists-p nnml-current-directory))))
531 556
532 (defun nnml-possibly-create-directory (group) 557 (defun nnml-possibly-create-directory (group)
533 (let (dir dirs) 558 (let (dir dirs)
534 (setq dir (nnmail-group-pathname group nnml-directory)) 559 (setq dir (nnmail-group-pathname group nnml-directory))
535 (while (not (file-directory-p dir)) 560 (while (not (file-directory-p dir))
536 (setq dirs (cons dir dirs)) 561 (push dir dirs)
537 (setq dir (file-name-directory (directory-file-name dir)))) 562 (setq dir (file-name-directory (directory-file-name dir))))
538 (while dirs 563 (while dirs
539 (make-directory (directory-file-name (car dirs))) 564 (make-directory (directory-file-name (car dirs)))
540 (nnheader-message 5 "Creating mail directory %s" (car dirs)) 565 (nnheader-message 5 "Creating mail directory %s" (car dirs))
541 (setq dirs (cdr dirs))))) 566 (setq dirs (cdr dirs)))))
542 567
543 (defun nnml-save-mail () 568 (defun nnml-save-mail (group-art)
544 "Called narrowed to an article." 569 "Called narrowed to an article."
545 (let ((group-art (nreverse (nnmail-article-group 'nnml-active-number))) 570 (let (chars headers)
546 chars headers)
547 (setq chars (nnmail-insert-lines)) 571 (setq chars (nnmail-insert-lines))
548 (nnmail-insert-xref group-art) 572 (nnmail-insert-xref group-art)
549 (run-hooks 'nnmail-prepare-save-mail-hook) 573 (run-hooks 'nnmail-prepare-save-mail-hook)
550 (run-hooks 'nnml-prepare-save-mail-hook) 574 (run-hooks 'nnml-prepare-save-mail-hook)
551 (goto-char (point-min)) 575 (goto-char (point-min))
552 (while (looking-at "From ") 576 (while (looking-at "From ")
553 (replace-match "X-From-Line: ") 577 (replace-match "X-From-Line: ")
554 (forward-line 1)) 578 (forward-line 1))
555 ;; We save the article in all the newsgroups it belongs in. 579 ;; We save the article in all the groups it belongs in.
556 (let ((ga group-art) 580 (let ((ga group-art)
557 first) 581 first)
558 (while ga 582 (while ga
559 (nnml-possibly-create-directory (caar ga)) 583 (nnml-possibly-create-directory (caar ga))
560 (let ((file (concat (nnmail-group-pathname 584 (let ((file (concat (nnmail-group-pathname
562 (int-to-string (cdar ga))))) 586 (int-to-string (cdar ga)))))
563 (if first 587 (if first
564 ;; It was already saved, so we just make a hard link. 588 ;; It was already saved, so we just make a hard link.
565 (funcall nnmail-crosspost-link-function first file t) 589 (funcall nnmail-crosspost-link-function first file t)
566 ;; Save the article. 590 ;; Save the article.
567 (write-region (point-min) (point-max) file nil 591 (nnmail-write-region (point-min) (point-max) file nil
568 (if (nnheader-be-verbose 5) nil 'nomesg)) 592 (if (nnheader-be-verbose 5) nil 'nomesg))
569 (setq first file))) 593 (setq first file)))
570 (setq ga (cdr ga)))) 594 (setq ga (cdr ga))))
571 ;; Generate a nov line for this article. We generate the nov 595 ;; Generate a nov line for this article. We generate the nov
572 ;; line after saving, because nov generation destroys the 596 ;; line after saving, because nov generation destroys the
573 ;; header. 597 ;; header.
574 (setq headers (nnml-parse-head chars)) 598 (setq headers (nnml-parse-head chars))
575 ;; Output the nov line to all nov databases that should have it. 599 ;; Output the nov line to all nov databases that should have it.
576 (let ((ga group-art)) 600 (let ((ga group-art))
597 (setq active 621 (setq active
598 (if nnml-article-file-alist 622 (if nnml-article-file-alist
599 (cons (caar nnml-article-file-alist) 623 (cons (caar nnml-article-file-alist)
600 (caar (last nnml-article-file-alist))) 624 (caar (last nnml-article-file-alist)))
601 (cons 1 0))) 625 (cons 1 0)))
602 (setq nnml-group-alist (cons (list group active) nnml-group-alist))) 626 (push (list group active) nnml-group-alist))
603 (setcdr active (1+ (cdr active))) 627 (setcdr active (1+ (cdr active)))
604 (while (file-exists-p 628 (while (file-exists-p
605 (concat (nnmail-group-pathname group nnml-directory) 629 (concat (nnmail-group-pathname group nnml-directory)
606 (int-to-string (cdr active)))) 630 (int-to-string (cdr active))))
607 (setcdr active (1+ (cdr active)))) 631 (setcdr active (1+ (cdr active))))
637 (mail-header-set-number headers number) 661 (mail-header-set-number headers number)
638 headers)))) 662 headers))))
639 663
640 (defun nnml-open-nov (group) 664 (defun nnml-open-nov (group)
641 (or (cdr (assoc group nnml-nov-buffer-alist)) 665 (or (cdr (assoc group nnml-nov-buffer-alist))
642 (let ((buffer (find-file-noselect 666 (let ((buffer (nnheader-find-file-noselect
643 (concat (nnmail-group-pathname group nnml-directory) 667 (concat (nnmail-group-pathname group nnml-directory)
644 nnml-nov-file-name)))) 668 nnml-nov-file-name))))
645 (save-excursion 669 (save-excursion
646 (set-buffer buffer) 670 (set-buffer buffer)
647 (buffer-disable-undo (current-buffer))) 671 (buffer-disable-undo (current-buffer)))
648 (setq nnml-nov-buffer-alist 672 (push (cons group buffer) nnml-nov-buffer-alist)
649 (cons (cons group buffer) nnml-nov-buffer-alist))
650 buffer))) 673 buffer)))
651 674
652 (defun nnml-save-nov () 675 (defun nnml-save-nov ()
653 (save-excursion 676 (save-excursion
654 (while nnml-nov-buffer-alist 677 (while nnml-nov-buffer-alist
655 (when (buffer-name (cdar nnml-nov-buffer-alist)) 678 (when (buffer-name (cdar nnml-nov-buffer-alist))
656 (set-buffer (cdar nnml-nov-buffer-alist)) 679 (set-buffer (cdar nnml-nov-buffer-alist))
657 (and (buffer-modified-p) 680 (when (buffer-modified-p)
658 (write-region 681 (nnmail-write-region 1 (point-max) (buffer-file-name) nil 'nomesg))
659 1 (point-max) (buffer-file-name) nil 'nomesg))
660 (set-buffer-modified-p nil) 682 (set-buffer-modified-p nil)
661 (kill-buffer (current-buffer))) 683 (kill-buffer (current-buffer)))
662 (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist))))) 684 (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist)))))
663 685
664 ;;;###autoload 686 ;;;###autoload
673 ;; Recurse down the directories. 695 ;; Recurse down the directories.
674 (nnml-generate-nov-databases-1 nnml-directory) 696 (nnml-generate-nov-databases-1 nnml-directory)
675 ;; Save the active file. 697 ;; Save the active file.
676 (nnmail-save-active nnml-group-alist nnml-active-file)) 698 (nnmail-save-active nnml-group-alist nnml-active-file))
677 699
678 (defun nnml-generate-nov-databases-1 (dir) 700 (defun nnml-generate-nov-databases-1 (dir &optional seen)
679 (setq dir (file-name-as-directory dir)) 701 (setq dir (file-name-as-directory dir))
680 ;; We descend recursively 702 ;; Only scan this sub-tree if we haven't been here yet.
681 (let ((dirs (directory-files dir t nil t)) 703 (unless (member (file-truename dir) seen)
682 dir) 704 (push (file-truename dir) seen)
683 (while dirs 705 ;; We descend recursively
684 (setq dir (pop dirs)) 706 (let ((dirs (directory-files dir t nil t))
685 (when (and (not (member (file-name-nondirectory dir) '("." ".."))) 707 dir)
686 (file-directory-p dir)) 708 (while (setq dir (pop dirs))
687 (nnml-generate-nov-databases-1 dir)))) 709 (when (and (not (member (file-name-nondirectory dir) '("." "..")))
688 ;; Do this directory. 710 (file-directory-p dir))
689 (let ((files (sort 711 (nnml-generate-nov-databases-1 dir seen))))
690 (mapcar 712 ;; Do this directory.
691 (lambda (name) (string-to-int name)) 713 (let ((files (sort (nnheader-article-to-file-alist dir)
692 (directory-files dir nil "^[0-9]+$" t)) 714 (lambda (a b) (< (car a) (car b))))))
693 '<))) 715 (when files
694 (when files 716 (funcall nnml-generate-active-function dir)
695 (funcall nnml-generate-active-function dir) 717 ;; Generate the nov file.
696 ;; Generate the nov file. 718 (nnml-generate-nov-file dir files)))))
697 (nnml-generate-nov-file dir files))))
698 719
699 (defvar files) 720 (defvar files)
700 (defun nnml-generate-active-info (dir) 721 (defun nnml-generate-active-info (dir)
701 ;; Update the active info for this group. 722 ;; Update the active info for this group.
702 (let ((group (nnheader-file-to-group 723 (let ((group (nnheader-file-to-group
703 (directory-file-name dir) nnml-directory))) 724 (directory-file-name dir) nnml-directory)))
704 (setq nnml-group-alist 725 (setq nnml-group-alist
705 (delq (assoc group nnml-group-alist) nnml-group-alist)) 726 (delq (assoc group nnml-group-alist) nnml-group-alist))
706 (push (list group 727 (push (list group
707 (cons (car files) 728 (cons (caar files)
708 (let ((f files)) 729 (let ((f files))
709 (while (cdr f) (setq f (cdr f))) 730 (while (cdr f) (setq f (cdr f)))
710 (car f)))) 731 (caar f))))
711 nnml-group-alist))) 732 nnml-group-alist)))
712 733
713 (defun nnml-generate-nov-file (dir files) 734 (defun nnml-generate-nov-file (dir files)
714 (let* ((dir (file-name-as-directory dir)) 735 (let* ((dir (file-name-as-directory dir))
715 (nov (concat dir nnml-nov-file-name)) 736 (nov (concat dir nnml-nov-file-name))
716 (nov-buffer (get-buffer-create " *nov*")) 737 (nov-buffer (get-buffer-create " *nov*"))
717 nov-line chars file headers) 738 chars file headers)
718 (save-excursion 739 (save-excursion
719 ;; Init the nov buffer. 740 ;; Init the nov buffer.
720 (set-buffer nov-buffer) 741 (set-buffer nov-buffer)
721 (buffer-disable-undo (current-buffer)) 742 (buffer-disable-undo (current-buffer))
722 (erase-buffer) 743 (erase-buffer)
723 (set-buffer nntp-server-buffer) 744 (set-buffer nntp-server-buffer)
724 ;; Delete the old NOV file. 745 ;; Delete the old NOV file.
725 (when (file-exists-p nov) 746 (when (file-exists-p nov)
726 (funcall nnmail-delete-file-function nov)) 747 (funcall nnmail-delete-file-function nov))
727 (while files 748 (while files
728 (unless (file-directory-p 749 (unless (file-directory-p (setq file (concat dir (cdar files))))
729 (setq file (concat dir (int-to-string (car files)))))
730 (erase-buffer) 750 (erase-buffer)
731 (insert-file-contents file) 751 (nnheader-insert-file-contents file)
732 (narrow-to-region 752 (narrow-to-region
733 (goto-char (point-min)) 753 (goto-char (point-min))
734 (progn 754 (progn
735 (search-forward "\n\n" nil t) 755 (search-forward "\n\n" nil t)
736 (setq chars (- (point-max) (point))) 756 (setq chars (- (point-max) (point)))
737 (max 1 (1- (point))))) 757 (max 1 (1- (point)))))
738 (when (and (not (= 0 chars)) ; none of them empty files... 758 (when (and (not (= 0 chars)) ; none of them empty files...
739 (not (= (point-min) (point-max)))) 759 (not (= (point-min) (point-max))))
740 (goto-char (point-min)) 760 (goto-char (point-min))
741 (setq headers (nnml-parse-head chars (car files))) 761 (setq headers (nnml-parse-head chars (caar files)))
742 (save-excursion 762 (save-excursion
743 (set-buffer nov-buffer) 763 (set-buffer nov-buffer)
744 (goto-char (point-max)) 764 (goto-char (point-max))
745 (nnheader-insert-nov headers))) 765 (nnheader-insert-nov headers)))
746 (widen)) 766 (widen))
747 (setq files (cdr files))) 767 (setq files (cdr files)))
748 (save-excursion 768 (save-excursion
749 (set-buffer nov-buffer) 769 (set-buffer nov-buffer)
750 (write-region 1 (point-max) (expand-file-name nov) nil 770 (nnmail-write-region 1 (point-max) nov nil 'nomesg)
751 'nomesg)
752 (kill-buffer (current-buffer)))))) 771 (kill-buffer (current-buffer))))))
753 772
754 (defun nnml-nov-delete-article (group article) 773 (defun nnml-nov-delete-article (group article)
755 (save-excursion 774 (save-excursion
756 (set-buffer (nnml-open-nov group)) 775 (set-buffer (nnml-open-nov group))
757 (goto-char (point-min)) 776 (goto-char (point-min))
758 (if (re-search-forward (concat "^" (int-to-string article) "\t") nil t) 777 (when (re-search-forward (concat "^" (int-to-string article) "\t") nil t)
759 (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) 778 (delete-region (match-beginning 0) (progn (forward-line 1) (point))))
760 t)) 779 t))
761 780
762 (provide 'nnml) 781 (provide 'nnml)
763 782
764 ;;; nnml.el ends here 783 ;;; nnml.el ends here