Mercurial > emacs
annotate lisp/=mhspool.el @ 853:224b0d5d1a38
*** empty log message ***
author | Jim Blandy <jimb@redhat.com> |
---|---|
date | Wed, 22 Jul 1992 21:20:04 +0000 |
parents | 113281b361ec |
children | 7e4999005da1 |
rev | line source |
---|---|
659
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
1 ;;; mhspool.el --- MH folder access using NNTP for GNU Emacs |
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
2 |
840
113281b361ec
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
811
diff
changeset
|
3 ;; Copyright (C) 1988, 1989 Fujitsu Laboratories LTD. |
113281b361ec
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
811
diff
changeset
|
4 ;; Copyright (C) 1988, 1989, 1990 Masanobu UMEDA |
113281b361ec
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
811
diff
changeset
|
5 |
791
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
6 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
7 ;; Maintainer: FSF |
811
e694e0879463
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
791
diff
changeset
|
8 ;; Keywords: mail, news |
791
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
9 |
87 | 10 ;; This file is part of GNU Emacs. |
11 | |
12 ;; GNU Emacs is distributed in the hope that it will be useful, | |
13 ;; but WITHOUT ANY WARRANTY. No author or distributor | |
14 ;; accepts responsibility to anyone for the consequences of using it | |
15 ;; or for whether it serves any particular purpose or works at all, | |
16 ;; unless he says so in writing. Refer to the GNU Emacs General Public | |
17 ;; License for full details. | |
18 | |
19 ;; Everyone is granted permission to copy, modify and redistribute | |
20 ;; GNU Emacs, but only under the conditions described in the | |
21 ;; GNU Emacs General Public License. A copy of this license is | |
22 ;; supposed to have been given to you along with GNU Emacs so you | |
23 ;; can know your rights and responsibilities. It should be in a | |
24 ;; file named COPYING. Among other things, the copyright notice | |
25 ;; and this notice must be preserved on all copies. | |
26 | |
791
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
27 ;; Commentary: |
87 | 28 |
29 ;; This package enables you to read mail or articles in MH folders, or | |
30 ;; articles saved by GNUS. In any case, the file names of mail or | |
31 ;; articles must consist of only numeric letters. | |
32 | |
33 ;; Before using this package, you have to create a server specific | |
34 ;; startup file according to the directory which you want to read. For | |
35 ;; example, if you want to read mail under the directory named | |
36 ;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is | |
37 ;; no way to specify hierarchical directory now.) In this case, the | |
38 ;; name of the NNTP server passed to GNUS must be `:Mail'. | |
39 | |
791
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
40 ;; Code: |
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
41 |
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
42 (require 'nntp) |
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
43 |
87 | 44 (defvar mhspool-list-directory-switches '("-R") |
227 | 45 "*Switches for `nntp-request-list' to pass to `ls' for gettting file lists. |
87 | 46 One entry should appear on one line. You may need to add `-1' option.") |
47 | |
48 | |
49 | |
50 (defconst mhspool-version "MHSPOOL 1.5" | |
51 "Version numbers of this version of MHSPOOL.") | |
52 | |
53 (defvar mhspool-spool-directory "~/Mail" | |
54 "Private mail directory.") | |
55 | |
56 (defvar mhspool-current-directory nil | |
57 "Current news group directory.") | |
58 | |
59 ;;; | |
60 ;;; Replacement of Extended Command for retrieving many headers. | |
61 ;;; | |
62 | |
63 (defun mhspool-retrieve-headers (sequence) | |
64 "Return list of article headers specified by SEQUENCE of article id. | |
65 The format of list is | |
66 `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. | |
67 Reader macros for the vector are defined as `nntp-header-FIELD'. | |
68 Writer macros for the vector are defined as `nntp-set-header-FIELD'. | |
69 News group must be selected before calling me." | |
70 (save-excursion | |
71 (set-buffer nntp-server-buffer) | |
72 ;;(erase-buffer) | |
73 (let ((file nil) | |
74 (number (length sequence)) | |
75 (count 0) | |
76 (headers nil) ;Result list. | |
77 (article 0) | |
78 (subject nil) | |
79 (message-id nil) | |
80 (from nil) | |
81 (xref nil) | |
82 (lines 0) | |
83 (date nil) | |
84 (references nil)) | |
85 (while sequence | |
86 ;;(nntp-send-strings-to-server "HEAD" (car sequence)) | |
87 (setq article (car sequence)) | |
88 (setq file | |
89 (concat mhspool-current-directory (prin1-to-string article))) | |
90 (if (and (file-exists-p file) | |
91 (not (file-directory-p file))) | |
92 (progn | |
93 (erase-buffer) | |
94 (insert-file-contents file) | |
95 ;; Make message body invisible. | |
96 (goto-char (point-min)) | |
97 (search-forward "\n\n" nil 'move) | |
98 (narrow-to-region (point-min) (point)) | |
99 ;; Fold continuation lines. | |
100 (goto-char (point-min)) | |
101 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) | |
102 (replace-match " " t t)) | |
103 ;; Make it possible to search for `\nFIELD'. | |
104 (goto-char (point-min)) | |
105 (insert "\n") | |
106 ;; Extract From: | |
107 (goto-char (point-min)) | |
108 (if (search-forward "\nFrom: " nil t) | |
109 (setq from (buffer-substring | |
110 (point) | |
111 (save-excursion (end-of-line) (point)))) | |
112 (setq from "(Unknown User)")) | |
113 ;; Extract Subject: | |
114 (goto-char (point-min)) | |
115 (if (search-forward "\nSubject: " nil t) | |
116 (setq subject (buffer-substring | |
117 (point) | |
118 (save-excursion (end-of-line) (point)))) | |
119 (setq subject "(None)")) | |
120 ;; Extract Message-ID: | |
121 (goto-char (point-min)) | |
122 (if (search-forward "\nMessage-ID: " nil t) | |
123 (setq message-id (buffer-substring | |
124 (point) | |
125 (save-excursion (end-of-line) (point)))) | |
126 (setq message-id nil)) | |
127 ;; Extract Date: | |
128 (goto-char (point-min)) | |
129 (if (search-forward "\nDate: " nil t) | |
130 (setq date (buffer-substring | |
131 (point) | |
132 (save-excursion (end-of-line) (point)))) | |
133 (setq date nil)) | |
134 ;; Extract Lines: | |
135 (goto-char (point-min)) | |
136 (if (search-forward "\nLines: " nil t) | |
137 (setq lines (string-to-int | |
138 (buffer-substring | |
139 (point) | |
140 (save-excursion (end-of-line) (point))))) | |
141 (setq lines 0)) | |
142 ;; Extract Xref: | |
143 (goto-char (point-min)) | |
144 (if (search-forward "\nXref: " nil t) | |
145 (setq xref (buffer-substring | |
146 (point) | |
147 (save-excursion (end-of-line) (point)))) | |
148 (setq xref nil)) | |
149 ;; Extract References: | |
150 ;; If no References: field, use In-Reply-To: field instead. | |
151 ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA). | |
152 (goto-char (point-min)) | |
153 (if (or (search-forward "\nReferences: " nil t) | |
154 (search-forward "\nIn-Reply-To: " nil t)) | |
155 (setq references (buffer-substring | |
156 (point) | |
157 (save-excursion (end-of-line) (point)))) | |
158 (setq references nil)) | |
159 (setq headers | |
160 (cons (vector article subject from | |
161 xref lines date | |
162 message-id references) headers)) | |
163 )) | |
164 (setq sequence (cdr sequence)) | |
165 (setq count (1+ count)) | |
166 (and (numberp nntp-large-newsgroup) | |
167 (> number nntp-large-newsgroup) | |
168 (zerop (% count 20)) | |
169 (message "MHSPOOL: %d%% of headers received." | |
170 (/ (* count 100) number))) | |
171 ) | |
172 (and (numberp nntp-large-newsgroup) | |
173 (> number nntp-large-newsgroup) | |
174 (message "MHSPOOL: 100%% of headers received.")) | |
175 (nreverse headers) | |
176 ))) | |
177 | |
178 | |
179 ;;; | |
180 ;;; Replacement of NNTP Raw Interface. | |
181 ;;; | |
182 | |
183 (defun mhspool-open-server (host &optional service) | |
184 "Open news server on HOST. | |
185 If HOST is nil, use value of environment variable `NNTPSERVER'. | |
186 If optional argument SERVICE is non-nil, open by the service name." | |
187 (let ((host (or host (getenv "NNTPSERVER"))) | |
188 (status nil)) | |
189 ;; Get directory name from HOST name. | |
190 (if (string-match ":\\(.+\\)$" host) | |
191 (progn | |
192 (setq mhspool-spool-directory | |
193 (file-name-as-directory | |
194 (expand-file-name | |
195 (substring host (match-beginning 1) (match-end 1)) | |
196 (expand-file-name "~/" nil)))) | |
197 (setq host (system-name))) | |
198 (setq mhspool-spool-directory nil)) | |
199 (setq nntp-status-message-string "") | |
200 (cond ((and (stringp host) | |
201 (stringp mhspool-spool-directory) | |
202 (file-directory-p mhspool-spool-directory) | |
203 (string-equal host (system-name))) | |
204 (setq status (mhspool-open-server-internal host service))) | |
205 ((string-equal host (system-name)) | |
206 (setq nntp-status-message-string | |
207 (format "No such directory: %s. Goodbye." | |
208 mhspool-spool-directory))) | |
209 ((null host) | |
210 (setq nntp-status-message-string "NNTP server is not specified.")) | |
211 (t | |
212 (setq nntp-status-message-string | |
213 (format "MHSPOOL: cannot talk to %s." host))) | |
214 ) | |
215 status | |
216 )) | |
217 | |
218 (defun mhspool-close-server () | |
219 "Close news server." | |
220 (mhspool-close-server-internal)) | |
221 | |
222 (fset 'mhspool-request-quit (symbol-function 'mhspool-close-server)) | |
223 | |
224 (defun mhspool-server-opened () | |
225 "Return server process status, T or NIL. | |
226 If the stream is opened, return T, otherwise return NIL." | |
227 (and nntp-server-buffer | |
228 (get-buffer nntp-server-buffer))) | |
229 | |
230 (defun mhspool-status-message () | |
231 "Return server status response as string." | |
232 nntp-status-message-string | |
233 ) | |
234 | |
235 (defun mhspool-request-article (id) | |
236 "Select article by message ID (or number)." | |
237 (let ((file (concat mhspool-current-directory (prin1-to-string id)))) | |
238 (if (and (stringp file) | |
239 (file-exists-p file) | |
240 (not (file-directory-p file))) | |
241 (save-excursion | |
242 (mhspool-find-file file))) | |
243 )) | |
244 | |
245 (defun mhspool-request-body (id) | |
246 "Select article body by message ID (or number)." | |
247 (if (mhspool-request-article id) | |
248 (save-excursion | |
249 (set-buffer nntp-server-buffer) | |
250 (goto-char (point-min)) | |
251 (if (search-forward "\n\n" nil t) | |
252 (delete-region (point-min) (point))) | |
253 t | |
254 ) | |
255 )) | |
256 | |
257 (defun mhspool-request-head (id) | |
258 "Select article head by message ID (or number)." | |
259 (if (mhspool-request-article id) | |
260 (save-excursion | |
261 (set-buffer nntp-server-buffer) | |
262 (goto-char (point-min)) | |
263 (if (search-forward "\n\n" nil t) | |
264 (delete-region (1- (point)) (point-max))) | |
265 t | |
266 ) | |
267 )) | |
268 | |
269 (defun mhspool-request-stat (id) | |
270 "Select article by message ID (or number)." | |
271 (error "MHSPOOL: STAT is not implemented.")) | |
272 | |
273 (defun mhspool-request-group (group) | |
274 "Select news GROUP." | |
275 (cond ((file-directory-p | |
276 (mhspool-article-pathname group)) | |
277 ;; Mail/NEWS.GROUP/N | |
278 (setq mhspool-current-directory | |
279 (mhspool-article-pathname group))) | |
280 ((file-directory-p | |
281 (mhspool-article-pathname | |
282 (mhspool-replace-chars-in-string group ?. ?/))) | |
283 ;; Mail/NEWS/GROUP/N | |
284 (setq mhspool-current-directory | |
285 (mhspool-article-pathname | |
286 (mhspool-replace-chars-in-string group ?. ?/)))) | |
287 )) | |
288 | |
289 (defun mhspool-request-list () | |
290 "List valid newsgoups." | |
291 (save-excursion | |
292 (let* ((newsgroup nil) | |
293 (articles nil) | |
294 (directory (file-name-as-directory | |
295 (expand-file-name mhspool-spool-directory nil))) | |
296 (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$")) | |
297 (buffer (get-buffer-create " *GNUS file listing*"))) | |
298 (set-buffer nntp-server-buffer) | |
299 (erase-buffer) | |
300 (set-buffer buffer) | |
301 (erase-buffer) | |
302 (apply 'call-process | |
303 "ls" nil t nil | |
304 (append mhspool-list-directory-switches (list directory))) | |
305 (goto-char (point-min)) | |
306 (while (re-search-forward folder-regexp nil t) | |
307 (setq newsgroup | |
308 (mhspool-replace-chars-in-string | |
309 (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.)) | |
310 (setq articles nil) | |
311 (forward-line 1) ;(beginning-of-line) | |
312 ;; Thank nobu@flab.fujitsu.junet for his bug fixes. | |
313 (while (and (not (eobp)) | |
314 (not (looking-at "^$"))) | |
315 (if (looking-at "^[0-9]+$") | |
316 (setq articles | |
317 (cons (string-to-int | |
318 (buffer-substring | |
319 (match-beginning 0) (match-end 0))) | |
320 articles))) | |
321 (forward-line 1)) | |
322 (if articles | |
323 (princ (format "%s %d %d n\n" newsgroup | |
324 (apply (function max) articles) | |
325 (apply (function min) articles)) | |
326 nntp-server-buffer)) | |
327 ) | |
328 (kill-buffer buffer) | |
329 (set-buffer nntp-server-buffer) | |
330 (buffer-size) | |
331 ))) | |
332 | |
333 (defun mhspool-request-last () | |
227 | 334 "Set current article pointer to the previous article in the current newsgroup." |
87 | 335 (error "MHSPOOL: LAST is not implemented.")) |
336 | |
337 (defun mhspool-request-next () | |
338 "Advance current article pointer." | |
339 (error "MHSPOOL: NEXT is not implemented.")) | |
340 | |
341 (defun mhspool-request-post () | |
342 "Post a new news in current buffer." | |
343 (setq nntp-status-message-string "MHSPOOL: what do you mean post?") | |
344 nil | |
345 ) | |
346 | |
347 | |
348 ;;; | |
349 ;;; Replacement of Low-Level Interface to NNTP Server. | |
350 ;;; | |
351 | |
352 (defun mhspool-open-server-internal (host &optional service) | |
353 "Open connection to news server on HOST by SERVICE (default is nntp)." | |
354 (save-excursion | |
355 (if (not (string-equal host (system-name))) | |
356 (error "MHSPOOL: cannot talk to %s." host)) | |
357 ;; Initialize communication buffer. | |
358 (setq nntp-server-buffer (get-buffer-create " *nntpd*")) | |
359 (set-buffer nntp-server-buffer) | |
360 (buffer-flush-undo (current-buffer)) | |
361 (erase-buffer) | |
362 (kill-all-local-variables) | |
363 (setq case-fold-search t) ;Should ignore case. | |
364 (setq nntp-server-process nil) | |
365 (setq nntp-server-name host) | |
366 ;; It is possible to change kanji-fileio-code in this hook. | |
367 (run-hooks 'nntp-server-hook) | |
368 t | |
369 )) | |
370 | |
371 (defun mhspool-close-server-internal () | |
372 "Close connection to news server." | |
373 (if nntp-server-buffer | |
374 (kill-buffer nntp-server-buffer)) | |
375 (setq nntp-server-buffer nil) | |
376 (setq nntp-server-process nil)) | |
377 | |
378 (defun mhspool-find-file (file) | |
379 "Insert FILE in server buffer safely." | |
380 (set-buffer nntp-server-buffer) | |
381 (erase-buffer) | |
382 (condition-case () | |
383 (progn | |
384 (insert-file-contents file) | |
385 (goto-char (point-min)) | |
386 ;; If there is no body, `^L' appears at end of file. Special | |
387 ;; hack for MH folder. | |
388 (and (search-forward "\n\n" nil t) | |
389 (string-equal (buffer-substring (point) (point-max)) "\^L") | |
390 (delete-char 1)) | |
391 t | |
392 ) | |
393 (file-error nil) | |
394 )) | |
395 | |
396 (defun mhspool-article-pathname (group) | |
397 "Make pathname for GROUP." | |
398 (concat (file-name-as-directory mhspool-spool-directory) group "/")) | |
399 | |
400 (defun mhspool-replace-chars-in-string (string from to) | |
401 "Replace characters in STRING from FROM to TO." | |
402 (let ((string (substring string 0)) ;Copy string. | |
403 (len (length string)) | |
404 (idx 0)) | |
405 ;; Replace all occurence of FROM with TO. | |
406 (while (< idx len) | |
407 (if (= (aref string idx) from) | |
408 (aset string idx to)) | |
409 (setq idx (1+ idx))) | |
410 string | |
411 )) | |
584 | 412 |
413 (provide 'mhspool) | |
659
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
414 |
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
415 ;;; mhspool.el ends here |