lisp/mh-e/mh-identity.el

   1 ;;; mh-identity.el --- Multiple identify support for MH-E.
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005 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 `mh-identity-list'.")
  51 (make-variable-buffer-local 'mh-identity-pgg-default-user-id)
  52
  53 ;;;###mh-autoload
  54 (defun mh-identity-make-menu ()
  55   "Build the Identity menu.
  56 This should be called any time `mh-identity-list' or `mh-auto-fields-list'
  57 change."
  58   (easy-menu-define mh-identity-menu mh-letter-mode-map
  59     "MH-E identity menu"
  60     (append
  61      '("Identity")
  62      ;; Dynamically render :type corresponding to `mh-identity-list'
  63      ;; e.g.:
  64      ;;  ["Home" (mh-insert-identity "Home")
  65      ;;   :style radio :active (not (equal mh-identity-local "Home"))
  66      ;;   :selected (equal mh-identity-local "Home")]
  67      '(["Insert Auto Fields"
  68         (mh-insert-auto-fields) mh-auto-fields-list]
  69        "--")
  70
  71      (mapcar (function
  72               (lambda (arg)
  73                 `[,arg  (mh-insert-identity ,arg) :style radio
  74                         :selected (equal mh-identity-local ,arg)]))
  75              (mapcar 'car mh-identity-list))
  76      '(["None"
  77         (mh-insert-identity "None") :style radio
  78         :selected (not mh-identity-local)]
  79        "--"
  80        ["Set Default for Session"
  81         (setq mh-identity-default mh-identity-local) t]
  82        ["Save as Default"
  83         (customize-save-variable 'mh-identity-default mh-identity-local) t]
  84        ["Customize Identities" (customize-variable 'mh-identity-list) t]
  85        ))))
  86
  87 ;;;###mh-autoload
  88 (defun mh-identity-list-set (symbol value)
  89   "Update the `mh-identity-list' variable, and rebuild the menu.
  90 Sets the default for SYMBOL (for example, `mh-identity-list') to VALUE (as set
  91 in customization). This is called after 'customize is used to alter
  92 `mh-identity-list'."
  93   (set-default symbol value)
  94   (mh-identity-make-menu))
  95
  96 (defvar mh-identity-local nil
  97   "Buffer-local variable that holds the identity currently in use.")
  98 (make-variable-buffer-local 'mh-identity-local)
  99
 100 (defun mh-header-field-delete (field value-only)
 101   "Delete header FIELD, or only its value if VALUE-ONLY is t.
 102 Return t if anything is deleted."
 103   (let ((field-colon (if (string-match "^.*:$" field)
 104                          field
 105                        (concat field ":"))))
 106     (when (mh-goto-header-field field-colon)
 107       (if (not value-only)
 108           (beginning-of-line)
 109         (forward-char))
 110       (delete-region (point)
 111                      (progn (mh-header-field-end)
 112                             (if (not value-only) (forward-char 1))
 113                             (point)))
 114       t)))
 115
 116 (defvar mh-identity-signature-start nil
 117   "Marker for the beginning of a signature inserted by `mh-insert-identity'.")
 118 (defvar mh-identity-signature-end nil
 119   "Marker for the end of a signature inserted by `mh-insert-identity'.")
 120
 121 (defun mh-identity-field-handler (field)
 122   "Return the handler for header FIELD or nil if none set.
 123 The field name is downcased. If the FIELD begins with the character
 124 `:', then it must have a special handler defined in
 125 `mh-identity-handlers', else return an error since it is not a valid
 126 header field."
 127   (or (cdr (assoc (downcase field) mh-identity-handlers))
 128       (and (eq (aref field 0) ?:)
 129            (error "Field %s - unknown mh-identity-handler" field))
 130       (cdr (assoc ":default" mh-identity-handlers))
 131       'mh-identity-handler-default))
 132
 133 ;;;###mh-autoload
 134 (defun mh-insert-identity (identity)
 135   "Insert fields specified by given IDENTITY.
 136 See `mh-identity-list'."
 137   (interactive
 138    (list (completing-read
 139           "Identity: "
 140           (if mh-identity-local
 141               (cons '("None")
 142                     (mapcar 'list (mapcar 'car mh-identity-list)))
 143             (mapcar 'list (mapcar 'car mh-identity-list)))
 144           nil t)))
 145   (save-excursion
 146     ;;First remove old settings, if any.
 147     (when mh-identity-local
 148       (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list))))
 149         (while pers-list
 150           (let* ((field (caar pers-list))
 151                  (handler (mh-identity-field-handler field)))
 152             (funcall handler field 'remove))
 153           (setq pers-list (cdr pers-list)))))
 154     ;; Then insert the replacement
 155     (when (not (equal "None" identity))
 156       (let ((pers-list (cadr (assoc identity mh-identity-list))))
 157         (while pers-list
 158           (let* ((field (caar pers-list))
 159                  (value (cdar pers-list))
 160                  (handler (mh-identity-field-handler field)))
 161             (funcall handler field 'add value))
 162           (setq pers-list (cdr pers-list))))))
 163   ;; Remember what is in use in this buffer
 164   (if (equal "None" identity)
 165       (setq mh-identity-local nil)
 166     (setq mh-identity-local identity)))
 167
 168 ;;;###mh-autoload
 169 (defun mh-identity-handler-gpg-identity (field action &optional value)
 170   "Process header FIELD \":pgg-default-user-id\".
 171 The ACTION is one of 'remove or 'add. If 'add, the VALUE is added.
 172 The buffer-local variable `mh-identity-pgg-default-user-id' is set to VALUE
 173 when action 'add is selected."
 174   (cond
 175    ((or (equal action 'remove)
 176         (not value)
 177         (string= value ""))
 178     (setq mh-identity-pgg-default-user-id nil))
 179    ((equal action 'add)
 180     (setq mh-identity-pgg-default-user-id value))))
 181
 182 ;;;###mh-autoload
 183 (defun mh-identity-handler-signature (field action &optional value)
 184   "Process header FIELD \":signature\".
 185 The ACTION is one of 'remove or 'add. If 'add, the VALUE is added."
 186   (cond
 187    ((equal action 'remove)
 188     (when (and (markerp mh-identity-signature-start)
 189                (markerp mh-identity-signature-end))
 190       (delete-region mh-identity-signature-start
 191                      mh-identity-signature-end)))
 192    (t
 193     ;; Insert "signature". Nil value means to use `mh-signature-file-name'.
 194     (when (not (mh-signature-separator-p)) ;...unless already present
 195       (goto-char (point-max))
 196       (save-restriction
 197         (narrow-to-region (point) (point))
 198         (if (null value)
 199             (mh-insert-signature)
 200           (mh-insert-signature value))
 201         (set (make-local-variable 'mh-identity-signature-start)
 202              (point-min-marker))
 203         (set-marker-insertion-type mh-identity-signature-start t)
 204         (set (make-local-variable 'mh-identity-signature-end)
 205              (point-max-marker)))))))
 206
 207 (defvar mh-identity-attribution-verb-start nil
 208   "Marker for the beginning of the attribution verb.")
 209 (defvar mh-identity-attribution-verb-end nil
 210   "Marker for the end of the attribution verb.")
 211
 212 ;;;###mh-autoload
 213 (defun mh-identity-handler-attribution-verb (field action &optional value)
 214   "Process header FIELD \":attribution-verb\".
 215 The ACTION is one of 'remove or 'add. If 'add, the VALUE is added."
 216   (when (and (markerp mh-identity-attribution-verb-start)
 217              (markerp mh-identity-attribution-verb-end))
 218     (delete-region mh-identity-attribution-verb-start
 219                    mh-identity-attribution-verb-end)
 220     (goto-char mh-identity-attribution-verb-start)
 221     (cond
 222      ((equal action 'remove)              ; Replace with default
 223       (mh-identity-insert-attribution-verb nil))
 224      (t                                   ; Insert attribution verb.
 225       (mh-identity-insert-attribution-verb value)))))
 226
 227 ;;;###mh-autoload
 228 (defun mh-identity-insert-attribution-verb (value)
 229   "Insert VALUE as attribution verb, setting up delimiting markers.
 230 If VALUE is nil, use `mh-extract-from-attribution-verb'."
 231   (save-restriction
 232     (narrow-to-region (point) (point))
 233     (if (null value)
 234         (insert mh-extract-from-attribution-verb)
 235       (insert value))
 236     (set (make-local-variable 'mh-identity-attribution-verb-start)
 237          (point-min-marker))
 238     (set-marker-insertion-type mh-identity-attribution-verb-start t)
 239     (set (make-local-variable 'mh-identity-attribution-verb-end)
 240          (point-max-marker))))
 241
 242 (defun mh-identity-handler-default (field action top &optional value)
 243   "Process header FIELD.
 244 The ACTION is one of 'remove or 'add. If TOP is non-nil, add the field and its
 245 VALUE at the top of the header, else add it at the bottom of the header. If
 246 action is 'add, the VALUE is added."
 247   (let ((field-colon (if (string-match "^.*:$" field)
 248                          field
 249                        (concat field ":"))))
 250     (cond
 251      ((equal action 'remove)
 252       (mh-header-field-delete field-colon nil))
 253      (t
 254       (cond
 255        ;; No value, remove field
 256        ((or (not value)
 257             (string= value ""))
 258         (mh-header-field-delete field-colon nil))
 259        ;; Existing field, replace
 260        ((mh-header-field-delete field-colon t)
 261         (insert value))
 262        ;; Other field, add at end or top
 263        (t
 264         (goto-char (point-min))
 265         (if (not top)
 266             (mh-goto-header-end 0))
 267         (insert field-colon " " value "\n")))))))
 268
 269 ;;;###mh-autoload
 270 (defun mh-identity-handler-top (field action &optional value)
 271   "Process header FIELD.
 272 The ACTION is one of 'remove or 'add. If 'add, the VALUE is added.
 273 If the field wasn't present, it is added to the top of the header."
 274   (mh-identity-handler-default field action t value))
 275
 276 ;;;###mh-autoload
 277 (defun mh-identity-handler-bottom (field action &optional value)
 278   "Process header FIELD.
 279 The ACTION is one of 'remove or 'add. If 'add, the VALUE is added.
 280 If the field wasn't present, it is added to the bottom of the header."
 281   (mh-identity-handler-default field action nil value))
 282
 283 (provide 'mh-identity)
 284
 285 ;;; Local Variables:
 286 ;;; indent-tabs-mode: nil
 287 ;;; sentence-end-double-space: nil
 288 ;;; End:
 289
 290 ;;; arch-tag: 07d66ef6-8726-4ac6-9ecf-e566cd5bfb45
 291 ;;; mh-identity.el ends here