home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / gnus / mhspool.el < prev    next >
Encoding:
Text File  |  1995-03-25  |  17.3 KB  |  550 lines

  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 XEmacs.
  10.  
  11. ;; XEmacs is free software; you can redistribute it and/or modify it
  12. ;; 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. ;; XEmacs is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23. ;; 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.
  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.  
  51. (defvar mhspool-list-directory-switches '("-R")
  52.   "*Switches for mhspool-list-folders-using-ls to pass to `ls' for getting file lists.
  53. One entry should appear on one line. You may need to add `-1' option.")
  54.  
  55. ;;; XEmacs addition: from Rick Sladkey <jrs@world.std.com>
  56. (defvar mhspool-retrieve-headers-method
  57.   (function mhspool-retrieve-headers-using-emacs-lisp)
  58.   "*Function to retrieve headers from articles in an mhspool
  59. directory.  The function accepts a list of articles to retrieve the
  60. headers from where the articles are located in the directory
  61. mhspool-current-directory.  Two functions
  62. mhspool-retrieve-headers-using-emacs-lisp and
  63. mhspool-retrieve-headers-using-gnushdrs are provided now.  For the
  64. latter mhspool-retrieve-headers-gnushdrs-program specifies the name
  65. of the program to execute (which see).")
  66.  
  67. ;;; XEmacs addition: from Rick Sladkey <jrs@world.std.com>
  68. (defvar mhspool-retrieve-headers-gnushdrs-program "gnushdrs"
  69.   "*The name of a program used to retrieve headers from articles when
  70. mhspool-retrieve-headers-method is set to
  71. mhspool-retrieve-headers-using-gnushdrs.  The program takes a directory
  72. as it first argument and the files to retrieve articles from as the
  73. rest of its arguments.  It must produce on its standard output an
  74. emacs lisp expression in the same format as the value of
  75. mhspool-retrieve-headers (which see).")
  76.  
  77.  
  78.  
  79. (defconst mhspool-version "MHSPOOL 1.8"
  80.   "Version numbers of this version of MHSPOOL.")
  81.  
  82. (defvar mhspool-spool-directory "~/Mail"
  83.   "Private mail directory.")
  84.  
  85. (defvar mhspool-current-directory nil
  86.   "Current news group directory.")
  87.  
  88. ;;;
  89. ;;; Replacement of Extended Command for retrieving many headers.
  90. ;;;
  91.  
  92. (defvar mhspool-article-header-read-size 1024
  93.   "Number of bytes to read when processing headers from MHSPOOL.")
  94.  
  95. ;;; XEmacs change: from Chris Davis <ckd@kei.com>
  96. ;;; UNIMPLEMENTED!  Probably can be implemented based on 
  97. ;;; mhspool-find-article-by-message-id (you may need to fiddle
  98. ;;; together a "history file" for MH archives)
  99. (defun mhspool-retrieve-headers-by-id (message-id)
  100.   "UNIMPLEMENTED.  Should return same things mhspool-retrieve-headers does."
  101.   (error "Unimplemented function, sorry."))
  102.  
  103. ;;; XEmacs change: from Rick Sladkey <jrs@world.std.com>
  104. (defun mhspool-retrieve-headers (sequence)
  105.   "Return list of article headers specified by SEQUENCE of article id.
  106. The format of list is
  107.  `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
  108. If there is no References: field, In-Reply-To: field is used instead.
  109. Reader macros for the vector are defined as `nntp-header-FIELD'.
  110. Writer macros for the vector are defined as `nntp-set-header-FIELD'.
  111. Newsgroup must be selected before calling this."
  112.   (funcall mhspool-retrieve-headers-method sequence))
  113.  
  114. (defun mhspool-retrieve-headers-using-gnushdrs (sequence)
  115.   "A method for mhspool-retrieve-headers that uses the program gnushdrs."
  116.   (save-excursion
  117.     (let ((msg (and (numberp nntp-large-newsgroup)
  118.             (> (length sequence) nntp-large-newsgroup))))
  119.       (set-buffer nntp-server-buffer)
  120.       (erase-buffer)
  121.       (let ((process-connection-type nil))
  122.     (apply 'call-process mhspool-retrieve-headers-gnushdrs-program
  123.            nil t nil mhspool-current-directory
  124.            (mapcar 'int-to-string sequence))
  125.     (and msg (message "MHSPOOL: parsing headers..."))
  126.     (goto-char (point-min))
  127.     (prog1
  128.         (read nntp-server-buffer)
  129.       (erase-buffer)
  130.       (and msg (message "MHSPOOL: parsing headers...done.")))))))
  131.  
  132. (defun mhspool-retrieve-headers-using-emacs-lisp (sequence)
  133.   "A method for mhspool-retrieve-headers that only uses Emacs Lisp."
  134.   (save-excursion
  135.     (set-buffer nntp-server-buffer)
  136.     ;;(erase-buffer)
  137.     (let ((file nil)
  138.       (number (length sequence))
  139.       (count 0)
  140.       (headers nil)            ;Result list.
  141.       (article 0)
  142.       (subject nil)
  143.       (message-id nil)
  144.       (from nil)
  145.       (xref nil)
  146.       (lines 0)
  147.       (date nil)
  148.       (references nil))
  149.       (while sequence
  150.     ;;(nntp-send-strings-to-server "HEAD" (car sequence))
  151.     (setq article (car sequence))
  152.     (setq file
  153.           (concat mhspool-current-directory (prin1-to-string article)))
  154.     (if (and (file-exists-p file)
  155.          (not (file-directory-p file)))
  156.         (progn
  157.           (erase-buffer)
  158.           (insert-file-contents file
  159.                     nil 0 mhspool-article-header-read-size)
  160.           ;; Make message body invisible.
  161.           (goto-char (point-min))
  162.           (search-forward "\n\n" nil 'move)
  163.           (narrow-to-region (point-min) (point))
  164.           ;; Fold continuation lines.
  165.           (goto-char (point-min))
  166.           (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
  167.         (replace-match " " t t))
  168.           ;; Make it possible to search for `\nFIELD'.
  169.           (goto-char (point-min))
  170.           (insert "\n")
  171.           ;; Extract From:
  172.           (goto-char (point-min))
  173.           (if (search-forward "\nFrom: " nil t)
  174.           (setq from (buffer-substring
  175.                   (point)
  176.                   (save-excursion (end-of-line) (point))))
  177.         (setq from "(Unknown User)"))
  178.           ;; Extract Subject:
  179.           (goto-char (point-min))
  180.           (if (search-forward "\nSubject: " nil t)
  181.           (setq subject (buffer-substring
  182.                  (point)
  183.                  (save-excursion (end-of-line) (point))))
  184.         (setq subject "(None)"))
  185.           ;; Extract Message-ID:
  186.           (goto-char (point-min))
  187.           (if (search-forward "\nMessage-ID: " nil t)
  188.           (setq message-id (buffer-substring
  189.                     (point)
  190.                     (save-excursion (end-of-line) (point))))
  191.         (setq message-id nil))
  192.           ;; Extract Date:
  193.           (goto-char (point-min))
  194.           (if (search-forward "\nDate: " nil t)
  195.           (setq date (buffer-substring
  196.                   (point)
  197.                   (save-excursion (end-of-line) (point))))
  198.         (setq date nil))
  199.           ;; Extract Lines:
  200.           (goto-char (point-min))
  201.           (if (search-forward "\nLines: " nil t)
  202.           (setq lines (string-to-int
  203.                    (buffer-substring
  204.                 (point)
  205.                 (save-excursion (end-of-line) (point)))))
  206.         ;; Count lines since there is no lines field in most cases.
  207.         (setq lines
  208.               (save-restriction
  209.             (goto-char (point-max))
  210.             (widen)
  211.             (count-lines (point) (point-max)))))
  212.           ;; Extract Xref:
  213.           (goto-char (point-min))
  214.           (if (search-forward "\nXref: " nil t)
  215.           (setq xref (buffer-substring
  216.                   (point)
  217.                   (save-excursion (end-of-line) (point))))
  218.         (setq xref nil))
  219.           ;; Extract References:
  220.           ;; If no References: field, use In-Reply-To: field instead.
  221.           ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA).
  222.           (goto-char (point-min))
  223.           (if (or (search-forward "\nReferences: " nil t)
  224.               (search-forward "\nIn-Reply-To: " nil t))
  225.           (setq references (buffer-substring
  226.                     (point)
  227.                     (save-excursion (end-of-line) (point))))
  228.         (setq references nil))
  229.           ;; Collect valid article only.
  230.           (and article
  231.            message-id
  232.            (setq headers
  233.              (cons (vector article subject from
  234.                        xref lines date
  235.                        message-id references) headers)))
  236.           ))
  237.     (setq sequence (cdr sequence))
  238.     (setq count (1+ count))
  239.     (and (numberp nntp-large-newsgroup)
  240.          (> number nntp-large-newsgroup)
  241.          (zerop (% count 20))
  242.          (message "MHSPOOL: Receiving headers... %d%%"
  243.               (/ (* count 100) number)))
  244.     )
  245.       (and (numberp nntp-large-newsgroup)
  246.        (> number nntp-large-newsgroup)
  247.        (message "MHSPOOL: Receiving headers... done"))
  248.       (nreverse headers)
  249.       )))
  250.  
  251.  
  252. ;;;
  253. ;;; Replacement of NNTP Raw Interface.
  254. ;;;
  255.  
  256. (defun mhspool-open-server (host &optional service)
  257.   "Open news server on HOST.
  258. If HOST is nil, use value of environment variable `NNTPSERVER'.
  259. If optional argument SERVICE is non-nil, open by the service name."
  260.   (let ((host (or host (getenv "NNTPSERVER")))
  261.     (status nil))
  262.     ;; Get directory name from HOST name.
  263.     (if (string-match ":\\(.+\\)$" host)
  264.     (progn
  265.       (setq mhspool-spool-directory
  266.         (file-name-as-directory
  267.          (expand-file-name
  268.           (substring host (match-beginning 1) (match-end 1))
  269.           (expand-file-name "~/" nil))))
  270.       (setq host (system-name)))
  271.       (setq mhspool-spool-directory nil))
  272.     (setq nntp-status-string "")
  273.     (cond ((and (stringp host)
  274.         (stringp mhspool-spool-directory)
  275.         (file-directory-p mhspool-spool-directory)
  276.         (string-equal host (system-name)))
  277.        (setq status (mhspool-open-server-internal host service)))
  278.       ((string-equal host (system-name))
  279.        (setq nntp-status-string
  280.          (format "No such directory: %s.  Goodbye."
  281.              mhspool-spool-directory)))
  282.       ((null host)
  283.        (setq nntp-status-string "NNTP server is not specified."))
  284.       (t
  285.        (setq nntp-status-string
  286.          (format "MHSPOOL: cannot talk to %s." host)))
  287.       )
  288.     status
  289.     ))
  290.  
  291. (defun mhspool-close-server ()
  292.   "Close news server."
  293.   (mhspool-close-server-internal))
  294.  
  295. (fset 'mhspool-request-quit (symbol-function 'mhspool-close-server))
  296.  
  297. (defun mhspool-server-opened ()
  298.   "Return server process status, T or NIL.
  299. If the stream is opened, return T, otherwise return NIL."
  300.   (and nntp-server-buffer
  301.        (get-buffer nntp-server-buffer)))
  302.  
  303. (defun mhspool-status-message ()
  304.   "Return server status response as string."
  305.   nntp-status-string
  306.   )
  307.  
  308. (defun mhspool-request-article (id)
  309.   "Select article by message ID (or number)."
  310.   (let ((file (concat mhspool-current-directory (prin1-to-string id))))
  311.     (if (and (stringp file)
  312.          (file-exists-p file)
  313.          (not (file-directory-p file)))
  314.     (save-excursion
  315.       (mhspool-find-file file)))
  316.     ))
  317.  
  318. (defun mhspool-request-body (id)
  319.   "Select article body by message ID (or number)."
  320.   (if (mhspool-request-article id)
  321.       (save-excursion
  322.     (set-buffer nntp-server-buffer)
  323.     (goto-char (point-min))
  324.     (if (search-forward "\n\n" nil t)
  325.         (delete-region (point-min) (point)))
  326.     t
  327.     )
  328.     ))
  329.  
  330. (defun mhspool-request-head (id)
  331.   "Select article head by message ID (or number)."
  332.   (if (mhspool-request-article id)
  333.       (save-excursion
  334.     (set-buffer nntp-server-buffer)
  335.     (goto-char (point-min))
  336.     (if (search-forward "\n\n" nil t)
  337.         (delete-region (1- (point)) (point-max)))
  338.     t
  339.     )
  340.     ))
  341.  
  342. (defun mhspool-request-stat (id)
  343.   "Select article by message ID (or number)."
  344.   (setq nntp-status-string "MHSPOOL: STAT is not implemented.")
  345.   nil
  346.   )
  347.  
  348. (defun mhspool-request-group (group)
  349.   "Select news GROUP."
  350.   (cond ((file-directory-p
  351.       (mhspool-article-pathname group))
  352.      ;; Mail/NEWS.GROUP/N
  353.      (setq mhspool-current-directory
  354.            (mhspool-article-pathname group)))
  355.     ((file-directory-p
  356.       (mhspool-article-pathname
  357.        (mhspool-replace-chars-in-string group ?. ?/)))
  358.      ;; Mail/NEWS/GROUP/N
  359.      (setq mhspool-current-directory
  360.            (mhspool-article-pathname
  361.         (mhspool-replace-chars-in-string group ?. ?/))))
  362.     ))
  363.  
  364. (defun mhspool-request-list ()
  365.   "List active newsgoups."
  366.   (save-excursion
  367.     (let* ((newsgroup nil)
  368.        (articles nil)
  369.        (directory (file-name-as-directory
  370.                (expand-file-name mhspool-spool-directory nil)))
  371.        (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$"))
  372.        (buffer (get-buffer-create " *MHSPOOL File List*")))
  373.       (set-buffer nntp-server-buffer)
  374.       (erase-buffer)
  375.       (set-buffer buffer)
  376.       (erase-buffer)
  377. ;;      (apply 'call-process
  378. ;;         "ls" nil t nil
  379. ;;         (append mhspool-list-directory-switches (list directory)))
  380.       (funcall mhspool-list-folders-method directory)
  381.       (goto-char (point-min))
  382.       (while (re-search-forward folder-regexp nil t)
  383.     (setq newsgroup
  384.           (mhspool-replace-chars-in-string
  385.            (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.))
  386.     (setq articles nil)
  387.     (forward-line 1)        ;(beginning-of-line)
  388.     ;; Thank nobu@flab.fujitsu.junet for his bug fixes.
  389.     (while (and (not (eobp))
  390.             (not (looking-at "^$")))
  391.       (if (looking-at "^[0-9]+$")
  392.           (setq articles
  393.             (cons (string-to-int
  394.                (buffer-substring
  395.                 (match-beginning 0) (match-end 0)))
  396.               articles)))
  397.       (forward-line 1))
  398.     (if articles
  399.         (princ (format "%s %d %d n\n" newsgroup
  400.                (apply (function max) articles)
  401.                (apply (function min) articles))
  402.            nntp-server-buffer))
  403.     )
  404.       (kill-buffer buffer)
  405.       (set-buffer nntp-server-buffer)
  406.       (buffer-size)
  407.       )))
  408.  
  409. (defun mhspool-request-list-newsgroups ()
  410.   "List newsgoups (defined in NNTP2)."
  411.   (setq nntp-status-string "MHSPOOL: LIST NEWSGROUPS is not implemented.")
  412.   nil
  413.   )
  414.  
  415. (defun mhspool-request-list-distributions ()
  416.   "List distributions (defined in NNTP2)."
  417.   (setq nntp-status-string "MHSPOOL: LIST DISTRIBUTIONS is not implemented.")
  418.   nil
  419.   )
  420.  
  421. (defun mhspool-request-last ()
  422.   "Set current article pointer to the previous article
  423. in the current news group."
  424.   (setq nntp-status-string "MHSPOOL: LAST is not implemented.")
  425.   nil
  426.   )
  427.  
  428. (defun mhspool-request-next ()
  429.   "Advance current article pointer."
  430.   (setq nntp-status-string "MHSPOOL: NEXT is not implemented.")
  431.   nil
  432.   )
  433.  
  434. (defun mhspool-request-post ()
  435.   "Post a new news in current buffer."
  436.   (setq nntp-status-string "MHSPOOL: POST: what do you mean?")
  437.   nil
  438.   )
  439.  
  440.  
  441. ;;;
  442. ;;; Replacement of Low-Level Interface to NNTP Server.
  443. ;;; 
  444.  
  445. (defun mhspool-open-server-internal (host &optional service)
  446.   "Open connection to news server on HOST by SERVICE (default is nntp)."
  447.   (save-excursion
  448.     (if (not (string-equal host (system-name)))
  449.     (error "MHSPOOL: cannot talk to %s." host))
  450.     ;; Initialize communication buffer.
  451.     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
  452.     (set-buffer nntp-server-buffer)
  453.     (buffer-disable-undo (current-buffer))
  454.     (erase-buffer)
  455.     (kill-all-local-variables)
  456.     (setq case-fold-search t)        ;Should ignore case.
  457.     (if (boundp 'nntp-server-process)
  458.     (setq nntp-server-process nil))
  459.     (setq nntp-server-name host)
  460.     ;; It is possible to change kanji-fileio-code in this hook.
  461.     (run-hooks 'nntp-server-hook)
  462.     t
  463.     ))
  464.  
  465. (defun mhspool-close-server-internal ()
  466.   "Close connection to news server."
  467.   (if nntp-server-buffer
  468.       (kill-buffer nntp-server-buffer))
  469.   (setq nntp-server-buffer nil)
  470.   (if (boundp 'nntp-server-process)
  471.       (setq nntp-server-process nil)))
  472.  
  473. (defun mhspool-find-file (file)
  474.   "Insert FILE in server buffer safely."
  475.   (set-buffer nntp-server-buffer)
  476.   (erase-buffer)
  477.   (condition-case ()
  478.       (progn
  479.     (insert-file-contents file)
  480.     (goto-char (point-min))
  481.     ;; If there is no body, `^L' appears at end of file. Special
  482.     ;; hack for MH folder.
  483.     (and (search-forward "\n\n" nil t)
  484.          (string-equal (buffer-substring (point) (point-max)) "\^L")
  485.          (delete-char 1))
  486.     t
  487.     )
  488.     (file-error nil)
  489.     ))
  490.  
  491. (defun mhspool-article-pathname (group)
  492.   "Make pathname for GROUP."
  493.   (concat (file-name-as-directory mhspool-spool-directory) group "/"))
  494.  
  495. (defun mhspool-replace-chars-in-string (string from to)
  496.   "Replace characters in STRING from FROM to TO."
  497.   (let ((string (substring string 0))    ;Copy string.
  498.     (len (length string))
  499.     (idx 0))
  500.     ;; Replace all occurrences of FROM with TO.
  501.     (while (< idx len)
  502.       (if (= (aref string idx) from)
  503.       (aset string idx to))
  504.       (setq idx (1+ idx)))
  505.     string
  506.     ))
  507.  
  508.  
  509. ;; Methods for listing files in folders.
  510.  
  511. (defun mhspool-list-folders-using-ls (directory)
  512.   "List files in folders under DIRECTORY using 'ls'."
  513.   (apply 'call-process
  514.      "ls" nil t nil
  515.      (append mhspool-list-directory-switches (list directory))))
  516.  
  517. ;; Basic ideas by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA)
  518.  
  519. (defun mhspool-list-folders-using-sh (directory)
  520.   "List files in folders under DIRECTORY using '/bin/sh'."
  521.   (let ((buffer (current-buffer))
  522.     (script (get-buffer-create " *MHSPOOL Shell Script Buffer*")))
  523.     (save-excursion
  524.       (save-restriction
  525.     (set-buffer script)
  526.     (erase-buffer)
  527.     ;; /bin/sh script which does 'ls -R'.
  528.     (insert
  529.      "PS2=
  530.           ffind() {
  531.         cd $1; echo $1:
  532.         ls -1
  533.         echo
  534.         for j in `echo *[a-zA-Z]*`
  535.         do
  536.           if [ -d $1/$j ]; then
  537.             ffind $1/$j
  538.           fi
  539.         done
  540.       }
  541.       cd " directory "; ffind `pwd`; exit 0\n")
  542.     (call-process-region (point-min) (point-max) "sh" nil buffer nil)
  543.     ))
  544.     (kill-buffer script)
  545.     ))
  546.  
  547. (provide 'mhspool)
  548.  
  549. ;;; mhspool.el ends here
  550.