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 / vm / vm-pop.el < prev    next >
Encoding:
Text File  |  1995-07-28  |  9.5 KB  |  269 lines
  1. ;;; Simple POP (RFC 1460) client for VM
  2. ;;; Copyright (C) 1993, 1994 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-pop)
  19.  
  20. ;; Nothing fancy here.
  21. ;; Our goal is to drag the mail from the POP maildrop to the crash box.
  22. ;; just as if we were using movemail on a spool file.
  23. (defun vm-pop-move-mail (source destination)
  24.   (let ((process nil)
  25.     (folder-type vm-folder-type)
  26.     (save-password nil)
  27.     (handler (and (fboundp 'find-file-name-handler)
  28.               (condition-case ()
  29.               (find-file-name-handler source 'vm-pop-move-mail)
  30.             (wrong-number-of-arguments
  31.               (find-file-name-handler source)))))
  32.     (popdrop (vm-safe-popdrop-string source))
  33.     greeting timestamp n message-count
  34.     host port auth user pass source-list process-buffer)
  35.     (unwind-protect
  36.     (catch 'done
  37.       (if handler
  38.           (throw 'done
  39.              (funcall handler 'vm-pop-move-mail source destination)))
  40.       ;; parse the maildrop
  41.       (setq source-list (vm-parse source "\\([^:]+\\):?")
  42.         host (nth 0 source-list)
  43.         port (nth 1 source-list)
  44.         auth (nth 2 source-list)
  45.         user (nth 3 source-list)
  46.         pass (nth 4 source-list))
  47.       ;; carp if parts are missing
  48.       (if (null host)
  49.           (error "No host in POP maildrop specification, \"%s\""
  50.              source))
  51.       (if (null port)
  52.           (error "No port in POP maildrop specification, \"%s\""
  53.              source))
  54.       (if (string-match "^[0-9]+$" port)
  55.           (setq port (string-to-int port)))
  56.       (if (null auth)
  57.           (error
  58.            "No authentication method in POP maildrop specification, \"%s\""
  59.            source))
  60.       (if (null user)
  61.           (error "No user in POP maildrop specification, \"%s\""
  62.              source))
  63.       (if (null pass)
  64.           (error "No password in POP maildrop specification, \"%s\""
  65.              source))
  66.       (if (equal pass "*")
  67.           (progn
  68.         (setq pass (car (cdr (assoc source vm-pop-passwords))))
  69.         (if (null pass)
  70.             (setq pass
  71.               (vm-read-password
  72.                (format "POP password for %s: "
  73.                    popdrop))
  74.               save-password t))))
  75.       ;; get the trace buffer
  76.       (setq process-buffer
  77.         (get-buffer-create (format "trace of POP session to %s" host)))
  78.       ;; clear the trace buffer of old output
  79.       (save-excursion
  80.         (set-buffer process-buffer)
  81.         (erase-buffer))
  82.       ;; open the connection to the server
  83.       (setq process (open-network-stream "POP" process-buffer host port))
  84.       (and (null process) (throw 'done nil))
  85.       (set-process-filter process 'vm-pop-process-filter)
  86.       (save-excursion
  87.         (set-buffer process-buffer)
  88.         (make-local-variable 'vm-pop-read-point)
  89.         (setq vm-pop-read-point (point-min)
  90.           vm-folder-type (or folder-type vm-default-folder-type))
  91.         (and (null (setq greeting (vm-pop-read-response process t)))
  92.          (throw 'done nil))
  93.         ;; authentication
  94.         (cond ((equal auth "pass")
  95.            (vm-pop-send-command process (format "USER %s" user))
  96.            (and (null (vm-pop-read-response process))
  97.             (throw 'done nil))
  98.            (vm-pop-send-command process (format "PASS %s" pass))
  99.            (and (null (vm-pop-read-response process))
  100.             (throw 'done nil)))
  101.           ((equal auth "rpop")
  102.            (vm-pop-send-command process (format "USER %s" user))
  103.            (and (null (vm-pop-read-response process))
  104.             (throw 'done nil))
  105.            (vm-pop-send-command process (format "RPOP %s" pass))
  106.            (and (null (vm-pop-read-response process))
  107.             (throw 'done nil)))
  108.           ((equal auth "apop")
  109.            (setq timestamp (vm-parse greeting "[^<]+\\(<[^>]+>\\)")
  110.              timestamp (car timestamp))
  111.            (if (null timestamp)
  112.                (progn
  113.              (goto-char (point-max))
  114.          (insert "<<< ooops, no timestamp found in greeting! >>>\n")
  115.              (throw 'done nil)))
  116.            (vm-pop-send-command
  117.             process
  118.             (format "APOP %s %s"
  119.                 user
  120.                 (vm-pop-md5 (concat timestamp pass))))
  121.            (and (null (vm-pop-read-response process))
  122.             (throw 'done nil)))
  123.           (t (error "Don't know how to authenticate with %s" auth)))
  124.         ;; we're in.
  125.         ;; save the password if we read it from the user.
  126.         (if save-password
  127.         (setq vm-pop-passwords (cons (list source pass)
  128.                          vm-pop-passwords)))
  129.         ;; find out how many messages are in the box.
  130.         (vm-pop-send-command process "STAT")
  131.         (setq message-count (vm-pop-read-stat-response process))
  132.         ;; forget it if the command fails
  133.         ;; or if there are no messages present.
  134.         (if (or (null message-count)
  135.             (< message-count 1))
  136.         (throw 'done nil))
  137.         ;; loop through the maildrop retrieving and deleting
  138.         ;; messages as we go.
  139.         (setq n 1)
  140.         (while (<= n message-count)
  141.           (vm-unsaved-message "Retrieving message %d (of %d) from %s..."
  142.                   n message-count popdrop)
  143.           (vm-pop-send-command process (format "RETR %d" n))
  144.           (and (null (vm-pop-read-response process))
  145.            (throw 'done (not (equal n 1))))
  146.           (and (null (vm-pop-retrieve-to-crashbox process destination))
  147.            (throw 'done (not (equal n 1))))
  148.           (vm-pop-send-command process (format "DELE %d" n))
  149.           ;; DELE can't fail but Emacs or this code might
  150.           ;; blow a gasket and spew filth down the
  151.           ;; connection, so...
  152.           (and (null (vm-pop-read-response process))
  153.            (throw 'done (not (equal n 1))))
  154.           (vm-increment n))
  155.          t ))
  156.       (if process
  157.       (save-excursion
  158.         (set-buffer (process-buffer process))
  159.         (vm-pop-send-command process "QUIT")
  160.         (vm-pop-read-response process)
  161.         (delete-process process))))))
  162.  
  163. (defun vm-pop-process-filter (process output)
  164.   (save-excursion
  165.     (set-buffer (process-buffer process))
  166.     (goto-char (point-max))
  167.     (insert output)))
  168.  
  169. (defun vm-pop-send-command (process command)
  170.   (goto-char (point-max))
  171.   (if (= (aref command 0) ?P)
  172.       (insert "PASS <omitted>\r\n")
  173.     (insert command "\r\n"))
  174.   (setq vm-pop-read-point (point))
  175.   (process-send-string process command)
  176.   (process-send-string process "\r\n"))
  177.  
  178. (defun vm-pop-read-response (process &optional return-response-string)
  179.   (let ((case-fold-search nil)
  180.      match-end)
  181.     (goto-char vm-pop-read-point)
  182.     (while (not (search-forward "\r\n" nil t))
  183.       (accept-process-output process)
  184.       (goto-char vm-pop-read-point))
  185.     (setq match-end (point))
  186.     (goto-char vm-pop-read-point)
  187.     (if (not (looking-at "+OK"))
  188.     (progn (setq vm-pop-read-point match-end) nil)
  189.       (setq vm-pop-read-point match-end)
  190.       (if return-response-string
  191.       (buffer-substring (point) match-end)
  192.     t ))))
  193.  
  194. (defun vm-pop-read-stat-response (process)
  195.   (let ((response (vm-pop-read-response process t)))
  196.     (string-to-int (nth 1 (vm-parse response "\\([^ ]+\\) *")))))
  197.  
  198. (defun vm-pop-retrieve-to-crashbox (process crash)
  199.   (let ((start vm-pop-read-point) end)
  200.     (goto-char start)
  201.     (while (not (re-search-forward "^\\.\r\n" nil t))
  202.       (accept-process-output process)
  203.       (goto-char start))
  204.     (setq vm-pop-read-point (point-marker))
  205.     (goto-char (match-beginning 0))
  206.     (setq end (point-marker))
  207.     (vm-pop-cleanup-region start end)
  208.     ;; Some POP servers strip leading and trailing message
  209.     ;; separators, some don't.  Figure out what kind we're
  210.     ;; talking to and do the right thing.
  211.     (if (eq (vm-get-folder-type nil start end) 'unknown)
  212.     (progn
  213.       (vm-munge-message-separators vm-folder-type start end)
  214.       (goto-char start)
  215.       ;; avoid the consing and stat() call for all but babyl
  216.       ;; files, since this will probably slow things down.
  217.       ;; only babyl files have the folder header, and we
  218.       ;; should only insert it if the crash box is empty.
  219.       (if (and (eq vm-folder-type 'babyl)
  220.            (let ((attrs (file-attributes crash)))
  221.              (or (null attrs) (equal 0 (nth 7 attrs)))))
  222.           (let ((opoint (point)))
  223.         (vm-convert-folder-header nil vm-folder-type)
  224.         ;; if start is a marker, then it was moved
  225.         ;; forward by the insertion.  restore it.
  226.         (setq start opoint)
  227.         (goto-char start)
  228.         (vm-skip-past-folder-header)))
  229.       (insert (vm-leading-message-separator))
  230.       ;; this will not find the trailing message separator but
  231.       ;; for the Content-Length stuff counting from eob is
  232.       ;; the same thing in this case.
  233.       (vm-convert-folder-type-headers nil vm-folder-type)
  234.       (goto-char end)
  235.       (insert-before-markers (vm-trailing-message-separator))))
  236.     (write-region start end crash t 0)
  237.     (delete-region start end)
  238.     t ))
  239.  
  240. (defun vm-pop-cleanup-region (start end)
  241.   (setq end (vm-marker end))
  242.   (save-excursion
  243.     (goto-char start)
  244.     ;; CRLF -> LF
  245.     (while (and (< (point) end) (search-forward "\r\n"  end t))
  246.       (replace-match "\n" t t))
  247.     (goto-char start)
  248.     ;; chop leading dots
  249.     (while (and (< (point) end) (re-search-forward "^\\."  end t))
  250.       (replace-match "" t t)
  251.       (forward-char)))
  252.   (set-marker end nil))
  253.  
  254. (defun vm-pop-md5 (string)
  255.   (let ((buffer nil))
  256.     (unwind-protect
  257.     (save-excursion
  258.       (setq buffer (generate-new-buffer "*vm-work*"))
  259.       (set-buffer buffer)
  260.       (insert string)
  261.       (call-process-region (point-min) (point-max)
  262.                    "/bin/sh" t buffer nil
  263.                    "-c" vm-pop-md5-program)
  264.       ;; MD5 digest is 32 chars long
  265.       ;; mddriver adds a newline to make neaten output for tty
  266.       ;; viewing, make sure we leave it behind.
  267.       (vm-buffer-substring-no-properties (point-min) (+ (point-min) 32)))
  268.       (and buffer (kill-buffer buffer)))))
  269.