nnbabyl.el 21 KB

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