1;;; nnbabyl.el --- rmail mbox access for Gnus 2 3;; Copyright (C) 1995, 1996, 1997, 1998, 1099, 2000, 2001, 2002, 2003, 4;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 7;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 8;; Keywords: news, mail 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software; you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation; either version 2, or (at your option) 15;; any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs; see the file COPYING. If not, write to the 24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Commentary: 28 29;; For an overview of what the interface functions do, please see the 30;; Gnus sources. 31 32;;; Code: 33 34(require 'nnheader) 35(condition-case nil 36 (require 'rmail) 37 (t (nnheader-message 38 5 "Ignore rmail errors from this file, you don't have rmail"))) 39(require 'nnmail) 40(require 'nnoo) 41(eval-when-compile (require 'cl)) 42 43(nnoo-declare nnbabyl) 44 45(defvoo nnbabyl-mbox-file (expand-file-name "~/RMAIL") 46 "The name of the rmail box file in the users home directory.") 47 48(defvoo nnbabyl-active-file (expand-file-name "~/.rmail-active") 49 "The name of the active file for the rmail box.") 50 51(defvoo nnbabyl-get-new-mail t 52 "If non-nil, nnbabyl will check the incoming mail file and split the mail.") 53 54 55(defvoo nnbabyl-prepare-save-mail-hook nil 56 "Hook run narrowed to an article before saving.") 57 58 59 60(defvar nnbabyl-mail-delimiter "\^_") 61 62(defconst nnbabyl-version "nnbabyl 1.0" 63 "nnbabyl version.") 64 65(defvoo nnbabyl-mbox-buffer nil) 66(defvoo nnbabyl-current-group nil) 67(defvoo nnbabyl-status-string "") 68(defvoo nnbabyl-group-alist nil) 69(defvoo nnbabyl-active-timestamp nil) 70 71(defvoo nnbabyl-previous-buffer-mode nil) 72 73(eval-and-compile 74 (autoload 'gnus-set-text-properties "gnus-ems")) 75 76 77 78;;; Interface functions 79 80(nnoo-define-basics nnbabyl) 81 82(deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old) 83 (save-excursion 84 (set-buffer nntp-server-buffer) 85 (erase-buffer) 86 (let ((number (length articles)) 87 (count 0) 88 (delim (concat "^" nnbabyl-mail-delimiter)) 89 article art-string start stop) 90 (nnbabyl-possibly-change-newsgroup group server) 91 (while (setq article (pop articles)) 92 (setq art-string (nnbabyl-article-string article)) 93 (set-buffer nnbabyl-mbox-buffer) 94 (end-of-line) 95 (when (or (search-forward art-string nil t) 96 (search-backward art-string nil t)) 97 (unless (re-search-backward delim nil t) 98 (goto-char (point-min))) 99 (while (and (not (looking-at ".+:")) 100 (zerop (forward-line 1)))) 101 (setq start (point)) 102 (search-forward "\n\n" nil t) 103 (setq stop (1- (point))) 104 (set-buffer nntp-server-buffer) 105 (insert "221 ") 106 (princ article (current-buffer)) 107 (insert " Article retrieved.\n") 108 (insert-buffer-substring nnbabyl-mbox-buffer start stop) 109 (goto-char (point-max)) 110 (insert ".\n")) 111 (and (numberp nnmail-large-newsgroup) 112 (> number nnmail-large-newsgroup) 113 (zerop (% (incf count) 20)) 114 (nnheader-message 5 "nnbabyl: Receiving headers... %d%%" 115 (/ (* count 100) number)))) 116 117 (and (numberp nnmail-large-newsgroup) 118 (> number nnmail-large-newsgroup) 119 (nnheader-message 5 "nnbabyl: Receiving headers...done")) 120 121 (set-buffer nntp-server-buffer) 122 (nnheader-fold-continuation-lines) 123 'headers))) 124 125(deffoo nnbabyl-open-server (server &optional defs) 126 (nnoo-change-server 'nnbabyl server defs) 127 (nnbabyl-create-mbox) 128 (cond 129 ((not (file-exists-p nnbabyl-mbox-file)) 130 (nnbabyl-close-server) 131 (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file)) 132 ((file-directory-p nnbabyl-mbox-file) 133 (nnbabyl-close-server) 134 (nnheader-report 'nnbabyl "Not a regular file: %s" nnbabyl-mbox-file)) 135 (t 136 (nnheader-report 'nnbabyl "Opened server %s using mbox %s" server 137 nnbabyl-mbox-file) 138 t))) 139 140(deffoo nnbabyl-close-server (&optional server) 141 ;; Restore buffer mode. 142 (when (and (nnbabyl-server-opened) 143 nnbabyl-previous-buffer-mode) 144 (save-excursion 145 (set-buffer nnbabyl-mbox-buffer) 146 (narrow-to-region 147 (caar nnbabyl-previous-buffer-mode) 148 (cdar nnbabyl-previous-buffer-mode)) 149 (funcall (cdr nnbabyl-previous-buffer-mode)))) 150 (nnoo-close-server 'nnbabyl server) 151 (setq nnbabyl-mbox-buffer nil) 152 t) 153 154(deffoo nnbabyl-server-opened (&optional server) 155 (and (nnoo-current-server-p 'nnbabyl server) 156 nnbabyl-mbox-buffer 157 (buffer-name nnbabyl-mbox-buffer) 158 nntp-server-buffer 159 (buffer-name nntp-server-buffer))) 160 161(deffoo nnbabyl-request-article (article &optional newsgroup server buffer) 162 (nnbabyl-possibly-change-newsgroup newsgroup server) 163 (save-excursion 164 (set-buffer nnbabyl-mbox-buffer) 165 (goto-char (point-min)) 166 (when (search-forward (nnbabyl-article-string article) nil t) 167 (let (start stop summary-line) 168 (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) 169 (goto-char (point-min)) 170 (end-of-line)) 171 (while (and (not (looking-at ".+:")) 172 (zerop (forward-line 1)))) 173 (setq start (point)) 174 (or (when (re-search-forward 175 (concat "^" nnbabyl-mail-delimiter) nil t) 176 (beginning-of-line) 177 t) 178 (goto-char (point-max))) 179 (setq stop (point)) 180 (let ((nntp-server-buffer (or buffer nntp-server-buffer))) 181 (set-buffer nntp-server-buffer) 182 (erase-buffer) 183 (insert-buffer-substring nnbabyl-mbox-buffer start stop) 184 (goto-char (point-min)) 185 ;; If there is an EOOH header, then we have to remove some 186 ;; duplicated headers. 187 (setq summary-line (looking-at "Summary-line:")) 188 (when (search-forward "\n*** EOOH ***" nil t) 189 (if summary-line 190 ;; The headers to be deleted are located before the 191 ;; EOOH line... 192 (delete-region (point-min) (progn (forward-line 1) 193 (point))) 194 ;; ...or after. 195 (delete-region (progn (beginning-of-line) (point)) 196 (or (search-forward "\n\n" nil t) 197 (point))))) 198 (if (numberp article) 199 (cons nnbabyl-current-group article) 200 (nnbabyl-article-group-number))))))) 201 202(deffoo nnbabyl-request-group (group &optional server dont-check) 203 (let ((active (cadr (assoc group nnbabyl-group-alist)))) 204 (save-excursion 205 (cond 206 ((or (null active) 207 (null (nnbabyl-possibly-change-newsgroup group server))) 208 (nnheader-report 'nnbabyl "No such group: %s" group)) 209 (dont-check 210 (nnheader-report 'nnbabyl "Selected group %s" group) 211 (nnheader-insert "")) 212 (t 213 (nnheader-report 'nnbabyl "Selected group %s" group) 214 (nnheader-insert "211 %d %d %d %s\n" 215 (1+ (- (cdr active) (car active))) 216 (car active) (cdr active) group)))))) 217 218(deffoo nnbabyl-request-scan (&optional group server) 219 (nnbabyl-possibly-change-newsgroup group server) 220 (nnbabyl-read-mbox) 221 (nnmail-get-new-mail 222 'nnbabyl 223 (lambda () 224 (save-excursion 225 (set-buffer nnbabyl-mbox-buffer) 226 (save-buffer))) 227 (file-name-directory nnbabyl-mbox-file) 228 group 229 (lambda () 230 (save-excursion 231 (let ((in-buf (current-buffer))) 232 (goto-char (point-min)) 233 (while (search-forward "\n\^_\n" nil t) 234 (delete-char -1)) 235 (set-buffer nnbabyl-mbox-buffer) 236 (goto-char (point-max)) 237 (search-backward "\n\^_" nil t) 238 (goto-char (match-end 0)) 239 (insert-buffer-substring in-buf))) 240 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))) 241 242(deffoo nnbabyl-close-group (group &optional server) 243 t) 244 245(deffoo nnbabyl-request-create-group (group &optional server args) 246 (nnmail-activate 'nnbabyl) 247 (unless (assoc group nnbabyl-group-alist) 248 (push (list group (cons 1 0)) 249 nnbabyl-group-alist) 250 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) 251 t) 252 253(deffoo nnbabyl-request-list (&optional server) 254 (save-excursion 255 (nnmail-find-file nnbabyl-active-file) 256 (setq nnbabyl-group-alist (nnmail-get-active)) 257 t)) 258 259(deffoo nnbabyl-request-newgroups (date &optional server) 260 (nnbabyl-request-list server)) 261 262(deffoo nnbabyl-request-list-newsgroups (&optional server) 263 (nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented.")) 264 265(deffoo nnbabyl-request-expire-articles 266 (articles newsgroup &optional server force) 267 (nnbabyl-possibly-change-newsgroup newsgroup server) 268 (let* ((is-old t) 269 rest) 270 (nnmail-activate 'nnbabyl) 271 272 (save-excursion 273 (set-buffer nnbabyl-mbox-buffer) 274 (gnus-set-text-properties (point-min) (point-max) nil) 275 (while (and articles is-old) 276 (goto-char (point-min)) 277 (when (search-forward (nnbabyl-article-string (car articles)) nil t) 278 (if (setq is-old 279 (nnmail-expired-article-p 280 newsgroup 281 (buffer-substring 282 (point) (progn (end-of-line) (point))) force)) 283 (progn 284 (unless (eq nnmail-expiry-target 'delete) 285 (with-temp-buffer 286 (nnbabyl-request-article (car articles) 287 newsgroup server 288 (current-buffer)) 289 (let ((nnml-current-directory nil)) 290 (nnmail-expiry-target-group 291 nnmail-expiry-target newsgroup))) 292 (nnbabyl-possibly-change-newsgroup newsgroup server)) 293 (nnheader-message 5 "Deleting article %d in %s..." 294 (car articles) newsgroup) 295 (nnbabyl-delete-mail)) 296 (push (car articles) rest))) 297 (setq articles (cdr articles))) 298 (save-buffer) 299 ;; Find the lowest active article in this group. 300 (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist)))) 301 (goto-char (point-min)) 302 (while (and (not (search-forward 303 (nnbabyl-article-string (car active)) nil t)) 304 (<= (car active) (cdr active))) 305 (setcar active (1+ (car active))) 306 (goto-char (point-min)))) 307 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 308 (nconc rest articles)))) 309 310(deffoo nnbabyl-request-move-article 311 (article group server accept-form &optional last) 312 (let ((buf (get-buffer-create " *nnbabyl move*")) 313 result) 314 (and 315 (nnbabyl-request-article article group server) 316 (save-excursion 317 (set-buffer buf) 318 (insert-buffer-substring nntp-server-buffer) 319 (goto-char (point-min)) 320 (while (re-search-forward 321 "^X-Gnus-Newsgroup:" 322 (save-excursion (search-forward "\n\n" nil t) (point)) t) 323 (delete-region (progn (beginning-of-line) (point)) 324 (progn (forward-line 1) (point)))) 325 (setq result (eval accept-form)) 326 (kill-buffer (current-buffer)) 327 result) 328 (save-excursion 329 (nnbabyl-possibly-change-newsgroup group server) 330 (set-buffer nnbabyl-mbox-buffer) 331 (goto-char (point-min)) 332 (if (search-forward (nnbabyl-article-string article) nil t) 333 (nnbabyl-delete-mail)) 334 (and last (save-buffer)))) 335 result)) 336 337(deffoo nnbabyl-request-accept-article (group &optional server last) 338 (nnbabyl-possibly-change-newsgroup group server) 339 (nnmail-check-syntax) 340 (let ((buf (current-buffer)) 341 result beg) 342 (and 343 (nnmail-activate 'nnbabyl) 344 (save-excursion 345 (goto-char (point-min)) 346 (search-forward "\n\n" nil t) 347 (forward-line -1) 348 (save-excursion 349 (while (re-search-backward "^X-Gnus-Newsgroup: " beg t) 350 (delete-region (point) (progn (forward-line 1) (point))))) 351 (when nnmail-cache-accepted-message-ids 352 (nnmail-cache-insert (nnmail-fetch-field "message-id") 353 group 354 (nnmail-fetch-field "subject") 355 (nnmail-fetch-field "from"))) 356 (setq result 357 (if (stringp group) 358 (list (cons group (nnbabyl-active-number group))) 359 (nnmail-article-group 'nnbabyl-active-number))) 360 (if (and (null result) 361 (yes-or-no-p "Moved to `junk' group; delete article? ")) 362 (setq result 'junk) 363 (setq result (car (nnbabyl-save-mail result)))) 364 (set-buffer nnbabyl-mbox-buffer) 365 (goto-char (point-max)) 366 (search-backward "\n\^_") 367 (goto-char (match-end 0)) 368 (insert-buffer-substring buf) 369 (when last 370 (when nnmail-cache-accepted-message-ids 371 (nnmail-cache-insert (nnmail-fetch-field "message-id") 372 group 373 (nnmail-fetch-field "subject") 374 (nnmail-fetch-field "from"))) 375 (save-buffer) 376 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) 377 result)))) 378 379(deffoo nnbabyl-request-replace-article (article group buffer) 380 (nnbabyl-possibly-change-newsgroup group) 381 (save-excursion 382 (set-buffer nnbabyl-mbox-buffer) 383 (goto-char (point-min)) 384 (if (not (search-forward (nnbabyl-article-string article) nil t)) 385 nil 386 (nnbabyl-delete-mail t t) 387 (insert-buffer-substring buffer) 388 (save-buffer) 389 t))) 390 391(deffoo nnbabyl-request-delete-group (group &optional force server) 392 (nnbabyl-possibly-change-newsgroup group server) 393 ;; Delete all articles in GROUP. 394 (if (not force) 395 () ; Don't delete the articles. 396 (save-excursion 397 (set-buffer nnbabyl-mbox-buffer) 398 (goto-char (point-min)) 399 ;; Delete all articles in this group. 400 (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) 401 found) 402 (while (search-forward ident nil t) 403 (setq found t) 404 (nnbabyl-delete-mail)) 405 (when found 406 (save-buffer))))) 407 ;; Remove the group from all structures. 408 (setq nnbabyl-group-alist 409 (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist) 410 nnbabyl-current-group nil) 411 ;; Save the active file. 412 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 413 t) 414 415(deffoo nnbabyl-request-rename-group (group new-name &optional server) 416 (nnbabyl-possibly-change-newsgroup group server) 417 (save-excursion 418 (set-buffer nnbabyl-mbox-buffer) 419 (goto-char (point-min)) 420 (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) 421 (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) 422 found) 423 (while (search-forward ident nil t) 424 (replace-match new-ident t t) 425 (setq found t)) 426 (when found 427 (save-buffer)))) 428 (let ((entry (assoc group nnbabyl-group-alist))) 429 (and entry (setcar entry new-name)) 430 (setq nnbabyl-current-group nil) 431 ;; Save the new group alist. 432 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 433 t)) 434 435 436;;; Internal functions. 437 438;; If FORCE, delete article no matter how many X-Gnus-Newsgroup 439;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox 440;; delimiter line. 441(defun nnbabyl-delete-mail (&optional force leave-delim) 442 ;; Delete the current X-Gnus-Newsgroup line. 443 (unless force 444 (delete-region 445 (progn (beginning-of-line) (point)) 446 (progn (forward-line 1) (point)))) 447 ;; Beginning of the article. 448 (save-excursion 449 (save-restriction 450 (widen) 451 (narrow-to-region 452 (save-excursion 453 (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) 454 (goto-char (point-min)) 455 (end-of-line)) 456 (if leave-delim (progn (forward-line 1) (point)) 457 (match-beginning 0))) 458 (progn 459 (forward-line 1) 460 (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) 461 nil t) 462 (match-beginning 0)) 463 (point-max)))) 464 (goto-char (point-min)) 465 ;; Only delete the article if no other groups owns it as well. 466 (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) 467 (delete-region (point-min) (point-max)))))) 468 469(defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server) 470 (when (and server 471 (not (nnbabyl-server-opened server))) 472 (nnbabyl-open-server server)) 473 (when (or (not nnbabyl-mbox-buffer) 474 (not (buffer-name nnbabyl-mbox-buffer))) 475 (save-excursion (nnbabyl-read-mbox))) 476 (unless nnbabyl-group-alist 477 (nnmail-activate 'nnbabyl)) 478 (if newsgroup 479 (if (assoc newsgroup nnbabyl-group-alist) 480 (setq nnbabyl-current-group newsgroup) 481 (nnheader-report 'nnbabyl "No such group in file")) 482 t)) 483 484(defun nnbabyl-article-string (article) 485 (if (numberp article) 486 (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":" 487 (int-to-string article) " ") 488 (concat "\nMessage-ID: " article))) 489 490(defun nnbabyl-article-group-number () 491 (save-excursion 492 (goto-char (point-min)) 493 (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " 494 nil t) 495 (cons (buffer-substring (match-beginning 1) (match-end 1)) 496 (string-to-number 497 (buffer-substring (match-beginning 2) (match-end 2))))))) 498 499(defun nnbabyl-insert-lines () 500 "Insert how many lines and chars there are in the body of the mail." 501 (let (lines chars) 502 (save-excursion 503 (goto-char (point-min)) 504 (when (search-forward "\n\n" nil t) 505 ;; There may be an EOOH line here... 506 (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") 507 (search-forward "\n\n" nil t)) 508 (setq chars (- (point-max) (point)) 509 lines (max (- (count-lines (point) (point-max)) 1) 0)) 510 ;; Move back to the end of the headers. 511 (goto-char (point-min)) 512 (search-forward "\n\n" nil t) 513 (forward-char -1) 514 (save-excursion 515 (when (re-search-backward "^Lines: " nil t) 516 (delete-region (point) (progn (forward-line 1) (point))))) 517 (insert (format "Lines: %d\n" lines)) 518 chars)))) 519 520(defun nnbabyl-save-mail (group-art) 521 ;; Called narrowed to an article. 522 (nnbabyl-insert-lines) 523 (nnmail-insert-xref group-art) 524 (nnbabyl-insert-newsgroup-line group-art) 525 (run-hooks 'nnbabyl-prepare-save-mail-hook) 526 group-art) 527 528(defun nnbabyl-insert-newsgroup-line (group-art) 529 (save-excursion 530 (goto-char (point-min)) 531 (while (looking-at "From ") 532 (replace-match "Mail-from: From " t t) 533 (forward-line 1)) 534 ;; If there is a C-l at the beginning of the narrowed region, this 535 ;; isn't really a "save", but rather a "scan". 536 (goto-char (point-min)) 537 (unless (looking-at "\^L") 538 (save-excursion 539 (insert "\^L\n0, unseen,,\n*** EOOH ***\n") 540 (goto-char (point-max)) 541 (insert "\^_\n"))) 542 (when (search-forward "\n\n" nil t) 543 (forward-char -1) 544 (while group-art 545 (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" 546 (caar group-art) (cdar group-art) 547 (current-time-string))) 548 (setq group-art (cdr group-art)))) 549 t)) 550 551(defun nnbabyl-active-number (group) 552 ;; Find the next article number in GROUP. 553 (let ((active (cadr (assoc group nnbabyl-group-alist)))) 554 (if active 555 (setcdr active (1+ (cdr active))) 556 ;; This group is new, so we create a new entry for it. 557 ;; This might be a bit naughty... creating groups on the drop of 558 ;; a hat, but I don't know... 559 (push (list group (setq active (cons 1 1))) 560 nnbabyl-group-alist)) 561 (cdr active))) 562 563(defun nnbabyl-create-mbox () 564 (unless (file-exists-p nnbabyl-mbox-file) 565 ;; Create a new, empty RMAIL mbox file. 566 (save-excursion 567 (set-buffer (setq nnbabyl-mbox-buffer 568 (create-file-buffer nnbabyl-mbox-file))) 569 (setq buffer-file-name nnbabyl-mbox-file) 570 (insert "BABYL OPTIONS:\n\n\^_") 571 (nnmail-write-region 572 (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) 573 574(defun nnbabyl-read-mbox () 575 (nnmail-activate 'nnbabyl) 576 (nnbabyl-create-mbox) 577 578 (unless (and nnbabyl-mbox-buffer 579 (buffer-name nnbabyl-mbox-buffer) 580 (save-excursion 581 (set-buffer nnbabyl-mbox-buffer) 582 (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) 583 ;; This buffer has changed since we read it last. Possibly. 584 (save-excursion 585 (let ((delim (concat "^" nnbabyl-mail-delimiter)) 586 (alist nnbabyl-group-alist) 587 start end number) 588 (set-buffer (setq nnbabyl-mbox-buffer 589 (nnheader-find-file-noselect 590 nnbabyl-mbox-file nil t))) 591 ;; Save previous buffer mode. 592 (setq nnbabyl-previous-buffer-mode 593 (cons (cons (point-min) (point-max)) 594 major-mode)) 595 596 (buffer-disable-undo) 597 (widen) 598 (setq buffer-read-only nil) 599 (fundamental-mode) 600 601 ;; Go through the group alist and compare against 602 ;; the rmail file. 603 (while alist 604 (goto-char (point-max)) 605 (when (and (re-search-backward 606 (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " 607 (caar alist)) 608 nil t) 609 (> (setq number 610 (string-to-number 611 (buffer-substring 612 (match-beginning 1) (match-end 1)))) 613 (cdadar alist))) 614 (setcdr (cadar alist) number)) 615 (setq alist (cdr alist))) 616 617 ;; We go through the mbox and make sure that each and 618 ;; every mail belongs to some group or other. 619 (goto-char (point-min)) 620 (if (looking-at "\^L") 621 (setq start (point)) 622 (re-search-forward delim nil t) 623 (setq start (match-end 0))) 624 (while (re-search-forward delim nil t) 625 (setq end (match-end 0)) 626 (unless (search-backward "\nX-Gnus-Newsgroup: " start t) 627 (goto-char end) 628 (save-excursion 629 (save-restriction 630 (narrow-to-region (goto-char start) end) 631 (nnbabyl-save-mail 632 (nnmail-article-group 'nnbabyl-active-number)) 633 (setq end (point-max))))) 634 (goto-char (setq start end))) 635 (when (buffer-modified-p (current-buffer)) 636 (save-buffer)) 637 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))) 638 639(defun nnbabyl-remove-incoming-delims () 640 (goto-char (point-min)) 641 (while (search-forward "\^_" nil t) 642 (replace-match "?" t t))) 643 644(defun nnbabyl-check-mbox () 645 "Go through the nnbabyl mbox and make sure that no article numbers are reused." 646 (interactive) 647 (let ((idents (make-vector 1000 0)) 648 id) 649 (save-excursion 650 (when (or (not nnbabyl-mbox-buffer) 651 (not (buffer-name nnbabyl-mbox-buffer))) 652 (nnbabyl-read-mbox)) 653 (set-buffer nnbabyl-mbox-buffer) 654 (goto-char (point-min)) 655 (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t) 656 (if (intern-soft (setq id (match-string 1)) idents) 657 (progn 658 (delete-region (progn (beginning-of-line) (point)) 659 (progn (forward-line 1) (point))) 660 (nnheader-message 7 "Moving %s..." id) 661 (nnbabyl-save-mail 662 (nnmail-article-group 'nnbabyl-active-number))) 663 (intern id idents))) 664 (when (buffer-modified-p (current-buffer)) 665 (save-buffer)) 666 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 667 (nnheader-message 5 "")))) 668 669(provide 'nnbabyl) 670 671;;; arch-tag: aa7ddedb-8c07-4c0e-beb0-58e795c2b81b 672;;; nnbabyl.el ends here 673