git.chise.org Git - elisp/gnus.git-/blob - lisp/pop3-fma.el

   1 ;; pop3-fma.el.el --- POP3 for Multiple Account for Gnus.
   2 ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. , Tatsuya Ichikawa
   3 ;;                                                           Yasuo Okabe
   4 ;; Author: Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
   5 ;;         Yasuo OKABE <okabe@kuis.kyoto-u.ac.jp>
   6 ;; Version: 1.12
   7 ;; Keywords: mail , gnus , pop3
   8 ;;
   9 ;; SPECIAL THANKS
  10 ;;    Keiichi Suzuki <kei-suzu@mail.wbs.or.jp>
  11 ;;    Katsumi Yamaoka <yamaoka@jpl.org>
  12 ;;
  13 ;; This file is not part of GNU Emacs.
  14
  15 ;; GNU Emacs is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation; either version 2, or (at your option)
  18 ;; any later version.
  19
  20 ;; GNU Emacs is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29
  30 ;;; Commentary:
  31 ;;
  32 ;; Note.
  33 ;;
  34 ;; This file store pop3 password in variable "pop3-fma-password".
  35 ;; Please take care by yourself to treat pop3 password.
  36 ;;
  37 ;; How to use.
  38 ;;
  39 ;; add your .emacs following codes.
  40 ;;
  41 ;;  (require 'pop3-fma)
  42 ;;  (setq pop3-fma-spool-file-alist
  43 ;;        '(
  44 ;;          ("po:username0@mailhost0.your.domain0" pass)
  45 ;;          ("po:username1@mailhost1.your.domain1" apop)
  46 ;;                         :
  47 ;;                         :
  48 ;;         ))
  49 ;;
  50 ;;      pass means normal authentication USER/PASS.
  51 ;;      apop means authentication using APOP.
  52 ;;
  53 ;; When using apop , Please set pop3-fma-movemail-type 'lisp.
  54 ;; movemail.exe does not work on APOP protocol.
  55 ;;
  56 ;; Variables
  57 ;;
  58 ;;  pop3-fma-spool-file-alist      ... Spool file alist of POP3 protocol
  59 ;;  pop3-fma-movemail-type         ... Type of movemail program.
  60 ;;                                         'lisp or 'exe
  61 ;;                                         'lisp use pop3.el
  62 ;;                                         'exe use movemail
  63 ;;  pop3-fma-movemail-arguments    ... List of options of movemail program.
  64 ;;
  65 ;;; Code:
  66
  67 (require 'cl)
  68 (require 'custom)
  69
  70 (unless (and (condition-case ()
  71                  (require 'custom)
  72                (file-error nil))
  73              (fboundp 'defgroup)
  74              (fboundp 'defcustom))
  75   (require 'backquote)
  76   (defmacro defgroup (&rest args))
  77   (defmacro defcustom (symbol value &optional doc &rest args)
  78     (` (defvar (, symbol) (, value) (, doc))))
  79   )
  80
  81 (unless (and (fboundp 'pop3-fma-encode-string)
  82              (fboundp 'pop3-fma-decode-string))
  83   (require 'mel-b)
  84   (fset 'pop3-fma-encode-string 'base64-encode-string)
  85   (fset 'pop3-fma-decode-string 'base64-decode-string))
  86
  87 (defgroup pop3-fma nil
  88   "Multile POP3 account utility for Gnus."
  89   :prefix "pop3-fma-"
  90   :group 'mail
  91   :group 'news)
  92
  93 (defconst pop3-fma-version-number "1.12")
  94 (defconst pop3-fma-codename
  95 ;;  "Feel the wind"             ; 0.10
  96 ;;  "My home town"              ; 0.11
  97 ;;  "On the road"               ; 0.12
  98 ;;  "Rock'n Roll city"          ; 0.13
  99 ;;  "Money"                     ; 0.20
 100 ;;  "Still 19"                  ; 0.21
 101 ;;  "J boy"                     ; 1.00
 102 ;;  "Blood line"                ; 1.10
 103 ;;  "Star ring"                 ; 1.11
 104   "Goodbye Game"                ; 1.12
 105   )
 106 (defconst pop3-fma-version (format "Multiple POP3 account utiliy for Gnus v%s - \"%s\""
 107                                        pop3-fma-version-number
 108                                        pop3-fma-codename))
 109
 110 (defcustom pop3-fma-spool-file-alist nil
 111   "*Spool file to get mail using pop3 protocol.
 112 You should specify this variable like
 113  '(
 114    (\"po:user1@mailhost1\" type)
 115    (\"po:user2@mailhost2\" type)
 116   )
 117 Type must be pass or apop."
 118   :group 'pop3-fma
 119   :type 'alist)
 120
 121 (defcustom pop3-fma-local-spool-file-alist nil
 122   "*List of Local spool file to get mail."
 123   :group 'pop3-fma
 124   :type 'alist)
 125
 126 (defcustom pop3-fma-movemail-type 'lisp
 127   "*Type of movemail program.
 128 Lisp means `nnmail-movemail-program' is lisp function.
 129  Exe means `nnmail-movemail-program' is external program.
 130  Please do not use exe if you do not use Meadow."
 131   :group 'pop3-fma
 132   :type '(choice (const lisp)
 133                  (const exe)))
 134
 135 (defcustom pop3-fma-movemail-arguments '("-pf")
 136   "*Options for movemail."
 137   :group 'pop3-fma
 138   :type '(repeat (string :tag "Argument")))
 139
 140 ;;; Internal variables.
 141 (defvar pop3-fma-password nil
 142   "*POP3 password , user , mailhost information for Gnus.")
 143
 144 (defvar pop3-fma-movemail-program "movemail.exe"
 145   "*External program name your movemail.
 146 Please do not set this valiable non-nil if you do not use Meadow.")
 147
 148 ;; Temporary variable
 149 (defvar hdr nil)
 150 (defvar passwd nil)
 151 (defvar str nil)
 152 (defvar spool nil)
 153 (defvar movemail-output-buffer " *movemail-out*")
 154 (defvar pop3-fma-commandline-arguments nil)
 155
 156 (defun pop3-fma-init-message-hook ()
 157   (add-hook 'mime-edit-translate-hook 'pop3-fma-message-add-header))
 158
 159 (eval-after-load "message"
 160   '(pop3-fma-init-message-hook))
 161
 162 (add-hook 'gnus-after-exiting-gnus-hook
 163           '(lambda () (setq pop3-fma-password nil)))
 164 (add-hook 'gnus-before-startup-hook 'pop3-fma-set-pop3-password)
 165
 166 ;;
 167 ;;
 168 ;; Gnus POP3 additional utility...
 169 ;;
 170 (defun pop3-fma-movemail (inbox crashbox)
 171   "Function to move mail from INBOX on a pop3 server to file CRASHBOX."
 172   (if (string-match "^po:" inbox)
 173       (progn
 174         (let ((pop3-maildrop
 175                (substring inbox (match-end (string-match "^po:" inbox))
 176                           (- (match-end (string-match "^.*@" inbox)) 1)))
 177               (pop3-mailhost
 178                (substring inbox (match-end (string-match "^.*@" inbox))))
 179               (pop3-password
 180                (pop3-fma-read-passwd (substring inbox (match-end (string-match "^.*@" inbox)))))
 181               (pop3-authentication-scheme
 182                (nth 1 (assoc inbox pop3-fma-spool-file-alist)))
 183               (pop3-fma-movemail-type (pop3-fma-get-movemail-type inbox)))
 184           (if (eq pop3-authentication-scheme 'pass)
 185               (message "Checking new mail user %s at %s using USER/PASS ..." pop3-maildrop pop3-mailhost)
 186             (message "Checking new mail user %s at %s using APOP ..." pop3-maildrop pop3-mailhost))
 187           (if (and (eq system-type 'windows-nt)
 188                    (eq pop3-fma-movemail-type 'exe))
 189               (progn
 190                 (setenv "MAILHOST" pop3-mailhost)
 191                 (if (and (not (memq pop3-password pop3-fma-commandline-arguments))
 192                          (not (memq (concat "po:" pop3-maildrop) pop3-fma-commandline-arguments)))
 193                     (progn
 194                       (setq pop3-fma-commandline-arguments
 195                             (append
 196                              pop3-fma-movemail-arguments
 197                                     (list
 198                                      (concat "po:" pop3-maildrop)
 199                                      crashbox
 200                                      pop3-password)))))
 201                 (if (not (get-buffer movemail-output-buffer))
 202                     (get-buffer-create movemail-output-buffer))
 203                 (set-buffer movemail-output-buffer)
 204                 (erase-buffer)
 205                 (apply 'call-process (concat
 206                                       exec-directory
 207                                       pop3-fma-movemail-program)
 208                        nil movemail-output-buffer nil
 209                        pop3-fma-commandline-arguments)
 210                 (let ((string (buffer-string)))
 211                   (if (> (length string) 0)
 212                       (progn
 213                         (if (y-or-n-p
 214                              (concat (substring string 0
 215                                                 (- (length string) 1))
 216                                                 " continue ??"))
 217                             nil
 218                           nil)))))
 219             (pop3-movemail crashbox))))
 220     (message "Checking new mail at %s ... " inbox)
 221     (call-process (concat exec-directory pop3-fma-movemail-program)
 222                   nil
 223                   nil
 224                   nil
 225                   inbox
 226                   crashbox)
 227     (message "Checking new mail at %s ... done." inbox)))
 228 ;;
 229 ;;
 230 (defun pop3-fma-read-passwd (mailhost)
 231   (setq passwd (nth 2 (assoc mailhost pop3-fma-password)))
 232   (pop3-fma-decode-string passwd))
 233
 234 (setq pop3-read-passwd 'pop3-fma-read-passwd)
 235 ;;
 236 ;; Set multiple pop3 server's password
 237 (defun pop3-fma-store-password (passwd)
 238   (interactive
 239    (list (pop3-fma-read-noecho
 240           (format "POP Password for %s at %s: " pop3-maildrop pop3-mailhost) t)))
 241   (if (not (assoc pop3-mailhost pop3-fma-password))
 242       (setq pop3-fma-password
 243             (append pop3-fma-password
 244                     (list
 245                      (list
 246                       pop3-mailhost
 247                       pop3-maildrop
 248                       (pop3-fma-encode-string passwd)))))
 249     (setcar (cdr (cdr (assoc pop3-mailhost pop3-fma-password)))
 250             (pop3-fma-encode-string passwd)))
 251   (message "POP password registered.")
 252   (pop3-fma-encode-string passwd))
 253 ;;
 254 ;;;###autoload
 255 (defun pop3-fma-set-pop3-password()
 256   (interactive)
 257   (mapcar
 258    (lambda (x)
 259      (let ((pop3-maildrop
 260             (substring (car x) (match-end (string-match "^po:" (car x)))
 261                        (- (match-end (string-match "^.*@" (car x))) 1)))
 262            (pop3-mailhost
 263             (substring (car x) (match-end (string-match "^.*@" (car x))))))
 264        (call-interactively 'pop3-fma-store-password)))
 265    pop3-fma-spool-file-alist)
 266   (setq nnmail-movemail-program 'pop3-fma-movemail)
 267 ;;  (setq nnmail-spool-file pop3-fma-spool-file-alist))
 268   (setq nnmail-spool-file (append
 269                            pop3-fma-local-spool-file-alist
 270                            (mapcar
 271                             (lambda (spool)
 272                               (car spool))
 273                             pop3-fma-spool-file-alist))))
 274 ;;
 275 (defmacro pop3-fma-read-char-exclusive ()
 276   (cond ((featurep 'xemacs)
 277          '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
 278                                (left . ?\C-h))))
 279                 event key)
 280             (while (not
 281                     (and
 282                      (key-press-event-p (setq event (next-command-event)))
 283                      (setq key (or (event-to-character event)
 284                                    (cdr (assq (event-key event) table)))))))
 285             key))
 286         ((fboundp 'read-char-exclusive)
 287          '(read-char-exclusive))
 288         (t
 289          '(read-char))))
 290 ;;
 291 (defun pop3-fma-read-noecho (prompt &optional stars)
 292   "Read a single line of text from user without echoing, and return it.
 293 Argument PROMPT ."
 294   (let ((ans "")
 295         (c 0)
 296         (echo-keystrokes 0)
 297         (cursor-in-echo-area t)
 298         (log-message-max-size 0)
 299         message-log-max done msg truncate)
 300     (while (not done)
 301       (if (or (not stars) (string-equal "" ans))
 302           (setq msg prompt)
 303         (setq msg (concat prompt (make-string (length ans) ?*)))
 304         (setq truncate
 305               (1+ (- (length msg) (window-width (minibuffer-window)))))
 306         (and (> truncate 0)
 307              (setq msg (concat "$" (substring msg (1+ truncate))))))
 308       (message msg)
 309       (setq c (pop3-fma-read-char-exclusive))
 310       (cond ((eq ?\C-g c)
 311              (setq quit-flag t
 312                    done t))
 313             ((memq c '(?\r ?\n ?\e))
 314              (setq done t))
 315             ((eq ?\C-u c)
 316              (setq ans ""))
 317             ((and (/= ?\b c) (/= ?\177 c))
 318              (setq ans (concat ans (char-to-string c))))
 319             ((> (length ans) 0)
 320              (setq ans (substring ans 0 -1)))))
 321     (if quit-flag
 322         (prog1
 323             (setq quit-flag nil)
 324           (message "Quit")
 325           (beep t))
 326       (message "")
 327       ans)))
 328 ;;
 329 ;;
 330 (defun pop3-fma-message-add-header ()
 331   (if (message-mail-p)
 332       (pop3-fma-add-custom-header "X-Ya-Pop3:" pop3-fma-version)))
 333
 334 ;;
 335 ;; Add your custom header.
 336 (defun pop3-fma-add-custom-header (header string)
 337   (let ((delimline
 338          (progn (goto-char (point-min))
 339                 (re-search-forward
 340                  (concat "^" (regexp-quote mail-header-separator) "\n"))
 341                 (point-marker))))
 342     (goto-char (point-min))
 343     (or (re-search-forward (concat "^" header) delimline t)
 344         (progn
 345           (goto-char delimline)
 346           (forward-line -1)
 347           (beginning-of-line)
 348           (setq hdr (concat header " "))
 349           (setq str (concat hdr string))
 350           (setq hdr (concat str "\n"))
 351           (insert-string hdr)))))
 352 ;;
 353 ;;
 354 (defun pop3-fma-get-movemail-type (inbox)
 355   (if (eq (nth 1 (assoc inbox pop3-fma-spool-file-alist)) 'apop)
 356       'lisp
 357     pop3-fma-movemail-type))
 358 ;;
 359 (provide 'pop3-fma)
 360 ;;
 361 ;; pop3-fma.el ends here.
 362
 363