home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 31 / CDASC_31_1996_juillet_aout.iso / vrac_os2 / e31el3.zip / EMACS / 19.31 / LISP / NNMBOX.EL < prev    next >
Lisp/Scheme  |  1996-01-20  |  17KB  |  511 lines
  1. ;;; nnmbox.el --- mail mbox access for Gnus
  2.  
  3. ;; Copyright (C) 1995 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  6. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  7. ;; Keywords: news, mail
  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 the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; For an overview of what the interface functions do, please see the
  29. ;; Gnus sources.  
  30.  
  31. ;;; Code:
  32.  
  33. (require 'nnheader)
  34. (require 'rmail)
  35. (require 'nnmail)
  36.  
  37. (defvar nnmbox-mbox-file (expand-file-name "~/mbox")
  38.   "The name of the mail box file in the user's home directory.")
  39.  
  40. (defvar nnmbox-active-file (expand-file-name "~/.mbox-active")
  41.   "The name of the active file for the mail box.")
  42.  
  43. (defvar nnmbox-get-new-mail t
  44.   "If non-nil, nnmbox will check the incoming mail file and split the mail.")
  45.  
  46. (defvar nnmbox-prepare-save-mail-hook nil
  47.   "Hook run narrowed to an article before saving.")
  48.  
  49.  
  50.  
  51. (defconst nnmbox-version "nnmbox 1.0"
  52.   "nnmbox version.")
  53.  
  54. (defvar nnmbox-current-group nil
  55.   "Current nnmbox news group directory.")
  56.  
  57. (defconst nnmbox-mbox-buffer nil)
  58.  
  59. (defvar nnmbox-status-string "")
  60.  
  61. (defvar nnmbox-group-alist nil)
  62. (defvar nnmbox-active-timestamp nil)
  63.  
  64.  
  65.  
  66. (defvar nnmbox-current-server nil)
  67. (defvar nnmbox-server-alist nil)
  68. (defvar nnmbox-server-variables 
  69.   (list
  70.    (list 'nnmbox-mbox-file nnmbox-mbox-file)
  71.    (list 'nnmbox-active-file nnmbox-active-file)
  72.    (list 'nnmbox-get-new-mail nnmbox-get-new-mail)
  73.    '(nnmbox-current-group nil)
  74.    '(nnmbox-status-string "")
  75.    '(nnmbox-group-alist nil)))
  76.  
  77.  
  78.  
  79. ;;; Interface functions
  80.  
  81. (defun nnmbox-retrieve-headers (sequence &optional newsgroup server)
  82.   (save-excursion
  83.     (set-buffer nntp-server-buffer)
  84.     (erase-buffer)
  85.     (let ((number (length sequence))
  86.       (count 0)
  87.       article art-string start stop)
  88.       (nnmbox-possibly-change-newsgroup newsgroup)
  89.       (if (stringp (car sequence))
  90.       'headers
  91.     (while sequence
  92.       (setq article (car sequence))
  93.       (setq art-string (nnmbox-article-string article))
  94.       (set-buffer nnmbox-mbox-buffer)
  95.       (if (or (search-forward art-string nil t)
  96.           (progn (goto-char (point-min))
  97.              (search-forward art-string nil t)))
  98.           (progn
  99.         (setq start 
  100.               (save-excursion
  101.             (re-search-backward 
  102.              (concat "^" rmail-unix-mail-delimiter) nil t)
  103.             (point)))
  104.         (search-forward "\n\n" nil t)
  105.         (setq stop (1- (point)))
  106.         (set-buffer nntp-server-buffer)
  107.         (insert (format "221 %d Article retrieved.\n" article))
  108.         (insert-buffer-substring nnmbox-mbox-buffer start stop)
  109.         (goto-char (point-max))
  110.         (insert ".\n")))
  111.       (setq sequence (cdr sequence))
  112.       (setq count (1+ count))
  113.       (and (numberp nnmail-large-newsgroup)
  114.            (> number nnmail-large-newsgroup)
  115.            (zerop (% count 20))
  116.            gnus-verbose-backends
  117.            (message "nnmbox: Receiving headers... %d%%"
  118.             (/ (* count 100) number))))
  119.  
  120.     (and (numberp nnmail-large-newsgroup)
  121.          (> number nnmail-large-newsgroup)
  122.          gnus-verbose-backends
  123.          (message "nnmbox: Receiving headers...done"))
  124.  
  125.     ;; Fold continuation lines.
  126.     (set-buffer nntp-server-buffer)
  127.     (goto-char (point-min))
  128.     (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
  129.       (replace-match " " t t))
  130.     'headers))))
  131.  
  132. (defun nnmbox-open-server (server &optional defs)
  133.   (nnheader-init-server-buffer)
  134.   (if (equal server nnmbox-current-server)
  135.       t
  136.     (if nnmbox-current-server
  137.     (setq nnmbox-server-alist 
  138.           (cons (list nnmbox-current-server
  139.               (nnheader-save-variables nnmbox-server-variables))
  140.             nnmbox-server-alist)))
  141.     (let ((state (assoc server nnmbox-server-alist)))
  142.       (if state 
  143.       (progn
  144.         (nnheader-restore-variables (nth 1 state))
  145.         (setq nnmbox-server-alist (delq state nnmbox-server-alist)))
  146.     (nnheader-set-init-variables nnmbox-server-variables defs)))
  147.     (setq nnmbox-current-server server)))
  148.  
  149. (defun nnmbox-close-server (&optional server)
  150.   t)
  151.  
  152. (defun nnmbox-server-opened (&optional server)
  153.   (and (equal server nnmbox-current-server)
  154.        nnmbox-mbox-buffer
  155.        (buffer-name nnmbox-mbox-buffer)
  156.        nntp-server-buffer
  157.        (buffer-name nntp-server-buffer)))
  158.  
  159. (defun nnmbox-status-message (&optional server)
  160.   nnmbox-status-string)
  161.  
  162. (defun nnmbox-request-article (article &optional newsgroup server buffer)
  163.   (nnmbox-possibly-change-newsgroup newsgroup)
  164.   (if (stringp article)
  165.       nil
  166.     (save-excursion
  167.       (set-buffer nnmbox-mbox-buffer)
  168.       (goto-char (point-min))
  169.       (if (search-forward (nnmbox-article-string article) nil t)
  170.       (let (start stop)
  171.         (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
  172.         (setq start (point))
  173.         (forward-line 1)
  174.         (or (and (re-search-forward 
  175.               (concat "^" rmail-unix-mail-delimiter) nil t)
  176.              (forward-line -1))
  177.         (goto-char (point-max)))
  178.         (setq stop (point))
  179.         (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
  180.           (set-buffer nntp-server-buffer)
  181.           (erase-buffer)
  182.           (insert-buffer-substring nnmbox-mbox-buffer start stop)
  183.           (goto-char (point-min))
  184.           (while (looking-at "From ")
  185.         (delete-char 5)
  186.         (insert "X-From-Line: ")
  187.         (forward-line 1))
  188.           t))))))
  189.  
  190. (defun nnmbox-request-group (group &optional server dont-check)
  191.   (save-excursion
  192.     (if (nnmbox-possibly-change-newsgroup group)
  193.     (if dont-check
  194.         t
  195.       (nnmbox-get-new-mail group)
  196.       (save-excursion
  197.         (set-buffer nntp-server-buffer)
  198.         (erase-buffer)
  199.         (let ((active (assoc group nnmbox-group-alist)))
  200.           (insert (format "211 %d %d %d %s\n" 
  201.                   (1+ (- (cdr (car (cdr active)))
  202.                      (car (car (cdr active)))))
  203.                   (car (car (cdr active)))
  204.                   (cdr (car (cdr active)))
  205.                   (car active))))
  206.         t)))))
  207.  
  208. (defun nnmbox-close-group (group &optional server)
  209.   t)
  210.  
  211. (defun nnmbox-request-list (&optional server)
  212.   (if server (nnmbox-get-new-mail))
  213.   (save-excursion
  214.     (or (nnmail-find-file nnmbox-active-file)
  215.     (progn
  216.       (setq nnmbox-group-alist (nnmail-get-active))
  217.       (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  218.       (nnmail-find-file nnmbox-active-file)))))
  219.  
  220. (defun nnmbox-request-newgroups (date &optional server)
  221.   (nnmbox-request-list server))
  222.  
  223. (defun nnmbox-request-list-newsgroups (&optional server)
  224.   (setq nnmbox-status-string "nnmbox: LIST NEWSGROUPS is not implemented.")
  225.   nil)
  226.  
  227. (defun nnmbox-request-post (&optional server)
  228.   (mail-send-and-exit nil))
  229.  
  230. (defalias 'nnmbox-request-post-buffer 'nnmail-request-post-buffer)
  231.  
  232. (defun nnmbox-request-expire-articles 
  233.   (articles newsgroup &optional server force)
  234.   (nnmbox-possibly-change-newsgroup newsgroup)
  235.   (let* ((days (or (and nnmail-expiry-wait-function
  236.             (funcall nnmail-expiry-wait-function newsgroup))
  237.            nnmail-expiry-wait))
  238.      (is-old t)
  239.      rest)
  240.     (nnmail-activate 'nnmbox)
  241.  
  242.     (save-excursion 
  243.       (set-buffer nnmbox-mbox-buffer)
  244.       (while (and articles is-old)
  245.     (goto-char (point-min))
  246.     (if (search-forward (nnmbox-article-string (car articles)) nil t)
  247.         (if (or force
  248.             (setq is-old
  249.               (> (nnmail-days-between 
  250.                   (current-time-string)
  251.                   (buffer-substring 
  252.                    (point) (progn (end-of-line) (point))))
  253.                  days)))
  254.         (progn
  255.           (and gnus-verbose-backends
  256.                (message "Deleting article %s..." (car articles)))
  257.           (nnmbox-delete-mail))
  258.           (setq rest (cons (car articles) rest))))
  259.     (setq articles (cdr articles)))
  260.       (save-buffer)
  261.       ;; Find the lowest active article in this group.
  262.       (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
  263.     (goto-char (point-min))
  264.     (while (and (not (search-forward
  265.               (nnmbox-article-string (car active)) nil t))
  266.             (<= (car active) (cdr active)))
  267.       (setcar active (1+ (car active)))
  268.       (goto-char (point-min))))
  269.       (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  270.       (nconc rest articles))))
  271.  
  272. (defun nnmbox-request-move-article
  273.   (article group server accept-form &optional last)
  274.   (nnmbox-possibly-change-newsgroup group)
  275.   (let ((buf (get-buffer-create " *nnmbox move*"))
  276.     result)
  277.     (and 
  278.      (nnmbox-request-article article group server)
  279.      (save-excursion
  280.        (set-buffer buf)
  281.        (buffer-disable-undo (current-buffer))
  282.        (erase-buffer)
  283.        (insert-buffer-substring nntp-server-buffer)
  284.        (goto-char (point-min))
  285.        (while (re-search-forward 
  286.            "^X-Gnus-Newsgroup:" 
  287.            (save-excursion (search-forward "\n\n" nil t) (point)) t)
  288.      (delete-region (progn (beginning-of-line) (point))
  289.             (progn (forward-line 1) (point))))
  290.        (setq result (eval accept-form))
  291.        (kill-buffer buf)
  292.        result)
  293.      (save-excursion
  294.        (set-buffer nnmbox-mbox-buffer)
  295.        (goto-char (point-min))
  296.        (if (search-forward (nnmbox-article-string article) nil t)
  297.        (nnmbox-delete-mail))
  298.        (and last (save-buffer))))
  299.     result))
  300.  
  301. (defun nnmbox-request-accept-article (group &optional last)
  302.   (let ((buf (current-buffer))
  303.     result)
  304.     (goto-char (point-min))
  305.     (if (looking-at "X-From-Line: ")
  306.     (replace-match "From ")
  307.       (insert "From nobody " (current-time-string) "\n"))
  308.     (and 
  309.      (nnmail-activate 'nnmbox)
  310.      (progn
  311.        (set-buffer buf)
  312.        (goto-char (point-min))
  313.        (search-forward "\n\n" nil t)
  314.        (forward-line -1)
  315.        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
  316.      (delete-region (point) (progn (forward-line 1) (point))))
  317.        (setq result (nnmbox-save-mail (and (stringp group) group))))
  318.      (save-excursion
  319.        (set-buffer nnmbox-mbox-buffer)
  320.        (insert-buffer-substring buf)
  321.        (and last (save-buffer))
  322.        result)
  323.      (nnmail-save-active nnmbox-group-alist nnmbox-active-file))
  324.     (car result)))
  325.  
  326. (defun nnmbox-request-replace-article (article group buffer)
  327.   (nnmbox-possibly-change-newsgroup group)
  328.   (save-excursion
  329.     (set-buffer nnmbox-mbox-buffer)
  330.     (goto-char (point-min))
  331.     (if (not (search-forward (nnmbox-article-string article) nil t))
  332.     nil
  333.       (nnmbox-delete-mail t t)
  334.       (insert-buffer-substring buffer)
  335.       (save-buffer)
  336.       t)))
  337.  
  338.  
  339. ;;; Internal functions.
  340.  
  341. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
  342. ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
  343. ;; delimiter line.
  344. (defun nnmbox-delete-mail (&optional force leave-delim)
  345.   ;; Delete the current X-Gnus-Newsgroup line.
  346.   (or force
  347.       (delete-region
  348.        (progn (beginning-of-line) (point))
  349.        (progn (forward-line 1) (point))))
  350.   ;; Beginning of the article.
  351.   (save-excursion
  352.     (save-restriction
  353.       (narrow-to-region
  354.        (save-excursion
  355.      (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
  356.      (if leave-delim (progn (forward-line 1) (point))
  357.        (match-beginning 0)))
  358.        (progn
  359.      (forward-line 1)
  360.      (or (and (re-search-forward (concat "^" rmail-unix-mail-delimiter) 
  361.                      nil t)
  362.           (if (and (not (bobp)) leave-delim)
  363.               (progn (forward-line -2) (point))
  364.             (match-beginning 0)))
  365.          (point-max))))
  366.       (goto-char (point-min))
  367.       ;; Only delete the article if no other groups owns it as well.
  368.       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
  369.       (delete-region (point-min) (point-max))))))
  370.  
  371. (defun nnmbox-possibly-change-newsgroup (newsgroup)
  372.   (if (or (not nnmbox-mbox-buffer)
  373.       (not (buffer-name nnmbox-mbox-buffer)))
  374.       (save-excursion
  375.     (set-buffer (setq nnmbox-mbox-buffer 
  376.               (nnheader-find-file-noselect
  377.                nnmbox-mbox-file nil 'raw)))
  378.     (buffer-disable-undo (current-buffer))))
  379.   (if (not nnmbox-group-alist)
  380.       (nnmail-activate 'nnmbox))
  381.   (if newsgroup
  382.       (if (assoc newsgroup nnmbox-group-alist)
  383.       (setq nnmbox-current-group newsgroup))))
  384.  
  385. (defun nnmbox-article-string (article)
  386.   (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":" 
  387.       (int-to-string article) " "))
  388.  
  389. (defun nnmbox-save-mail (&optional group)
  390.   "Called narrowed to an article."
  391.   (let* ((nnmail-split-methods 
  392.       (if group (list (list group "")) nnmail-split-methods))
  393.      (group-art (nreverse (nnmail-article-group 'nnmbox-active-number))))
  394.     (nnmail-insert-lines)
  395.     (nnmail-insert-xref group-art)
  396.     (nnmbox-insert-newsgroup-line group-art)
  397.     (run-hooks 'nnml-prepare-save-mail-hook)
  398.     group-art))
  399.  
  400. (defun nnmbox-insert-newsgroup-line (group-art)
  401.   (save-excursion
  402.     (goto-char (point-min))
  403.     (if (search-forward "\n\n" nil t)
  404.     (progn
  405.       (forward-char -1)
  406.       (while group-art
  407.         (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n" 
  408.                 (car (car group-art)) (cdr (car group-art))
  409.                 (current-time-string)))
  410.         (setq group-art (cdr group-art)))))
  411.     t))
  412.  
  413. (defun nnmbox-active-number (group)
  414.   ;; Find the next article number in GROUP.
  415.   (let ((active (car (cdr (assoc group nnmbox-group-alist)))))
  416.     (if active
  417.     (setcdr active (1+ (cdr active)))
  418.       ;; This group is new, so we create a new entry for it.
  419.       ;; This might be a bit naughty... creating groups on the drop of
  420.       ;; a hat, but I don't know...
  421.       (setq nnmbox-group-alist (cons (list group (setq active (cons 1 1)))
  422.                      nnmbox-group-alist)))
  423.     (cdr active)))
  424.  
  425. (defun nnmbox-read-mbox ()
  426.   (nnmail-activate 'nnmbox)
  427.   (if (not (file-exists-p nnmbox-mbox-file))
  428.       (write-region 1 1 nnmbox-mbox-file t 'nomesg))
  429.   (if (and nnmbox-mbox-buffer
  430.        (buffer-name nnmbox-mbox-buffer)
  431.        (save-excursion
  432.          (set-buffer nnmbox-mbox-buffer)
  433.          (= (buffer-size) (nth 7 (file-attributes nnmbox-mbox-file)))))
  434.       ()
  435.     (save-excursion
  436.       (let ((delim (concat "^" rmail-unix-mail-delimiter))
  437.         start end)
  438.     (set-buffer (setq nnmbox-mbox-buffer 
  439.               (nnheader-find-file-noselect 
  440.                nnmbox-mbox-file nil 'raw)))
  441.     (buffer-disable-undo (current-buffer))
  442.     (goto-char (point-min))
  443.     (while (re-search-forward delim nil t)
  444.       (setq start (match-beginning 0))
  445.       (if (not (search-forward "\nX-Gnus-Newsgroup: " 
  446.                    (save-excursion 
  447.                      (setq end
  448.                        (or
  449.                         (and
  450.                          (re-search-forward delim nil t)
  451.                          (match-beginning 0))
  452.                         (point-max))))
  453.                    t))
  454.           (save-excursion
  455.         (save-restriction
  456.           (narrow-to-region start end)
  457.           (nnmbox-save-mail))))
  458.       (goto-char end))))))
  459.  
  460. (defun nnmbox-get-new-mail (&optional group)
  461.   "Read new incoming mail."
  462.   (let* ((spools (nnmail-get-spool-files group))
  463.      (group-in group)
  464.      incoming incomings)
  465.     (nnmbox-read-mbox)
  466.     (if (or (not nnmbox-get-new-mail) (not nnmail-spool-file))
  467.     ()
  468.       ;; We go through all the existing spool files and split the
  469.       ;; mail from each.
  470.       (while spools
  471.     (and
  472.      (file-exists-p (car spools))
  473.      (> (nth 7 (file-attributes (car spools))) 0)
  474.      (progn
  475.        (and gnus-verbose-backends 
  476.         (message "nnmbox: Reading incoming mail..."))
  477.        (if (not (setq incoming 
  478.               (nnmail-move-inbox 
  479.                (car spools) 
  480.                (concat nnmbox-mbox-file "-Incoming"))))
  481.            ()
  482.          (setq incomings (cons incoming incomings))
  483.          (save-excursion
  484.            (setq group (nnmail-get-split-group (car spools) group-in))
  485.            (let ((in-buf (nnmail-split-incoming 
  486.                   incoming 'nnmbox-save-mail t group)))
  487.          (set-buffer nnmbox-mbox-buffer)
  488.          (goto-char (point-max))
  489.          (insert-buffer-substring in-buf)
  490.          (kill-buffer in-buf))))))
  491.     (setq spools (cdr spools)))
  492.       ;; If we did indeed read any incoming spools, we save all info. 
  493.       (and (buffer-modified-p nnmbox-mbox-buffer) 
  494.        (save-excursion
  495.          (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  496.          (set-buffer nnmbox-mbox-buffer)
  497.          (save-buffer)))
  498.       (if incomings (run-hooks 'nnmail-read-incoming-hook))
  499.       (while incomings
  500.     (setq incoming (car incomings))
  501.     (and nnmail-delete-incoming
  502.          (file-exists-p incoming) 
  503.          (file-writable-p incoming) 
  504.          (delete-file incoming))
  505.     (setq incomings (cdr incomings))))))
  506.  
  507.  
  508. (provide 'nnmbox)
  509.  
  510. ;;; nnmbox.el ends here
  511.