X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fnnmh.el;h=24829dd7acb629b0c19bf0abbaf3ab3b005bd40a;hb=191eb7a2bfcd2b268e24faa9933bc190db941cc4;hp=cda525c8d78a7cd7843b10b801927dcf82bd0184;hpb=2e3886a9dbfb821a8af27ead05316d64d097c122;p=elisp%2Fgnus.git- diff --git a/lisp/nnmh.el b/lisp/nnmh.el index cda525c..24829dd 100644 --- a/lisp/nnmh.el +++ b/lisp/nnmh.el @@ -1,8 +1,11 @@ ;;; nnmh.el --- mhspool access for Gnus -;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc. + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Masanobu UMEDA +;; Masanobu UMEDA +;; MORIOKA Tomohiko ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -30,25 +33,38 @@ ;;; Code: +(eval-when-compile (require 'cl)) +(eval-when-compile (require 'gnus-clfns)) + (require 'nnheader) (require 'nnmail) (require 'gnus-start) (require 'nnoo) -(eval-when-compile (require 'cl)) (nnoo-declare nnmh) (defvoo nnmh-directory message-directory - "*Mail spool directory.") + "*Mail spool directory. + +This variable is a virtual server slot. See the Gnus manual for details.") (defvoo nnmh-get-new-mail t - "*If non-nil, nnmh will check the incoming mail file and split the mail.") + "*If non-nil, nnmh will check the incoming mail file and split the mail. + +This variable is a virtual server slot. See the Gnus manual for details.") (defvoo nnmh-prepare-save-mail-hook nil - "*Hook run narrowed to an article before saving.") + "*Hook run narrowed to an article before saving. + +This variable is a virtual server slot. See the Gnus manual for details.") (defvoo nnmh-be-safe nil - "*If non-nil, nnmh will check all articles to make sure whether they are new or not.") + "*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. + +This variable is a virtual server slot. See the Gnus manual for details.") @@ -60,7 +76,10 @@ (defvoo nnmh-status-string "") (defvoo nnmh-group-alist nil) -(defvoo nnmh-allow-delete-final 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) @@ -77,7 +96,8 @@ (large (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup))) (count 0) - (pathname-coding-system 'binary) + (file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system) beg article) (nnmh-possibly-change-directory newsgroup server) ;; We don't support fetching by Message-ID. @@ -105,151 +125,13 @@ (and large (zerop (% count 20)) (nnheader-message 5 "nnmh: Receiving headers... %d%%" - (/ (* count 100) number)))) - - (when large - (nnheader-message 5 "nnmh: Receiving headers...done")) - - ;; (nnheader-fold-continuation-lines) - 'headers)))) - -(deffoo nnmh-retrieve-parsed-headers (articles - dependencies - &optional newsgroup server fetch-old - force-new) - (save-excursion - (set-buffer nntp-server-buffer) - (let* ((file nil) - (number (length articles)) - (large (and (numberp nnmail-large-newsgroup) - (> number nnmail-large-newsgroup))) - (count 0) - (pathname-coding-system 'binary) - (case-fold-search t) - ;;beg - article - headers header id end ref lines chars ctype in-reply-to - (cur (current-buffer))) - (nnmh-possibly-change-directory newsgroup server) - ;; We don't support fetching by Message-ID. - (if (stringp (car articles)) - 'headers - (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)) - (erase-buffer) - (nnheader-insert-head file) - (save-restriction - (std11-narrow-to-header) - (setq - header - (make-full-mail-header - ;; Number. - article - ;; Subject. - (or (std11-fetch-field "Subject") - "(none)") - ;; From. - (or (std11-fetch-field "From") - "(nobody)") - ;; Date. - (or (std11-fetch-field "Date") - "") - ;; Message-ID. - (progn - (goto-char (point-min)) - (setq id (if (re-search-forward - "^Message-ID: *\\(<[^\n\t> ]+>\\)" nil t) - ;; We do it this way to make sure the Message-ID - ;; is (somewhat) syntactically valid. - (buffer-substring (match-beginning 1) - (match-end 1)) - ;; If there was no message-id, we just fake one - ;; to make subsequent routines simpler. - (nnheader-generate-fake-message-id)))) - ;; References. - (progn - (goto-char (point-min)) - (if (search-forward "\nReferences: " nil t) - (progn - (setq end (point)) - (prog1 - (buffer-substring (match-end 0) (std11-field-end)) - (setq ref - (buffer-substring - (progn - ;; (end-of-line) - (search-backward ">" end t) - (1+ (point))) - (progn - (search-backward "<" end t) - (point)))))) - ;; Get the references from the in-reply-to header if there - ;; were no references and the in-reply-to header looks - ;; promising. - (if (and (search-forward "\nIn-Reply-To: " nil t) - (setq in-reply-to - (buffer-substring (match-end 0) - (std11-field-end))) - (string-match "<[^>]+>" in-reply-to)) - (let (ref2) - (setq ref (substring in-reply-to (match-beginning 0) - (match-end 0))) - (while (string-match "<[^>]+>" - in-reply-to (match-end 0)) - (setq ref2 - (substring in-reply-to (match-beginning 0) - (match-end 0))) - (when (> (length ref2) (length ref)) - (setq ref ref2))) - ref) - (setq ref nil)))) - ;; Chars. - (progn - (goto-char (point-min)) - (if (search-forward "\nChars: " nil t) - (if (numberp (setq chars (ignore-errors (read cur)))) - chars 0) - 0)) - ;; Lines. - (progn - (goto-char (point-min)) - (if (search-forward "\nLines: " nil t) - (if (numberp (setq lines (ignore-errors (read cur)))) - lines 0) - 0)) - ;; Xref. - (std11-fetch-field "Xref") - )) - (goto-char (point-min)) - (if (setq ctype (std11-fetch-field "Content-Type")) - (mime-entity-set-content-type-internal - header (mime-parse-Content-Type ctype))) - ) - (when (setq header - (gnus-dependencies-add-header - header dependencies force-new)) - (push header headers)) - ) - (setq count (1+ count)) - - (and large - (zerop (% count 20)) - (nnheader-message 5 "nnmh: Receiving headers... %d%%" (/ (* count 100) number)))) (when large (nnheader-message 5 "nnmh: Receiving headers...done")) - ;; (nnheader-fold-continuation-lines) - (cons 'header (nreverse headers)) - )))) + ;; (nnheader-fold-continuation-lines) + 'headers)))) (deffoo nnmh-open-server (server &optional defs) (nnoo-change-server 'nnmh server defs) @@ -274,7 +156,8 @@ (let ((file (if (stringp id) nil (concat nnmh-current-directory (int-to-string id)))) - (pathname-coding-system 'binary) + (file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system) (nntp-server-buffer (or buffer nntp-server-buffer))) (and (stringp file) (file-exists-p file) @@ -286,7 +169,8 @@ (nnheader-init-server-buffer) (nnmh-possibly-change-directory group server) (let ((pathname (nnmail-group-pathname group nnmh-directory)) - (pathname-coding-system 'binary) + (file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system) dir) (cond ((not (file-directory-p pathname)) @@ -309,16 +193,19 @@ (mapcar (lambda (name) (string-to-int name)) (directory-files pathname nil "^[0-9]+$" t)) '<)) - (cond - (dir - (nnheader-report 'nnmh "Selected group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (length dir) (car dir) - (progn (while (cdr dir) (setq dir (cdr dir))) (car dir)) - group)) - (t - (nnheader-report 'nnmh "Empty group %s" group) - (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) + (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)) @@ -326,7 +213,8 @@ (deffoo nnmh-request-list (&optional server dir) (nnheader-insert "") (nnmh-possibly-change-directory nil server) - (let ((pathname-coding-system 'binary) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system) (nnmh-toplev (file-truename (or dir (file-name-as-directory nnmh-directory))))) (nnmh-request-list-1 nnmh-toplev)) @@ -366,10 +254,12 @@ (file-truename (file-name-as-directory (expand-file-name nnmh-toplev)))) dir) - (nnheader-replace-chars-in-string - (decode-coding-string (substring dir (match-end 0)) - nnmail-pathname-coding-system) - ?/ ?.)) + (string-as-multibyte + (encode-coding-string + (nnheader-replace-chars-in-string + (substring dir (match-end 0)) + ?/ ?.) + nnmail-pathname-coding-system))) (apply 'max files) (apply 'min files))))))) t) @@ -392,6 +282,13 @@ (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 () @@ -409,7 +306,7 @@ t) (deffoo nnmh-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last) (let ((buf (get-buffer-create " *nnmh move*")) result) (and @@ -541,7 +438,8 @@ (nnmh-open-server server)) (when newsgroup (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) - (pathname-coding-system 'binary)) + (file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system)) (if (file-directory-p pathname) (setq nnmh-current-directory pathname) (error "No such newsgroup: %s" newsgroup))))) @@ -590,7 +488,9 @@ "Compute the next article number in GROUP." (let ((active (cadr (assoc group nnmh-group-alist))) (dir (nnmail-group-pathname group nnmh-directory)) - (pathname-coding-system 'binary)) + (file-name-coding-system nnmail-pathname-coding-system) + (pathname-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. @@ -608,9 +508,15 @@ (when files (setcdr active (car files))))) (setcdr active (1+ (cdr active))) - (while (file-exists-p - (concat (nnmail-group-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)))