lisp/mh-e/mh-identity.el

   1 ;;; mh-identity.el --- Multiple identify support for MH-E.
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
   4
   5 ;; Author: Peter S. Galbraith <psg@debian.org>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Multiple identity support for MH-E.
  30 ;;
  31 ;; Used to easily set different fields such as From and Organization, as
  32 ;; well as different signature files.
  33 ;;
  34 ;; Customize the variable `mh-identity-list' and an Identity menu will
  35 ;; appear in mh-letter-mode.  The command 'mh-insert-identity can be used
  36 ;; from the command line.
  37
  38 ;;; Change Log:
  39
  40 ;;; Code:
  41
  42 (eval-when-compile (require 'mh-acros))
  43 (mh-require-cl)
  44 (require 'mh-comp)
  45
  46 (autoload 'mml-insert-tag "mml")
  47
  48 (defvar mh-identity-pgg-default-user-id nil
  49   "Holds the GPG key ID to be used by pgg.el.
  50 This is normally set as part of an Identity in
  51 `mh-identity-list'.")
  52 (make-variable-buffer-local 'mh-identity-pgg-default-user-id)
  53
  54 ;;;###mh-autoload
  55 (defun mh-identity-make-menu ()
  56   "Build the Identity menu.
  57 This should be called any time `mh-identity-list' or
  58 `mh-auto-fields-list' change."
  59   (easy-menu-define mh-identity-menu mh-letter-mode-map
  60     "MH-E identity menu"
  61     (append
  62      '("Identity")
  63      ;; Dynamically render :type corresponding to `mh-identity-list'
  64      ;; e.g.:
  65      ;;  ["Home" (mh-insert-identity "Home")
  66      ;;   :style radio :active (not (equal mh-identity-local "Home"))
  67      ;;   :selected (equal mh-identity-local "Home")]
  68      '(["Insert Auto Fields"
  69         (mh-insert-auto-fields) mh-auto-fields-list]
  70        "--")
  71
  72      (mapcar (function
  73               (lambda (arg)
  74                 `[,arg  (mh-insert-identity ,arg) :style radio
  75                         :selected (equal mh-identity-local ,arg)]))
  76              (mapcar 'car mh-identity-list))
  77      '(["None"
  78         (mh-insert-identity "None") :style radio
  79         :selected (not mh-identity-local)]
  80        "--"
  81        ["Set Default for Session"
  82         (setq mh-identity-default mh-identity-local) t]
  83        ["Save as Default"
  84         (customize-save-variable 'mh-identity-default mh-identity-local) t]
  85        ["Customize Identities" (customize-variable 'mh-identity-list) t]
  86        ))))
  87
  88 ;;;###mh-autoload
  89 (defun mh-identity-list-set (symbol value)
  90   "Update the `mh-identity-list' variable, and rebuild the menu.
  91 Sets the default for SYMBOL (for example, `mh-identity-list') to
  92 VALUE (as set in customization). This is called after 'customize
  93 is used to alter `mh-identity-list'."
  94   (set-default symbol value)
  95   (mh-identity-make-menu))
  96
  97 (defvar mh-identity-local nil
  98   "Buffer-local variable that holds the identity currently in use.")
  99 (make-variable-buffer-local 'mh-identity-local)
 100
 101 (defun mh-header-field-delete (field value-only)
 102   "Delete header FIELD, or only its value if VALUE-ONLY is t.
 103 Return t if anything is deleted."
 104   (let ((field-colon (if (string-match "^.*:$" field)
 105                          field
 106                        (concat field ":"))))
 107     (when (mh-goto-header-field field-colon)
 108       (if (not value-only)
 109           (beginning-of-line)
 110         (forward-char))
 111       (delete-region (point)
 112                      (progn (mh-header-field-end)
 113                             (if (not value-only) (forward-char 1))
 114                             (point)))
 115       t)))
 116
 117 (defvar mh-identity-signature-start nil
 118   "Marker for the beginning of a signature inserted by `mh-insert-identity'.")
 119 (defvar mh-identity-signature-end nil
 120   "Marker for the end of a signature inserted by `mh-insert-identity'.")
 121
 122 (defun mh-identity-field-handler (field)
 123   "Return the handler for header FIELD or nil if none set.
 124 The field name is downcased. If the FIELD begins with the
 125 character \":\", then it must have a special handler defined in
 126 `mh-identity-handlers', else return an error since it is not a
 127 valid header field."
 128   (or (cdr (mh-assoc-ignore-case field mh-identity-handlers))
 129       (and (eq (aref field 0) ?:)
 130            (error "Field %s not found in `mh-identity-handlers'" field))
 131       (cdr (assoc ":default" mh-identity-handlers))
 132       'mh-identity-handler-default))
 133
 134 ;;;###mh-autoload
 135 (defun mh-insert-identity (identity)
 136   "Insert fields specified by given IDENTITY.
 137 See `mh-identity-list'."
 138   (interactive
 139    (list (completing-read
 140           "Identity: "
 141           (if mh-identity-local
 142               (cons '("None")
 143                     (mapcar 'list (mapcar 'car mh-identity-list)))
 144             (mapcar 'list (mapcar 'car mh-identity-list)))
 145           nil t)))
 146   (save-excursion
 147     ;;First remove old settings, if any.
 148     (when mh-identity-local
 149       (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list))))
 150         (while pers-list
 151           (let* ((field (caar pers-list))
 152                  (handler (mh-identity-field-handler field)))
 153             (funcall handler field 'remove))
 154           (setq pers-list (cdr pers-list)))))
 155     ;; Then insert the replacement
 156     (when (not (equal "None" identity))
 157       (let ((pers-list (cadr (assoc identity mh-identity-list))))
 158         (while pers-list
 159           (let* ((field (caar pers-list))
 160                  (value (cdar pers-list))
 161                  (handler (mh-identity-field-handler field)))
 162             (funcall handler field 'add value))
 163           (setq pers-list (cdr pers-list))))))
 164   ;; Remember what is in use in this buffer
 165   (if (equal "None" identity)
 166       (setq mh-identity-local nil)
 167     (setq mh-identity-local identity)))
 168
 169 ;;;###mh-autoload
 170 (defun mh-identity-handler-gpg-identity (field action &optional value)
 171   "Process header FIELD \":pgg-default-user-id\".
 172 The ACTION is one of 'remove or 'add. If 'add, the VALUE is added.
 173 The buffer-local variable `mh-identity-pgg-default-user-id' is set to
 174 VALUE when action 'add is selected."
 175   (cond
 176    ((or (equal action 'remove)
 177         (not value)
 178         (string= value ""))
 179     (setq mh-identity-pgg-default-user-id nil))
 180    ((equal action 'add)
 181     (setq mh-identity-pgg-default-user-id value))))
 182
 183 ;;;###mh-autoload
 184 (defun mh-identity-handler-signature (field action &optional value)
 185   "Process header FIELD \":signature\".
 186 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 187 added."
 188   (cond
 189    ((equal action 'remove)
 190     (when (and (markerp mh-identity-signature-start)
 191                (markerp mh-identity-signature-end))
 192       (delete-region mh-identity-signature-start
 193                      mh-identity-signature-end)))
 194    (t
 195     ;; Insert "signature". Nil value means to use `mh-signature-file-name'.
 196     (when (not (mh-signature-separator-p)) ;...unless already present
 197       (goto-char (point-max))
 198       (save-restriction
 199         (narrow-to-region (point) (point))
 200         (if (null value)
 201             (mh-insert-signature)
 202           (mh-insert-signature value))
 203         (set (make-local-variable 'mh-identity-signature-start)
 204              (point-min-marker))
 205         (set-marker-insertion-type mh-identity-signature-start t)
 206         (set (make-local-variable 'mh-identity-signature-end)
 207              (point-max-marker)))))))
 208
 209 (defvar mh-identity-attribution-verb-start nil
 210   "Marker for the beginning of the attribution verb.")
 211 (defvar mh-identity-attribution-verb-end nil
 212   "Marker for the end of the attribution verb.")
 213
 214 ;;;###mh-autoload
 215 (defun mh-identity-handler-attribution-verb (field action &optional value)
 216   "Process header FIELD \":attribution-verb\".
 217 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 218 added."
 219   (when (and (markerp mh-identity-attribution-verb-start)
 220              (markerp mh-identity-attribution-verb-end))
 221     (delete-region mh-identity-attribution-verb-start
 222                    mh-identity-attribution-verb-end)
 223     (goto-char mh-identity-attribution-verb-start)
 224     (cond
 225      ((equal action 'remove)              ; Replace with default
 226       (mh-identity-insert-attribution-verb nil))
 227      (t                                   ; Insert attribution verb.
 228       (mh-identity-insert-attribution-verb value)))))
 229
 230 ;;;###mh-autoload
 231 (defun mh-identity-insert-attribution-verb (value)
 232   "Insert VALUE as attribution verb, setting up delimiting markers.
 233 If VALUE is nil, use `mh-extract-from-attribution-verb'."
 234   (save-restriction
 235     (narrow-to-region (point) (point))
 236     (if (null value)
 237         (insert mh-extract-from-attribution-verb)
 238       (insert value))
 239     (set (make-local-variable 'mh-identity-attribution-verb-start)
 240          (point-min-marker))
 241     (set-marker-insertion-type mh-identity-attribution-verb-start t)
 242     (set (make-local-variable 'mh-identity-attribution-verb-end)
 243          (point-max-marker))))
 244
 245 (defun mh-identity-handler-default (field action top &optional value)
 246   "Process header FIELD.
 247 The ACTION is one of 'remove or 'add. If TOP is non-nil, add the
 248 field and its VALUE at the top of the header, else add it at the
 249 bottom of the header. If action is 'add, the VALUE is added."
 250   (let ((field-colon (if (string-match "^.*:$" field)
 251                          field
 252                        (concat field ":"))))
 253     (cond
 254      ((equal action 'remove)
 255       (mh-header-field-delete field-colon nil))
 256      (t
 257       (cond
 258        ;; No value, remove field
 259        ((or (not value)
 260             (string= value ""))
 261         (mh-header-field-delete field-colon nil))
 262        ;; Existing field, replace
 263        ((mh-header-field-delete field-colon t)
 264         (insert value))
 265        ;; Other field, add at end or top
 266        (t
 267         (goto-char (point-min))
 268         (if (not top)
 269             (mh-goto-header-end 0))
 270         (insert field-colon " " value "\n")))))))
 271
 272 ;;;###mh-autoload
 273 (defun mh-identity-handler-top (field action &optional value)
 274   "Process header FIELD.
 275 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 276 added. If the field wasn't present, it is added to the top of the
 277 header."
 278   (mh-identity-handler-default field action t value))
 279
 280 ;;;###mh-autoload
 281 (defun mh-identity-handler-bottom (field action &optional value)
 282   "Process header FIELD.
 283 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 284 added. If the field wasn't present, it is added to the bottom of
 285 the header."
 286   (mh-identity-handler-default field action nil value))
 287
 288 (provide 'mh-identity)
 289
 290 ;; Local Variables:
 291 ;; indent-tabs-mode: nil
 292 ;; sentence-end-double-space: nil
 293 ;; End:
 294
 295 ;; arch-tag: 07d66ef6-8726-4ac6-9ecf-e566cd5bfb45
 296 ;;; mh-identity.el ends here