1 ;;; mhspool.el --- MH folder access using NNTP for GNU Emacs
3 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5 ;; Last-Modified: 16 Mar 1992
6 ;; Keywords: mail, news
8 ;; $Header: mhspool.el,v 1.5 90/03/23 13:25:23 umerin Locked $
10 ;; Copyright (C) 1988, 1989 Fujitsu Laboratories LTD.
11 ;; Copyright (C) 1988, 1989, 1990 Masanobu UMEDA
13 ;; This file is part of GNU Emacs.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY. No author or distributor
17 ;; accepts responsibility to anyone for the consequences of using it
18 ;; or for whether it serves any particular purpose or works at all,
19 ;; unless he says so in writing. Refer to the GNU Emacs General Public
20 ;; License for full details.
22 ;; Everyone is granted permission to copy, modify and redistribute
23 ;; GNU Emacs, but only under the conditions described in the
24 ;; GNU Emacs General Public License. A copy of this license is
25 ;; supposed to have been given to you along with GNU Emacs so you
26 ;; can know your rights and responsibilities. It should be in a
27 ;; file named COPYING. Among other things, the copyright notice
28 ;; and this notice must be preserved on all copies.
32 ;; This package enables you to read mail or articles in MH folders, or
33 ;; articles saved by GNUS. In any case, the file names of mail or
34 ;; articles must consist of only numeric letters.
36 ;; Before using this package, you have to create a server specific
37 ;; startup file according to the directory which you want to read. For
38 ;; example, if you want to read mail under the directory named
39 ;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is
40 ;; no way to specify hierarchical directory now.) In this case, the
41 ;; name of the NNTP server passed to GNUS must be `:Mail'.
47 (defvar mhspool-list-directory-switches
'("-R")
48 "*Switches for `nntp-request-list' to pass to `ls' for gettting file lists.
49 One entry should appear on one line. You may need to add `-1' option.")
53 (defconst mhspool-version
"MHSPOOL 1.5"
54 "Version numbers of this version of MHSPOOL.")
56 (defvar mhspool-spool-directory
"~/Mail"
57 "Private mail directory.")
59 (defvar mhspool-current-directory nil
60 "Current news group directory.")
63 ;;; Replacement of Extended Command for retrieving many headers.
66 (defun mhspool-retrieve-headers (sequence)
67 "Return list of article headers specified by SEQUENCE of article id.
69 `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
70 Reader macros for the vector are defined as `nntp-header-FIELD'.
71 Writer macros for the vector are defined as `nntp-set-header-FIELD'.
72 News group must be selected before calling me."
74 (set-buffer nntp-server-buffer
)
77 (number (length sequence
))
79 (headers nil
) ;Result list.
89 ;;(nntp-send-strings-to-server "HEAD" (car sequence))
90 (setq article
(car sequence
))
92 (concat mhspool-current-directory
(prin1-to-string article
)))
93 (if (and (file-exists-p file
)
94 (not (file-directory-p file
)))
97 (insert-file-contents file
)
98 ;; Make message body invisible.
99 (goto-char (point-min))
100 (search-forward "\n\n" nil
'move
)
101 (narrow-to-region (point-min) (point))
102 ;; Fold continuation lines.
103 (goto-char (point-min))
104 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t
)
105 (replace-match " " t t
))
106 ;; Make it possible to search for `\nFIELD'.
107 (goto-char (point-min))
110 (goto-char (point-min))
111 (if (search-forward "\nFrom: " nil t
)
112 (setq from
(buffer-substring
114 (save-excursion (end-of-line) (point))))
115 (setq from
"(Unknown User)"))
117 (goto-char (point-min))
118 (if (search-forward "\nSubject: " nil t
)
119 (setq subject
(buffer-substring
121 (save-excursion (end-of-line) (point))))
122 (setq subject
"(None)"))
123 ;; Extract Message-ID:
124 (goto-char (point-min))
125 (if (search-forward "\nMessage-ID: " nil t
)
126 (setq message-id
(buffer-substring
128 (save-excursion (end-of-line) (point))))
129 (setq message-id nil
))
131 (goto-char (point-min))
132 (if (search-forward "\nDate: " nil t
)
133 (setq date
(buffer-substring
135 (save-excursion (end-of-line) (point))))
138 (goto-char (point-min))
139 (if (search-forward "\nLines: " nil t
)
140 (setq lines
(string-to-int
143 (save-excursion (end-of-line) (point)))))
146 (goto-char (point-min))
147 (if (search-forward "\nXref: " nil t
)
148 (setq xref
(buffer-substring
150 (save-excursion (end-of-line) (point))))
152 ;; Extract References:
153 ;; If no References: field, use In-Reply-To: field instead.
154 ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA).
155 (goto-char (point-min))
156 (if (or (search-forward "\nReferences: " nil t
)
157 (search-forward "\nIn-Reply-To: " nil t
))
158 (setq references
(buffer-substring
160 (save-excursion (end-of-line) (point))))
161 (setq references nil
))
163 (cons (vector article subject from
165 message-id references
) headers
))
167 (setq sequence
(cdr sequence
))
168 (setq count
(1+ count
))
169 (and (numberp nntp-large-newsgroup
)
170 (> number nntp-large-newsgroup
)
172 (message "MHSPOOL: %d%% of headers received."
173 (/ (* count
100) number
)))
175 (and (numberp nntp-large-newsgroup
)
176 (> number nntp-large-newsgroup
)
177 (message "MHSPOOL: 100%% of headers received."))
183 ;;; Replacement of NNTP Raw Interface.
186 (defun mhspool-open-server (host &optional service
)
187 "Open news server on HOST.
188 If HOST is nil, use value of environment variable `NNTPSERVER'.
189 If optional argument SERVICE is non-nil, open by the service name."
190 (let ((host (or host
(getenv "NNTPSERVER")))
192 ;; Get directory name from HOST name.
193 (if (string-match ":\\(.+\\)$" host
)
195 (setq mhspool-spool-directory
196 (file-name-as-directory
198 (substring host
(match-beginning 1) (match-end 1))
199 (expand-file-name "~/" nil
))))
200 (setq host
(system-name)))
201 (setq mhspool-spool-directory nil
))
202 (setq nntp-status-message-string
"")
203 (cond ((and (stringp host
)
204 (stringp mhspool-spool-directory
)
205 (file-directory-p mhspool-spool-directory
)
206 (string-equal host
(system-name)))
207 (setq status
(mhspool-open-server-internal host service
)))
208 ((string-equal host
(system-name))
209 (setq nntp-status-message-string
210 (format "No such directory: %s. Goodbye."
211 mhspool-spool-directory
)))
213 (setq nntp-status-message-string
"NNTP server is not specified."))
215 (setq nntp-status-message-string
216 (format "MHSPOOL: cannot talk to %s." host
)))
221 (defun mhspool-close-server ()
223 (mhspool-close-server-internal))
225 (fset 'mhspool-request-quit
(symbol-function 'mhspool-close-server
))
227 (defun mhspool-server-opened ()
228 "Return server process status, T or NIL.
229 If the stream is opened, return T, otherwise return NIL."
230 (and nntp-server-buffer
231 (get-buffer nntp-server-buffer
)))
233 (defun mhspool-status-message ()
234 "Return server status response as string."
235 nntp-status-message-string
238 (defun mhspool-request-article (id)
239 "Select article by message ID (or number)."
240 (let ((file (concat mhspool-current-directory
(prin1-to-string id
))))
241 (if (and (stringp file
)
243 (not (file-directory-p file
)))
245 (mhspool-find-file file
)))
248 (defun mhspool-request-body (id)
249 "Select article body by message ID (or number)."
250 (if (mhspool-request-article id
)
252 (set-buffer nntp-server-buffer
)
253 (goto-char (point-min))
254 (if (search-forward "\n\n" nil t
)
255 (delete-region (point-min) (point)))
260 (defun mhspool-request-head (id)
261 "Select article head by message ID (or number)."
262 (if (mhspool-request-article id
)
264 (set-buffer nntp-server-buffer
)
265 (goto-char (point-min))
266 (if (search-forward "\n\n" nil t
)
267 (delete-region (1- (point)) (point-max)))
272 (defun mhspool-request-stat (id)
273 "Select article by message ID (or number)."
274 (error "MHSPOOL: STAT is not implemented."))
276 (defun mhspool-request-group (group)
278 (cond ((file-directory-p
279 (mhspool-article-pathname group
))
281 (setq mhspool-current-directory
282 (mhspool-article-pathname group
)))
284 (mhspool-article-pathname
285 (mhspool-replace-chars-in-string group ?. ?
/)))
287 (setq mhspool-current-directory
288 (mhspool-article-pathname
289 (mhspool-replace-chars-in-string group ?. ?
/))))
292 (defun mhspool-request-list ()
293 "List valid newsgoups."
295 (let* ((newsgroup nil
)
297 (directory (file-name-as-directory
298 (expand-file-name mhspool-spool-directory nil
)))
299 (folder-regexp (concat "^" (regexp-quote directory
) "\\(.+\\):$"))
300 (buffer (get-buffer-create " *GNUS file listing*")))
301 (set-buffer nntp-server-buffer
)
307 (append mhspool-list-directory-switches
(list directory
)))
308 (goto-char (point-min))
309 (while (re-search-forward folder-regexp nil t
)
311 (mhspool-replace-chars-in-string
312 (buffer-substring (match-beginning 1) (match-end 1)) ?
/ ?.
))
314 (forward-line 1) ;(beginning-of-line)
315 ;; Thank nobu@flab.fujitsu.junet for his bug fixes.
316 (while (and (not (eobp))
317 (not (looking-at "^$")))
318 (if (looking-at "^[0-9]+$")
322 (match-beginning 0) (match-end 0)))
326 (princ (format "%s %d %d n\n" newsgroup
327 (apply (function max
) articles
)
328 (apply (function min
) articles
))
332 (set-buffer nntp-server-buffer
)
336 (defun mhspool-request-last ()
337 "Set current article pointer to the previous article in the current newsgroup."
338 (error "MHSPOOL: LAST is not implemented."))
340 (defun mhspool-request-next ()
341 "Advance current article pointer."
342 (error "MHSPOOL: NEXT is not implemented."))
344 (defun mhspool-request-post ()
345 "Post a new news in current buffer."
346 (setq nntp-status-message-string
"MHSPOOL: what do you mean post?")
352 ;;; Replacement of Low-Level Interface to NNTP Server.
355 (defun mhspool-open-server-internal (host &optional service
)
356 "Open connection to news server on HOST by SERVICE (default is nntp)."
358 (if (not (string-equal host
(system-name)))
359 (error "MHSPOOL: cannot talk to %s." host
))
360 ;; Initialize communication buffer.
361 (setq nntp-server-buffer
(get-buffer-create " *nntpd*"))
362 (set-buffer nntp-server-buffer
)
363 (buffer-flush-undo (current-buffer))
365 (kill-all-local-variables)
366 (setq case-fold-search t
) ;Should ignore case.
367 (setq nntp-server-process nil
)
368 (setq nntp-server-name host
)
369 ;; It is possible to change kanji-fileio-code in this hook.
370 (run-hooks 'nntp-server-hook
)
374 (defun mhspool-close-server-internal ()
375 "Close connection to news server."
376 (if nntp-server-buffer
377 (kill-buffer nntp-server-buffer
))
378 (setq nntp-server-buffer nil
)
379 (setq nntp-server-process nil
))
381 (defun mhspool-find-file (file)
382 "Insert FILE in server buffer safely."
383 (set-buffer nntp-server-buffer
)
387 (insert-file-contents file
)
388 (goto-char (point-min))
389 ;; If there is no body, `^L' appears at end of file. Special
390 ;; hack for MH folder.
391 (and (search-forward "\n\n" nil t
)
392 (string-equal (buffer-substring (point) (point-max)) "\^L")
399 (defun mhspool-article-pathname (group)
400 "Make pathname for GROUP."
401 (concat (file-name-as-directory mhspool-spool-directory
) group
"/"))
403 (defun mhspool-replace-chars-in-string (string from to
)
404 "Replace characters in STRING from FROM to TO."
405 (let ((string (substring string
0)) ;Copy string.
406 (len (length string
))
408 ;; Replace all occurence of FROM with TO.
410 (if (= (aref string idx
) from
)
411 (aset string idx to
))
418 ;;; mhspool.el ends here