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: 0.21
   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"
  45 ;;          "po:username1@mailhost1.your.domain1"
  46 ;;                         :
  47 ;;                         :
  48 ;;         ))
  49 ;;
  50 ;; Variables
  51 ;;
  52 ;;  pop3-fma-spool-file-alist      ... Spool file alist of POP3 protocol
  53 ;;  pop3-fma-movemail-type         ... Type of movemail program.
  54 ;;                                         'lisp or 'exe
  55 ;;                                         'lisp use pop3.el
  56 ;;                                         'exe use movemail
  57 ;;  pop3-fma-movemail-arguments    ... List of options of movemail program.
  58 ;;
  59 ;;; Code:
  60
  61 (require 'cl)
  62 (require 'custom)
  63
  64 (unless (and (condition-case ()
  65                  (require 'custom)
  66                (file-error nil))
  67              (fboundp 'defgroup)
  68              (fboundp 'defcustom))
  69   (require 'backquote)
  70   (defmacro defgroup (&rest args))
  71   (defmacro defcustom (symbol value &optional doc &rest args)
  72     (` (defvar (, symbol) (, value) (, doc))))
  73   )
  74
  75 (unless (and (fboundp 'pop3-fma-encode-string)
  76              (fboundp 'pop3-fma-decode-string))
  77   (require 'mel-b)
  78   (fset 'pop3-fma-encode-string 'base64-encode-string)
  79   (fset 'pop3-fma-decode-string 'base64-decode-string))
  80
  81 (defgroup pop3-fma nil
  82   "Multile POP3 account utility for Gnus."
  83   :prefix "pop3-fma-"
  84   :group 'mail
  85   :group 'news)
  86
  87 (defconst pop3-fma-version-number "0.21")
  88 (defconst pop3-fma-codename
  89 ;;  "Feel the wind"             ; 0.10
  90 ;;  "My home town"              ; 0.11
  91 ;;  "On the road"               ; 0.12
  92 ;;  "Rock'n Roll city"          ; 0.13
  93 ;;  "Money"                     ; 0.20
  94   "Still 19"                    ; 0.21
  95 ;;  "J boy"                     ; 0.xx
  96 ;;  "Blood line"                ; 0.xx
  97 ;;  "Star ring"                 ; 0.xx
  98 ;;  "Goodbye Game"              ; 0.xx
  99   )
 100 (defconst pop3-fma-version (format "Multiple POP3 account utiliy for Gnus v%s - \"%s\""
 101                                        pop3-fma-version-number
 102                                        pop3-fma-codename))
 103
 104 (defcustom pop3-fma-spool-file-alist nil
 105   "*Spool file to get mail using pop3 protocol.
 106 You should specify this variable like
 107  '(
 108    \"po:user1@mailhost1\"
 109    \"po:user2@mailhost2\"
 110   )"
 111   :group 'pop3-fma
 112   :type 'alist)
 113
 114 (defcustom pop3-fma-local-spool-file-alist nil
 115   "*List of Local spool file to get mail."
 116   :group 'pop3-fma
 117   :type 'alist)
 118
 119 (defcustom pop3-fma-movemail-type 'lisp
 120   "*Type of movemail program.
 121 Lisp means `nnmail-movemail-program' is lisp function.
 122  Exe means `nnmail-movemail-program' is external program.
 123  Please do not use exe if you do not use Meadow."
 124   :group 'pop3-fma
 125   :type '(choice (const lisp)
 126                  (const exe)))
 127
 128 (defcustom pop3-fma-movemail-arguments '("-pf")
 129   "*Options for movemail."
 130   :group 'pop3-fma
 131   :type '(repeat (string :tag "Argument")))
 132
 133 ;;; Internal variables.
 134 (defvar pop3-fma-password nil
 135   "*POP3 password , user , mailhost information for Gnus.")
 136
 137 (defvar pop3-fma-movemail-program "movemail.exe"
 138   "*External program name your movemail.
 139 Please do not set this valiable non-nil if you do not use Meadow.")
 140
 141 ;; Temporary variable
 142 (defvar hdr nil)
 143 (defvar passwd nil)
 144 (defvar str nil)
 145 (defvar pop3-fma-movemail-options pop3-fma-movemail-arguments)
 146 (defvar spool nil)
 147
 148 (defun pop3-fma-init-message-hook ()
 149   (add-hook 'message-send-hook 'pop3-fma-message-add-header))
 150
 151 (eval-after-load "message"
 152   '(pop3-fma-init-message-hook))
 153
 154 (add-hook 'gnus-after-exiting-gnus-hook
 155           '(lambda () (setq pop3-fma-password nil)))
 156 (add-hook 'gnus-before-startup-hook 'pop3-fma-set-pop3-password)
 157
 158 ;;
 159 ;;
 160 ;; Gnus POP3 additional utility...
 161 ;;
 162 (defun pop3-fma-movemail (inbox crashbox)
 163   "Function to move mail from INBOX on a pop3 server to file CRASHBOX."
 164   (if (string-match "^po:" inbox)
 165       (progn
 166         (let ((pop3-maildrop
 167                (substring inbox (match-end (string-match "^po:" inbox))
 168                           (- (match-end (string-match "^.*@" inbox)) 1)))
 169               (pop3-mailhost
 170                (substring inbox (match-end (string-match "^.*@" inbox)))))
 171           (let ((pop3-password
 172                  (pop3-fma-read-passwd pop3-mailhost)))
 173             (message "Checking new mail user %s at %s..." pop3-maildrop pop3-mailhost)
 174             (if (and (eq system-type 'windows-nt)
 175                      (eq pop3-fma-movemail-type 'exe))
 176                 (progn
 177                   (setenv "MAILHOST" pop3-mailhost)
 178                   (if (and (not (memq pop3-password pop3-fma-movemail-arguments))
 179                            (not (memq (concat "po:" pop3-maildrop) pop3-fma-movemail-arguments)))
 180                       (progn
 181                         (setq pop3-fma-movemail-arguments nil)
 182                         (setq pop3-fma-movemail-arguments
 183                               (append pop3-fma-movemail-options
 184                                       (list
 185                                        (concat "po:" pop3-maildrop)
 186                                        crashbox
 187                                        pop3-password)))))
 188                   (apply 'call-process (concat
 189                                         exec-directory
 190                                         pop3-fma-movemail-program)
 191                          nil nil nil
 192                          pop3-fma-movemail-arguments))
 193               (pop3-movemail crashbox)))))
 194     (message "Checking new mail at %s ... " inbox)
 195     (call-process (concat exec-directory pop3-fma-movemail-program)
 196                   nil
 197                   nil
 198                   nil
 199                   inbox
 200                   crashbox)
 201     (message "Checking new mail at %s ... done." inbox)))
 202 ;;
 203 ;;
 204 (defun pop3-fma-read-passwd (mailhost)
 205   (setq passwd (nth 2 (assoc mailhost pop3-fma-password)))
 206   (pop3-fma-decode-string passwd))
 207
 208 (setq pop3-read-passwd 'pop3-fma-read-passwd)
 209 ;;
 210 ;; Set multiple pop3 server's password
 211 (defun pop3-fma-store-password (passwd)
 212   (interactive
 213    (list (pop3-fma-read-noecho
 214           (format "POP Password for %s at %s: " pop3-maildrop pop3-mailhost) t)))
 215   (if (not (assoc pop3-mailhost pop3-fma-password))
 216       (setq pop3-fma-password
 217             (append pop3-fma-password
 218                     (list
 219                      (list
 220                       pop3-mailhost
 221                       pop3-maildrop
 222                       (pop3-fma-encode-string passwd)))))
 223     (setcar (cdr (cdr (assoc pop3-mailhost pop3-fma-password)))
 224             (pop3-fma-encode-string passwd)))
 225   (message "POP password registered.")
 226   (pop3-fma-encode-string passwd))
 227 ;;
 228 ;;;###autoload
 229 (defun pop3-fma-set-pop3-password()
 230   (interactive)
 231   (mapcar
 232    (lambda (x)
 233      (let ((pop3-maildrop
 234             (substring x (match-end (string-match "^po:" x))
 235                        (- (match-end (string-match "^.*@" x)) 1)))
 236            (pop3-mailhost
 237             (substring x (match-end (string-match "^.*@" x)))))
 238        (call-interactively 'pop3-fma-store-password)))
 239    pop3-fma-spool-file-alist)
 240   (setq nnmail-movemail-program 'pop3-fma-movemail)
 241 ;;  (setq nnmail-spool-file pop3-fma-spool-file-alist))
 242   (setq nnmail-spool-file (append
 243                            pop3-fma-local-spool-file-alist
 244                            pop3-fma-spool-file-alist)))
 245 ;;
 246 (defun pop3-fma-read-noecho (prompt &optional stars)
 247   "Read a single line of text from user without echoing, and return it.
 248 Argument PROMPT ."
 249   (let ((ans "")
 250         (c 0)
 251         (echo-keystrokes 0)
 252         (cursor-in-echo-area t)
 253         (log-message-max-size 0)
 254         message-log-max done msg truncate)
 255     (while (not done)
 256       (if (or (not stars) (string-equal "" ans))
 257           (setq msg prompt)
 258         (setq msg (concat prompt (make-string (length ans) ?*)))
 259         (setq truncate
 260               (1+ (- (length msg) (window-width (minibuffer-window)))))
 261         (and (> truncate 0)
 262              (setq msg (concat "$" (substring msg (1+ truncate))))))
 263       (message msg)
 264       (setq c (read-char-exclusive))
 265       (cond ((= c ?\C-g)
 266              (setq quit-flag t
 267                    done t))
 268             ((or (= c ?\r) (= c ?\n) (= c ?\e))
 269              (setq done t))
 270             ((= c ?\C-u)
 271              (setq ans ""))
 272             ((and (/= c ?\b) (/= c ?\177))
 273              (setq ans (concat ans (char-to-string c))))
 274             ((> (length ans) 0)
 275              (setq ans (substring ans 0 -1)))))
 276     (if quit-flag
 277         (prog1
 278             (setq quit-flag nil)
 279           (message "Quit")
 280           (beep t))
 281       (message "")
 282       ans)))
 283 ;;
 284 ;;
 285 (defun pop3-fma-message-add-header ()
 286   (if (message-mail-p)
 287       (pop3-fma-add-custom-header "X-Ya-Pop3:" pop3-fma-version)))
 288
 289 ;;
 290 ;; Add your custom header.
 291 ;;
 292 (defun pop3-fma-add-custom-header (header string)
 293   (let ((delimline
 294          (progn (goto-char (point-min))
 295                 (re-search-forward
 296                  (concat "^" (regexp-quote mail-header-separator) "\n"))
 297                 (point-marker))))
 298     (goto-char (point-min))
 299     (or (re-search-forward (concat "^" header) delimline t)
 300         (progn
 301           (goto-char delimline)
 302           (forward-line -1)
 303           (beginning-of-line)
 304           (setq hdr (concat header " "))
 305           (setq str (concat hdr string))
 306           (setq hdr (concat str "\n"))
 307           (insert-string hdr)))))
 308 ;;
 309 (provide 'pop3-fma)
 310 ;;
 311 ;; pop3-fma.el ends here.