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