1;;; mhspool.el --- MH folder access using NNTP for GNU Emacs 2 3;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc. 4 5;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 6;; Maintainer: FSF 7;; Keywords: mail, news 8 9;; This file is part of GNU Emacs. 10 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 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. 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. 24 25;;; Commentary: 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 38;;; Code: 39 40(require 'nntp) 41 42(defvar mhspool-list-folders-method 43 (function mhspool-list-folders-using-sh) 44 "*Function to list files in folders. 45The function should accept a directory as its argument, and fill the 46current buffer with file and directory names. The output format must 47be the same as that of 'ls -R1'. Two functions 48mhspool-list-folders-using-ls and mhspool-list-folders-using-sh are 49provided now. I suppose the later is faster.") 50 51(defvar mhspool-list-directory-switches '("-R") 52 "*Switches for mhspool-list-folders-using-ls to pass to `ls' for getting file lists. 53One entry should appear on one line. You may need to add `-1' option.") 54 55 56 57(defconst mhspool-version "MHSPOOL 1.8" 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. 72The format of list is 73 `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. 74If there is no References: field, In-Reply-To: field is used instead. 75Reader macros for the vector are defined as `nntp-header-FIELD'. 76Writer macros for the vector are defined as `nntp-set-header-FIELD'. 77Newsgroup must be selected before calling this." 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))))) 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))))) 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)) 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))) 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)) 185 (message "MHSPOOL: Receiving headers... %d%%" 186 (/ (* count 100) number))) 187 ) 188 (and (numberp nntp-large-newsgroup) 189 (> number nntp-large-newsgroup) 190 (message "MHSPOOL: Receiving headers... done")) 191 (nreverse headers) 192 ))) 193 194 195;;; 196;;; Replacement of NNTP Raw Interface. 197;;; 198 199(defun mhspool-open-server (host &optional service) 200 "Open news server on HOST. 201If HOST is nil, use value of environment variable `NNTPSERVER'. 202If 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)) 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))) 225 ((null host) 226 (setq nntp-status-string "NNTP server is not specified.")) 227 (t 228 (setq nntp-status-string 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. 242If 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." 248 nntp-status-string 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)." 287 (setq nntp-status-string "MHSPOOL: STAT is not implemented.") 288 nil 289 ) 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 () 308 "List active newsgoups." 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) "\\(.+\\):$")) 315 (buffer (get-buffer-create " *MHSPOOL File List*"))) 316 (set-buffer nntp-server-buffer) 317 (erase-buffer) 318 (set-buffer buffer) 319 (erase-buffer) 320;; (apply 'call-process 321;; "ls" nil t nil 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) 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 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 364(defun mhspool-request-last () 365 "Set current article pointer to the previous article 366in the current news group." 367 (setq nntp-status-string "MHSPOOL: LAST is not implemented.") 368 nil 369 ) 370 371(defun mhspool-request-next () 372 "Advance current article pointer." 373 (setq nntp-status-string "MHSPOOL: NEXT is not implemented.") 374 nil 375 ) 376 377(defun mhspool-request-post () 378 "Post a new news in current buffer." 379 (setq nntp-status-string "MHSPOOL: POST: what do you mean?") 380 nil 381 ) 382 383 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)) 441 ;; Replace all occurrences of FROM with TO. 442 (while (< idx len) 443 (if (= (aref string idx) from) 444 (aset string idx to)) 445 (setq idx (1+ idx))) 446 string 447 )) 448 449 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 488(provide 'mhspool) 489 490;;; mhspool.el ends here 491