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.17
   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 ;; Variables
  54 ;;
  55 ;;  pop3-fma-spool-file-alist      ... Spool file alist of POP3 protocol
  56 ;;  pop3-fma-movemail-type         ... Type of movemail program.
  57 ;;                                         'lisp or 'exe
  58 ;;                                         'lisp use pop3.el
  59 ;;                                         'exe use movemail
  60 ;;  pop3-fma-movemail-arguments    ... List of options of movemail program.
  61 ;;
  62 ;;; Code:
  63
  64 (require 'cl)
  65 (require 'custom)
  66
  67 (unless (and (condition-case ()
  68                  (require 'custom)
  69                (file-error nil))
  70              (fboundp 'defgroup)
  71              (fboundp 'defcustom))
  72   (require 'backquote)
  73   (defmacro defgroup (&rest args))
  74   (defmacro defcustom (symbol value &optional doc &rest args)
  75     (` (defvar (, symbol) (, value) (, doc))))
  76   )
  77
  78 (defgroup pop3-fma nil
  79   "Multile POP3 account utility for Gnus."
  80   :prefix "pop3-fma-"
  81   :group 'mail
  82   :group 'news)
  83
  84 (defconst pop3-fma-version-number "1.16")
  85 (defconst pop3-fma-codename
  86 ;;  "J boy"                     ; 1.00
  87 ;;  "Blood line"                ; 1.10
  88 ;;  "Star ring"                 ; 1.11
  89 ;;  "Goodbye Game"              ; 1.12
  90 ;;  "Love is Gamble"            ; 1.13
  91 ;;  "Lonely"                    ; 1.14
  92 ;;  "Feel the wind"             ; 1.16
  93   "Sadness like snow"           ; 1.17
  94   )
  95 (defconst pop3-fma-version (format "Multiple POP3 account utiliy for Gnus v%s - \"%s\""
  96                                        pop3-fma-version-number
  97                                        pop3-fma-codename))
  98
  99 (defcustom pop3-fma-spool-file-alist nil
 100   "*Spool file to get mail using pop3 protocol.
 101 You should specify this variable like
 102  '(
 103    (\"po:user1@mailhost1\" type)
 104    (\"po:user2@mailhost2\" type)
 105   )
 106 Type must be pass or apop."
 107   :group 'pop3-fma
 108   :type 'alist)
 109
 110 (defcustom pop3-fma-local-spool-file-alist nil
 111   "*List of Local spool file to get mail."
 112   :group 'pop3-fma
 113   :type 'alist)
 114
 115 (defcustom pop3-fma-movemail-type 'lisp
 116   "*Type of movemail program.
 117 Lisp means `nnmail-movemail-program' is lisp function.
 118  Exe means `nnmail-movemail-program' is external program."
 119   :group 'pop3-fma
 120   :type '(choice (const lisp)
 121                  (const exe)))
 122
 123 (defcustom pop3-fma-movemail-arguments '("-pf")
 124   "*Options for movemail."
 125   :group 'pop3-fma
 126   :type '(repeat (string :tag "Argument")))
 127
 128 (defcustom pop3-fma-save-password-information nil
 129   "*If non nil , save POP Server's password information.
 130 ============== Important notice =====================
 131 Please take care of your password information.
 132 If set to t , your pop3 password is saved in pop3-fma-password in raw text.
 133 So , Anybody can see this information by describe-variable.
 134 If there is any problem , please set this variable to nil(default).
 135 ============== Important notice ====================="
 136   :group 'pop3-fma
 137   :type 'boolean)
 138
 139 ;;; Internal variables.
 140 (defvar pop3-fma-password nil
 141   "*POP3 password , user , mailhost information for Gnus.")
 142
 143 (defvar pop3-fma-movemail-program
 144   (if (eq system-type 'windows-nt)
 145       "movemail.exe"
 146     "movemail")
 147   "*External program name your movemail.")
 148
 149
 150 ;; Temporary variable
 151 (defvar hdr nil)
 152 (defvar passwd nil)
 153 (defvar str nil)
 154 (defvar spool nil)
 155 (defvar movemail-output-buffer " *movemail-out*")
 156 (defvar pop3-fma-commandline-arguments nil)
 157
 158 ;;; To silence byte compiler
 159 (and
 160  (fboundp 'eval-when-compile)
 161  (eval-when-compile
 162    (save-excursion
 163      (beginning-of-defun)
 164      (eval-region (point-min) (point)))
 165    (let (case-fold-search)
 166      (mapcar
 167       (function
 168        (lambda (symbol)
 169          (unless (boundp symbol)
 170            (make-local-variable symbol)
 171            (eval (list 'setq symbol nil)))))
 172       '(:group
 173         :prefix :type
 174         pop3-maildrop
 175         pop3-mailhost
 176         ))
 177      (make-local-variable 'byte-compile-warnings)
 178      (setq byte-compile-warnings nil))))
 179
 180 (defun pop3-fma-init-message-hook ()
 181   (add-hook 'message-send-hook 'pop3-fma-message-add-header))
 182
 183 (eval-after-load "message"
 184   '(pop3-fma-init-message-hook))
 185
 186 (add-hook 'gnus-after-exiting-gnus-hook
 187           '(lambda () (setq pop3-fma-password nil)))
 188 (add-hook 'gnus-before-startup-hook 'pop3-fma-set-pop3-password)
 189
 190 ;;
 191 ;;
 192 ;; Gnus POP3 additional utility...
 193 ;;
 194 (defun pop3-fma-movemail (inbox crashbox)
 195   "Function to move mail from INBOX on a pop3 server to file CRASHBOX."
 196   (if (string-match "^po:" inbox)
 197       (progn
 198         (if (and pop3-fma-save-password-information
 199                  (not pop3-fma-password))
 200             (pop3-fma-set-pop3-password))
 201         (let ((pop3-maildrop
 202                (substring inbox (match-end (string-match "^po:" inbox))
 203                           (- (match-end (string-match "^.*@" inbox)) 1)))
 204               (pop3-mailhost
 205                (substring inbox (match-end (string-match "^.*@" inbox))))
 206               (pop3-password
 207                (if (and pop3-fma-save-password-information
 208                         pop3-fma-password)
 209                    (pop3-fma-read-passwd (substring inbox (match-end (string-match "^.*@" inbox))))
 210                  (pop3-fma-input-password
 211                   (substring inbox (match-end (string-match "^.*@" inbox)))
 212                   (substring inbox (match-end (string-match "^po:" inbox))
 213                              (- (match-end (string-match "^.*@" inbox)) 1)))))
 214               (pop3-authentication-scheme
 215                (nth 1 (assoc inbox pop3-fma-spool-file-alist))))
 216 ;;            (pop3-fma-movemail-type (pop3-fma-get-movemail-type inbox)))
 217           (if (eq pop3-authentication-scheme 'pass)
 218               (message "Checking new mail user %s at %s using USER/PASS ..." pop3-maildrop pop3-mailhost)
 219             (message "Checking new mail user %s at %s using APOP ..." pop3-maildrop pop3-mailhost))
 220           (if (eq pop3-fma-movemail-type 'exe)
 221               (progn
 222                 (setenv "MAILHOST" pop3-mailhost)
 223                 (if (and (not (memq pop3-password pop3-fma-commandline-arguments))
 224                          (not (memq (concat "po:" pop3-maildrop) pop3-fma-commandline-arguments)))
 225                     (progn
 226                       (if (eq pop3-authentication-scheme 'apop)
 227                           (setq pop3-fma-commandline-arguments
 228                                 (append
 229                                  pop3-fma-movemail-arguments
 230                                  (list
 231                                   "-A"
 232                                   (concat "po:" pop3-maildrop)
 233                                   crashbox
 234                                   pop3-password)))
 235                         (setq pop3-fma-commandline-arguments
 236                               (append
 237                                pop3-fma-movemail-arguments
 238                                (list
 239                                 (concat "po:" pop3-maildrop)
 240                                 crashbox
 241                                 pop3-password))))))
 242                 (if (not (get-buffer movemail-output-buffer))
 243                     (get-buffer-create movemail-output-buffer))
 244                 (set-buffer movemail-output-buffer)
 245                 (erase-buffer)
 246                 (apply 'call-process (concat
 247                                       exec-directory
 248                                       pop3-fma-movemail-program)
 249                        nil movemail-output-buffer nil
 250                        pop3-fma-commandline-arguments)
 251                 (let ((string (buffer-string)))
 252                   (if (> (length string) 0)
 253                       (progn
 254                         (if (y-or-n-p
 255                              (concat (substring string 0
 256                                                 (- (length string) 1))
 257                                                 " continue ??"))
 258                             nil
 259                           nil)))))
 260             (pop3-movemail crashbox))))
 261     (message "Checking new mail at %s ... " inbox)
 262     (call-process (concat exec-directory pop3-fma-movemail-program)
 263                   nil
 264                   nil
 265                   nil
 266                   inbox
 267                   crashbox)
 268     (message "Checking new mail at %s ... done." inbox)))
 269 ;;
 270 ;;
 271 (defun pop3-fma-read-passwd (mailhost)
 272   (setq passwd (nth 2 (assoc mailhost pop3-fma-password)))
 273   passwd)
 274
 275 (defun pop3-fma-input-password (mailhost maildrop)
 276   (pop3-fma-read-noecho
 277    (format "POP Password for %s at %s: " maildrop mailhost) t))
 278
 279 (setq pop3-read-passwd 'pop3-fma-read-passwd
 280       nnmail-read-passwd 'pop3-fma-read-passwd)
 281 ;;
 282 ;; Set multiple pop3 server's password
 283 (defun pop3-fma-store-password (passwd)
 284   (interactive
 285    (list (pop3-fma-read-noecho
 286           (format "POP Password for %s at %s: " pop3-maildrop pop3-mailhost) t)))
 287   (if (not (assoc pop3-mailhost pop3-fma-password))
 288       (setq pop3-fma-password
 289             (append pop3-fma-password
 290                     (list
 291                      (list
 292                       pop3-mailhost
 293                       pop3-maildrop
 294                       passwd)))))
 295     (setcar (cdr (cdr (assoc pop3-mailhost pop3-fma-password)))
 296             passwd)
 297     (message "POP password registered.")
 298     passwd)
 299 ;;
 300 ;;;###autoload
 301 (defun pop3-fma-set-pop3-password()
 302   (interactive)
 303   (if pop3-fma-save-password-information
 304       (progn
 305         (mapcar
 306          (lambda (x)
 307            (let ((pop3-maildrop
 308                   (substring (car x) (match-end (string-match "^po:" (car x)))
 309                              (- (match-end (string-match "^.*@" (car x))) 1)))
 310                  (pop3-mailhost
 311                   (substring (car x) (match-end (string-match "^.*@" (car x))))))
 312              (call-interactively 'pop3-fma-store-password)))
 313          pop3-fma-spool-file-alist)))
 314   (setq nnmail-movemail-program 'pop3-fma-movemail)
 315 ;;  (setq nnmail-spool-file pop3-fma-spool-file-alist))
 316   (setq nnmail-spool-file (append
 317                            pop3-fma-local-spool-file-alist
 318                            (mapcar
 319                             (lambda (spool)
 320                               (car spool))
 321                             pop3-fma-spool-file-alist))))
 322 ;;
 323 (defmacro pop3-fma-read-char-exclusive ()
 324   (cond ((featurep 'xemacs)
 325          '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
 326                                (left . ?\C-h))))
 327                 event key)
 328             (while (not
 329                     (and
 330                      (key-press-event-p (setq event (next-command-event)))
 331                      (setq key (or (event-to-character event)
 332                                    (cdr (assq (event-key event) table)))))))
 333             key))
 334         ((fboundp 'read-char-exclusive)
 335          '(read-char-exclusive))
 336         (t
 337          '(read-char))))
 338 ;;
 339 (defun pop3-fma-read-noecho (prompt &optional stars)
 340   "Read a single line of text from user without echoing, and return it.
 341 Argument PROMPT ."
 342   (let ((ans "")
 343         (c 0)
 344         (echo-keystrokes 0)
 345         (cursor-in-echo-area t)
 346         (log-message-max-size 0)
 347         message-log-max done msg truncate)
 348     (while (not done)
 349       (if (or (not stars) (string-equal "" ans))
 350           (setq msg prompt)
 351         (setq msg (concat prompt (make-string (length ans) ?*)))
 352         (setq truncate
 353               (1+ (- (length msg) (window-width (minibuffer-window)))))
 354         (and (> truncate 0)
 355              (setq msg (concat "$" (substring msg (1+ truncate))))))
 356       (message msg)
 357       (setq c (pop3-fma-read-char-exclusive))
 358       (cond ((eq ?\C-g c)
 359              (setq quit-flag t
 360                    done t))
 361             ((memq c '(?\r ?\n ?\e))
 362              (setq done t))
 363             ((eq ?\C-u c)
 364              (setq ans ""))
 365             ((and (/= ?\b c) (/= ?\177 c))
 366              (setq ans (concat ans (char-to-string c))))
 367             ((> (length ans) 0)
 368              (setq ans (substring ans 0 -1)))))
 369     (if quit-flag
 370         (prog1
 371             (setq quit-flag nil)
 372           (message "Quit")
 373           (beep t))
 374       (message "")
 375       ans)))
 376 ;;
 377 ;;
 378 (defun pop3-fma-message-add-header ()
 379   (if (message-mail-p)
 380       (pop3-fma-add-custom-header "X-Ya-Pop3:" pop3-fma-version)))
 381
 382 ;;
 383 ;; Add your custom header.
 384 (defun pop3-fma-add-custom-header (header string)
 385   (let ((delimline
 386          (progn (goto-char (point-min))
 387                 (re-search-forward
 388                  (concat "^" (regexp-quote mail-header-separator) "\n"))
 389                 (point-marker))))
 390     (goto-char (point-min))
 391     (or (re-search-forward (concat "^" header) delimline t)
 392         (progn
 393           (goto-char delimline)
 394           (forward-line -1)
 395           (beginning-of-line)
 396           (setq hdr (concat header " "))
 397           (setq str (concat hdr string))
 398           (setq hdr (concat str "\n"))
 399           (insert-string hdr)))))
 400 ;;
 401 ;;
 402 (defun pop3-fma-get-movemail-type (inbox)
 403   (if (eq (nth 1 (assoc inbox pop3-fma-spool-file-alist)) 'apop)
 404       'lisp
 405     pop3-fma-movemail-type))
 406 ;;
 407 (provide 'pop3-fma)
 408 ;;
 409 ;; pop3-fma.el ends here.
 410
 411