1 ;;; mhspool.el --- MH folder access using NNTP for GNU Emacs
3 ;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc.
5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7 ;; Keywords: mail, news
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to
23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
27 ;; This package enables you to read mail or articles in MH folders, or
28 ;; articles saved by GNUS. In any case, the file names of mail or
29 ;; articles must consist of only numeric letters.
31 ;; Before using this package, you have to create a server specific
32 ;; startup file according to the directory which you want to read. For
33 ;; example, if you want to read mail under the directory named
34 ;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is
35 ;; no way to specify hierarchical directory now.) In this case, the
36 ;; name of the NNTP server passed to GNUS must be `:Mail'.
42 (defvar mhspool-list-folders-method
43 (function mhspool-list-folders-using-sh
)
44 "*Function to list files in folders.
45 The function should accept a directory as its argument, and fill the
46 current buffer with file and directory names. The output format must
47 be the same as that of 'ls -R1'. Two functions
48 mhspool-list-folders-using-ls and mhspool-list-folders-using-sh are
49 provided now. I suppose the later is faster.")
51 (defvar mhspool-list-directory-switches
'("-R")
52 "*Switches for mhspool-list-folders-using-ls to pass to `ls' for gettting file lists.
53 One entry should appear on one line. You may need to add `-1' option.")
57 (defconst mhspool-version
"MHSPOOL 1.8"
58 "Version numbers of this version of MHSPOOL.")
60 (defvar mhspool-spool-directory
"~/Mail"
61 "Private mail directory.")
63 (defvar mhspool-current-directory nil
64 "Current news group directory.")
67 ;;; Replacement of Extended Command for retrieving many headers.
70 (defun mhspool-retrieve-headers (sequence)
71 "Return list of article headers specified by SEQUENCE of article id.
73 `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
74 If there is no References: field, In-Reply-To: field is used instead.
75 Reader macros for the vector are defined as `nntp-header-FIELD'.
76 Writer macros for the vector are defined as `nntp-set-header-FIELD'.
77 Newsgroup must be selected before calling this."
79 (set-buffer nntp-server-buffer
)
82 (number (length sequence
))
84 (headers nil
) ;Result list.
94 ;;(nntp-send-strings-to-server "HEAD" (car sequence))
95 (setq article
(car sequence
))
97 (concat mhspool-current-directory
(prin1-to-string article
)))
98 (if (and (file-exists-p file
)
99 (not (file-directory-p file
)))
102 (insert-file-contents file
)
103 ;; Make message body invisible.
104 (goto-char (point-min))
105 (search-forward "\n\n" nil
'move
)
106 (narrow-to-region (point-min) (point))
107 ;; Fold continuation lines.
108 (goto-char (point-min))
109 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t
)
110 (replace-match " " t t
))
111 ;; Make it possible to search for `\nFIELD'.
112 (goto-char (point-min))
115 (goto-char (point-min))
116 (if (search-forward "\nFrom: " nil t
)
117 (setq from
(buffer-substring
119 (save-excursion (end-of-line) (point))))
120 (setq from
"(Unknown User)"))
122 (goto-char (point-min))
123 (if (search-forward "\nSubject: " nil t
)
124 (setq subject
(buffer-substring
126 (save-excursion (end-of-line) (point))))
127 (setq subject
"(None)"))
128 ;; Extract Message-ID:
129 (goto-char (point-min))
130 (if (search-forward "\nMessage-ID: " nil t
)
131 (setq message-id
(buffer-substring
133 (save-excursion (end-of-line) (point))))
134 (setq message-id nil
))
136 (goto-char (point-min))
137 (if (search-forward "\nDate: " nil t
)
138 (setq date
(buffer-substring
140 (save-excursion (end-of-line) (point))))
143 (goto-char (point-min))
144 (if (search-forward "\nLines: " nil t
)
145 (setq lines
(string-to-int
148 (save-excursion (end-of-line) (point)))))
149 ;; Count lines since there is no lines field in most cases.
152 (goto-char (point-max))
154 (count-lines (point) (point-max)))))
156 (goto-char (point-min))
157 (if (search-forward "\nXref: " nil t
)
158 (setq xref
(buffer-substring
160 (save-excursion (end-of-line) (point))))
162 ;; Extract References:
163 ;; If no References: field, use In-Reply-To: field instead.
164 ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA).
165 (goto-char (point-min))
166 (if (or (search-forward "\nReferences: " nil t
)
167 (search-forward "\nIn-Reply-To: " nil t
))
168 (setq references
(buffer-substring
170 (save-excursion (end-of-line) (point))))
171 (setq references nil
))
172 ;; Collect valid article only.
176 (cons (vector article subject from
178 message-id references
) headers
)))
180 (setq sequence
(cdr sequence
))
181 (setq count
(1+ count
))
182 (and (numberp nntp-large-newsgroup
)
183 (> number nntp-large-newsgroup
)
185 (message "MHSPOOL: Receiving headers... %d%%"
186 (/ (* count
100) number
)))
188 (and (numberp nntp-large-newsgroup
)
189 (> number nntp-large-newsgroup
)
190 (message "MHSPOOL: Receiving headers... done"))
196 ;;; Replacement of NNTP Raw Interface.
199 (defun mhspool-open-server (host &optional service
)
200 "Open news server on HOST.
201 If HOST is nil, use value of environment variable `NNTPSERVER'.
202 If optional argument SERVICE is non-nil, open by the service name."
203 (let ((host (or host
(getenv "NNTPSERVER")))
205 ;; Get directory name from HOST name.
206 (if (string-match ":\\(.+\\)$" host
)
208 (setq mhspool-spool-directory
209 (file-name-as-directory
211 (substring host
(match-beginning 1) (match-end 1))
212 (expand-file-name "~/" nil
))))
213 (setq host
(system-name)))
214 (setq mhspool-spool-directory nil
))
215 (setq nntp-status-string
"")
216 (cond ((and (stringp host
)
217 (stringp mhspool-spool-directory
)
218 (file-directory-p mhspool-spool-directory
)
219 (string-equal host
(system-name)))
220 (setq status
(mhspool-open-server-internal host service
)))
221 ((string-equal host
(system-name))
222 (setq nntp-status-string
223 (format "No such directory: %s. Goodbye."
224 mhspool-spool-directory
)))
226 (setq nntp-status-string
"NNTP server is not specified."))
228 (setq nntp-status-string
229 (format "MHSPOOL: cannot talk to %s." host
)))
234 (defun mhspool-close-server ()
236 (mhspool-close-server-internal))
238 (fset 'mhspool-request-quit
(symbol-function 'mhspool-close-server
))
240 (defun mhspool-server-opened ()
241 "Return server process status, T or NIL.
242 If the stream is opened, return T, otherwise return NIL."
243 (and nntp-server-buffer
244 (get-buffer nntp-server-buffer
)))
246 (defun mhspool-status-message ()
247 "Return server status response as string."
251 (defun mhspool-request-article (id)
252 "Select article by message ID (or number)."
253 (let ((file (concat mhspool-current-directory
(prin1-to-string id
))))
254 (if (and (stringp file
)
256 (not (file-directory-p file
)))
258 (mhspool-find-file file
)))
261 (defun mhspool-request-body (id)
262 "Select article body by message ID (or number)."
263 (if (mhspool-request-article id
)
265 (set-buffer nntp-server-buffer
)
266 (goto-char (point-min))
267 (if (search-forward "\n\n" nil t
)
268 (delete-region (point-min) (point)))
273 (defun mhspool-request-head (id)
274 "Select article head by message ID (or number)."
275 (if (mhspool-request-article id
)
277 (set-buffer nntp-server-buffer
)
278 (goto-char (point-min))
279 (if (search-forward "\n\n" nil t
)
280 (delete-region (1- (point)) (point-max)))
285 (defun mhspool-request-stat (id)
286 "Select article by message ID (or number)."
287 (setq nntp-status-string
"MHSPOOL: STAT is not implemented.")
291 (defun mhspool-request-group (group)
293 (cond ((file-directory-p
294 (mhspool-article-pathname group
))
296 (setq mhspool-current-directory
297 (mhspool-article-pathname group
)))
299 (mhspool-article-pathname
300 (mhspool-replace-chars-in-string group ?. ?
/)))
302 (setq mhspool-current-directory
303 (mhspool-article-pathname
304 (mhspool-replace-chars-in-string group ?. ?
/))))
307 (defun mhspool-request-list ()
308 "List active newsgoups."
310 (let* ((newsgroup nil
)
312 (directory (file-name-as-directory
313 (expand-file-name mhspool-spool-directory nil
)))
314 (folder-regexp (concat "^" (regexp-quote directory
) "\\(.+\\):$"))
315 (buffer (get-buffer-create " *MHSPOOL File List*")))
316 (set-buffer nntp-server-buffer
)
320 ;; (apply 'call-process
322 ;; (append mhspool-list-directory-switches (list directory)))
323 (funcall mhspool-list-folders-method directory
)
324 (goto-char (point-min))
325 (while (re-search-forward folder-regexp nil t
)
327 (mhspool-replace-chars-in-string
328 (buffer-substring (match-beginning 1) (match-end 1)) ?
/ ?.
))
330 (forward-line 1) ;(beginning-of-line)
331 ;; Thank nobu@flab.fujitsu.junet for his bug fixes.
332 (while (and (not (eobp))
333 (not (looking-at "^$")))
334 (if (looking-at "^[0-9]+$")
338 (match-beginning 0) (match-end 0)))
342 (princ (format "%s %d %d n\n" newsgroup
343 (apply (function max
) articles
)
344 (apply (function min
) articles
))
348 (set-buffer nntp-server-buffer
)
352 (defun mhspool-request-list-newsgroups ()
353 "List newsgoups (defined in NNTP2)."
354 (setq nntp-status-string
"MHSPOOL: LIST NEWSGROUPS is not implemented.")
358 (defun mhspool-request-list-distributions ()
359 "List distributions (defined in NNTP2)."
360 (setq nntp-status-string
"MHSPOOL: LIST DISTRIBUTIONS is not implemented.")
364 (defun mhspool-request-last ()
365 "Set current article pointer to the previous article
366 in the current news group."
367 (setq nntp-status-string
"MHSPOOL: LAST is not implemented.")
371 (defun mhspool-request-next ()
372 "Advance current article pointer."
373 (setq nntp-status-string
"MHSPOOL: NEXT is not implemented.")
377 (defun mhspool-request-post ()
378 "Post a new news in current buffer."
379 (setq nntp-status-string
"MHSPOOL: POST: what do you mean?")
385 ;;; Replacement of Low-Level Interface to NNTP Server.
388 (defun mhspool-open-server-internal (host &optional service
)
389 "Open connection to news server on HOST by SERVICE (default is nntp)."
391 (if (not (string-equal host
(system-name)))
392 (error "MHSPOOL: cannot talk to %s." host
))
393 ;; Initialize communication buffer.
394 (setq nntp-server-buffer
(get-buffer-create " *nntpd*"))
395 (set-buffer nntp-server-buffer
)
396 (buffer-flush-undo (current-buffer))
398 (kill-all-local-variables)
399 (setq case-fold-search t
) ;Should ignore case.
400 (setq nntp-server-process nil
)
401 (setq nntp-server-name host
)
402 ;; It is possible to change kanji-fileio-code in this hook.
403 (run-hooks 'nntp-server-hook
)
407 (defun mhspool-close-server-internal ()
408 "Close connection to news server."
409 (if nntp-server-buffer
410 (kill-buffer nntp-server-buffer
))
411 (setq nntp-server-buffer nil
)
412 (setq nntp-server-process nil
))
414 (defun mhspool-find-file (file)
415 "Insert FILE in server buffer safely."
416 (set-buffer nntp-server-buffer
)
420 (insert-file-contents file
)
421 (goto-char (point-min))
422 ;; If there is no body, `^L' appears at end of file. Special
423 ;; hack for MH folder.
424 (and (search-forward "\n\n" nil t
)
425 (string-equal (buffer-substring (point) (point-max)) "\^L")
432 (defun mhspool-article-pathname (group)
433 "Make pathname for GROUP."
434 (concat (file-name-as-directory mhspool-spool-directory
) group
"/"))
436 (defun mhspool-replace-chars-in-string (string from to
)
437 "Replace characters in STRING from FROM to TO."
438 (let ((string (substring string
0)) ;Copy string.
439 (len (length string
))
441 ;; Replace all occurence of FROM with TO.
443 (if (= (aref string idx
) from
)
444 (aset string idx to
))
450 ;; Methods for listing files in folders.
452 (defun mhspool-list-folders-using-ls (directory)
453 "List files in folders under DIRECTORY using 'ls'."
456 (append mhspool-list-directory-switches
(list directory
))))
458 ;; Basic ideas by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA)
460 (defun mhspool-list-folders-using-sh (directory)
461 "List files in folders under DIRECTORY using '/bin/sh'."
462 (let ((buffer (current-buffer))
463 (script (get-buffer-create " *MHSPOOL Shell Script Buffer*")))
468 ;; /bin/sh script which does 'ls -R'.
475 for j in `echo *[a-zA-Z]*`
477 if [ -d $1/$j ]; then
482 cd " directory
"; ffind `pwd`; exit 0\n")
483 (call-process-region (point-min) (point-max) "sh" nil buffer nil
)
490 ;;; mhspool.el ends here