1;;; nnmh.el --- mhspool access for Gnus 2 3;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 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;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>. 30;; For an overview of what the interface functions do, please see the 31;; Gnus sources. 32 33;;; Code: 34 35(require 'nnheader) 36(require 'nnmail) 37(require 'gnus-start) 38(require 'nnoo) 39(eval-when-compile (require 'cl)) 40 41(nnoo-declare nnmh) 42 43(defvoo nnmh-directory message-directory 44 "Mail spool directory.") 45 46(defvoo nnmh-get-new-mail t 47 "If non-nil, nnmh will check the incoming mail file and split the mail.") 48 49(defvoo nnmh-prepare-save-mail-hook nil 50 "Hook run narrowed to an article before saving.") 51 52(defvoo nnmh-be-safe nil 53 "If non-nil, nnmh will check all articles to make sure whether they are new or not. 54Go through the .nnmh-articles file and compare with the actual 55articles in this folder. The articles that are \"new\" will be marked 56as unread by Gnus.") 57 58 59 60(defconst nnmh-version "nnmh 1.0" 61 "nnmh version.") 62 63(defvoo nnmh-current-directory nil 64 "Current news group directory.") 65 66(defvoo nnmh-status-string "") 67(defvoo nnmh-group-alist nil) 68;; Don't even think about setting this variable. It does not exist. 69;; Forget about it. Uh-huh. Nope. Nobody here. It's only bound 70;; dynamically by certain functions in nndraft. 71(defvar nnmh-allow-delete-final nil) 72 73 74 75;;; Interface functions. 76 77(nnoo-define-basics nnmh) 78 79(deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old) 80 (save-excursion 81 (set-buffer nntp-server-buffer) 82 (erase-buffer) 83 (let* ((file nil) 84 (number (length articles)) 85 (large (and (numberp nnmail-large-newsgroup) 86 (> number nnmail-large-newsgroup))) 87 (count 0) 88 (file-name-coding-system nnmail-pathname-coding-system) 89 beg article) 90 (nnmh-possibly-change-directory newsgroup server) 91 ;; We don't support fetching by Message-ID. 92 (if (stringp (car articles)) 93 'headers 94 (while articles 95 (when (and (file-exists-p 96 (setq file (concat (file-name-as-directory 97 nnmh-current-directory) 98 (int-to-string 99 (setq article (pop articles)))))) 100 (not (file-directory-p file))) 101 (insert (format "221 %d Article retrieved.\n" article)) 102 (setq beg (point)) 103 (nnheader-insert-head file) 104 (goto-char beg) 105 (if (search-forward "\n\n" nil t) 106 (forward-char -1) 107 (goto-char (point-max)) 108 (insert "\n\n")) 109 (insert ".\n") 110 (delete-region (point) (point-max))) 111 (setq count (1+ count)) 112 113 (and large 114 (zerop (% count 20)) 115 (nnheader-message 5 "nnmh: Receiving headers... %d%%" 116 (/ (* count 100) number)))) 117 118 (when large 119 (nnheader-message 5 "nnmh: Receiving headers...done")) 120 121 (nnheader-fold-continuation-lines) 122 'headers)))) 123 124(deffoo nnmh-open-server (server &optional defs) 125 (nnoo-change-server 'nnmh server defs) 126 (when (not (file-exists-p nnmh-directory)) 127 (condition-case () 128 (make-directory nnmh-directory t) 129 (error t))) 130 (cond 131 ((not (file-exists-p nnmh-directory)) 132 (nnmh-close-server) 133 (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory)) 134 ((not (file-directory-p (file-truename nnmh-directory))) 135 (nnmh-close-server) 136 (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory)) 137 (t 138 (nnheader-report 'nnmh "Opened server %s using directory %s" 139 server nnmh-directory) 140 t))) 141 142(deffoo nnmh-request-article (id &optional newsgroup server buffer) 143 (nnmh-possibly-change-directory newsgroup server) 144 (let ((file (if (stringp id) 145 nil 146 (concat nnmh-current-directory (int-to-string id)))) 147 (file-name-coding-system nnmail-pathname-coding-system) 148 (nntp-server-buffer (or buffer nntp-server-buffer))) 149 (and (stringp file) 150 (file-exists-p file) 151 (not (file-directory-p file)) 152 (save-excursion (nnmail-find-file file)) 153 (string-to-number (file-name-nondirectory file))))) 154 155(deffoo nnmh-request-group (group &optional server dont-check) 156 (nnheader-init-server-buffer) 157 (nnmh-possibly-change-directory group server) 158 (let ((pathname (nnmail-group-pathname group nnmh-directory)) 159 (file-name-coding-system nnmail-pathname-coding-system) 160 dir) 161 (cond 162 ((not (file-directory-p pathname)) 163 (nnheader-report 164 'nnmh "Can't select group (no such directory): %s" group)) 165 (t 166 (setq nnmh-current-directory pathname) 167 (and nnmh-get-new-mail 168 nnmh-be-safe 169 (nnmh-update-gnus-unreads group)) 170 (cond 171 (dont-check 172 (nnheader-report 'nnmh "Selected group %s" group) 173 t) 174 (t 175 ;; Re-scan the directory if it's on a foreign system. 176 (nnheader-re-read-dir pathname) 177 (setq dir 178 (sort 179 (mapcar (lambda (name) (string-to-number name)) 180 (directory-files pathname nil "^[0-9]+$" t)) 181 '<)) 182 (cond 183 (dir 184 (setq nnmh-group-alist 185 (delq (assoc group nnmh-group-alist) nnmh-group-alist)) 186 (push (list group (cons (car dir) (car (last dir)))) 187 nnmh-group-alist) 188 (nnheader-report 'nnmh "Selected group %s" group) 189 (nnheader-insert 190 "211 %d %d %d %s\n" (length dir) (car dir) 191 (car (last dir)) group)) 192 (t 193 (nnheader-report 'nnmh "Empty group %s" group) 194 (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) 195 196(deffoo nnmh-request-scan (&optional group server) 197 (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) 198 199(deffoo nnmh-request-list (&optional server dir) 200 (nnheader-insert "") 201 (nnmh-possibly-change-directory nil server) 202 (let ((file-name-coding-system nnmail-pathname-coding-system) 203 (nnmh-toplev 204 (file-truename (or dir (file-name-as-directory nnmh-directory))))) 205 (nnmh-request-list-1 nnmh-toplev)) 206 (setq nnmh-group-alist (nnmail-get-active)) 207 t) 208 209(defvar nnmh-toplev) 210(defun nnmh-request-list-1 (dir) 211 (setq dir (expand-file-name dir)) 212 ;; Recurse down all directories. 213 (let ((dirs (and (file-readable-p dir) 214 (> (nth 1 (file-attributes (file-chase-links dir))) 2) 215 (nnheader-directory-files dir t nil t))) 216 rdir) 217 ;; Recurse down directories. 218 (while (setq rdir (pop dirs)) 219 (when (and (file-directory-p rdir) 220 (file-readable-p rdir) 221 (not (equal (file-truename rdir) 222 (file-truename dir)))) 223 (nnmh-request-list-1 rdir)))) 224 ;; For each directory, generate an active file line. 225 (unless (string= (expand-file-name nnmh-toplev) dir) 226 (let ((files (mapcar 227 (lambda (name) (string-to-number name)) 228 (directory-files dir nil "^[0-9]+$" t)))) 229 (when files 230 (save-excursion 231 (set-buffer nntp-server-buffer) 232 (goto-char (point-max)) 233 (insert 234 (format 235 "%s %.0f %.0f y\n" 236 (progn 237 (string-match 238 (regexp-quote 239 (file-truename (file-name-as-directory 240 (expand-file-name nnmh-toplev)))) 241 dir) 242 (mm-string-as-multibyte 243 (mm-encode-coding-string 244 (nnheader-replace-chars-in-string 245 (substring dir (match-end 0)) 246 ?/ ?.) 247 nnmail-pathname-coding-system))) 248 (apply 'max files) 249 (apply 'min files))))))) 250 t) 251 252(deffoo nnmh-request-newgroups (date &optional server) 253 (nnmh-request-list server)) 254 255(deffoo nnmh-request-expire-articles (articles newsgroup 256 &optional server force) 257 (nnmh-possibly-change-directory newsgroup server) 258 (let* ((is-old t) 259 article rest mod-time) 260 (nnheader-init-server-buffer) 261 262 (while (and articles is-old) 263 (setq article (concat nnmh-current-directory 264 (int-to-string (car articles)))) 265 (when (setq mod-time (nth 5 (file-attributes article))) 266 (if (and (nnmh-deletable-article-p newsgroup (car articles)) 267 (setq is-old 268 (nnmail-expired-article-p newsgroup mod-time force))) 269 (progn 270 ;; Allow a special target group. -- jcn 271 (unless (eq nnmail-expiry-target 'delete) 272 (with-temp-buffer 273 (nnmh-request-article (car articles) 274 newsgroup server (current-buffer)) 275 (nnmail-expiry-target-group 276 nnmail-expiry-target newsgroup))) 277 (nnheader-message 5 "Deleting article %s in %s..." 278 article newsgroup) 279 (condition-case () 280 (funcall nnmail-delete-file-function article) 281 (file-error 282 (nnheader-message 1 "Couldn't delete article %s in %s" 283 article newsgroup) 284 (push (car articles) rest)))) 285 (push (car articles) rest))) 286 (setq articles (cdr articles))) 287 (nnheader-message 5 "") 288 (nconc rest articles))) 289 290(deffoo nnmh-close-group (group &optional server) 291 t) 292 293(deffoo nnmh-request-move-article (article group server 294 accept-form &optional last) 295 (let ((buf (get-buffer-create " *nnmh move*")) 296 result) 297 (and 298 (nnmh-deletable-article-p group article) 299 (nnmh-request-article article group server) 300 (save-excursion 301 (set-buffer buf) 302 (erase-buffer) 303 (insert-buffer-substring nntp-server-buffer) 304 (setq result (eval accept-form)) 305 (kill-buffer (current-buffer)) 306 result) 307 (progn 308 (nnmh-possibly-change-directory group server) 309 (condition-case () 310 (funcall nnmail-delete-file-function 311 (concat nnmh-current-directory (int-to-string article))) 312 (file-error nil)))) 313 result)) 314 315(deffoo nnmh-request-accept-article (group &optional server last noinsert) 316 (nnmh-possibly-change-directory group server) 317 (nnmail-check-syntax) 318 (when nnmail-cache-accepted-message-ids 319 (nnmail-cache-insert (nnmail-fetch-field "message-id") 320 group 321 (nnmail-fetch-field "subject") 322 (nnmail-fetch-field "from"))) 323 (nnheader-init-server-buffer) 324 (prog1 325 (if (stringp group) 326 (if noinsert 327 (nnmh-active-number group) 328 (car (nnmh-save-mail 329 (list (cons group (nnmh-active-number group))) 330 noinsert))) 331 (let ((res (nnmail-article-group 'nnmh-active-number))) 332 (if (and (null res) 333 (yes-or-no-p "Moved to `junk' group; delete article? ")) 334 'junk 335 (car (nnmh-save-mail res noinsert))))) 336 (when (and last nnmail-cache-accepted-message-ids) 337 (nnmail-cache-close)))) 338 339(deffoo nnmh-request-replace-article (article group buffer) 340 (nnmh-possibly-change-directory group) 341 (save-excursion 342 (set-buffer buffer) 343 (nnmh-possibly-create-directory group) 344 (ignore-errors 345 (nnmail-write-region 346 (point-min) (point-max) 347 (concat nnmh-current-directory (int-to-string article)) 348 nil (if (nnheader-be-verbose 5) nil 'nomesg)) 349 t))) 350 351(deffoo nnmh-request-create-group (group &optional server args) 352 (nnheader-init-server-buffer) 353 (unless (assoc group nnmh-group-alist) 354 (let (active) 355 (push (list group (setq active (cons 1 0))) 356 nnmh-group-alist) 357 (nnmh-possibly-create-directory group) 358 (nnmh-possibly-change-directory group server) 359 (let ((articles (mapcar 360 (lambda (file) 361 (string-to-number file)) 362 (directory-files 363 nnmh-current-directory nil "^[0-9]+$")))) 364 (when articles 365 (setcar active (apply 'min articles)) 366 (setcdr active (apply 'max articles)))))) 367 t) 368 369(deffoo nnmh-request-delete-group (group &optional force server) 370 (nnmh-possibly-change-directory group server) 371 ;; Delete all articles in GROUP. 372 (if (not force) 373 () ; Don't delete the articles. 374 (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$"))) 375 (while articles 376 (when (file-writable-p (car articles)) 377 (nnheader-message 5 "Deleting article %s in %s..." 378 (car articles) group) 379 (funcall nnmail-delete-file-function (car articles))) 380 (setq articles (cdr articles)))) 381 ;; Try to delete the directory itself. 382 (ignore-errors 383 (delete-directory nnmh-current-directory))) 384 ;; Remove the group from all structures. 385 (setq nnmh-group-alist 386 (delq (assoc group nnmh-group-alist) nnmh-group-alist) 387 nnmh-current-directory nil) 388 t) 389 390(deffoo nnmh-request-rename-group (group new-name &optional server) 391 (nnmh-possibly-change-directory group server) 392 (let ((new-dir (nnmail-group-pathname new-name nnmh-directory)) 393 (old-dir (nnmail-group-pathname group nnmh-directory))) 394 (when (ignore-errors 395 (make-directory new-dir t) 396 t) 397 ;; We move the articles file by file instead of renaming 398 ;; the directory -- there may be subgroups in this group. 399 ;; One might be more clever, I guess. 400 (let ((files (nnheader-article-to-file-alist old-dir))) 401 (while files 402 (rename-file 403 (concat old-dir (cdar files)) 404 (concat new-dir (cdar files))) 405 (pop files))) 406 (when (<= (length (directory-files old-dir)) 2) 407 (ignore-errors 408 (delete-directory old-dir))) 409 ;; That went ok, so we change the internal structures. 410 (let ((entry (assoc group nnmh-group-alist))) 411 (when entry 412 (setcar entry new-name)) 413 (setq nnmh-current-directory nil) 414 t)))) 415 416(nnoo-define-skeleton nnmh) 417 418 419;;; Internal functions. 420 421(defun nnmh-possibly-change-directory (newsgroup &optional server) 422 (when (and server 423 (not (nnmh-server-opened server))) 424 (nnmh-open-server server)) 425 (when newsgroup 426 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) 427 (file-name-coding-system nnmail-pathname-coding-system)) 428 (if (file-directory-p pathname) 429 (setq nnmh-current-directory pathname) 430 (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))))) 431 432(defun nnmh-possibly-create-directory (group) 433 (let (dir dirs) 434 (setq dir (nnmail-group-pathname group nnmh-directory)) 435 (while (not (file-directory-p dir)) 436 (push dir dirs) 437 (setq dir (file-name-directory (directory-file-name dir)))) 438 (while dirs 439 (when (make-directory (directory-file-name (car dirs))) 440 (error "Could not create directory %s" (car dirs))) 441 (nnheader-message 5 "Creating mail directory %s" (car dirs)) 442 (setq dirs (cdr dirs))))) 443 444(defun nnmh-save-mail (group-art &optional noinsert) 445 "Called narrowed to an article." 446 (unless noinsert 447 (nnmail-insert-lines) 448 (nnmail-insert-xref group-art)) 449 (run-hooks 'nnmail-prepare-save-mail-hook) 450 (run-hooks 'nnmh-prepare-save-mail-hook) 451 (goto-char (point-min)) 452 (while (looking-at "From ") 453 (replace-match "X-From-Line: ") 454 (forward-line 1)) 455 ;; We save the article in all the newsgroups it belongs in. 456 (let ((ga group-art) 457 first) 458 (while ga 459 (nnmh-possibly-create-directory (caar ga)) 460 (let ((file (concat (nnmail-group-pathname 461 (caar ga) nnmh-directory) 462 (int-to-string (cdar ga))))) 463 (if first 464 ;; It was already saved, so we just make a hard link. 465 (funcall nnmail-crosspost-link-function first file t) 466 ;; Save the article. 467 (nnmail-write-region (point-min) (point-max) file nil nil) 468 (setq first file))) 469 (setq ga (cdr ga)))) 470 group-art) 471 472(defun nnmh-active-number (group) 473 "Compute the next article number in GROUP." 474 (let ((active (cadr (assoc group nnmh-group-alist))) 475 (dir (nnmail-group-pathname group nnmh-directory)) 476 (file-name-coding-system nnmail-pathname-coding-system) 477 file) 478 (unless active 479 ;; The group wasn't known to nnmh, so we just create an active 480 ;; entry for it. 481 (setq active (cons 1 0)) 482 (push (list group active) nnmh-group-alist) 483 (unless (file-exists-p dir) 484 (gnus-make-directory dir)) 485 ;; Find the highest number in the group. 486 (let ((files (sort 487 (mapcar 488 (lambda (f) 489 (string-to-number f)) 490 (directory-files dir nil "^[0-9]+$")) 491 '>))) 492 (when files 493 (setcdr active (car files))))) 494 (setcdr active (1+ (cdr active))) 495 (while (or 496 ;; See whether the file exists... 497 (file-exists-p 498 (setq file (concat (nnmail-group-pathname group nnmh-directory) 499 (int-to-string (cdr active))))) 500 ;; ... or there is a buffer that will make that file exist 501 ;; in the future. 502 (get-file-buffer file)) 503 ;; Skip past that file. 504 (setcdr active (1+ (cdr active)))) 505 (cdr active))) 506 507(defun nnmh-update-gnus-unreads (group) 508 ;; Go through the .nnmh-articles file and compare with the actual 509 ;; articles in this folder. The articles that are "new" will be 510 ;; marked as unread by Gnus. 511 (let* ((dir nnmh-current-directory) 512 (files (sort (mapcar (function (lambda (name) (string-to-number name))) 513 (directory-files nnmh-current-directory 514 nil "^[0-9]+$" t)) 515 '<)) 516 (nnmh-file (concat dir ".nnmh-articles")) 517 new articles) 518 ;; Load the .nnmh-articles file. 519 (when (file-exists-p nnmh-file) 520 (setq articles 521 (let (nnmh-newsgroup-articles) 522 (ignore-errors (load nnmh-file nil t t)) 523 nnmh-newsgroup-articles))) 524 ;; Add all new articles to the `new' list. 525 (let ((art files)) 526 (while art 527 (unless (assq (car art) articles) 528 (push (car art) new)) 529 (setq art (cdr art)))) 530 ;; Remove all deleted articles. 531 (let ((art articles)) 532 (while art 533 (unless (memq (caar art) files) 534 (setq articles (delq (car art) articles))) 535 (setq art (cdr art)))) 536 ;; Check whether the articles really are the ones that Gnus thinks 537 ;; they are by looking at the time-stamps. 538 (let ((arts articles) 539 art) 540 (while (setq art (pop arts)) 541 (when (not (equal 542 (nth 5 (file-attributes 543 (concat dir (int-to-string (car art))))) 544 (cdr art))) 545 (setq articles (delq art articles)) 546 (push (car art) new)))) 547 ;; Go through all the new articles and add them, and their 548 ;; time-stamps, to the list. 549 (setq articles 550 (nconc articles 551 (mapcar 552 (lambda (art) 553 (cons art 554 (nth 5 (file-attributes 555 (concat dir (int-to-string art)))))) 556 new))) 557 ;; Make Gnus mark all new articles as unread. 558 (when new 559 (gnus-make-articles-unread 560 (gnus-group-prefixed-name group (list 'nnmh "")) 561 (setq new (sort new '<)))) 562 ;; Sort the article list with highest numbers first. 563 (setq articles (sort articles (lambda (art1 art2) 564 (> (car art1) (car art2))))) 565 ;; Finally write this list back to the .nnmh-articles file. 566 (with-temp-file nnmh-file 567 (insert ";; Gnus article active file for " group "\n\n") 568 (insert "(setq nnmh-newsgroup-articles '") 569 (gnus-prin1 articles) 570 (insert ")\n")))) 571 572(defun nnmh-deletable-article-p (group article) 573 "Say whether ARTICLE in GROUP can be deleted." 574 (let ((path (concat nnmh-current-directory (int-to-string article)))) 575 ;; Writable. 576 (and (file-writable-p path) 577 (or 578 ;; We can never delete the last article in the group. 579 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) 580 article)) 581 ;; Well, we can. 582 nnmh-allow-delete-final)))) 583 584(provide 'nnmh) 585 586;;; arch-tag: 36c12a98-3bad-44b3-9953-628078ef0e04 587;;; nnmh.el ends here 588