Mercurial > hg > xemacs-beta

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