(require 'mail-utils)
(defgroup pop3 nil
"Post Office Protocol."
:group 'mail
:group 'mail-source)
(defcustom pop3-maildrop (or (user-login-name)
(getenv "LOGNAME")
(getenv "USER"))
"*POP3 maildrop."
:version "22.1" :type 'string
:group 'pop3)
(defcustom pop3-mailhost (or (getenv "MAILHOST") "pop3")
"*POP3 mailhost."
:version "22.1" :type 'string
:group 'pop3)
(defcustom pop3-port 110
"*POP3 port."
:version "22.1" :type 'number
:group 'pop3)
(defcustom pop3-password-required t
"*Non-nil if a password is required when connecting to POP server."
:version "22.1" :type 'boolean
:group 'pop3)
(defvar pop3-password nil
"*Password to use when connecting to POP server.")
(defcustom pop3-authentication-scheme 'pass
"*POP3 authentication scheme.
Defaults to `pass', for the standard USER/PASS authentication. The other
valid value is 'apop'."
:type '(choice (const :tag "Normal user/password" pass)
(const :tag "APOP" apop))
:version "22.1" :group 'pop3)
(defcustom pop3-leave-mail-on-server nil
"*Non-nil if the mail is to be left on the POP server after fetching.
If `pop3-leave-mail-on-server' is non-nil the mail is to be left
on the POP server after fetching. Note that POP servers maintain
no state information between sessions, so what the client
believes is there and what is actually there may not match up.
If they do not, then you may get duplicate mails or the whole
thing can fall apart and leave you with a corrupt mailbox."
:version "22.1" :type 'boolean
:group 'pop3)
(defvar pop3-timestamp nil
"Timestamp returned when initially connected to the POP server.
Used for APOP authentication.")
(defvar pop3-read-point nil)
(defvar pop3-debug nil)
(defvar pop3-read-timeout
(if (string-match "windows-nt\\|os/2\\|emx\\|cygwin"
(symbol-name system-type))
1.0
0.1)
"How long pop3 should wait between checking for the end of output.
Shorter values mean quicker response, but are more CPU intensive.")
(defun pop3-accept-process-output (process)
(accept-process-output
process
(truncate pop3-read-timeout)
(truncate (* (- pop3-read-timeout
(truncate pop3-read-timeout))
1000))))
(defun pop3-movemail (&optional crashbox)
"Transfer contents of a maildrop to the specified CRASHBOX."
(or crashbox (setq crashbox (expand-file-name "~/.crashbox")))
(let* ((process (pop3-open-server pop3-mailhost pop3-port))
(crashbuf (get-buffer-create " *pop3-retr*"))
(n 1)
message-count
(pop3-password pop3-password))
(if pop3-debug (switch-to-buffer (process-buffer process)))
(if (and pop3-password-required (not pop3-password))
(setq pop3-password
(read-passwd (format "Password for %s: " pop3-maildrop))))
(cond ((equal 'apop pop3-authentication-scheme)
(pop3-apop process pop3-maildrop))
((equal 'pass pop3-authentication-scheme)
(pop3-user process pop3-maildrop)
(pop3-pass process))
(t (error "Invalid POP3 authentication scheme")))
(setq message-count (car (pop3-stat process)))
(unwind-protect
(while (<= n message-count)
(message "Retrieving message %d of %d from %s..."
n message-count pop3-mailhost)
(pop3-retr process n crashbuf)
(save-excursion
(set-buffer crashbuf)
(let ((coding-system-for-write 'binary))
(write-region (point-min) (point-max) crashbox t 'nomesg))
(set-buffer (process-buffer process))
(while (> (buffer-size) 5000)
(goto-char (point-min))
(forward-line 50)
(delete-region (point-min) (point))))
(unless pop3-leave-mail-on-server
(pop3-dele process n))
(setq n (+ 1 n))
(if pop3-debug (sit-for 1) (sit-for 0.1))) (when (and pop3-leave-mail-on-server
(> n 1))
(message "pop3.el doesn't support UIDL. Setting `pop3-leave-mail-on-server'
to %s might not give the result you'd expect." pop3-leave-mail-on-server)
(sit-for 1))
(pop3-quit process))
(kill-buffer crashbuf))
t)
(defun pop3-get-message-count ()
"Return the number of messages in the maildrop."
(let* ((process (pop3-open-server pop3-mailhost pop3-port))
message-count
(pop3-password pop3-password))
(if pop3-debug (switch-to-buffer (process-buffer process)))
(if (and pop3-password-required (not pop3-password))
(setq pop3-password
(read-passwd (format "Password for %s: " pop3-maildrop))))
(cond ((equal 'apop pop3-authentication-scheme)
(pop3-apop process pop3-maildrop))
((equal 'pass pop3-authentication-scheme)
(pop3-user process pop3-maildrop)
(pop3-pass process))
(t (error "Invalid POP3 authentication scheme")))
(setq message-count (car (pop3-stat process)))
(pop3-quit process)
message-count))
(defun pop3-open-server (mailhost port)
"Open TCP connection to MAILHOST on PORT.
Returns the process associated with the connection."
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary)
process)
(save-excursion
(set-buffer (get-buffer-create (concat " trace of POP session to "
mailhost)))
(erase-buffer)
(setq pop3-read-point (point-min))
(setq process (open-network-stream "POP" (current-buffer) mailhost port))
(let ((response (pop3-read-response process t)))
(setq pop3-timestamp
(substring response (or (string-match "<" response) 0)
(+ 1 (or (string-match ">" response) -1)))))
process)))
(defun pop3-process-filter (process output)
(save-excursion
(set-buffer (process-buffer process))
(goto-char (point-max))
(insert output)))
(defun pop3-send-command (process command)
(set-buffer (process-buffer process))
(goto-char (point-max))
(setq pop3-read-point (point))
(goto-char (point-max))
(process-send-string process (concat command "\r\n")))
(defun pop3-read-response (process &optional return)
"Read the response from the server.
Return the response string if optional second argument is non-nil."
(let ((case-fold-search nil)
match-end)
(save-excursion
(set-buffer (process-buffer process))
(goto-char pop3-read-point)
(while (and (memq (process-status process) '(open run))
(not (search-forward "\r\n" nil t)))
(pop3-accept-process-output process)
(goto-char pop3-read-point))
(setq match-end (point))
(goto-char pop3-read-point)
(if (looking-at "-ERR")
(error (buffer-substring (point) (- match-end 2)))
(if (not (looking-at "+OK"))
(progn (setq pop3-read-point match-end) nil)
(setq pop3-read-point match-end)
(if return
(buffer-substring (point) match-end)
t)
)))))
(defun pop3-clean-region (start end)
(setq end (set-marker (make-marker) end))
(save-excursion
(goto-char start)
(while (and (< (point) end) (search-forward "\r\n" end t))
(replace-match "\n" t t))
(goto-char start)
(while (and (< (point) end) (re-search-forward "^\\." end t))
(replace-match "" t t)
(forward-char)))
(set-marker end nil))
(eval-when-compile (defvar parse-time-months))
(defun pop3-make-date (&optional now)
"Make a valid date header.
If NOW, use that time instead."
(require 'parse-time)
(let* ((now (or now (current-time)))
(zone (nth 8 (decode-time now)))
(sign "+"))
(when (< zone 0)
(setq sign "-")
(setq zone (- zone)))
(concat
(format-time-string "%d" now)
(format " %s "
(capitalize (car (rassoc (nth 4 (decode-time now))
parse-time-months))))
(format-time-string "%Y %H:%M:%S " now)
(format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
(defun pop3-munge-message-separator (start end)
"Check to see if a message separator exists. If not, generate one."
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char (point-min))
(if (not (or (looking-at "From .?") (looking-at "\001\001\001\001\n") (looking-at "BABYL OPTIONS:") ))
(let* ((from (mail-strip-quoted-names (mail-fetch-field "From")))
(tdate (mail-fetch-field "Date"))
(date (split-string (or (and tdate
(not (string= "" tdate))
tdate)
(pop3-make-date))
" "))
(From_))
(setq date
(cond ((not date)
"Tue Jan 1 00:00:0 1900")
((string-match "[A-Z]" (nth 0 date))
(format "%s %s %s %s %s"
(nth 0 date) (nth 2 date) (nth 1 date)
(nth 4 date) (nth 3 date)))
(t
(format "Sun %s %s %s %s"
(nth 1 date) (nth 0 date)
(nth 3 date) (nth 2 date)))
))
(setq From_ (format "\nFrom %s %s\n" from date))
(while (string-match "," From_)
(setq From_ (concat (substring From_ 0 (match-beginning 0))
(substring From_ (match-end 0)))))
(goto-char (point-min))
(insert From_)
(if (search-forward "\n\n" nil t)
nil
(goto-char (point-max))
(insert "\n"))
(narrow-to-region (point) (point-max))
(let ((size (- (point-max) (point-min))))
(goto-char (point-min))
(widen)
(forward-line -1)
(insert (format "Content-Length: %s\n" size)))
)))))
(eval-when-compile
(if (not (fboundp 'md5)) (defalias 'md5 'ignore)))
(eval-and-compile
(if (and (fboundp 'md5)
(condition-case nil
(md5 "Check whether the 4th argument is allowed"
nil nil 'binary)
(error nil)))
(defun pop3-md5 (string)
(md5 string nil nil 'binary))
(defvar pop3-md5-program "md5"
"*Program to encode its input in MD5.
\"openssl\" is a popular alternative; set `pop3-md5-program-args' to
'(\"md5\") if you use it.")
(defvar pop3-md5-program-args nil
"*List of arguments passed to `pop3-md5-program'.")
(defun pop3-md5 (string)
(let ((default-enable-multibyte-characters t)
(coding-system-for-write 'binary))
(with-temp-buffer
(insert string)
(apply 'call-process-region (point-min) (point-max)
pop3-md5-program t (current-buffer) nil
pop3-md5-program-args)
(buffer-substring (point-min) (+ 32 (point-min))))))))
(defun pop3-user (process user)
"Send USER information to POP3 server."
(pop3-send-command process (format "USER %s" user))
(let ((response (pop3-read-response process t)))
(if (not (and response (string-match "+OK" response)))
(error "USER %s not valid" user))))
(defun pop3-pass (process)
"Send authentication information to the server."
(pop3-send-command process (format "PASS %s" pop3-password))
(let ((response (pop3-read-response process t)))
(if (not (and response (string-match "+OK" response)))
(pop3-quit process))))
(defun pop3-apop (process user)
"Send alternate authentication information to the server."
(let ((pass pop3-password))
(if (and pop3-password-required (not pass))
(setq pass
(read-passwd (format "Password for %s: " pop3-maildrop))))
(if pass
(let ((hash (pop3-md5 (concat pop3-timestamp pass))))
(pop3-send-command process (format "APOP %s %s" user hash))
(let ((response (pop3-read-response process t)))
(if (not (and response (string-match "+OK" response)))
(pop3-quit process)))))
))
(defun pop3-stat (process)
"Return the number of messages in the maildrop and the maildrop's size."
(pop3-send-command process "STAT")
(let ((response (pop3-read-response process t)))
(list (string-to-number (nth 1 (split-string response " ")))
(string-to-number (nth 2 (split-string response " "))))
))
(defun pop3-list (process &optional msg)
"Scan listing of available messages.
This function currently does nothing.")
(defun pop3-retr (process msg crashbuf)
"Retrieve message-id MSG to buffer CRASHBUF."
(pop3-send-command process (format "RETR %s" msg))
(pop3-read-response process)
(let ((start pop3-read-point) end)
(save-excursion
(set-buffer (process-buffer process))
(while (not (re-search-forward "^\\.\r\n" nil t))
(pop3-accept-process-output process)
(goto-char start))
(setq pop3-read-point (point-marker))
(goto-char (match-beginning 0))
(setq end (point-marker))
(pop3-clean-region start end)
(pop3-munge-message-separator start end)
(save-excursion
(set-buffer crashbuf)
(erase-buffer))
(copy-to-buffer crashbuf start end)
(delete-region start end)
)))
(defun pop3-dele (process msg)
"Mark message-id MSG as deleted."
(pop3-send-command process (format "DELE %s" msg))
(pop3-read-response process))
(defun pop3-noop (process msg)
"No-operation."
(pop3-send-command process "NOOP")
(pop3-read-response process))
(defun pop3-last (process)
"Return highest accessed message-id number for the session."
(pop3-send-command process "LAST")
(let ((response (pop3-read-response process t)))
(string-to-number (nth 1 (split-string response " ")))
))
(defun pop3-rset (process)
"Remove all delete marks from current maildrop."
(pop3-send-command process "RSET")
(pop3-read-response process))
(defun pop3-quit (process)
"Close connection to POP3 server.
Tell server to remove all messages marked as deleted, unlock the maildrop,
and close the connection."
(pop3-send-command process "QUIT")
(pop3-read-response process t)
(if process
(save-excursion
(set-buffer (process-buffer process))
(goto-char (point-max))
(delete-process process))))
(provide 'pop3)