Commit | Line | Data |
---|---|---|
6594deb0 ER |
1 | ;;; mhspool.el --- MH folder access using NNTP for GNU Emacs |
2 | ||
84176303 ER |
3 | ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
4 | ;; Maintainer: FSF | |
5 | ;; Last-Modified: 16 Mar 1992 | |
fd7fa35a | 6 | ;; Keywords: mail, news |
84176303 ER |
7 | |
8 | ;; $Header: mhspool.el,v 1.5 90/03/23 13:25:23 umerin Locked $ | |
9 | ||
05328297 | 10 | ;; Copyright (C) 1988, 1989 Fujitsu Laboratories LTD. |
11 | ;; Copyright (C) 1988, 1989, 1990 Masanobu UMEDA | |
05328297 | 12 | |
13 | ;; This file is part of GNU Emacs. | |
14 | ||
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. | |
21 | ||
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. | |
29 | ||
84176303 | 30 | ;; Commentary: |
05328297 | 31 | |
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. | |
35 | ||
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'. | |
42 | ||
84176303 ER |
43 | ;; Code: |
44 | ||
45 | (require 'nntp) | |
46 | ||
05328297 | 47 | (defvar mhspool-list-directory-switches '("-R") |
b5874a20 | 48 | "*Switches for `nntp-request-list' to pass to `ls' for gettting file lists. |
05328297 | 49 | One entry should appear on one line. You may need to add `-1' option.") |
50 | ||
51 | \f | |
52 | ||
53 | (defconst mhspool-version "MHSPOOL 1.5" | |
54 | "Version numbers of this version of MHSPOOL.") | |
55 | ||
56 | (defvar mhspool-spool-directory "~/Mail" | |
57 | "Private mail directory.") | |
58 | ||
59 | (defvar mhspool-current-directory nil | |
60 | "Current news group directory.") | |
61 | ||
62 | ;;; | |
63 | ;;; Replacement of Extended Command for retrieving many headers. | |
64 | ;;; | |
65 | ||
66 | (defun mhspool-retrieve-headers (sequence) | |
67 | "Return list of article headers specified by SEQUENCE of article id. | |
68 | The format of list is | |
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." | |
73 | (save-excursion | |
74 | (set-buffer nntp-server-buffer) | |
75 | ;;(erase-buffer) | |
76 | (let ((file nil) | |
77 | (number (length sequence)) | |
78 | (count 0) | |
79 | (headers nil) ;Result list. | |
80 | (article 0) | |
81 | (subject nil) | |
82 | (message-id nil) | |
83 | (from nil) | |
84 | (xref nil) | |
85 | (lines 0) | |
86 | (date nil) | |
87 | (references nil)) | |
88 | (while sequence | |
89 | ;;(nntp-send-strings-to-server "HEAD" (car sequence)) | |
90 | (setq article (car sequence)) | |
91 | (setq file | |
92 | (concat mhspool-current-directory (prin1-to-string article))) | |
93 | (if (and (file-exists-p file) | |
94 | (not (file-directory-p file))) | |
95 | (progn | |
96 | (erase-buffer) | |
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)) | |
108 | (insert "\n") | |
109 | ;; Extract From: | |
110 | (goto-char (point-min)) | |
111 | (if (search-forward "\nFrom: " nil t) | |
112 | (setq from (buffer-substring | |
113 | (point) | |
114 | (save-excursion (end-of-line) (point)))) | |
115 | (setq from "(Unknown User)")) | |
116 | ;; Extract Subject: | |
117 | (goto-char (point-min)) | |
118 | (if (search-forward "\nSubject: " nil t) | |
119 | (setq subject (buffer-substring | |
120 | (point) | |
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 | |
127 | (point) | |
128 | (save-excursion (end-of-line) (point)))) | |
129 | (setq message-id nil)) | |
130 | ;; Extract Date: | |
131 | (goto-char (point-min)) | |
132 | (if (search-forward "\nDate: " nil t) | |
133 | (setq date (buffer-substring | |
134 | (point) | |
135 | (save-excursion (end-of-line) (point)))) | |
136 | (setq date nil)) | |
137 | ;; Extract Lines: | |
138 | (goto-char (point-min)) | |
139 | (if (search-forward "\nLines: " nil t) | |
140 | (setq lines (string-to-int | |
141 | (buffer-substring | |
142 | (point) | |
143 | (save-excursion (end-of-line) (point))))) | |
144 | (setq lines 0)) | |
145 | ;; Extract Xref: | |
146 | (goto-char (point-min)) | |
147 | (if (search-forward "\nXref: " nil t) | |
148 | (setq xref (buffer-substring | |
149 | (point) | |
150 | (save-excursion (end-of-line) (point)))) | |
151 | (setq xref nil)) | |
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 | |
159 | (point) | |
160 | (save-excursion (end-of-line) (point)))) | |
161 | (setq references nil)) | |
162 | (setq headers | |
163 | (cons (vector article subject from | |
164 | xref lines date | |
165 | message-id references) headers)) | |
166 | )) | |
167 | (setq sequence (cdr sequence)) | |
168 | (setq count (1+ count)) | |
169 | (and (numberp nntp-large-newsgroup) | |
170 | (> number nntp-large-newsgroup) | |
171 | (zerop (% count 20)) | |
172 | (message "MHSPOOL: %d%% of headers received." | |
173 | (/ (* count 100) number))) | |
174 | ) | |
175 | (and (numberp nntp-large-newsgroup) | |
176 | (> number nntp-large-newsgroup) | |
177 | (message "MHSPOOL: 100%% of headers received.")) | |
178 | (nreverse headers) | |
179 | ))) | |
180 | ||
181 | \f | |
182 | ;;; | |
183 | ;;; Replacement of NNTP Raw Interface. | |
184 | ;;; | |
185 | ||
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"))) | |
191 | (status nil)) | |
192 | ;; Get directory name from HOST name. | |
193 | (if (string-match ":\\(.+\\)$" host) | |
194 | (progn | |
195 | (setq mhspool-spool-directory | |
196 | (file-name-as-directory | |
197 | (expand-file-name | |
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))) | |
212 | ((null host) | |
213 | (setq nntp-status-message-string "NNTP server is not specified.")) | |
214 | (t | |
215 | (setq nntp-status-message-string | |
216 | (format "MHSPOOL: cannot talk to %s." host))) | |
217 | ) | |
218 | status | |
219 | )) | |
220 | ||
221 | (defun mhspool-close-server () | |
222 | "Close news server." | |
223 | (mhspool-close-server-internal)) | |
224 | ||
225 | (fset 'mhspool-request-quit (symbol-function 'mhspool-close-server)) | |
226 | ||
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))) | |
232 | ||
233 | (defun mhspool-status-message () | |
234 | "Return server status response as string." | |
235 | nntp-status-message-string | |
236 | ) | |
237 | ||
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) | |
242 | (file-exists-p file) | |
243 | (not (file-directory-p file))) | |
244 | (save-excursion | |
245 | (mhspool-find-file file))) | |
246 | )) | |
247 | ||
248 | (defun mhspool-request-body (id) | |
249 | "Select article body by message ID (or number)." | |
250 | (if (mhspool-request-article id) | |
251 | (save-excursion | |
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))) | |
256 | t | |
257 | ) | |
258 | )) | |
259 | ||
260 | (defun mhspool-request-head (id) | |
261 | "Select article head by message ID (or number)." | |
262 | (if (mhspool-request-article id) | |
263 | (save-excursion | |
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))) | |
268 | t | |
269 | ) | |
270 | )) | |
271 | ||
272 | (defun mhspool-request-stat (id) | |
273 | "Select article by message ID (or number)." | |
274 | (error "MHSPOOL: STAT is not implemented.")) | |
275 | ||
276 | (defun mhspool-request-group (group) | |
277 | "Select news GROUP." | |
278 | (cond ((file-directory-p | |
279 | (mhspool-article-pathname group)) | |
280 | ;; Mail/NEWS.GROUP/N | |
281 | (setq mhspool-current-directory | |
282 | (mhspool-article-pathname group))) | |
283 | ((file-directory-p | |
284 | (mhspool-article-pathname | |
285 | (mhspool-replace-chars-in-string group ?. ?/))) | |
286 | ;; Mail/NEWS/GROUP/N | |
287 | (setq mhspool-current-directory | |
288 | (mhspool-article-pathname | |
289 | (mhspool-replace-chars-in-string group ?. ?/)))) | |
290 | )) | |
291 | ||
292 | (defun mhspool-request-list () | |
293 | "List valid newsgoups." | |
294 | (save-excursion | |
295 | (let* ((newsgroup nil) | |
296 | (articles 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) | |
302 | (erase-buffer) | |
303 | (set-buffer buffer) | |
304 | (erase-buffer) | |
305 | (apply 'call-process | |
306 | "ls" nil t nil | |
307 | (append mhspool-list-directory-switches (list directory))) | |
308 | (goto-char (point-min)) | |
309 | (while (re-search-forward folder-regexp nil t) | |
310 | (setq newsgroup | |
311 | (mhspool-replace-chars-in-string | |
312 | (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.)) | |
313 | (setq articles nil) | |
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]+$") | |
319 | (setq articles | |
320 | (cons (string-to-int | |
321 | (buffer-substring | |
322 | (match-beginning 0) (match-end 0))) | |
323 | articles))) | |
324 | (forward-line 1)) | |
325 | (if articles | |
326 | (princ (format "%s %d %d n\n" newsgroup | |
327 | (apply (function max) articles) | |
328 | (apply (function min) articles)) | |
329 | nntp-server-buffer)) | |
330 | ) | |
331 | (kill-buffer buffer) | |
332 | (set-buffer nntp-server-buffer) | |
333 | (buffer-size) | |
334 | ))) | |
335 | ||
336 | (defun mhspool-request-last () | |
b5874a20 | 337 | "Set current article pointer to the previous article in the current newsgroup." |
05328297 | 338 | (error "MHSPOOL: LAST is not implemented.")) |
339 | ||
340 | (defun mhspool-request-next () | |
341 | "Advance current article pointer." | |
342 | (error "MHSPOOL: NEXT is not implemented.")) | |
343 | ||
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?") | |
347 | nil | |
348 | ) | |
349 | ||
350 | \f | |
351 | ;;; | |
352 | ;;; Replacement of Low-Level Interface to NNTP Server. | |
353 | ;;; | |
354 | ||
355 | (defun mhspool-open-server-internal (host &optional service) | |
356 | "Open connection to news server on HOST by SERVICE (default is nntp)." | |
357 | (save-excursion | |
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)) | |
364 | (erase-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) | |
371 | t | |
372 | )) | |
373 | ||
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)) | |
380 | ||
381 | (defun mhspool-find-file (file) | |
382 | "Insert FILE in server buffer safely." | |
383 | (set-buffer nntp-server-buffer) | |
384 | (erase-buffer) | |
385 | (condition-case () | |
386 | (progn | |
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") | |
393 | (delete-char 1)) | |
394 | t | |
395 | ) | |
396 | (file-error nil) | |
397 | )) | |
398 | ||
399 | (defun mhspool-article-pathname (group) | |
400 | "Make pathname for GROUP." | |
401 | (concat (file-name-as-directory mhspool-spool-directory) group "/")) | |
402 | ||
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)) | |
407 | (idx 0)) | |
408 | ;; Replace all occurence of FROM with TO. | |
409 | (while (< idx len) | |
410 | (if (= (aref string idx) from) | |
411 | (aset string idx to)) | |
412 | (setq idx (1+ idx))) | |
413 | string | |
414 | )) | |
49116ac0 JB |
415 | |
416 | (provide 'mhspool) | |
6594deb0 ER |
417 | |
418 | ;;; mhspool.el ends here |