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