Commit | Line | Data |
---|---|---|
6594deb0 ER |
1 | ;;; mhspool.el --- MH folder access using NNTP for GNU Emacs |
2 | ||
b027f415 | 3 | ;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc. |
eea8d4ef | 4 | |
84176303 ER |
5 | ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
6 | ;; Maintainer: FSF | |
fd7fa35a | 7 | ;; Keywords: mail, news |
84176303 | 8 | |
05328297 | 9 | ;; This file is part of GNU Emacs. |
10 | ||
ee3b8d4d RS |
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) | |
14 | ;; any later version. | |
15 | ||
05328297 | 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
ee3b8d4d RS |
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. | |
20 | ||
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. | |
05328297 | 24 | |
aae56ea7 | 25 | ;;; Commentary: |
05328297 | 26 | |
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. | |
30 | ||
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'. | |
37 | ||
aae56ea7 | 38 | ;;; Code: |
84176303 ER |
39 | |
40 | (require 'nntp) | |
41 | ||
b027f415 RS |
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.") | |
50 | ||
05328297 | 51 | (defvar mhspool-list-directory-switches '("-R") |
eb8c3be9 | 52 | "*Switches for mhspool-list-folders-using-ls to pass to `ls' for getting file lists. |
05328297 | 53 | One entry should appear on one line. You may need to add `-1' option.") |
54 | ||
55 | \f | |
56 | ||
b027f415 | 57 | (defconst mhspool-version "MHSPOOL 1.8" |
05328297 | 58 | "Version numbers of this version of MHSPOOL.") |
59 | ||
60 | (defvar mhspool-spool-directory "~/Mail" | |
61 | "Private mail directory.") | |
62 | ||
63 | (defvar mhspool-current-directory nil | |
64 | "Current news group directory.") | |
65 | ||
66 | ;;; | |
67 | ;;; Replacement of Extended Command for retrieving many headers. | |
68 | ;;; | |
69 | ||
70 | (defun mhspool-retrieve-headers (sequence) | |
71 | "Return list of article headers specified by SEQUENCE of article id. | |
72 | The format of list is | |
73 | `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. | |
b027f415 | 74 | If there is no References: field, In-Reply-To: field is used instead. |
05328297 | 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'. | |
b027f415 | 77 | Newsgroup must be selected before calling this." |
05328297 | 78 | (save-excursion |
79 | (set-buffer nntp-server-buffer) | |
80 | ;;(erase-buffer) | |
81 | (let ((file nil) | |
82 | (number (length sequence)) | |
83 | (count 0) | |
84 | (headers nil) ;Result list. | |
85 | (article 0) | |
86 | (subject nil) | |
87 | (message-id nil) | |
88 | (from nil) | |
89 | (xref nil) | |
90 | (lines 0) | |
91 | (date nil) | |
92 | (references nil)) | |
93 | (while sequence | |
94 | ;;(nntp-send-strings-to-server "HEAD" (car sequence)) | |
95 | (setq article (car sequence)) | |
96 | (setq file | |
97 | (concat mhspool-current-directory (prin1-to-string article))) | |
98 | (if (and (file-exists-p file) | |
99 | (not (file-directory-p file))) | |
100 | (progn | |
101 | (erase-buffer) | |
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)) | |
113 | (insert "\n") | |
114 | ;; Extract From: | |
115 | (goto-char (point-min)) | |
116 | (if (search-forward "\nFrom: " nil t) | |
117 | (setq from (buffer-substring | |
118 | (point) | |
119 | (save-excursion (end-of-line) (point)))) | |
120 | (setq from "(Unknown User)")) | |
121 | ;; Extract Subject: | |
122 | (goto-char (point-min)) | |
123 | (if (search-forward "\nSubject: " nil t) | |
124 | (setq subject (buffer-substring | |
125 | (point) | |
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 | |
132 | (point) | |
133 | (save-excursion (end-of-line) (point)))) | |
134 | (setq message-id nil)) | |
135 | ;; Extract Date: | |
136 | (goto-char (point-min)) | |
137 | (if (search-forward "\nDate: " nil t) | |
138 | (setq date (buffer-substring | |
139 | (point) | |
140 | (save-excursion (end-of-line) (point)))) | |
141 | (setq date nil)) | |
142 | ;; Extract Lines: | |
143 | (goto-char (point-min)) | |
144 | (if (search-forward "\nLines: " nil t) | |
145 | (setq lines (string-to-int | |
146 | (buffer-substring | |
147 | (point) | |
148 | (save-excursion (end-of-line) (point))))) | |
b027f415 RS |
149 | ;; Count lines since there is no lines field in most cases. |
150 | (setq lines | |
151 | (save-restriction | |
152 | (goto-char (point-max)) | |
153 | (widen) | |
154 | (count-lines (point) (point-max))))) | |
05328297 | 155 | ;; Extract Xref: |
156 | (goto-char (point-min)) | |
157 | (if (search-forward "\nXref: " nil t) | |
158 | (setq xref (buffer-substring | |
159 | (point) | |
160 | (save-excursion (end-of-line) (point)))) | |
161 | (setq xref nil)) | |
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 | |
169 | (point) | |
170 | (save-excursion (end-of-line) (point)))) | |
171 | (setq references nil)) | |
b027f415 RS |
172 | ;; Collect valid article only. |
173 | (and article | |
174 | message-id | |
175 | (setq headers | |
176 | (cons (vector article subject from | |
177 | xref lines date | |
178 | message-id references) headers))) | |
05328297 | 179 | )) |
180 | (setq sequence (cdr sequence)) | |
181 | (setq count (1+ count)) | |
182 | (and (numberp nntp-large-newsgroup) | |
183 | (> number nntp-large-newsgroup) | |
184 | (zerop (% count 20)) | |
b027f415 | 185 | (message "MHSPOOL: Receiving headers... %d%%" |
05328297 | 186 | (/ (* count 100) number))) |
187 | ) | |
188 | (and (numberp nntp-large-newsgroup) | |
189 | (> number nntp-large-newsgroup) | |
b027f415 | 190 | (message "MHSPOOL: Receiving headers... done")) |
05328297 | 191 | (nreverse headers) |
192 | ))) | |
193 | ||
194 | \f | |
195 | ;;; | |
196 | ;;; Replacement of NNTP Raw Interface. | |
197 | ;;; | |
198 | ||
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"))) | |
204 | (status nil)) | |
205 | ;; Get directory name from HOST name. | |
206 | (if (string-match ":\\(.+\\)$" host) | |
207 | (progn | |
208 | (setq mhspool-spool-directory | |
209 | (file-name-as-directory | |
210 | (expand-file-name | |
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)) | |
b027f415 | 215 | (setq nntp-status-string "") |
05328297 | 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)) | |
b027f415 | 222 | (setq nntp-status-string |
05328297 | 223 | (format "No such directory: %s. Goodbye." |
224 | mhspool-spool-directory))) | |
225 | ((null host) | |
b027f415 | 226 | (setq nntp-status-string "NNTP server is not specified.")) |
05328297 | 227 | (t |
b027f415 | 228 | (setq nntp-status-string |
05328297 | 229 | (format "MHSPOOL: cannot talk to %s." host))) |
230 | ) | |
231 | status | |
232 | )) | |
233 | ||
234 | (defun mhspool-close-server () | |
235 | "Close news server." | |
236 | (mhspool-close-server-internal)) | |
237 | ||
238 | (fset 'mhspool-request-quit (symbol-function 'mhspool-close-server)) | |
239 | ||
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))) | |
245 | ||
246 | (defun mhspool-status-message () | |
247 | "Return server status response as string." | |
b027f415 | 248 | nntp-status-string |
05328297 | 249 | ) |
250 | ||
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) | |
255 | (file-exists-p file) | |
256 | (not (file-directory-p file))) | |
257 | (save-excursion | |
258 | (mhspool-find-file file))) | |
259 | )) | |
260 | ||
261 | (defun mhspool-request-body (id) | |
262 | "Select article body by message ID (or number)." | |
263 | (if (mhspool-request-article id) | |
264 | (save-excursion | |
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))) | |
269 | t | |
270 | ) | |
271 | )) | |
272 | ||
273 | (defun mhspool-request-head (id) | |
274 | "Select article head by message ID (or number)." | |
275 | (if (mhspool-request-article id) | |
276 | (save-excursion | |
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))) | |
281 | t | |
282 | ) | |
283 | )) | |
284 | ||
285 | (defun mhspool-request-stat (id) | |
286 | "Select article by message ID (or number)." | |
b027f415 RS |
287 | (setq nntp-status-string "MHSPOOL: STAT is not implemented.") |
288 | nil | |
289 | ) | |
05328297 | 290 | |
291 | (defun mhspool-request-group (group) | |
292 | "Select news GROUP." | |
293 | (cond ((file-directory-p | |
294 | (mhspool-article-pathname group)) | |
295 | ;; Mail/NEWS.GROUP/N | |
296 | (setq mhspool-current-directory | |
297 | (mhspool-article-pathname group))) | |
298 | ((file-directory-p | |
299 | (mhspool-article-pathname | |
300 | (mhspool-replace-chars-in-string group ?. ?/))) | |
301 | ;; Mail/NEWS/GROUP/N | |
302 | (setq mhspool-current-directory | |
303 | (mhspool-article-pathname | |
304 | (mhspool-replace-chars-in-string group ?. ?/)))) | |
305 | )) | |
306 | ||
307 | (defun mhspool-request-list () | |
b027f415 | 308 | "List active newsgoups." |
05328297 | 309 | (save-excursion |
310 | (let* ((newsgroup nil) | |
311 | (articles nil) | |
312 | (directory (file-name-as-directory | |
313 | (expand-file-name mhspool-spool-directory nil))) | |
314 | (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$")) | |
b027f415 | 315 | (buffer (get-buffer-create " *MHSPOOL File List*"))) |
05328297 | 316 | (set-buffer nntp-server-buffer) |
317 | (erase-buffer) | |
318 | (set-buffer buffer) | |
319 | (erase-buffer) | |
b027f415 RS |
320 | ;; (apply 'call-process |
321 | ;; "ls" nil t nil | |
322 | ;; (append mhspool-list-directory-switches (list directory))) | |
323 | (funcall mhspool-list-folders-method directory) | |
05328297 | 324 | (goto-char (point-min)) |
325 | (while (re-search-forward folder-regexp nil t) | |
326 | (setq newsgroup | |
327 | (mhspool-replace-chars-in-string | |
328 | (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.)) | |
329 | (setq articles nil) | |
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]+$") | |
335 | (setq articles | |
336 | (cons (string-to-int | |
337 | (buffer-substring | |
338 | (match-beginning 0) (match-end 0))) | |
339 | articles))) | |
340 | (forward-line 1)) | |
341 | (if articles | |
342 | (princ (format "%s %d %d n\n" newsgroup | |
343 | (apply (function max) articles) | |
344 | (apply (function min) articles)) | |
345 | nntp-server-buffer)) | |
346 | ) | |
347 | (kill-buffer buffer) | |
348 | (set-buffer nntp-server-buffer) | |
349 | (buffer-size) | |
350 | ))) | |
351 | ||
b027f415 RS |
352 | (defun mhspool-request-list-newsgroups () |
353 | "List newsgoups (defined in NNTP2)." | |
354 | (setq nntp-status-string "MHSPOOL: LIST NEWSGROUPS is not implemented.") | |
355 | nil | |
356 | ) | |
357 | ||
358 | (defun mhspool-request-list-distributions () | |
359 | "List distributions (defined in NNTP2)." | |
360 | (setq nntp-status-string "MHSPOOL: LIST DISTRIBUTIONS is not implemented.") | |
361 | nil | |
362 | ) | |
363 | ||
05328297 | 364 | (defun mhspool-request-last () |
b027f415 RS |
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.") | |
368 | nil | |
369 | ) | |
05328297 | 370 | |
371 | (defun mhspool-request-next () | |
372 | "Advance current article pointer." | |
b027f415 RS |
373 | (setq nntp-status-string "MHSPOOL: NEXT is not implemented.") |
374 | nil | |
375 | ) | |
05328297 | 376 | |
377 | (defun mhspool-request-post () | |
378 | "Post a new news in current buffer." | |
b027f415 | 379 | (setq nntp-status-string "MHSPOOL: POST: what do you mean?") |
05328297 | 380 | nil |
381 | ) | |
382 | ||
383 | \f | |
384 | ;;; | |
385 | ;;; Replacement of Low-Level Interface to NNTP Server. | |
386 | ;;; | |
387 | ||
388 | (defun mhspool-open-server-internal (host &optional service) | |
389 | "Open connection to news server on HOST by SERVICE (default is nntp)." | |
390 | (save-excursion | |
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)) | |
397 | (erase-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) | |
404 | t | |
405 | )) | |
406 | ||
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)) | |
413 | ||
414 | (defun mhspool-find-file (file) | |
415 | "Insert FILE in server buffer safely." | |
416 | (set-buffer nntp-server-buffer) | |
417 | (erase-buffer) | |
418 | (condition-case () | |
419 | (progn | |
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") | |
426 | (delete-char 1)) | |
427 | t | |
428 | ) | |
429 | (file-error nil) | |
430 | )) | |
431 | ||
432 | (defun mhspool-article-pathname (group) | |
433 | "Make pathname for GROUP." | |
434 | (concat (file-name-as-directory mhspool-spool-directory) group "/")) | |
435 | ||
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)) | |
440 | (idx 0)) | |
eb8c3be9 | 441 | ;; Replace all occurrences of FROM with TO. |
05328297 | 442 | (while (< idx len) |
443 | (if (= (aref string idx) from) | |
444 | (aset string idx to)) | |
445 | (setq idx (1+ idx))) | |
446 | string | |
447 | )) | |
49116ac0 | 448 | |
b027f415 RS |
449 | \f |
450 | ;; Methods for listing files in folders. | |
451 | ||
452 | (defun mhspool-list-folders-using-ls (directory) | |
453 | "List files in folders under DIRECTORY using 'ls'." | |
454 | (apply 'call-process | |
455 | "ls" nil t nil | |
456 | (append mhspool-list-directory-switches (list directory)))) | |
457 | ||
458 | ;; Basic ideas by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA) | |
459 | ||
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*"))) | |
464 | (save-excursion | |
465 | (save-restriction | |
466 | (set-buffer script) | |
467 | (erase-buffer) | |
468 | ;; /bin/sh script which does 'ls -R'. | |
469 | (insert | |
470 | "PS2= | |
471 | ffind() { | |
472 | cd $1; echo $1: | |
473 | ls -1 | |
474 | echo | |
475 | for j in `echo *[a-zA-Z]*` | |
476 | do | |
477 | if [ -d $1/$j ]; then | |
478 | ffind $1/$j | |
479 | fi | |
480 | done | |
481 | } | |
482 | cd " directory "; ffind `pwd`; exit 0\n") | |
483 | (call-process-region (point-min) (point-max) "sh" nil buffer nil) | |
484 | )) | |
485 | (kill-buffer script) | |
486 | )) | |
487 | ||
49116ac0 | 488 | (provide 'mhspool) |
6594deb0 ER |
489 | |
490 | ;;; mhspool.el ends here |