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