Mercurial > hg > xemacs-beta

comparison lisp/gnus/nnbabyl.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 ;;; nnbabyl.el --- rmail mbox access for Gnus 1 ;;; nnbabyl.el --- rmail mbox 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
23 ;; Boston, MA 02111-1307, USA. 23 ;; Boston, MA 02111-1307, USA.
24 24
25 ;;; Commentary: 25 ;;; Commentary:
26 26
27 ;; For an overview of what the interface functions do, please see the 27 ;; For an overview of what the interface functions do, please see the
28 ;; Gnus sources. 28 ;; Gnus sources.
29 29
30 ;;; Code: 30 ;;; Code:
31 31
32 (require 'nnheader) 32 (require 'nnheader)
33 (require 'rmail) 33 (require 'rmail)
83 article art-string start stop) 83 article art-string start stop)
84 (nnbabyl-possibly-change-newsgroup group server) 84 (nnbabyl-possibly-change-newsgroup group server)
85 (while (setq article (pop articles)) 85 (while (setq article (pop articles))
86 (setq art-string (nnbabyl-article-string article)) 86 (setq art-string (nnbabyl-article-string article))
87 (set-buffer nnbabyl-mbox-buffer) 87 (set-buffer nnbabyl-mbox-buffer)
88 (end-of-line) 88 (beginning-of-line)
89 (when (or (search-forward art-string nil t) 89 (when (or (search-forward art-string nil t)
90 (search-backward art-string nil t)) 90 (search-backward art-string nil t))
91 (unless (re-search-backward delim nil t) 91 (re-search-backward delim nil t)
92 (goto-char (point-min)))
93 (while (and (not (looking-at ".+:")) 92 (while (and (not (looking-at ".+:"))
94 (zerop (forward-line 1)))) 93 (zerop (forward-line 1))))
95 (setq start (point)) 94 (setq start (point))
96 (search-forward "\n\n" nil t) 95 (search-forward "\n\n" nil t)
97 (setq stop (1- (point))) 96 (setq stop (1- (point)))
116 (nnheader-fold-continuation-lines) 115 (nnheader-fold-continuation-lines)
117 'headers))) 116 'headers)))
118 117
119 (deffoo nnbabyl-open-server (server &optional defs) 118 (deffoo nnbabyl-open-server (server &optional defs)
120 (nnoo-change-server 'nnbabyl server defs) 119 (nnoo-change-server 'nnbabyl server defs)
121 (nnbabyl-create-mbox) 120 (cond
122 (cond
123 ((not (file-exists-p nnbabyl-mbox-file)) 121 ((not (file-exists-p nnbabyl-mbox-file))
124 (nnbabyl-close-server) 122 (nnbabyl-close-server)
125 (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file)) 123 (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file))
126 ((file-directory-p nnbabyl-mbox-file) 124 ((file-directory-p nnbabyl-mbox-file)
127 (nnbabyl-close-server) 125 (nnbabyl-close-server)
157 (save-excursion 155 (save-excursion
158 (set-buffer nnbabyl-mbox-buffer) 156 (set-buffer nnbabyl-mbox-buffer)
159 (goto-char (point-min)) 157 (goto-char (point-min))
160 (when (search-forward (nnbabyl-article-string article) nil t) 158 (when (search-forward (nnbabyl-article-string article) nil t)
161 (let (start stop summary-line) 159 (let (start stop summary-line)
162 (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) 160 (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
163 (goto-char (point-min))
164 (end-of-line))
165 (while (and (not (looking-at ".+:")) 161 (while (and (not (looking-at ".+:"))
166 (zerop (forward-line 1)))) 162 (zerop (forward-line 1))))
167 (setq start (point)) 163 (setq start (point))
168 (or (when (re-search-forward 164 (or (and (re-search-forward
169 (concat "^" nnbabyl-mail-delimiter) nil t) 165 (concat "^" nnbabyl-mail-delimiter) nil t)
170 (beginning-of-line) 166 (forward-line -1))
171 t)
172 (goto-char (point-max))) 167 (goto-char (point-max)))
173 (setq stop (point)) 168 (setq stop (point))
174 (let ((nntp-server-buffer (or buffer nntp-server-buffer))) 169 (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
175 (set-buffer nntp-server-buffer) 170 (set-buffer nntp-server-buffer)
176 (erase-buffer) 171 (erase-buffer)
177 (insert-buffer-substring nnbabyl-mbox-buffer start stop) 172 (insert-buffer-substring nnbabyl-mbox-buffer start stop)
178 (goto-char (point-min)) 173 (goto-char (point-min))
179 ;; If there is an EOOH header, then we have to remove some 174 ;; If there is an EOOH header, then we have to remove some
180 ;; duplicated headers. 175 ;; duplicated headers.
181 (setq summary-line (looking-at "Summary-line:")) 176 (setq summary-line (looking-at "Summary-line:"))
182 (when (search-forward "\n*** EOOH ***" nil t) 177 (when (search-forward "\n*** EOOH ***" nil t)
183 (if summary-line 178 (if summary-line
184 ;; The headers to be deleted are located before the 179 ;; The headers to be deleted are located before the
185 ;; EOOH line... 180 ;; EOOH line...
187 (point))) 182 (point)))
188 ;; ...or after. 183 ;; ...or after.
189 (delete-region (progn (beginning-of-line) (point)) 184 (delete-region (progn (beginning-of-line) (point))
190 (or (search-forward "\n\n" nil t) 185 (or (search-forward "\n\n" nil t)
191 (point))))) 186 (point)))))
192 (if (numberp article) 187 (if (numberp article)
193 (cons nnbabyl-current-group article) 188 (cons nnbabyl-current-group article)
194 (nnbabyl-article-group-number))))))) 189 (nnbabyl-article-group-number)))))))
195 190
196 (deffoo nnbabyl-request-group (group &optional server dont-check) 191 (deffoo nnbabyl-request-group (group &optional server dont-check)
197 (let ((active (cadr (assoc group nnbabyl-group-alist)))) 192 (let ((active (cadr (assoc group nnbabyl-group-alist))))
198 (save-excursion 193 (save-excursion
199 (cond 194 (cond
200 ((or (null active) 195 ((or (null active)
201 (null (nnbabyl-possibly-change-newsgroup group server))) 196 (null (nnbabyl-possibly-change-newsgroup group server)))
202 (nnheader-report 'nnbabyl "No such group: %s" group)) 197 (nnheader-report 'nnbabyl "No such group: %s" group))
203 (dont-check 198 (dont-check
204 (nnheader-report 'nnbabyl "Selected group %s" group) 199 (nnheader-report 'nnbabyl "Selected group %s" group)
205 (nnheader-insert "")) 200 (nnheader-insert ""))
206 (t 201 (t
207 (nnheader-report 'nnbabyl "Selected group %s" group) 202 (nnheader-report 'nnbabyl "Selected group %s" group)
208 (nnheader-insert "211 %d %d %d %s\n" 203 (nnheader-insert "211 %d %d %d %s\n"
209 (1+ (- (cdr active) (car active))) 204 (1+ (- (cdr active) (car active)))
210 (car active) (cdr active) group)))))) 205 (car active) (cdr active) group))))))
211 206
212 (deffoo nnbabyl-request-scan (&optional group server) 207 (deffoo nnbabyl-request-scan (&optional group server)
213 (nnbabyl-possibly-change-newsgroup group server)
214 (nnbabyl-read-mbox) 208 (nnbabyl-read-mbox)
215 (nnmail-get-new-mail 209 (nnmail-get-new-mail
216 'nnbabyl 210 'nnbabyl
217 (lambda () 211 (lambda ()
218 (save-excursion 212 (save-excursion
219 (set-buffer nnbabyl-mbox-buffer) 213 (set-buffer nnbabyl-mbox-buffer)
220 (save-buffer))) 214 (save-buffer)))
221 (file-name-directory nnbabyl-mbox-file) 215 nnbabyl-mbox-file group
222 group
223 (lambda () 216 (lambda ()
224 (save-excursion 217 (save-excursion
225 (let ((in-buf (current-buffer))) 218 (let ((in-buf (current-buffer)))
226 (goto-char (point-min)) 219 (goto-char (point-min))
227 (while (search-forward "\n\^_\n" nil t) 220 (while (search-forward "\n\^_\n" nil t)
234 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))) 227 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))
235 228
236 (deffoo nnbabyl-close-group (group &optional server) 229 (deffoo nnbabyl-close-group (group &optional server)
237 t) 230 t)
238 231
239 (deffoo nnbabyl-request-create-group (group &optional server args) 232 (deffoo nnbabyl-request-create-group (group &optional server)
240 (nnmail-activate 'nnbabyl) 233 (nnmail-activate 'nnbabyl)
241 (unless (assoc group nnbabyl-group-alist) 234 (unless (assoc group nnbabyl-group-alist)
242 (push (list group (cons 1 0)) 235 (setq nnbabyl-group-alist (cons (list group (cons 1 0))
243 nnbabyl-group-alist) 236 nnbabyl-group-alist))
244 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) 237 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
245 t) 238 t)
246 239
247 (deffoo nnbabyl-request-list (&optional server) 240 (deffoo nnbabyl-request-list (&optional server)
248 (save-excursion 241 (save-excursion
249 (nnmail-find-file nnbabyl-active-file) 242 (nnmail-find-file nnbabyl-active-file)
250 (setq nnbabyl-group-alist (nnmail-get-active)) 243 (setq nnbabyl-group-alist (nnmail-get-active))))
251 t))
252 244
253 (deffoo nnbabyl-request-newgroups (date &optional server) 245 (deffoo nnbabyl-request-newgroups (date &optional server)
254 (nnbabyl-request-list server)) 246 (nnbabyl-request-list server))
255 247
256 (deffoo nnbabyl-request-list-newsgroups (&optional server) 248 (deffoo nnbabyl-request-list-newsgroups (&optional server)
261 (nnbabyl-possibly-change-newsgroup newsgroup server) 253 (nnbabyl-possibly-change-newsgroup newsgroup server)
262 (let* ((is-old t) 254 (let* ((is-old t)
263 rest) 255 rest)
264 (nnmail-activate 'nnbabyl) 256 (nnmail-activate 'nnbabyl)
265 257
266 (save-excursion 258 (save-excursion
267 (set-buffer nnbabyl-mbox-buffer) 259 (set-buffer nnbabyl-mbox-buffer)
268 (gnus-set-text-properties (point-min) (point-max) nil) 260 (gnus-set-text-properties (point-min) (point-max) nil)
269 (while (and articles is-old) 261 (while (and articles is-old)
270 (goto-char (point-min)) 262 (goto-char (point-min))
271 (when (search-forward (nnbabyl-article-string (car articles)) nil t) 263 (if (search-forward (nnbabyl-article-string (car articles)) nil t)
272 (if (setq is-old 264 (if (setq is-old
273 (nnmail-expired-article-p 265 (nnmail-expired-article-p
274 newsgroup 266 newsgroup
275 (buffer-substring 267 (buffer-substring
276 (point) (progn (end-of-line) (point))) force)) 268 (point) (progn (end-of-line) (point))) force))
277 (progn 269 (progn
278 (nnheader-message 5 "Deleting article %d in %s..." 270 (nnheader-message 5 "Deleting article %d in %s..."
279 (car articles) newsgroup) 271 (car articles) newsgroup)
280 (nnbabyl-delete-mail)) 272 (nnbabyl-delete-mail))
281 (push (car articles) rest))) 273 (setq rest (cons (car articles) rest))))
282 (setq articles (cdr articles))) 274 (setq articles (cdr articles)))
283 (save-buffer) 275 (save-buffer)
284 ;; Find the lowest active article in this group. 276 ;; Find the lowest active article in this group.
285 (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist)))) 277 (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist))))
286 (goto-char (point-min)) 278 (goto-char (point-min))
290 (setcar active (1+ (car active))) 282 (setcar active (1+ (car active)))
291 (goto-char (point-min)))) 283 (goto-char (point-min))))
292 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 284 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
293 (nconc rest articles)))) 285 (nconc rest articles))))
294 286
295 (deffoo nnbabyl-request-move-article 287 (deffoo nnbabyl-request-move-article
296 (article group server accept-form &optional last) 288 (article group server accept-form &optional last)
289 (nnbabyl-possibly-change-newsgroup group server)
297 (let ((buf (get-buffer-create " *nnbabyl move*")) 290 (let ((buf (get-buffer-create " *nnbabyl move*"))
298 result) 291 result)
299 (and 292 (and
300 (nnbabyl-request-article article group server) 293 (nnbabyl-request-article article group server)
301 (save-excursion 294 (save-excursion
302 (set-buffer buf) 295 (set-buffer buf)
303 (insert-buffer-substring nntp-server-buffer) 296 (insert-buffer-substring nntp-server-buffer)
304 (goto-char (point-min)) 297 (goto-char (point-min))
305 (while (re-search-forward 298 (if (re-search-forward
306 "^X-Gnus-Newsgroup:" 299 "^X-Gnus-Newsgroup:"
307 (save-excursion (search-forward "\n\n" nil t) (point)) t) 300 (save-excursion (search-forward "\n\n" nil t) (point)) t)
308 (delete-region (progn (beginning-of-line) (point)) 301 (delete-region (progn (beginning-of-line) (point))
309 (progn (forward-line 1) (point)))) 302 (progn (forward-line 1) (point))))
310 (setq result (eval accept-form)) 303 (setq result (eval accept-form))
311 (kill-buffer (current-buffer)) 304 (kill-buffer (current-buffer))
312 result) 305 result)
313 (save-excursion 306 (save-excursion
314 (nnbabyl-possibly-change-newsgroup group server)
315 (set-buffer nnbabyl-mbox-buffer) 307 (set-buffer nnbabyl-mbox-buffer)
316 (goto-char (point-min)) 308 (goto-char (point-min))
317 (if (search-forward (nnbabyl-article-string article) nil t) 309 (if (search-forward (nnbabyl-article-string article) nil t)
318 (nnbabyl-delete-mail)) 310 (nnbabyl-delete-mail))
319 (and last (save-buffer)))) 311 (and last (save-buffer))))
322 (deffoo nnbabyl-request-accept-article (group &optional server last) 314 (deffoo nnbabyl-request-accept-article (group &optional server last)
323 (nnbabyl-possibly-change-newsgroup group server) 315 (nnbabyl-possibly-change-newsgroup group server)
324 (nnmail-check-syntax) 316 (nnmail-check-syntax)
325 (let ((buf (current-buffer)) 317 (let ((buf (current-buffer))
326 result beg) 318 result beg)
327 (and 319 (and
328 (nnmail-activate 'nnbabyl) 320 (nnmail-activate 'nnbabyl)
329 (save-excursion 321 (save-excursion
330 (goto-char (point-min)) 322 (goto-char (point-min))
331 (search-forward "\n\n" nil t) 323 (search-forward "\n\n" nil t)
332 (forward-line -1) 324 (forward-line -1)
333 (save-excursion 325 (save-excursion
334 (while (re-search-backward "^X-Gnus-Newsgroup: " beg t) 326 (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
335 (delete-region (point) (progn (forward-line 1) (point))))) 327 (delete-region (point) (progn (forward-line 1) (point)))))
336 (when nnmail-cache-accepted-message-ids 328 (let ((nnmail-split-methods
337 (nnmail-cache-insert (nnmail-fetch-field "message-id"))) 329 (if (stringp group) (list (list group ""))
338 (setq result 330 nnmail-split-methods)))
339 (if (stringp group) 331 (setq result (car (nnbabyl-save-mail))))
340 (list (cons group (nnbabyl-active-number group)))
341 (nnmail-article-group 'nnbabyl-active-number)))
342 (if (null result)
343 (setq result 'junk)
344 (setq result (car (nnbabyl-save-mail result))))
345 (set-buffer nnbabyl-mbox-buffer) 332 (set-buffer nnbabyl-mbox-buffer)
346 (goto-char (point-max)) 333 (goto-char (point-max))
347 (search-backward "\n\^_") 334 (search-backward "\n\^_")
348 (goto-char (match-end 0)) 335 (goto-char (match-end 0))
349 (insert-buffer-substring buf) 336 (insert-buffer-substring buf)
350 (when last 337 (when last
351 (when nnmail-cache-accepted-message-ids
352 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
353 (save-buffer) 338 (save-buffer)
354 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) 339 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
355 result)))) 340 result))))
356 341
357 (deffoo nnbabyl-request-replace-article (article group buffer) 342 (deffoo nnbabyl-request-replace-article (article group buffer)
378 (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) 363 (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
379 found) 364 found)
380 (while (search-forward ident nil t) 365 (while (search-forward ident nil t)
381 (setq found t) 366 (setq found t)
382 (nnbabyl-delete-mail)) 367 (nnbabyl-delete-mail))
383 (when found 368 (and found (save-buffer)))))
384 (save-buffer)))))
385 ;; Remove the group from all structures. 369 ;; Remove the group from all structures.
386 (setq nnbabyl-group-alist 370 (setq nnbabyl-group-alist
387 (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist) 371 (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist)
388 nnbabyl-current-group nil) 372 nnbabyl-current-group nil)
389 ;; Save the active file. 373 ;; Save the active file.
390 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 374 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
391 t) 375 t)
399 (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) 383 (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
400 found) 384 found)
401 (while (search-forward ident nil t) 385 (while (search-forward ident nil t)
402 (replace-match new-ident t t) 386 (replace-match new-ident t t)
403 (setq found t)) 387 (setq found t))
404 (when found 388 (and found (save-buffer))))
405 (save-buffer))))
406 (let ((entry (assoc group nnbabyl-group-alist))) 389 (let ((entry (assoc group nnbabyl-group-alist)))
407 (and entry (setcar entry new-name)) 390 (and entry (setcar entry new-name))
408 (setq nnbabyl-current-group nil) 391 (setq nnbabyl-current-group nil)
409 ;; Save the new group alist. 392 ;; Save the new group alist.
410 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 393 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
412 395
413 396
414 ;;; Internal functions. 397 ;;; Internal functions.
415 398
416 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup 399 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
417 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox 400 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
418 ;; delimiter line. 401 ;; delimiter line.
419 (defun nnbabyl-delete-mail (&optional force leave-delim) 402 (defun nnbabyl-delete-mail (&optional force leave-delim)
420 ;; Delete the current X-Gnus-Newsgroup line. 403 ;; Delete the current X-Gnus-Newsgroup line.
421 (unless force 404 (or force
422 (delete-region 405 (delete-region
423 (progn (beginning-of-line) (point)) 406 (progn (beginning-of-line) (point))
424 (progn (forward-line 1) (point)))) 407 (progn (forward-line 1) (point))))
425 ;; Beginning of the article. 408 ;; Beginning of the article.
426 (save-excursion 409 (save-excursion
427 (save-restriction 410 (save-restriction
428 (widen) 411 (widen)
429 (narrow-to-region 412 (narrow-to-region
430 (save-excursion 413 (save-excursion
431 (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) 414 (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
432 (goto-char (point-min))
433 (end-of-line))
434 (if leave-delim (progn (forward-line 1) (point)) 415 (if leave-delim (progn (forward-line 1) (point))
435 (match-beginning 0))) 416 (match-beginning 0)))
436 (progn 417 (progn
437 (forward-line 1) 418 (forward-line 1)
438 (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) 419 (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter)
439 nil t) 420 nil t)
440 (match-beginning 0)) 421 (if (and (not (bobp)) leave-delim)
422 (progn (forward-line -2) (point))
423 (match-beginning 0)))
441 (point-max)))) 424 (point-max))))
442 (goto-char (point-min)) 425 (goto-char (point-min))
443 ;; Only delete the article if no other groups owns it as well. 426 ;; Only delete the article if no other groups owns it as well.
444 (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) 427 (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
445 (delete-region (point-min) (point-max)))))) 428 (delete-region (point-min) (point-max))))))
446 429
447 (defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server) 430 (defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server)
448 (when (and server 431 (when (and server
449 (not (nnbabyl-server-opened server))) 432 (not (nnbabyl-server-opened server)))
450 (nnbabyl-open-server server)) 433 (nnbabyl-open-server server))
451 (when (or (not nnbabyl-mbox-buffer) 434 (if (or (not nnbabyl-mbox-buffer)
452 (not (buffer-name nnbabyl-mbox-buffer))) 435 (not (buffer-name nnbabyl-mbox-buffer)))
453 (save-excursion (nnbabyl-read-mbox))) 436 (save-excursion (nnbabyl-read-mbox)))
454 (unless nnbabyl-group-alist 437 (or nnbabyl-group-alist
455 (nnmail-activate 'nnbabyl)) 438 (nnmail-activate 'nnbabyl))
456 (if newsgroup 439 (if newsgroup
457 (if (assoc newsgroup nnbabyl-group-alist) 440 (if (assoc newsgroup nnbabyl-group-alist)
458 (setq nnbabyl-current-group newsgroup) 441 (setq nnbabyl-current-group newsgroup)
459 (nnheader-report 'nnbabyl "No such group in file")) 442 (nnheader-report 'nnbabyl "No such group in file"))
460 t)) 443 t))
461 444
462 (defun nnbabyl-article-string (article) 445 (defun nnbabyl-article-string (article)
463 (if (numberp article) 446 (if (numberp article)
464 (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":" 447 (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"
465 (int-to-string article) " ") 448 (int-to-string article) " ")
466 (concat "\nMessage-ID: " article))) 449 (concat "\nMessage-ID: " article)))
467 450
468 (defun nnbabyl-article-group-number () 451 (defun nnbabyl-article-group-number ()
469 (save-excursion 452 (save-excursion
470 (goto-char (point-min)) 453 (goto-char (point-min))
471 (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " 454 (and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
472 nil t) 455 nil t)
473 (cons (buffer-substring (match-beginning 1) (match-end 1)) 456 (cons (buffer-substring (match-beginning 1) (match-end 1))
474 (string-to-int 457 (string-to-int
475 (buffer-substring (match-beginning 2) (match-end 2))))))) 458 (buffer-substring (match-beginning 2) (match-end 2)))))))
476 459
477 (defun nnbabyl-insert-lines () 460 (defun nnbabyl-insert-lines ()
478 "Insert how many lines and chars there are in the body of the mail." 461 "Insert how many lines and chars there are in the body of the mail."
479 (let (lines chars) 462 (let (lines chars)
480 (save-excursion 463 (save-excursion
481 (goto-char (point-min)) 464 (goto-char (point-min))
482 (when (search-forward "\n\n" nil t) 465 (when (search-forward "\n\n" nil t)
483 ;; There may be an EOOH line here... 466 ;; There may be an EOOH line here...
484 (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") 467 (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
485 (search-forward "\n\n" nil t)) 468 (search-forward "\n\n" nil t))
486 (setq chars (- (point-max) (point)) 469 (setq chars (- (point-max) (point))
487 lines (max (- (count-lines (point) (point-max)) 1) 0)) 470 lines (max (- (count-lines (point) (point-max)) 1) 0))
488 ;; Move back to the end of the headers. 471 ;; Move back to the end of the headers.
489 (goto-char (point-min)) 472 (goto-char (point-min))
490 (search-forward "\n\n" nil t) 473 (search-forward "\n\n" nil t)
491 (forward-char -1) 474 (forward-char -1)
492 (save-excursion 475 (save-excursion
493 (when (re-search-backward "^Lines: " nil t) 476 (when (re-search-backward "^Lines: " nil t)
494 (delete-region (point) (progn (forward-line 1) (point))))) 477 (delete-region (point) (progn (forward-line 1) (point)))))
495 (insert (format "Lines: %d\n" lines)) 478 (insert (format "Lines: %d\n" lines))
496 chars)))) 479 chars))))
497 480
498 (defun nnbabyl-save-mail (group-art) 481 (defun nnbabyl-save-mail ()
499 ;; Called narrowed to an article. 482 ;; Called narrowed to an article.
500 (nnbabyl-insert-lines) 483 (let ((group-art (nreverse (nnmail-article-group 'nnbabyl-active-number))))
501 (nnmail-insert-xref group-art) 484 (nnbabyl-insert-lines)
502 (nnbabyl-insert-newsgroup-line group-art) 485 (nnmail-insert-xref group-art)
503 (run-hooks 'nnbabyl-prepare-save-mail-hook) 486 (nnbabyl-insert-newsgroup-line group-art)
504 group-art) 487 (run-hooks 'nnbabyl-prepare-save-mail-hook)
488 group-art))
505 489
506 (defun nnbabyl-insert-newsgroup-line (group-art) 490 (defun nnbabyl-insert-newsgroup-line (group-art)
507 (save-excursion 491 (save-excursion
508 (goto-char (point-min)) 492 (goto-char (point-min))
509 (while (looking-at "From ") 493 (while (looking-at "From ")
510 (replace-match "Mail-from: From " t t) 494 (replace-match "Mail-from: From " t t)
511 (forward-line 1)) 495 (forward-line 1))
512 ;; If there is a C-l at the beginning of the narrowed region, this 496 ;; If there is a C-l at the beginning of the narrowed region, this
513 ;; isn't really a "save", but rather a "scan". 497 ;; isn't really a "save", but rather a "scan".
514 (goto-char (point-min)) 498 (goto-char (point-min))
515 (unless (looking-at "\^L") 499 (or (looking-at "\^L")
516 (save-excursion 500 (save-excursion
517 (insert "\^L\n0, unseen,,\n*** EOOH ***\n") 501 (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
518 (goto-char (point-max)) 502 (goto-char (point-max))
519 (insert "\^_\n"))) 503 (insert "\^_\n")))
520 (when (search-forward "\n\n" nil t) 504 (if (search-forward "\n\n" nil t)
521 (forward-char -1) 505 (progn
522 (while group-art 506 (forward-char -1)
523 (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" 507 (while group-art
524 (caar group-art) (cdar group-art) 508 (insert (format "X-Gnus-Newsgroup: %s:%d %s\n"
525 (current-time-string))) 509 (caar group-art) (cdar group-art)
526 (setq group-art (cdr group-art)))) 510 (current-time-string)))
511 (setq group-art (cdr group-art)))))
527 t)) 512 t))
528 513
529 (defun nnbabyl-active-number (group) 514 (defun nnbabyl-active-number (group)
530 ;; Find the next article number in GROUP. 515 ;; Find the next article number in GROUP.
531 (let ((active (cadr (assoc group nnbabyl-group-alist)))) 516 (let ((active (cadr (assoc group nnbabyl-group-alist))))
532 (if active 517 (if active
533 (setcdr active (1+ (cdr active))) 518 (setcdr active (1+ (cdr active)))
534 ;; This group is new, so we create a new entry for it. 519 ;; This group is new, so we create a new entry for it.
535 ;; This might be a bit naughty... creating groups on the drop of 520 ;; This might be a bit naughty... creating groups on the drop of
536 ;; a hat, but I don't know... 521 ;; a hat, but I don't know...
537 (push (list group (setq active (cons 1 1))) 522 (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 1)))
538 nnbabyl-group-alist)) 523 nnbabyl-group-alist)))
539 (cdr active))) 524 (cdr active)))
540 525
541 (defun nnbabyl-create-mbox () 526 (defun nnbabyl-read-mbox ()
527 (nnmail-activate 'nnbabyl)
542 (unless (file-exists-p nnbabyl-mbox-file) 528 (unless (file-exists-p nnbabyl-mbox-file)
543 ;; Create a new, empty RMAIL mbox file. 529 ;; Create a new, empty RMAIL mbox file.
544 (save-excursion 530 (save-excursion
545 (set-buffer (setq nnbabyl-mbox-buffer 531 (set-buffer (setq nnbabyl-mbox-buffer
546 (create-file-buffer nnbabyl-mbox-file))) 532 (create-file-buffer nnbabyl-mbox-file)))
547 (setq buffer-file-name nnbabyl-mbox-file) 533 (setq buffer-file-name nnbabyl-mbox-file)
548 (insert "BABYL OPTIONS:\n\n\^_") 534 (insert "BABYL OPTIONS:\n\n\^_")
549 (nnmail-write-region 535 (write-region (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))
550 (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) 536
551 537 (if (and nnbabyl-mbox-buffer
552 (defun nnbabyl-read-mbox ()
553 (nnmail-activate 'nnbabyl)
554 (nnbabyl-create-mbox)
555
556 (unless (and nnbabyl-mbox-buffer
557 (buffer-name nnbabyl-mbox-buffer) 538 (buffer-name nnbabyl-mbox-buffer)
558 (save-excursion 539 (save-excursion
559 (set-buffer nnbabyl-mbox-buffer) 540 (set-buffer nnbabyl-mbox-buffer)
560 (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) 541 (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file))))
561 ;; This buffer has changed since we read it last. Possibly. 542 () ; This buffer hasn't changed since we read it last. Possibly.
562 (save-excursion 543 (save-excursion
563 (let ((delim (concat "^" nnbabyl-mail-delimiter)) 544 (let ((delim (concat "^" nnbabyl-mail-delimiter))
564 (alist nnbabyl-group-alist) 545 (alist nnbabyl-group-alist)
565 start end number) 546 start end number)
566 (set-buffer (setq nnbabyl-mbox-buffer 547 (set-buffer (setq nnbabyl-mbox-buffer
567 (nnheader-find-file-noselect 548 (nnheader-find-file-noselect
568 nnbabyl-mbox-file nil 'raw))) 549 nnbabyl-mbox-file nil 'raw)))
569 ;; Save previous buffer mode. 550 ;; Save previous buffer mode.
570 (setq nnbabyl-previous-buffer-mode 551 (setq nnbabyl-previous-buffer-mode
571 (cons (cons (point-min) (point-max)) 552 (cons (cons (point-min) (point-max))
572 major-mode)) 553 major-mode))
573 554
574 (buffer-disable-undo (current-buffer)) 555 (buffer-disable-undo (current-buffer))
575 (widen) 556 (widen)
580 ;; the rmail file. 561 ;; the rmail file.
581 (while alist 562 (while alist
582 (goto-char (point-max)) 563 (goto-char (point-max))
583 (when (and (re-search-backward 564 (when (and (re-search-backward
584 (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " 565 (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
585 (caar alist)) 566 (caar alist)) nil t)
586 nil t)
587 (> (setq number 567 (> (setq number
588 (string-to-number 568 (string-to-number
589 (buffer-substring 569 (buffer-substring
590 (match-beginning 1) (match-end 1)))) 570 (match-beginning 1) (match-end 1))))
591 (cdadar alist))) 571 (cdadar alist)))
592 (setcdr (cadar alist) number)) 572 (setcdr (cadar alist) (1+ number)))
593 (setq alist (cdr alist))) 573 (setq alist (cdr alist)))
594 574
595 ;; We go through the mbox and make sure that each and 575 ;; We go through the mbox and make sure that each and
596 ;; every mail belongs to some group or other. 576 ;; every mail belongs to some group or other.
597 (goto-char (point-min)) 577 (goto-char (point-min))
598 (if (looking-at "\^L") 578 (re-search-forward delim nil t)
599 (setq start (point)) 579 (setq start (match-end 0))
600 (re-search-forward delim nil t)
601 (setq start (match-end 0)))
602 (while (re-search-forward delim nil t) 580 (while (re-search-forward delim nil t)
603 (setq end (match-end 0)) 581 (setq end (match-end 0))
604 (unless (search-backward "\nX-Gnus-Newsgroup: " start t) 582 (unless (search-backward "\nX-Gnus-Newsgroup: " start t)
605 (goto-char end) 583 (goto-char end)
606 (save-excursion 584 (save-excursion
607 (save-restriction 585 (save-restriction
608 (narrow-to-region (goto-char start) end) 586 (narrow-to-region (goto-char start) end)
609 (nnbabyl-save-mail 587 (nnbabyl-save-mail)
610 (nnmail-article-group 'nnbabyl-active-number))
611 (setq end (point-max))))) 588 (setq end (point-max)))))
612 (goto-char (setq start end))) 589 (goto-char (setq start end)))
613 (when (buffer-modified-p (current-buffer)) 590 (when (buffer-modified-p (current-buffer))
614 (save-buffer)) 591 (save-buffer))
615 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))) 592 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))))
634 (if (intern-soft (setq id (match-string 1)) idents) 611 (if (intern-soft (setq id (match-string 1)) idents)
635 (progn 612 (progn
636 (delete-region (progn (beginning-of-line) (point)) 613 (delete-region (progn (beginning-of-line) (point))
637 (progn (forward-line 1) (point))) 614 (progn (forward-line 1) (point)))
638 (nnheader-message 7 "Moving %s..." id) 615 (nnheader-message 7 "Moving %s..." id)
639 (nnbabyl-save-mail 616 (nnbabyl-save-mail))
640 (nnmail-article-group 'nnbabyl-active-number)))
641 (intern id idents))) 617 (intern id idents)))
642 (when (buffer-modified-p (current-buffer)) 618 (when (buffer-modified-p (current-buffer))
643 (save-buffer)) 619 (save-buffer))
644 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 620 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
645 (message "")))) 621 (message ""))))