X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnmh.el;h=7bc52211a3c426f50aad2c1cab3357ff1c86365e;hp=1229925426e3add1fdbee0018d23ae2f576e6a2f;hb=8b4ec91dbe121dff869c38366d31c93dab9b9e86;hpb=673b65f6cb73be1e5846b4bd999d9ee08ef3e785 diff --git a/lisp/nnmh.el b/lisp/nnmh.el index 122992542..7bc52211a 100644 --- a/lisp/nnmh.el +++ b/lisp/nnmh.el @@ -1,8 +1,10 @@ ;;; nnmh.el --- mhspool access for Gnus -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen -;; Masanobu UMEDA +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003 +;; Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Masanobu UMEDA ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -18,140 +20,131 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; Based on nnspool.el by Masanobu UMEDA . ;; For an overview of what the interface functions do, please see the -;; Gnus sources. +;; Gnus sources. ;;; Code: (require 'nnheader) -(require 'rmail) (require 'nnmail) -(require 'gnus) +(require 'gnus-start) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnmh) -(defvar nnmh-directory "~/Mail/" - "*Mail spool directory.") +(defvoo nnmh-directory message-directory + "Mail spool directory.") -(defvar nnmh-get-new-mail t - "*If non-nil, nnmh will check the incoming mail file and split the mail.") +(defvoo nnmh-get-new-mail t + "If non-nil, nnmh will check the incoming mail file and split the mail.") -(defvar nnmh-prepare-save-mail-hook nil - "*Hook run narrowed to an article before saving.") +(defvoo nnmh-prepare-save-mail-hook nil + "Hook run narrowed to an article before saving.") -(defvar nnmh-be-safe nil - "*If non-nil, nnmh will check all articles to make sure whether they are new or not.") +(defvoo nnmh-be-safe nil + "If non-nil, nnmh will check all articles to make sure whether they are new or not. +Go through the .nnmh-articles file and compare with the actual +articles in this folder. The articles that are \"new\" will be marked +as unread by Gnus.") (defconst nnmh-version "nnmh 1.0" "nnmh version.") -(defvar nnmh-current-directory nil +(defvoo nnmh-current-directory nil "Current news group directory.") -(defvar nnmh-status-string "") -(defvar nnmh-group-alist nil) - - - -(defvar nnmh-current-server nil) -(defvar nnmh-server-alist nil) -(defvar nnmh-server-variables - (list - (list 'nnmh-directory nnmh-directory) - (list 'nnmh-get-new-mail nnmh-get-new-mail) - '(nnmh-current-directory nil) - '(nnmh-status-string "") - '(nnmh-group-alist))) +(defvoo nnmh-status-string "") +(defvoo nnmh-group-alist nil) +;; Don't even think about setting this variable. It does not exist. +;; Forget about it. Uh-huh. Nope. Nobody here. It's only bound +;; dynamically by certain functions in nndraft. +(defvar nnmh-allow-delete-final nil) ;;; Interface functions. -(defun nnmh-retrieve-headers (sequence &optional newsgroup server fetch-old) +(nnoo-define-basics nnmh) + +(deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (let* ((file nil) - (number (length sequence)) + (number (length articles)) (large (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup))) (count 0) + (file-name-coding-system nnmail-pathname-coding-system) beg article) - (nnmh-possibly-change-directory newsgroup) - (if (stringp (car sequence)) + (nnmh-possibly-change-directory newsgroup server) + ;; We don't support fetching by Message-ID. + (if (stringp (car articles)) 'headers - (while sequence - (setq article (car sequence)) - (setq file - (concat nnmh-current-directory (int-to-string article))) - (if (and (file-exists-p file) - (not (file-directory-p file))) - (progn - (insert (format "221 %d Article retrieved.\n" article)) - (setq beg (point)) - (nnheader-insert-head file) - (goto-char beg) - (if (search-forward "\n\n" nil t) - (forward-char -1) - (goto-char (point-max)) - (insert "\n\n")) - (insert ".\n") - (delete-region (point) (point-max)))) - (setq sequence (cdr sequence)) + (while articles + (when (and (file-exists-p + (setq file (concat (file-name-as-directory + nnmh-current-directory) + (int-to-string + (setq article (pop articles)))))) + (not (file-directory-p file))) + (insert (format "221 %d Article retrieved.\n" article)) + (setq beg (point)) + (nnheader-insert-head file) + (goto-char beg) + (if (search-forward "\n\n" nil t) + (forward-char -1) + (goto-char (point-max)) + (insert "\n\n")) + (insert ".\n") + (delete-region (point) (point-max))) (setq count (1+ count)) (and large (zerop (% count 20)) - (message "nnmh: Receiving headers... %d%%" - (/ (* count 100) number)))) + (nnheader-message 5 "nnmh: Receiving headers... %d%%" + (/ (* count 100) number)))) - (and large (message "nnmh: Receiving headers...done")) + (when large + (nnheader-message 5 "nnmh: Receiving headers...done")) - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) + (nnheader-fold-continuation-lines) 'headers)))) -(defun nnmh-open-server (server &optional defs) - (nnheader-init-server-buffer) - (if (equal server nnmh-current-server) - t - (if nnmh-current-server - (setq nnmh-server-alist - (cons (list nnmh-current-server - (nnheader-save-variables nnmh-server-variables)) - nnmh-server-alist))) - (let ((state (assoc server nnmh-server-alist))) - (if state - (progn - (nnheader-restore-variables (nth 1 state)) - (setq nnmh-server-alist (delq state nnmh-server-alist))) - (nnheader-set-init-variables nnmh-server-variables defs))) - (setq nnmh-current-server server))) - -(defun nnmh-close-server (&optional server) - t) - -(defun nnmh-server-opened (&optional server) - (and (equal server nnmh-current-server) - nntp-server-buffer - (buffer-name nntp-server-buffer))) - -(defun nnmh-status-message (&optional server) - nnmh-status-string) - -(defun nnmh-request-article (id &optional newsgroup server buffer) - (nnmh-possibly-change-directory newsgroup) +(deffoo nnmh-open-server (server &optional defs) + (nnoo-change-server 'nnmh server defs) + (when (not (file-exists-p nnmh-directory)) + (condition-case () + (make-directory nnmh-directory t) + (error t))) + (cond + ((not (file-exists-p nnmh-directory)) + (nnmh-close-server) + (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory)) + ((not (file-directory-p (file-truename nnmh-directory))) + (nnmh-close-server) + (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory)) + (t + (nnheader-report 'nnmh "Opened server %s using directory %s" + server nnmh-directory) + t))) + +(deffoo nnmh-request-article (id &optional newsgroup server buffer) + (nnmh-possibly-change-directory newsgroup server) (let ((file (if (stringp id) nil (concat nnmh-current-directory (int-to-string id)))) + (file-name-coding-system nnmail-pathname-coding-system) (nntp-server-buffer (or buffer nntp-server-buffer))) (and (stringp file) (file-exists-p file) @@ -159,378 +152,430 @@ (save-excursion (nnmail-find-file file)) (string-to-int (file-name-nondirectory file))))) -(defun nnmh-request-group (group &optional server dont-check) - (let ((pathname (nnmh-article-pathname group nnmh-directory)) +(deffoo nnmh-request-group (group &optional server dont-check) + (nnheader-init-server-buffer) + (nnmh-possibly-change-directory group server) + (let ((pathname (nnmail-group-pathname group nnmh-directory)) + (file-name-coding-system nnmail-pathname-coding-system) dir) - (if (file-directory-p pathname) - (progn - (setq nnmh-current-directory pathname) - (and nnmh-get-new-mail - nnmh-be-safe - (nnmh-update-gnus-unreads group)) - (or dont-check - (progn - (setq dir - (sort - (mapcar - (function - (lambda (name) - (string-to-int name))) - (directory-files pathname nil "^[0-9]+$" t)) - '<)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (if dir - (insert (format "211 %d %d %d %s\n" (length dir) - (car dir) - (progn (while (cdr dir) - (setq dir (cdr dir))) - (car dir)) - group)) - (insert (format "211 0 1 0 %s\n" group)))))) - t) - (setq nnmh-status-string "No such group") - nil))) - -(defun nnmh-request-scan (&optional group server) - (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) - -(defun nnmh-request-list (&optional server dir) - (or dir - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (setq dir (file-truename (file-name-as-directory nnmh-directory))))) + (cond + ((not (file-directory-p pathname)) + (nnheader-report + 'nnmh "Can't select group (no such directory): %s" group)) + (t + (setq nnmh-current-directory pathname) + (and nnmh-get-new-mail + nnmh-be-safe + (nnmh-update-gnus-unreads group)) + (cond + (dont-check + (nnheader-report 'nnmh "Selected group %s" group) + t) + (t + ;; Re-scan the directory if it's on a foreign system. + (nnheader-re-read-dir pathname) + (setq dir + (sort + (mapcar 'string-to-int + (directory-files pathname nil "^[0-9]+$" t)) + '<)) + (cond + (dir + (setq nnmh-group-alist + (delq (assoc group nnmh-group-alist) nnmh-group-alist)) + (push (list group (cons (car dir) (car (last dir)))) + nnmh-group-alist) + (nnheader-report 'nnmh "Selected group %s" group) + (nnheader-insert + "211 %d %d %d %s\n" (length dir) (car dir) + (car (last dir)) group)) + (t + (nnheader-report 'nnmh "Empty group %s" group) + (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) + +(deffoo nnmh-request-scan (&optional group server) + (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) + +(deffoo nnmh-request-list (&optional server dir) + (nnheader-insert "") + (nnmh-possibly-change-directory nil server) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (nnmh-toplev + (file-truename (or dir (file-name-as-directory nnmh-directory))))) + (nnmh-request-list-1 nnmh-toplev)) + (setq nnmh-group-alist (nnmail-get-active)) + t) + +(defvar nnmh-toplev) +(defun nnmh-request-list-1 (dir) (setq dir (expand-file-name dir)) ;; Recurse down all directories. (let ((dirs (and (file-readable-p dir) - (> (nth 1 (file-attributes (file-chase-links dir))) 2) - (directory-files dir t nil t)))) - (while dirs - (if (and (not (string-match "/\\.\\.?$" (car dirs))) - (file-directory-p (car dirs)) - (file-readable-p (car dirs))) - (nnmh-request-list nil (car dirs))) - (setq dirs (cdr dirs)))) + (nnheader-directory-files dir t nil t))) + rdir) + ;; Recurse down directories. + (while (setq rdir (pop dirs)) + (when (and (file-directory-p rdir) + (file-readable-p rdir) + (not (equal (file-truename rdir) + (file-truename dir)))) + (nnmh-request-list-1 rdir)))) ;; For each directory, generate an active file line. - (if (not (string= (expand-file-name nnmh-directory) dir)) - (let ((files (mapcar - (lambda (name) (string-to-int name)) - (directory-files dir nil "^[0-9]+$" t)))) - (if (null files) - () - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-max)) - (insert - (format - "%s %d %d y\n" - (progn - (string-match (file-name-as-directory - (expand-file-name nnmh-directory)) dir) - (nnmail-replace-chars-in-string - (substring dir (match-end 0)) ?/ ?.)) - (apply (function max) files) - (apply (function min) files))))))) - (setq nnmh-group-alist (nnmail-get-active)) + (unless (string= (expand-file-name nnmh-toplev) dir) + (let ((files (mapcar 'string-to-int + (directory-files dir nil "^[0-9]+$" t)))) + (when files + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-max)) + (insert + (format + "%s %.0f %.0f y\n" + (progn + (string-match + (regexp-quote + (file-truename (file-name-as-directory + (expand-file-name nnmh-toplev)))) + dir) + (mm-string-as-multibyte + (mm-encode-coding-string + (nnheader-replace-chars-in-string + (substring dir (match-end 0)) + ?/ ?.) + nnmail-pathname-coding-system))) + (apply 'max files) + (apply 'min files))))))) t) -(defun nnmh-request-newgroups (date &optional server) +(deffoo nnmh-request-newgroups (date &optional server) (nnmh-request-list server)) -(defun nnmh-request-post (&optional server) - (mail-send-and-exit nil)) - -(defun nnmh-request-expire-articles (articles newsgroup &optional server force) - (nnmh-possibly-change-directory newsgroup) - (let* ((days (or (and nnmail-expiry-wait-function - (funcall nnmail-expiry-wait-function newsgroup)) - nnmail-expiry-wait)) - (active-articles - (mapcar - (function - (lambda (name) - (string-to-int name))) - (directory-files nnmh-current-directory nil "^[0-9]+$" t))) - (max-article (and active-articles (apply 'max active-articles))) - (is-old t) +(deffoo nnmh-request-expire-articles (articles newsgroup + &optional server force) + (nnmh-possibly-change-directory newsgroup server) + (let* ((is-old t) article rest mod-time) - (nnmail-activate 'nnmh) + (nnheader-init-server-buffer) (while (and articles is-old) - (setq article (concat nnmh-current-directory + (setq article (concat nnmh-current-directory (int-to-string (car articles)))) - (if (setq mod-time (nth 5 (file-attributes article))) - (if (and (or (not nnmail-keep-last-article) - (not max-article) - (not (= (car articles) max-article))) - (not (equal mod-time '(0 0))) - (or force - (setq is-old - (> (nnmail-days-between - (current-time-string) - (current-time-string mod-time)) - days)))) - (progn - (and gnus-verbose-backends - (message "Deleting article %s in %s..." - article newsgroup)) - (condition-case () - (funcall nnmail-delete-file-function article) - (file-error - (setq rest (cons (car articles) rest))))) - (setq rest (cons (car articles) rest)))) + (when (setq mod-time (nth 5 (file-attributes article))) + (if (and (nnmh-deletable-article-p newsgroup (car articles)) + (setq is-old + (nnmail-expired-article-p newsgroup mod-time force))) + (progn + ;; Allow a special target group. -- jcn + (unless (eq nnmail-expiry-target 'delete) + (with-temp-buffer + (nnmh-request-article (car articles) + newsgroup server (current-buffer)) + (nnmail-expiry-target-group + nnmail-expiry-target newsgroup))) + (nnheader-message 5 "Deleting article %s in %s..." + article newsgroup) + (condition-case () + (funcall nnmail-delete-file-function article) + (file-error + (nnheader-message 1 "Couldn't delete article %s in %s" + article newsgroup) + (push (car articles) rest)))) + (push (car articles) rest))) (setq articles (cdr articles))) - (message "") + (nnheader-message 5 "") (nconc rest articles))) -(defun nnmh-close-group (group &optional server) +(deffoo nnmh-close-group (group &optional server) t) -(defun nnmh-request-move-article - (article group server accept-form &optional last) +(deffoo nnmh-request-move-article (article group server accept-form + &optional last move-is-internal) (let ((buf (get-buffer-create " *nnmh move*")) result) - (and + (and + (nnmh-deletable-article-p group article) (nnmh-request-article article group server) (save-excursion (set-buffer buf) + (erase-buffer) (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form)) (kill-buffer (current-buffer)) result) - (condition-case () - (funcall nnmail-delete-file-function - (concat nnmh-current-directory (int-to-string article))) - (file-error nil))) + (progn + (nnmh-possibly-change-directory group server) + (condition-case () + (funcall nnmail-delete-file-function + (concat nnmh-current-directory (int-to-string article))) + (file-error nil)))) result)) -(defun nnmh-request-accept-article (group &optional last) - (if (stringp group) - (and - (nnmail-activate 'nnmh) - ;; We trick the choosing function into believing that only one - ;; group is availiable. - (let ((nnmail-split-methods (list (list group "")))) - (car (nnmh-save-mail)))) - (and - (nnmail-activate 'nnmh) - (car (nnmh-save-mail))))) - -(defun nnmh-request-replace-article (article group buffer) +(deffoo nnmh-request-accept-article (group &optional server last noinsert) + (nnmh-possibly-change-directory group server) + (nnmail-check-syntax) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) + (nnheader-init-server-buffer) + (prog1 + (if (stringp group) + (if noinsert + (nnmh-active-number group) + (car (nnmh-save-mail + (list (cons group (nnmh-active-number group))) + noinsert))) + (let ((res (nnmail-article-group 'nnmh-active-number))) + (if (and (null res) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + 'junk + (car (nnmh-save-mail res noinsert))))) + (when (and last nnmail-cache-accepted-message-ids) + (nnmail-cache-close)))) + +(deffoo nnmh-request-replace-article (article group buffer) (nnmh-possibly-change-directory group) (save-excursion (set-buffer buffer) (nnmh-possibly-create-directory group) - (condition-case () - (progn - (write-region (point-min) (point-max) - (concat nnmh-current-directory (int-to-string article)) - nil (if gnus-verbose-backends nil 'nomesg)) - t) - (error nil)))) - -(defun nnmh-request-create-group (group &optional server) - (nnmail-activate 'nnmh) - (or (assoc group nnmh-group-alist) - (let (active) - (setq nnmh-group-alist (cons (list group (setq active (cons 1 0))) - nnmh-group-alist)) - (nnmh-possibly-create-directory group) - (nnmh-possibly-change-directory group) - (let ((articles (mapcar - (lambda (file) - (string-to-int file)) - (directory-files - nnmh-current-directory nil "^[0-9]+$")))) - (and articles - (progn - (setcar active (apply 'min articles)) - (setcdr active (apply 'max articles))))))) + (ignore-errors + (nnmail-write-region + (point-min) (point-max) + (concat nnmh-current-directory (int-to-string article)) + nil (if (nnheader-be-verbose 5) nil 'nomesg)) + t))) + +(deffoo nnmh-request-create-group (group &optional server args) + (nnheader-init-server-buffer) + (unless (assoc group nnmh-group-alist) + (let (active) + (push (list group (setq active (cons 1 0))) + nnmh-group-alist) + (nnmh-possibly-create-directory group) + (nnmh-possibly-change-directory group server) + (let ((articles (mapcar 'string-to-int + (directory-files + nnmh-current-directory nil "^[0-9]+$")))) + (when articles + (setcar active (apply 'min articles)) + (setcdr active (apply 'max articles)))))) t) -(defun nnmh-request-delete-group (group &optional force server) - (nnmh-possibly-change-directory group) +(deffoo nnmh-request-delete-group (group &optional force server) + (nnmh-possibly-change-directory group server) ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$"))) - (while articles - (and (file-writable-p (car articles)) - (progn - (and gnus-verbose-backends - (message (message "Deleting article %s in %s..." - (car articles) group))) - (funcall nnmail-delete-file-function (car articles)))) + (while articles + (when (file-writable-p (car articles)) + (nnheader-message 5 "Deleting article %s in %s..." + (car articles) group) + (funcall nnmail-delete-file-function (car articles))) (setq articles (cdr articles)))) ;; Try to delete the directory itself. - (condition-case () - (delete-directory nnmh-current-directory) - (error nil))) + (ignore-errors + (delete-directory nnmh-current-directory))) ;; Remove the group from all structures. - (setq nnmh-group-alist + (setq nnmh-group-alist (delq (assoc group nnmh-group-alist) nnmh-group-alist) nnmh-current-directory nil) t) -(defun nnmh-request-rename-group (group new-name &optional server) - (nnmh-possibly-change-directory group) - ;; Rename directory. - (and (file-writable-p nnmh-current-directory) - (condition-case () - (progn - (rename-file - (directory-file-name nnmh-current-directory) - (directory-file-name - (nnmail-article-pathname new-name nnmh-directory))) - t) - (error nil)) - ;; That went ok, so we change the internal structures. - (let ((entry (assoc group nnmh-group-alist))) - (and entry (setcar entry new-name)) - (setq nnmh-current-directory nil) - t))) +(deffoo nnmh-request-rename-group (group new-name &optional server) + (nnmh-possibly-change-directory group server) + (let ((new-dir (nnmail-group-pathname new-name nnmh-directory)) + (old-dir (nnmail-group-pathname group nnmh-directory))) + (when (ignore-errors + (make-directory new-dir t) + t) + ;; We move the articles file by file instead of renaming + ;; the directory -- there may be subgroups in this group. + ;; One might be more clever, I guess. + (let ((files (nnheader-article-to-file-alist old-dir))) + (while files + (rename-file + (concat old-dir (cdar files)) + (concat new-dir (cdar files))) + (pop files))) + (when (<= (length (directory-files old-dir)) 2) + (ignore-errors + (delete-directory old-dir))) + ;; That went ok, so we change the internal structures. + (let ((entry (assoc group nnmh-group-alist))) + (when entry + (setcar entry new-name)) + (setq nnmh-current-directory nil) + t)))) + +(nnoo-define-skeleton nnmh) ;;; Internal functions. -(defun nnmh-possibly-change-directory (newsgroup) - (if newsgroup - (let ((pathname (nnmh-article-pathname newsgroup nnmh-directory))) - (if (file-directory-p pathname) - (setq nnmh-current-directory pathname) - (error "No such newsgroup: %s" newsgroup))))) +(defun nnmh-possibly-change-directory (newsgroup &optional server) + (when (and server + (not (nnmh-server-opened server))) + (nnmh-open-server server)) + (when newsgroup + (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) + (file-name-coding-system nnmail-pathname-coding-system)) + (if (file-directory-p pathname) + (setq nnmh-current-directory pathname) + (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))))) (defun nnmh-possibly-create-directory (group) (let (dir dirs) - (setq dir (nnmh-article-pathname group nnmh-directory)) + (setq dir (nnmail-group-pathname group nnmh-directory)) (while (not (file-directory-p dir)) - (setq dirs (cons dir dirs)) + (push dir dirs) (setq dir (file-name-directory (directory-file-name dir)))) (while dirs - (if (make-directory (directory-file-name (car dirs))) - (error "Could not create directory %s" (car dirs))) - (and gnus-verbose-backends - (message "Creating mail directory %s" (car dirs))) + (when (make-directory (directory-file-name (car dirs))) + (error "Could not create directory %s" (car dirs))) + (nnheader-message 5 "Creating mail directory %s" (car dirs)) (setq dirs (cdr dirs))))) - -(defun nnmh-save-mail () + +(defun nnmh-save-mail (group-art &optional noinsert) "Called narrowed to an article." - (let ((group-art (nreverse (nnmail-article-group 'nnmh-active-number)))) + (unless noinsert (nnmail-insert-lines) - (nnmail-insert-xref group-art) - (run-hooks 'nnmh-prepare-save-mail-hook) - (goto-char (point-min)) - (while (looking-at "From ") - (replace-match "X-From-Line: ") - (forward-line 1)) - ;; We save the article in all the newsgroups it belongs in. - (let ((ga group-art) - first) - (while ga - (nnmh-possibly-create-directory (car (car ga))) - (let ((file (concat (nnmh-article-pathname - (car (car ga)) nnmh-directory) - (int-to-string (cdr (car ga)))))) - (if first - ;; It was already saved, so we just make a hard link. - (add-name-to-file first file t) - ;; Save the article. - (write-region (point-min) (point-max) file nil nil) - (setq first file))) - (setq ga (cdr ga)))) - group-art)) + (nnmail-insert-xref group-art)) + (run-hooks 'nnmail-prepare-save-mail-hook) + (run-hooks 'nnmh-prepare-save-mail-hook) + (goto-char (point-min)) + (while (looking-at "From ") + (replace-match "X-From-Line: ") + (forward-line 1)) + ;; We save the article in all the newsgroups it belongs in. + (let ((ga group-art) + first) + (while ga + (nnmh-possibly-create-directory (caar ga)) + (let ((file (concat (nnmail-group-pathname + (caar ga) nnmh-directory) + (int-to-string (cdar ga))))) + (if first + ;; It was already saved, so we just make a hard link. + (funcall nnmail-crosspost-link-function first file t) + ;; Save the article. + (nnmail-write-region (point-min) (point-max) file nil nil) + (setq first file))) + (setq ga (cdr ga)))) + group-art) (defun nnmh-active-number (group) "Compute the next article number in GROUP." - (let ((active (car (cdr (assoc group nnmh-group-alist))))) - ;; The group wasn't known to nnmh, so we just create an active - ;; entry for it. - (or active - (progn - (setq active (cons 1 0)) - (setq nnmh-group-alist (cons (list group active) nnmh-group-alist)))) + (let ((active (cadr (assoc group nnmh-group-alist))) + (dir (nnmail-group-pathname group nnmh-directory)) + (file-name-coding-system nnmail-pathname-coding-system) + file) + (unless active + ;; The group wasn't known to nnmh, so we just create an active + ;; entry for it. + (setq active (cons 1 0)) + (push (list group active) nnmh-group-alist) + (unless (file-exists-p dir) + (gnus-make-directory dir)) + ;; Find the highest number in the group. + (let ((files (sort + (mapcar 'string-to-int + (directory-files dir nil "^[0-9]+$")) + '>))) + (when files + (setcdr active (car files))))) (setcdr active (1+ (cdr active))) - (while (file-exists-p - (concat (nnmh-article-pathname group nnmh-directory) - (int-to-string (cdr active)))) + (while (or + ;; See whether the file exists... + (file-exists-p + (setq file (concat (nnmail-group-pathname group nnmh-directory) + (int-to-string (cdr active))))) + ;; ... or there is a buffer that will make that file exist + ;; in the future. + (get-file-buffer file)) + ;; Skip past that file. (setcdr active (1+ (cdr active)))) (cdr active))) -(defun nnmh-article-pathname (group mail-dir) - "Make pathname for GROUP." - (let ((mail-dir (file-name-as-directory (expand-file-name mail-dir)))) - (if (file-directory-p (concat mail-dir group)) - (concat mail-dir group "/") - (concat mail-dir (nnmail-replace-chars-in-string group ?. ?/) "/")))) - (defun nnmh-update-gnus-unreads (group) ;; Go through the .nnmh-articles file and compare with the actual - ;; articles in this folder. The articles that are "new" will be + ;; articles in this folder. The articles that are "new" will be ;; marked as unread by Gnus. (let* ((dir nnmh-current-directory) - (files (sort (mapcar (function (lambda (name) (string-to-int name))) - (directory-files nnmh-current-directory - nil "^[0-9]+$" t)) '<)) + (files (sort (mapcar 'string-to-int + (directory-files nnmh-current-directory + nil "^[0-9]+$" t)) + '<)) (nnmh-file (concat dir ".nnmh-articles")) new articles) ;; Load the .nnmh-articles file. - (if (file-exists-p nnmh-file) - (setq articles - (let (nnmh-newsgroup-articles) - (condition-case nil (load nnmh-file nil t t) (error nil)) - nnmh-newsgroup-articles))) + (when (file-exists-p nnmh-file) + (setq articles + (let (nnmh-newsgroup-articles) + (ignore-errors (load nnmh-file nil t t)) + nnmh-newsgroup-articles))) ;; Add all new articles to the `new' list. (let ((art files)) (while art - (if (not (assq (car art) articles)) (setq new (cons (car art) new))) + (unless (assq (car art) articles) + (push (car art) new)) (setq art (cdr art)))) ;; Remove all deleted articles. (let ((art articles)) (while art - (if (not (memq (car (car art)) files)) - (setq articles (delq (car art) articles))) - (setq art (cdr art)))) - ;; Check whether the highest-numbered articles really are the ones - ;; that Gnus thinks they are by looking at the time-stamps. - (let ((art articles)) - (while (and art - (not (equal - (nth 5 (file-attributes - (concat dir (int-to-string (car (car art)))))) - (cdr (car art))))) - (setq articles (delq (car art) articles)) - (setq new (cons (car (car art)) new)) + (unless (memq (caar art) files) + (setq articles (delq (car art) articles))) (setq art (cdr art)))) + ;; Check whether the articles really are the ones that Gnus thinks + ;; they are by looking at the time-stamps. + (let ((arts articles) + art) + (while (setq art (pop arts)) + (when (not (equal + (nth 5 (file-attributes + (concat dir (int-to-string (car art))))) + (cdr art))) + (setq articles (delq art articles)) + (push (car art) new)))) ;; Go through all the new articles and add them, and their - ;; time-stamps to the list. - (let ((n new)) - (while n - (setq articles - (cons (cons - (car n) - (nth 5 (file-attributes - (concat dir (int-to-string (car n)))))) - articles)) - (setq n (cdr n)))) + ;; time-stamps, to the list. + (setq articles + (nconc articles + (mapcar + (lambda (art) + (cons art + (nth 5 (file-attributes + (concat dir (int-to-string art)))))) + new))) ;; Make Gnus mark all new articles as unread. - (or (zerop (length new)) - (gnus-make-articles-unread - (gnus-group-prefixed-name group (list 'nnmh "")) - (setq new (sort new '<)))) + (when new + (gnus-make-articles-unread + (gnus-group-prefixed-name group (list 'nnmh "")) + (setq new (sort new '<)))) ;; Sort the article list with highest numbers first. - (setq articles (sort articles (lambda (art1 art2) + (setq articles (sort articles (lambda (art1 art2) (> (car art1) (car art2))))) ;; Finally write this list back to the .nnmh-articles file. - (save-excursion - (set-buffer (get-buffer-create "*nnmh out*")) + (with-temp-file nnmh-file (insert ";; Gnus article active file for " group "\n\n") (insert "(setq nnmh-newsgroup-articles '") - (insert (prin1-to-string articles) ")\n") - (write-region (point-min) (point-max) nnmh-file nil 'nomesg) - (kill-buffer (current-buffer))))) + (gnus-prin1 articles) + (insert ")\n")))) + +(defun nnmh-deletable-article-p (group article) + "Say whether ARTICLE in GROUP can be deleted." + (let ((path (concat nnmh-current-directory (int-to-string article)))) + ;; Writable. + (and (file-writable-p path) + (or + ;; We can never delete the last article in the group. + (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) + article)) + ;; Well, we can. + nnmh-allow-delete-final)))) (provide 'nnmh) +;;; arch-tag: 36c12a98-3bad-44b3-9953-628078ef0e04 ;;; nnmh.el ends here